diff --git a/.gitmodules b/.gitmodules index 77affa0..e2374ec 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,3 +4,6 @@ [submodule "vendor/sci"] path = vendor/sci url = https://github.com/borkdude/sci.git +[submodule "vendor/clojure-test-suite"] + path = vendor/clojure-test-suite + url = https://github.com/jank-lang/clojure-test-suite.git diff --git a/host/chez/post-prelude.ss b/host/chez/post-prelude.ss index 573e889..0f42ad6 100644 --- a/host/chez/post-prelude.ss +++ b/host/chez/post-prelude.ss @@ -63,6 +63,12 @@ ;; a lazy-seq carries its own realized? flag (lazy-bridge.ss). The overlay ;; realized? reads :jolt/type and throws on a jolt-lazyseq record. ((jolt-lazyseq? x) (jolt-lazyseq-realized? x)) + ;; a seq cell answers by its forced flag: the rest of a realized lazy + ;; chain is a cseq under jolt's seq model, and (realized? (rest s)) after + ;; a next must be true like the JVM's realized LazySeq — never a throw + ;; whose message renders the (possibly infinite) seq. + ((cseq? x) (if (cseq-forced? x) #t #f)) + ((empty-list-t? x) #t) (else (jolt-invoke overlay-realized? x)))))) ;; clojure.edn/read over a reader: drain the jhost reader, then read through the ;; overlay read-string so the opts map (:readers/:default/:eof) is honored. diff --git a/host/chez/seed/prelude.ss b/host/chez/seed/prelude.ss index ccab69a..56b77d3 100644 --- a/host/chez/seed/prelude.ss +++ b/host/chez/seed/prelude.ss @@ -319,7 +319,7 @@ (guard (e (#t #f)) (def-var! "clojure.core" "char?" (letrec ((char? (lambda (x) (let fnrec4943 ((x x)) (jolt= (jolt-get x (keyword "jolt" "type")) (keyword "jolt" "char")))))) char?))) (guard (e (#t #f)) - (def-var! "clojure.core" "realized?" (letrec ((realized? (lambda (x) (let fnrec4944 ((x x)) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "delay?") x)) (jolt-invoke (var-deref "clojure.core" "boolean") (jolt-get x (keyword #f "realized"))) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "future?") x)) (jolt-invoke (var-deref "clojure.core" "boolean") (jolt-get x (keyword #f "cached"))) (if (jolt= (keyword "jolt" "lazy-seq") (jolt-get x (keyword "jolt" "type"))) (jolt-invoke (var-deref "clojure.core" "boolean") (jolt-get x (keyword #f "realized"))) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "atom?") x)) #t (if (jolt-truthy? (keyword #f "else")) (jolt-throw (jolt-invoke (var-deref "clojure.core" "str") "realized? not supported on: " x)) jolt-nil))))))))) realized?))) + (def-var! "clojure.core" "realized?" (letrec ((realized? (lambda (x) (let fnrec4944 ((x x)) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "delay?") x)) (jolt-invoke (var-deref "clojure.core" "boolean") (jolt-get x (keyword #f "realized"))) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "future?") x)) (jolt-invoke (var-deref "clojure.core" "boolean") (jolt-get x (keyword #f "cached"))) (if (jolt= (keyword "jolt" "lazy-seq") (jolt-get x (keyword "jolt" "type"))) (jolt-invoke (var-deref "clojure.core" "boolean") (jolt-get x (keyword #f "realized"))) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "atom?") x)) #t (if (jolt-truthy? (keyword #f "else")) (jolt-throw (jolt-invoke (var-deref "clojure.core" "str") "realized? not supported on: " (jolt-invoke (var-deref "clojure.core" "class") x))) jolt-nil))))))))) realized?))) (guard (e (#t #f)) (def-var! "clojure.core" "force" (letrec ((force (lambda (x) (let fnrec4945 ((x x)) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "delay?") x)) (jolt-invoke (var-deref "clojure.core" "deref") x) x))))) force))) (guard (e (#t #f)) diff --git a/host/chez/seq.ss b/host/chez/seq.ss index ac9e7ed..3ae923f 100644 --- a/host/chez/seq.ss +++ b/host/chez/seq.ss @@ -257,12 +257,18 @@ => (lambda (m) (apply jolt-invoke m f args))) ((and (reified-methods f) (hashtable-ref (reified-methods f) "invoke" #f)) => (lambda (m) (apply jolt-invoke m f args))) - ;; calling a non-fn: a ClassCastException naming the operator, thrown via - ;; jolt-throw so it is catchable and carries the throw-site continuation for a - ;; stack trace. + ;; calling a non-fn: a ClassCastException naming the operator's CLASS (like + ;; the JVM's "class clojure.lang.LazySeq cannot be cast to ... IFn" — never + ;; the value, whose printed form may be unbounded: ((range)) must throw, not + ;; hang rendering an infinite seq). Thrown via jolt-throw so it is catchable + ;; and carries the throw-site continuation for a stack trace. (else (jolt-throw (jolt-host-throwable "java.lang.ClassCastException" - (string-append (guard (e (#t "value")) (jolt-pr-str f)) - " cannot be cast to clojure.lang.IFn")))))) + (string-append + "class " + (guard (e (#t "value")) + (let ((c (jolt-class-name f))) + (if (string? c) c (jolt-pr-str f)))) + " cannot be cast to class clojure.lang.IFn")))))) ;; ============================================================================ ;; chunked-seq accessors — the host side of the Clojure IChunkedSeq contract diff --git a/host/chez/values.ss b/host/chez/values.ss index 02a694a..e0640f2 100644 --- a/host/chez/values.ss +++ b/host/chez/values.ss @@ -96,10 +96,16 @@ ((and (jolt-coll? a) (jolt-coll? b)) (jolt-coll=? a b)) (else (eq? a b)))) (define (jolt=2 a b) - (let loop ((as jolt-eq-arms)) - (cond ((null? as) (jolt=2-base a b)) - (((caar as) a b) ((cdar as) a b)) - (else (loop (cdr as)))))) + ;; identity fast path, like Util.equiv's k1 == k2: the same object equals + ;; itself without a structural walk — (= s s) on an infinite lazy seq must not + ;; realize it. Numbers keep the exactness-aware arm (Chez may intern flonum + ;; literals, and (= ##NaN ##NaN) is false like the JVM's). + (if (and (eq? a b) (not (number? a))) + #t + (let loop ((as jolt-eq-arms)) + (cond ((null? as) (jolt=2-base a b)) + (((caar as) a b) ((cdar as) a b)) + (else (loop (cdr as))))))) (define (jolt= a . rest) (let loop ((a a) (rest rest)) (cond ((null? rest) #t) diff --git a/jolt-core/clojure/core/20-coll.clj b/jolt-core/clojure/core/20-coll.clj index b7c346c..6fd0297 100644 --- a/jolt-core/clojure/core/20-coll.clj +++ b/jolt-core/clojure/core/20-coll.clj @@ -426,7 +426,9 @@ (future? x) (boolean (get x :cached)) (= :jolt/lazy-seq (get x :jolt/type)) (boolean (get x :realized)) (atom? x) true - :else (throw (str "realized? not supported on: " x)))) + ;; name the class, never the value — an error message must not render an + ;; arbitrary (possibly infinite) argument. + :else (throw (str "realized? not supported on: " (class x))))) (defn force [x] (if (delay? x) (deref x) x)) diff --git a/stdlib/clojure/test.clj b/stdlib/clojure/test.clj index dabd851..3866b4a 100644 --- a/stdlib/clojure/test.clj +++ b/stdlib/clojure/test.clj @@ -19,8 +19,8 @@ (def jolt-report counters) ;; alias used by the suite harness (def ctx-stack (atom [])) (def registry (atom [])) ;; [{:name sym :fn thunk}] -(def once-fixtures (atom [])) -(def each-fixtures (atom [])) +(def once-fixtures (atom {})) ;; ns-sym -> [fixture-fns] +(def each-fixtures (atom {})) ;; ns-sym -> [fixture-fns] ;; 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 @@ -32,8 +32,8 @@ (reset! counters {:test 0 :pass 0 :fail 0 :error 0 :fails []}) (reset! ctx-stack []) (reset! registry []) - (reset! once-fixtures []) - (reset! each-fixtures [])) + (reset! once-fixtures {}) + (reset! each-fixtures {})) (defn- ctx-str [] (str/join " " @ctx-stack)) @@ -135,6 +135,15 @@ ([form] `(is ~form nil)) ([form msg] (cond + ;; a library-registered custom assertion (the assert-expr extension point) + ;; wins over every inline path, like clojure.test, where each `is` dispatches + ;; assert-expr on the exact head symbol and the built-ins are just + ;; pre-registered methods. In particular a registered alias-qualified + ;; `p/thrown?` must not be captured by the by-name thrown? path below. + (and (seq? form) (symbol? (first form)) + (contains? (methods clojure.test/assert-expr) (first form))) + (clojure.test/assert-expr msg form) + ;; (is (thrown? Class body...)) (thrown-form? form "thrown?") (let [klass-sym (second form) @@ -172,13 +181,6 @@ (clojure.test/inc-pass!) (clojure.test/fail! (str "expected throw of " ~klass " matching " ~re " but got " (clojure.core/class e#) ": " m#))))))) - ;; a library-registered custom assertion (the assert-expr extension point); - ;; only fires for a symbol with an explicitly registered method, so built-in - ;; predicate forms keep the inline path below. - (and (seq? form) (symbol? (first form)) - (contains? (methods clojure.test/assert-expr) (first form))) - (clojure.test/assert-expr msg form) - ;; a predicate call — (= a b), (< x y), (pred? v): evaluate the args so a ;; failure shows the actual values, like clojure.test's assert-predicate. (and (seq? form) (contains? clojure.test/reported-preds (first form))) @@ -209,7 +211,9 @@ (defmacro deftest [name & body] `(do (defn ~name [] ~@body) - (swap! clojure.test/registry conj {:name '~name :fn ~name}) + (swap! clojure.test/registry conj {:name '~name + :ns (clojure.core/ns-name clojure.core/*ns*) + :fn ~name}) (var ~name))) (defmacro are [argv expr & data] @@ -222,10 +226,15 @@ ;; --- fixtures + run -------------------------------------------------------- +;; Fixtures are per-namespace, like clojure.test (which stores them in ns +;; metadata): use-fixtures records them under the calling ns, and only that +;; ns's tests run through them — a suite loading many test namespaces into one +;; process doesn't cross-apply or clobber another ns's fixtures. (defn use-fixtures [kind & fns] - (cond - (= kind :once) (reset! once-fixtures (vec fns)) - (= kind :each) (reset! each-fixtures (vec fns)))) + (let [n (ns-name *ns*)] + (cond + (= kind :once) (swap! once-fixtures assoc n (vec fns)) + (= kind :each) (swap! each-fixtures assoc n (vec fns))))) (defn- wrap-fixtures [fixtures body-fn] (if (empty? fixtures) @@ -234,25 +243,46 @@ (defn- run-one [t] (swap! counters update :test inc) - (wrap-fixtures @each-fixtures + (wrap-fixtures (get @each-fixtures (:ns t) []) (fn [] (try ((:fn t)) (catch Throwable e (err! (str (:name t) " crashed: " (err-text e)))))))) -(defn run-registered [] - (doseq [t @registry] (run-one t)) +;; Run the registered tests grouped by namespace (registration order preserved +;; within each ns), each group wrapped in its ns's :once fixtures. ns-set nil +;; means all. +(defn- run-selected [ns-set] + (let [ts (if ns-set (filter (fn [t] (contains? ns-set (:ns t))) @registry) @registry)] + (doseq [n (distinct (map :ns ts))] + (wrap-fixtures (get @once-fixtures n []) + (fn [] (doseq [t ts :when (= n (:ns t))] (run-one t)))))) nil) -(defn run-tests [& _nses] - (wrap-fixtures @once-fixtures (fn [] (run-registered))) - (let [r @counters] - (println) - (println (str "Ran " (:test r) " tests. " - (:pass r) " assertions passed, " - (:fail r) " failures, " (:error r) " errors.")) - r)) +(defn run-registered [] (run-selected nil)) + +;; (run-tests 'ns1 'ns2 …) runs only those namespaces' tests, like clojure.test. +;; With no args it runs everything registered (a deliberate superset of the +;; JVM's current-ns default — jolt's harnesses load then run whole suites). +;; Prints and returns THIS call's summary; the global counters stay cumulative +;; for the n-pass/n-fail harness API. +(defn run-tests [& nses] + (let [before @counters + ns-set (when (seq nses) + (set (map (fn [n] (if (symbol? n) n (ns-name n))) nses)))] + (run-selected ns-set) + (let [r @counters + d {:type :summary + :test (- (:test r) (:test before)) + :pass (- (:pass r) (:pass before)) + :fail (- (:fail r) (:fail before)) + :error (- (:error r) (:error before))}] + (println) + (println (str "Ran " (:test d) " tests. " + (:pass d) " assertions passed, " + (:fail d) " failures, " (:error d) " errors.")) + d))) (defn run-test [& _] nil) (defn test-var [& _] nil) diff --git a/test/chez/clojure-test.clj b/test/chez/clojure-test.clj index e222ae3..69db89c 100644 --- a/test/chez/clojure-test.clj +++ b/test/chez/clojure-test.clj @@ -11,6 +11,17 @@ (clojure.test/do-report {:type :pass}) (clojure.test/do-report {:type :fail :message ~msg :form '~form})))) +;; an ALIAS-QUALIFIED registered assertion whose simple name collides with the +;; built-in thrown? — the registered method must win over the by-name inline +;; path (clojure-test-suite's portability/thrown? registers exactly this shape). +(defmethod t/assert-expr 'p/thrown? [msg form] + `(try + (do ~@(rest form)) + (clojure.test/do-report {:type :fail :message ~msg :form '~form}) + (catch Throwable e# + (clojure.test/do-report {:type :pass}) + e#))) + ;; a custom report type (how test.check surfaces trial/shrink progress) (def trials (atom 0)) (defmethod t/report ::trial [_m] (swap! trials inc)) @@ -27,21 +38,28 @@ 6 (* 2 3)) (is (thrown? clojure.lang.ExceptionInfo (throw (ex-info "x" {})))) (is (thrown-with-msg? Exception #"bad" (throw (ex-info "bad" {})))) - (is (near? 1.0 1.005))) + (is (near? 1.0 1.005)) + (is (p/thrown? (throw (ex-info "boom" {}))))) (deftest expected-fail (is (= 1 2)) (is (near? 1.0 5.0))) -(run-tests) +;; run-tests returns THIS call's summary; with explicit nses it runs only their +;; tests (an unknown ns runs nothing). +(def r1 (run-tests)) +(def r2 (run-tests 'no.such.test-ns)) (t/do-report {:type ::trial}) (t/do-report {:type ::trial}) -;; 7 pass (= + vector? + 2 are rows + thrown? + thrown-with-msg? + near?), +;; 8 pass (= + vector? + 2 are rows + thrown? + thrown-with-msg? + near? + p/thrown?), ;; 2 fail (= 1 2, near? 1.0 5.0), 0 error, 2 fixture runs, 2 custom reports -(let [ok (and (= (t/n-pass) 7) (= (t/n-fail) 2) (= (t/n-error) 0) +(let [ok (and (= (t/n-pass) 8) (= (t/n-fail) 2) (= (t/n-error) 0) + (= 2 (:test r1)) (= 8 (:pass r1)) (= 2 (:fail r1)) + (= 0 (:test r2)) (= 0 (:pass r2)) (= @setups 2) (= @trials 2))] (println (if ok "CLOJURE-TEST OK" (str "CLOJURE-TEST FAIL pass=" (t/n-pass) " fail=" (t/n-fail) - " error=" (t/n-error) " setups=" @setups " trials=" @trials)))) + " error=" (t/n-error) " r1=" (pr-str r1) " r2=" (pr-str r2) + " setups=" @setups " trials=" @trials)))) diff --git a/test/chez/corpus.edn b/test/chez/corpus.edn index a99b970..b4aa774 100644 --- a/test/chez/corpus.edn +++ b/test/chez/corpus.edn @@ -3513,4 +3513,6 @@ {:suite "reduce / IReduceInit" :label "a deftype reduce honors reduced short-circuit" :expected "3" :actual "(do (deftype Rng [n] clojure.lang.IReduceInit (reduce [_ f init] (loop [i 0 acc init] (if (< i n) (let [a (f acc i)] (if (reduced? a) @a (recur (inc i) a))) acc)))) (reduce (fn [acc x] (if (= x 3) (reduced acc) (+ acc x))) 0 (->Rng 10)))"} {:suite "exceptions / typed throw" :label "a jolt-raised NumberFormatException reports its real class and message" :expected "[\"java.lang.NumberFormatException\" \"For input string: \\\"xyz\\\"\"]" :actual "(try (Long/parseLong \"xyz\") (catch Throwable e [(.getName (class e)) (.getMessage e)]))"} {:suite "exceptions / hierarchy catch" :label "a typed throwable matches its superclasses, not unrelated ones" :expected "[true true true false]" :actual "(let [e (try (Long/parseLong \"z\") (catch Throwable e e))] [(instance? NumberFormatException e) (instance? IllegalArgumentException e) (instance? Exception e) (instance? java.io.IOException e)])"} + {:suite "equality / identity" :label "= short-circuits on identity without realizing a lazy seq (Util.equiv k1 == k2)" :expected "0" :actual "(let [n (atom 0) s (map (fn [x] (swap! n inc) x) [1 2 3])] (= s s) @n)"} + {:suite "realized? / lazy seq" :label "realized? reads a lazy seq's realization flag" :expected "[false true]" :actual "(let [s (map inc [1 2 3])] [(realized? s) (do (doall s) (realized? s))])"} ] diff --git a/vendor/clojure-test-suite b/vendor/clojure-test-suite new file mode 160000 index 0000000..489b674 --- /dev/null +++ b/vendor/clojure-test-suite @@ -0,0 +1 @@ +Subproject commit 489b6743e8421687ef96cec557830acf258d1886