Merge pull request #262 from jolt-lang/conformance/test-check

test.check generators: unchecked-math/rand-double, ThreadLocal proxy, and host interop

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-classes.ss

@@ -697,6 +697,22 @@
 (def-var! "clojure.core" "__register-class-methods!"
   (lambda (tag members) (register-tagged-methods! tag (jmap->static-alist members)) jolt-nil))
 
+;; java.lang.ThreadLocal via a Chez thread-parameter: real per-thread storage with
+;; a lazy initialValue (the proxy macro lowers (proxy [ThreadLocal] …) to this).
+;; .get returns the thread's value, computing initialValue once; .set / .remove.
+(define tl-unset (list 'tl-unset))
+(define (jolt-make-thread-local init-thunk)
+  (make-jhost "threadlocal" (vector (make-thread-parameter tl-unset) init-thunk)))
+(register-host-methods! "threadlocal"
+  (list (cons "get" (lambda (self)
+                      (let* ((st (jhost-state self)) (tp (vector-ref st 0)) (v (tp)))
+                        (if (eq? v tl-unset)
+                            (let ((nv (jolt-invoke (vector-ref st 1)))) (tp nv) nv)
+                            v))))
+        (cons "set" (lambda (self v) ((vector-ref (jhost-state self) 0) v) jolt-nil))
+        (cons "remove" (lambda (self) ((vector-ref (jhost-state self) 0) tl-unset) jolt-nil))))
+(def-var! "jolt.host" "make-thread-local" jolt-make-thread-local)
+
 ;; Pluggable instance? — a library registers (fn [class-name-string val] -> true
 ;; | false | nil); nil means "not my class, fall through". First non-nil wins.
 (define user-instance-checks '())

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)))
-(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)

jolt-core/clojure/core/30-macros.clj

@@ -558,8 +558,14 @@
               (parse-extend-impls type-impls))))
 
 ;; extend is a real FUNCTION — defined above extend-type.
-;; JVM proxies are unsupported.
-(defmacro proxy [& args] nil)
+;; JVM proxies are unsupported in general, EXCEPT (proxy [ThreadLocal] [] (initialValue
+;; [] body)) — a per-thread store with a lazy initial value (test.check's no-seed
+;; PRNG uses one). Other proxies stay nil.
+(defmacro proxy [supers ctor-args & methods]
+  (when (and (vector? supers) (= 1 (count supers))
+             (let [s (name (first supers))] (or (= s "ThreadLocal") (= s "InheritableThreadLocal"))))
+    (let [init (some (fn [m] (when (= "initialValue" (name (first m))) m)) methods)]
+      `(jolt.host/make-thread-local (fn [] ~@(when init (nnext init)))))))
 ;; definterface is JVM-only; bind the name to a marker and return the name (not a
 ;; var), matching the JVM where definterface yields the interface Class.
 (defmacro definterface [name-sym & body]

jolt-core/jolt/analyzer.clj

@@ -636,9 +636,14 @@
                           (form-sym-name head)))
             shadowed (and hname (local? env hname))
             ;; under *unchecked-math*, a core +/-/*/inc/dec becomes its wrapping
-            ;; unchecked-* (computed once; nil when off or not such an op).
-            unm (when (and hname (not shadowed) (unchecked-math?))
-                  (unchecked-arith hname (count items)))]
+            ;; unchecked-* (computed once; nil when off or not such an op). The op
+            ;; may arrive bare (+) or clojure.core-qualified (clojure.core/*), the
+            ;; latter from a macro's syntax-quote — both must wrap.
+            unm (when (unchecked-math?)
+                  (let [opn (cond (and hname (not shadowed)) hname
+                                  (and (form-sym? head) (= "clojure.core" (form-sym-ns head)))
+                                  (form-sym-name head))]
+                    (when opn (unchecked-arith opn (count items)))))]
         (cond
           ;; *unchecked-math* rewrite, before macro/special dispatch (these are
           ;; ordinary core fns). The unchecked-* form re-analyzes normally.

jolt-core/jolt/backend_scheme.clj

@@ -188,10 +188,19 @@
     "unquote" "set!" "define" "define-syntax" "cond" "case" "when" "unless"
     "and" "or" "do" "else" "guard" "parameterize" "delay" "values"})
 
+;; clojure.core ops emitted as a BARE Scheme name (where native-ops maps the op
+;; to itself: + - * / < > min max …). A local binding with one of these names
+;; would otherwise shadow the emitted prim — e.g. (fn [max] (clojure.core/max …))
+;; emits (max …) calling the param — so such locals are prefixed, like reserved
+;; words. Derived from native-ops so the two never drift.
+(def ^:private bare-native-names
+  (set (keep (fn [[k v]] (when (= k v) k)) native-ops)))
+
 ;; Most jolt names are already valid Scheme identifiers. The one that isn't is
 ;; `#`, which jolt auto-gensyms use as a suffix (p1__0000X4# from #(...)) — `#`
 ;; starts a datum in Scheme, so replace it with `_`. A name that collides with a
-;; Scheme keyword is prefixed with `_` so it can never shadow the emitted form.
+;; Scheme keyword OR a bare-emitted native op is prefixed with `_` so it can never
+;; shadow the emitted form.
 (defn- munge-name [s]
   ;; A Clojure symbol may contain chars that break a Scheme identifier: ' is the
   ;; quote reader macro (a bare f' would read as f then 'rest), # already maps to
@@ -200,7 +209,7 @@
   (let [s (-> s
               (str/replace "#" "_")
               (str/replace "'" "_PRIME_"))]
-    (if (contains? scheme-reserved s) (str "_" s) s)))
+    (if (or (contains? scheme-reserved s) (contains? bare-native-names s)) (str "_" s) s)))
 
 (declare emit)
 

stdlib/clojure/test.clj

@@ -22,6 +22,12 @@
 (def once-fixtures (atom []))
 (def each-fixtures (atom []))
 
+;; clojure.test/*testing-vars* — the stack of vars under test. Real clojure.test
+;; binds it around each test var; test.check's default reporter reads it, so a
+;; defspec run through its :test metadata doesn't blow up on an unbound var.
+(def ^:dynamic *testing-vars* (list))
+(def ^:dynamic *report-counters* nil)
+
 (defn reset-report! []
   (reset! counters {:test 0 :pass 0 :fail 0 :error 0 :fails []})
   (reset! ctx-stack [])

test/chez/corpus.edn

@@ -3381,4 +3381,9 @@
   {:suite "host-interop / Compiler" :label "Compiler/specials keys include the special forms" :expected "true" :actual "(every? (set (keys clojure.lang.Compiler/specials)) (quote [if do let* fn* quote def loop* recur try letfn* var]))"}
   {: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)]"}
+  {:suite "host-interop / ThreadLocal proxy" :label "(proxy [ThreadLocal] [] (initialValue [] v)) get/set" :expected "[42 7]" :actual "(let [tl (proxy [ThreadLocal] [] (initialValue [] 42))] [(.get tl) (do (.set tl 7) (.get tl))])"}
 ]