Merge pull request #291 from jolt-lang/conformance/clojure-test-suite
Vendor clojure-test-suite as a standing gate (make cts)
This commit is contained in:
commit
53a8aac2d0
16 changed files with 365 additions and 44 deletions
3
.gitmodules
vendored
3
.gitmodules
vendored
|
|
@ -4,3 +4,6 @@
|
||||||
[submodule "vendor/sci"]
|
[submodule "vendor/sci"]
|
||||||
path = vendor/sci
|
path = vendor/sci
|
||||||
url = https://github.com/borkdude/sci.git
|
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
|
||||||
|
|
|
||||||
10
Makefile
10
Makefile
|
|
@ -4,7 +4,7 @@
|
||||||
# build step. `make test` is the full gate. `make remint` rebuilds the seed after a
|
# build step. `make test` is the full gate. `make remint` rebuilds the seed after a
|
||||||
# source change.
|
# source change.
|
||||||
|
|
||||||
.PHONY: test ci values corpus unit smoke buildsmoke staticnativesmoke selfhost sci certify ffi transient infer wp devirt fieldread numwp fieldnum protoret narrow directlink numeric inline shakesmoke remint joltc joltc-release joltc-debug joltcsmoke
|
.PHONY: test ci values corpus unit smoke buildsmoke staticnativesmoke selfhost sci cts certify ffi transient infer wp devirt fieldread numwp fieldnum protoret narrow directlink numeric inline shakesmoke remint joltc joltc-release joltc-debug joltcsmoke
|
||||||
|
|
||||||
# Full gate (dev machine). Includes the self-host byte-fixpoint, which only holds
|
# Full gate (dev machine). Includes the self-host byte-fixpoint, which only holds
|
||||||
# on the same Chez that minted the seed.
|
# on the same Chez that minted the seed.
|
||||||
|
|
@ -15,7 +15,7 @@ test: selfhost ci
|
||||||
# lockfile) — it RUNS correctly on any Chez, but `selfhost` rebuilds it and a
|
# lockfile) — it RUNS correctly on any Chez, but `selfhost` rebuilds it and a
|
||||||
# different Chez version may emit byte-different (gensym/order) output, so the
|
# different Chez version may emit byte-different (gensym/order) output, so the
|
||||||
# byte-fixpoint is a dev-machine check, not a CI one (jolt-8479).
|
# byte-fixpoint is a dev-machine check, not a CI one (jolt-8479).
|
||||||
ci: values corpus unit smoke buildsmoke staticnativesmoke sci ffi transient infer wp devirt fieldread numwp fieldnum protoret narrow directlink numeric inline certify
|
ci: values corpus unit smoke buildsmoke staticnativesmoke sci cts ffi transient infer wp devirt fieldread numwp fieldnum protoret narrow directlink numeric inline certify
|
||||||
@echo "OK: CI gates passed"
|
@echo "OK: CI gates passed"
|
||||||
|
|
||||||
# Self-host fixpoint: bootstrap.ss rebuild == checked-in seed.
|
# Self-host fixpoint: bootstrap.ss rebuild == checked-in seed.
|
||||||
|
|
@ -68,6 +68,12 @@ joltcsmoke:
|
||||||
sci:
|
sci:
|
||||||
@chez --script host/chez/run-sci.ss
|
@chez --script host/chez/run-sci.ss
|
||||||
|
|
||||||
|
# clojure-test-suite conformance: run the vendored jank-lang/clojure-test-suite
|
||||||
|
# per-namespace under joltc, gated on the per-namespace baseline
|
||||||
|
# (test/chez/cts-known-failures.txt).
|
||||||
|
cts:
|
||||||
|
@bash host/chez/cts.sh
|
||||||
|
|
||||||
# FFI: bind native functions (typed foreign-procedure), memory, and that a
|
# FFI: bind native functions (typed foreign-procedure), memory, and that a
|
||||||
# :blocking call is collect-safe (a parked thread doesn't pin the collector).
|
# :blocking call is collect-safe (a parked thread doesn't pin the collector).
|
||||||
ffi:
|
ffi:
|
||||||
|
|
|
||||||
120
host/chez/cts.sh
Executable file
120
host/chez/cts.sh
Executable file
|
|
@ -0,0 +1,120 @@
|
||||||
|
#!/bin/bash
|
||||||
|
# clojure-test-suite gate: run the vendored jank-lang/clojure-test-suite
|
||||||
|
# (vendor/clojure-test-suite) against joltc, one process per test namespace (a
|
||||||
|
# hang or crash is contained), and compare per-namespace fail/error counts
|
||||||
|
# against the checked-in baseline test/chez/cts-known-failures.txt.
|
||||||
|
#
|
||||||
|
# The comparison is exact, like certify's allowlist: a namespace doing WORSE
|
||||||
|
# than the baseline fails the gate (regression), and one doing BETTER also
|
||||||
|
# fails (stale baseline — update the file in the same change that improved it).
|
||||||
|
#
|
||||||
|
# JOLT_CTS_JOBS=N parallel workers (default 4)
|
||||||
|
# JOLT_CTS_TIMEOUT=SECS per-namespace timeout (default 120)
|
||||||
|
# JOLT_CTS_WRITE_BASELINE=1 regenerate the baseline file instead of gating
|
||||||
|
# JOLT_CTS_NS=ns1,ns2 run only these namespaces, verbose, no gating
|
||||||
|
set -u
|
||||||
|
root="$(CDPATH= cd -- "$(dirname -- "$0")/../.." && pwd)"
|
||||||
|
cd "$root"
|
||||||
|
|
||||||
|
suite="vendor/clojure-test-suite/test"
|
||||||
|
baseline="test/chez/cts-known-failures.txt"
|
||||||
|
app="$root/test/chez/cts-app"
|
||||||
|
jobs="${JOLT_CTS_JOBS:-4}"
|
||||||
|
tmo="${JOLT_CTS_TIMEOUT:-120}"
|
||||||
|
|
||||||
|
if [ ! -d "$suite/clojure" ]; then
|
||||||
|
echo "cts: skipped (git submodule update --init vendor/clojure-test-suite)"
|
||||||
|
exit 0
|
||||||
|
fi
|
||||||
|
|
||||||
|
work="$(mktemp -d)"
|
||||||
|
trap 'rm -rf "$work"' EXIT
|
||||||
|
|
||||||
|
# test namespaces from the .cljc files (portability is a helper, not a test ns)
|
||||||
|
find "$suite" -name '*.cljc' | sed "s|^$suite/||;s|\.cljc$||;s|/|.|g;s|_|-|g" \
|
||||||
|
| grep -v '\.portability$' | sort > "$work/nses"
|
||||||
|
if [ -n "${JOLT_CTS_NS:-}" ]; then
|
||||||
|
echo "${JOLT_CTS_NS}" | tr ',' '\n' > "$work/nses"
|
||||||
|
fi
|
||||||
|
|
||||||
|
# round-robin the namespaces over N sequential workers; each worker appends
|
||||||
|
# "ns pass fail error" lines (HUNG/CRASH in the pass column) to its own file.
|
||||||
|
awk -v j="$jobs" '{print > ("'"$work"'/chunk." (NR % j))}' "$work/nses"
|
||||||
|
run_chunk() {
|
||||||
|
chunk="$1"; out="$2"
|
||||||
|
while IFS= read -r ns; do
|
||||||
|
res=$(JOLT_PWD="$app" perl -e "alarm $tmo; exec @ARGV" -- "$root/bin/joltc" -M:cts "$ns" 2>&1 </dev/null)
|
||||||
|
rc=$?
|
||||||
|
line=$(echo "$res" | grep '^CTS-RESULT' | head -1)
|
||||||
|
if [ -n "$line" ]; then
|
||||||
|
echo "$line" | awk '{print $2, $3, $4, $5}' >> "$out"
|
||||||
|
if [ -n "${JOLT_CTS_NS:-}" ]; then
|
||||||
|
echo "$res" | grep -E 'FAIL:|ERROR:|LOAD:' | sed 's/^/ /' >> "$out"
|
||||||
|
fi
|
||||||
|
elif [ $rc -ge 128 ]; then
|
||||||
|
echo "$ns HUNG 0 0" >> "$out"
|
||||||
|
else
|
||||||
|
echo "$ns CRASH 0 0" >> "$out"
|
||||||
|
fi
|
||||||
|
done < "$chunk"
|
||||||
|
}
|
||||||
|
for c in "$work"/chunk.*; do
|
||||||
|
run_chunk "$c" "$c.res" &
|
||||||
|
done
|
||||||
|
wait
|
||||||
|
cat "$work"/chunk.*.res 2>/dev/null | sort > "$work/results"
|
||||||
|
|
||||||
|
if [ -n "${JOLT_CTS_NS:-}" ]; then
|
||||||
|
cat "$work/results"
|
||||||
|
exit 0
|
||||||
|
fi
|
||||||
|
|
||||||
|
summary=$(awk '$2!="HUNG" && $2!="CRASH" {p+=$2; f+=$3; e+=$4; c++}
|
||||||
|
$2=="HUNG" {h++} $2=="CRASH" {x++}
|
||||||
|
END {printf "%d namespaces: pass %d, fail %d, error %d, hung %d, crash %d",
|
||||||
|
c+h+x, p, f, e, h, x}' "$work/results")
|
||||||
|
|
||||||
|
if [ "${JOLT_CTS_WRITE_BASELINE:-0}" = "1" ]; then
|
||||||
|
{
|
||||||
|
echo "# clojure-test-suite known failures: <namespace> <fail> <error>"
|
||||||
|
echo "# The gate fails on any per-namespace change, worse OR better; regenerate"
|
||||||
|
echo "# with: JOLT_CTS_WRITE_BASELINE=1 host/chez/cts.sh"
|
||||||
|
awk '$2=="HUNG" || $2=="CRASH" {print $1, $2, $2; next}
|
||||||
|
$3 != 0 || $4 != 0 {print $1, $3, $4}' "$work/results"
|
||||||
|
} > "$baseline"
|
||||||
|
echo "cts: $summary"
|
||||||
|
echo "cts: baseline written to $baseline ($(grep -cv '^#' "$baseline") namespaces)"
|
||||||
|
exit 0
|
||||||
|
fi
|
||||||
|
|
||||||
|
if [ ! -f "$baseline" ]; then
|
||||||
|
echo "cts: FAIL — no baseline; run JOLT_CTS_WRITE_BASELINE=1 host/chez/cts.sh"
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
|
||||||
|
status=0
|
||||||
|
while read -r ns p f e; do
|
||||||
|
case "$p" in HUNG|CRASH) f="$p"; e="$p" ;; esac
|
||||||
|
bl=$(grep -v '^#' "$baseline" | awk -v n="$ns" '$1==n {print $2, $3; exit}')
|
||||||
|
if [ -n "$bl" ]; then bf="${bl%% *}"; be="${bl##* }"; else bf=0; be=0; fi
|
||||||
|
if [ "$f" = "$bf" ] && [ "$e" = "$be" ]; then
|
||||||
|
continue
|
||||||
|
elif [ "$f" = "HUNG" ] || [ "$f" = "CRASH" ] \
|
||||||
|
|| { [ "$bf" != "HUNG" ] && [ "$bf" != "CRASH" ] \
|
||||||
|
&& { [ "$f" -gt "$bf" ] || [ "$e" -gt "$be" ]; }; }; then
|
||||||
|
echo "cts: NEW regression in $ns — fail $f error $e (baseline $bf $be)"
|
||||||
|
status=1
|
||||||
|
else
|
||||||
|
echo "cts: STALE baseline for $ns — now fail $f error $e (baseline $bf $be); update $baseline"
|
||||||
|
status=1
|
||||||
|
fi
|
||||||
|
done < "$work/results"
|
||||||
|
|
||||||
|
# a baseline entry whose namespace no longer reports is stale too
|
||||||
|
while read -r ns bf be; do
|
||||||
|
grep -q "^$ns " "$work/results" || { echo "cts: STALE baseline entry $ns (namespace gone)"; status=1; }
|
||||||
|
done < <(grep -v '^#' "$baseline")
|
||||||
|
|
||||||
|
echo "cts: $summary"
|
||||||
|
if [ $status -eq 0 ]; then echo "cts: passed (matches baseline)"; else echo "cts: FAILED"; fi
|
||||||
|
exit $status
|
||||||
|
|
@ -63,6 +63,12 @@
|
||||||
;; a lazy-seq carries its own realized? flag (lazy-bridge.ss). The overlay
|
;; a lazy-seq carries its own realized? flag (lazy-bridge.ss). The overlay
|
||||||
;; realized? reads :jolt/type and throws on a jolt-lazyseq record.
|
;; realized? reads :jolt/type and throws on a jolt-lazyseq record.
|
||||||
((jolt-lazyseq? x) (jolt-lazyseq-realized? x))
|
((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))))))
|
(else (jolt-invoke overlay-realized? x))))))
|
||||||
;; clojure.edn/read over a reader: drain the jhost reader, then read through the
|
;; 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.
|
;; overlay read-string so the opts map (:readers/:default/:eof) is honored.
|
||||||
|
|
|
||||||
|
|
@ -319,7 +319,7 @@
|
||||||
(guard (e (#t #f))
|
(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?)))
|
(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))
|
(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))
|
(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)))
|
(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))
|
(guard (e (#t #f))
|
||||||
|
|
|
||||||
|
|
@ -257,12 +257,18 @@
|
||||||
=> (lambda (m) (apply jolt-invoke m f args)))
|
=> (lambda (m) (apply jolt-invoke m f args)))
|
||||||
((and (reified-methods f) (hashtable-ref (reified-methods f) "invoke" #f))
|
((and (reified-methods f) (hashtable-ref (reified-methods f) "invoke" #f))
|
||||||
=> (lambda (m) (apply jolt-invoke m f args)))
|
=> (lambda (m) (apply jolt-invoke m f args)))
|
||||||
;; calling a non-fn: a ClassCastException naming the operator, thrown via
|
;; calling a non-fn: a ClassCastException naming the operator's CLASS (like
|
||||||
;; jolt-throw so it is catchable and carries the throw-site continuation for a
|
;; the JVM's "class clojure.lang.LazySeq cannot be cast to ... IFn" — never
|
||||||
;; stack trace.
|
;; 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"
|
(else (jolt-throw (jolt-host-throwable "java.lang.ClassCastException"
|
||||||
(string-append (guard (e (#t "value")) (jolt-pr-str f))
|
(string-append
|
||||||
" cannot be cast to clojure.lang.IFn"))))))
|
"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
|
;; chunked-seq accessors — the host side of the Clojure IChunkedSeq contract
|
||||||
|
|
|
||||||
|
|
@ -96,10 +96,16 @@
|
||||||
((and (jolt-coll? a) (jolt-coll? b)) (jolt-coll=? a b))
|
((and (jolt-coll? a) (jolt-coll? b)) (jolt-coll=? a b))
|
||||||
(else (eq? a b))))
|
(else (eq? a b))))
|
||||||
(define (jolt=2 a b)
|
(define (jolt=2 a b)
|
||||||
(let loop ((as jolt-eq-arms))
|
;; identity fast path, like Util.equiv's k1 == k2: the same object equals
|
||||||
(cond ((null? as) (jolt=2-base a b))
|
;; itself without a structural walk — (= s s) on an infinite lazy seq must not
|
||||||
(((caar as) a b) ((cdar as) a b))
|
;; realize it. Numbers keep the exactness-aware arm (Chez may intern flonum
|
||||||
(else (loop (cdr as))))))
|
;; 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)
|
(define (jolt= a . rest)
|
||||||
(let loop ((a a) (rest rest))
|
(let loop ((a a) (rest rest))
|
||||||
(cond ((null? rest) #t)
|
(cond ((null? rest) #t)
|
||||||
|
|
|
||||||
|
|
@ -426,7 +426,9 @@
|
||||||
(future? x) (boolean (get x :cached))
|
(future? x) (boolean (get x :cached))
|
||||||
(= :jolt/lazy-seq (get x :jolt/type)) (boolean (get x :realized))
|
(= :jolt/lazy-seq (get x :jolt/type)) (boolean (get x :realized))
|
||||||
(atom? x) true
|
(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))
|
(defn force [x] (if (delay? x) (deref x) x))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -19,8 +19,8 @@
|
||||||
(def jolt-report counters) ;; alias used by the suite harness
|
(def jolt-report counters) ;; alias used by the suite harness
|
||||||
(def ctx-stack (atom []))
|
(def ctx-stack (atom []))
|
||||||
(def registry (atom [])) ;; [{:name sym :fn thunk}]
|
(def registry (atom [])) ;; [{:name sym :fn thunk}]
|
||||||
(def once-fixtures (atom []))
|
(def once-fixtures (atom {})) ;; ns-sym -> [fixture-fns]
|
||||||
(def each-fixtures (atom []))
|
(def each-fixtures (atom {})) ;; ns-sym -> [fixture-fns]
|
||||||
|
|
||||||
;; clojure.test/*testing-vars* — the stack of vars under test. Real clojure.test
|
;; 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
|
;; 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! counters {:test 0 :pass 0 :fail 0 :error 0 :fails []})
|
||||||
(reset! ctx-stack [])
|
(reset! ctx-stack [])
|
||||||
(reset! registry [])
|
(reset! registry [])
|
||||||
(reset! once-fixtures [])
|
(reset! once-fixtures {})
|
||||||
(reset! each-fixtures []))
|
(reset! each-fixtures {}))
|
||||||
|
|
||||||
(defn- ctx-str [] (str/join " " @ctx-stack))
|
(defn- ctx-str [] (str/join " " @ctx-stack))
|
||||||
|
|
||||||
|
|
@ -135,6 +135,15 @@
|
||||||
([form] `(is ~form nil))
|
([form] `(is ~form nil))
|
||||||
([form msg]
|
([form msg]
|
||||||
(cond
|
(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...))
|
;; (is (thrown? Class body...))
|
||||||
(thrown-form? form "thrown?")
|
(thrown-form? form "thrown?")
|
||||||
(let [klass-sym (second form)
|
(let [klass-sym (second form)
|
||||||
|
|
@ -172,13 +181,6 @@
|
||||||
(clojure.test/inc-pass!)
|
(clojure.test/inc-pass!)
|
||||||
(clojure.test/fail! (str "expected throw of " ~klass " matching " ~re " but got " (clojure.core/class e#) ": " m#)))))))
|
(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
|
;; 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.
|
;; failure shows the actual values, like clojure.test's assert-predicate.
|
||||||
(and (seq? form) (contains? clojure.test/reported-preds (first form)))
|
(and (seq? form) (contains? clojure.test/reported-preds (first form)))
|
||||||
|
|
@ -209,7 +211,9 @@
|
||||||
(defmacro deftest [name & body]
|
(defmacro deftest [name & body]
|
||||||
`(do
|
`(do
|
||||||
(defn ~name [] ~@body)
|
(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)))
|
(var ~name)))
|
||||||
|
|
||||||
(defmacro are [argv expr & data]
|
(defmacro are [argv expr & data]
|
||||||
|
|
@ -222,10 +226,15 @@
|
||||||
|
|
||||||
;; --- fixtures + run --------------------------------------------------------
|
;; --- 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]
|
(defn use-fixtures [kind & fns]
|
||||||
(cond
|
(let [n (ns-name *ns*)]
|
||||||
(= kind :once) (reset! once-fixtures (vec fns))
|
(cond
|
||||||
(= kind :each) (reset! each-fixtures (vec fns))))
|
(= kind :once) (swap! once-fixtures assoc n (vec fns))
|
||||||
|
(= kind :each) (swap! each-fixtures assoc n (vec fns)))))
|
||||||
|
|
||||||
(defn- wrap-fixtures [fixtures body-fn]
|
(defn- wrap-fixtures [fixtures body-fn]
|
||||||
(if (empty? fixtures)
|
(if (empty? fixtures)
|
||||||
|
|
@ -234,25 +243,46 @@
|
||||||
|
|
||||||
(defn- run-one [t]
|
(defn- run-one [t]
|
||||||
(swap! counters update :test inc)
|
(swap! counters update :test inc)
|
||||||
(wrap-fixtures @each-fixtures
|
(wrap-fixtures (get @each-fixtures (:ns t) [])
|
||||||
(fn []
|
(fn []
|
||||||
(try
|
(try
|
||||||
((:fn t))
|
((:fn t))
|
||||||
(catch Throwable e
|
(catch Throwable e
|
||||||
(err! (str (:name t) " crashed: " (err-text e))))))))
|
(err! (str (:name t) " crashed: " (err-text e))))))))
|
||||||
|
|
||||||
(defn run-registered []
|
;; Run the registered tests grouped by namespace (registration order preserved
|
||||||
(doseq [t @registry] (run-one t))
|
;; 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)
|
nil)
|
||||||
|
|
||||||
(defn run-tests [& _nses]
|
(defn run-registered [] (run-selected nil))
|
||||||
(wrap-fixtures @once-fixtures (fn [] (run-registered)))
|
|
||||||
(let [r @counters]
|
;; (run-tests 'ns1 'ns2 …) runs only those namespaces' tests, like clojure.test.
|
||||||
(println)
|
;; With no args it runs everything registered (a deliberate superset of the
|
||||||
(println (str "Ran " (:test r) " tests. "
|
;; JVM's current-ns default — jolt's harnesses load then run whole suites).
|
||||||
(:pass r) " assertions passed, "
|
;; Prints and returns THIS call's summary; the global counters stay cumulative
|
||||||
(:fail r) " failures, " (:error r) " errors."))
|
;; for the n-pass/n-fail harness API.
|
||||||
r))
|
(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 run-test [& _] nil)
|
||||||
(defn test-var [& _] nil)
|
(defn test-var [& _] nil)
|
||||||
|
|
|
||||||
|
|
@ -32,6 +32,16 @@ answers with `regen-corpus.clj` and re-certify with `test/conformance/certify.cl
|
||||||
- `selfcheck.sh` — self-host fixpoint: `bootstrap.ss` rebuild byte-equals the
|
- `selfcheck.sh` — self-host fixpoint: `bootstrap.ss` rebuild byte-equals the
|
||||||
checked-in seed (`host/chez/seed/`).
|
checked-in seed (`host/chez/seed/`).
|
||||||
- `smoke.sh` — real `bin/joltc -e` CLI smoke.
|
- `smoke.sh` — real `bin/joltc -e` CLI smoke.
|
||||||
|
- `cts.sh` — the vendored [jank-lang/clojure-test-suite](https://github.com/jank-lang/clojure-test-suite)
|
||||||
|
(`vendor/clojure-test-suite`, a per-core-fn clojure.test suite shared across
|
||||||
|
Clojure dialects), run one namespace per `joltc` process (a hang or crash is
|
||||||
|
contained) through the `test/chez/cts-app` project and `cts-run` runner.
|
||||||
|
Per-namespace fail/error counts must exactly match the checked-in baseline
|
||||||
|
`test/chez/cts-known-failures.txt` — a namespace doing worse fails the gate,
|
||||||
|
and one doing better fails as stale until the baseline is updated in the same
|
||||||
|
change. `make cts`;
|
||||||
|
`JOLT_CTS_NS=ns1,ns2` runs a subset verbosely,
|
||||||
|
`JOLT_CTS_WRITE_BASELINE=1` regenerates the baseline.
|
||||||
|
|
||||||
## Other Chez tests
|
## Other Chez tests
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -11,6 +11,17 @@
|
||||||
(clojure.test/do-report {:type :pass})
|
(clojure.test/do-report {:type :pass})
|
||||||
(clojure.test/do-report {:type :fail :message ~msg :form '~form}))))
|
(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)
|
;; a custom report type (how test.check surfaces trial/shrink progress)
|
||||||
(def trials (atom 0))
|
(def trials (atom 0))
|
||||||
(defmethod t/report ::trial [_m] (swap! trials inc))
|
(defmethod t/report ::trial [_m] (swap! trials inc))
|
||||||
|
|
@ -27,21 +38,28 @@
|
||||||
6 (* 2 3))
|
6 (* 2 3))
|
||||||
(is (thrown? clojure.lang.ExceptionInfo (throw (ex-info "x" {}))))
|
(is (thrown? clojure.lang.ExceptionInfo (throw (ex-info "x" {}))))
|
||||||
(is (thrown-with-msg? Exception #"bad" (throw (ex-info "bad" {}))))
|
(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
|
(deftest expected-fail
|
||||||
(is (= 1 2))
|
(is (= 1 2))
|
||||||
(is (near? 1.0 5.0)))
|
(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})
|
||||||
(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
|
;; 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))]
|
(= @setups 2) (= @trials 2))]
|
||||||
(println (if ok
|
(println (if ok
|
||||||
"CLOJURE-TEST OK"
|
"CLOJURE-TEST OK"
|
||||||
(str "CLOJURE-TEST FAIL pass=" (t/n-pass) " fail=" (t/n-fail)
|
(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))))
|
||||||
|
|
|
||||||
|
|
@ -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 "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 / 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 "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))])"}
|
||||||
]
|
]
|
||||||
|
|
|
||||||
2
test/chez/cts-app/deps.edn
Normal file
2
test/chez/cts-app/deps.edn
Normal file
|
|
@ -0,0 +1,2 @@
|
||||||
|
{:paths ["src" "../../../vendor/clojure-test-suite/test"]
|
||||||
|
:aliases {:cts {:main-opts ["-m" "cts-run"]}}}
|
||||||
18
test/chez/cts-app/src/cts_run.clj
Normal file
18
test/chez/cts-app/src/cts_run.clj
Normal file
|
|
@ -0,0 +1,18 @@
|
||||||
|
(ns cts-run
|
||||||
|
"Runner for the vendored jank-lang/clojure-test-suite (vendor/clojure-test-suite):
|
||||||
|
requires each test namespace given on the command line and runs its clojure.test
|
||||||
|
tests, printing one machine-readable result line per namespace. Driven per-process
|
||||||
|
by host/chez/cts.sh so a hang or crash in one namespace can't take out the run."
|
||||||
|
(:require [clojure.test :as t]))
|
||||||
|
|
||||||
|
(defn -main [& nses]
|
||||||
|
(doseq [n nses]
|
||||||
|
(let [ns-sym (symbol n)]
|
||||||
|
(try
|
||||||
|
(require ns-sym)
|
||||||
|
(let [r (t/run-tests ns-sym)]
|
||||||
|
(println "CTS-RESULT" n (:pass r 0) (:fail r 0) (:error r 0)))
|
||||||
|
(catch Throwable e
|
||||||
|
(println "CTS-RESULT" n 0 0 1
|
||||||
|
(str "LOAD: " (.getName (class e)) ": " (.getMessage e)))))))
|
||||||
|
(System/exit 0))
|
||||||
91
test/chez/cts-known-failures.txt
Normal file
91
test/chez/cts-known-failures.txt
Normal file
|
|
@ -0,0 +1,91 @@
|
||||||
|
# clojure-test-suite known failures: <namespace> <fail> <error>
|
||||||
|
# The gate fails on any per-namespace change, worse OR better; regenerate
|
||||||
|
# with: JOLT_CTS_WRITE_BASELINE=1 host/chez/cts.sh
|
||||||
|
clojure.core-test.abs 1 1
|
||||||
|
clojure.core-test.add-watch 0 3
|
||||||
|
clojure.core-test.ancestors 9 0
|
||||||
|
clojure.core-test.atom 14 0
|
||||||
|
clojure.core-test.bigint 6 0
|
||||||
|
clojure.core-test.bit-set 1 0
|
||||||
|
clojure.core-test.boolean-qmark 0 1
|
||||||
|
clojure.core-test.byte 7 5
|
||||||
|
clojure.core-test.char 1 0
|
||||||
|
clojure.core-test.compare 1 0
|
||||||
|
clojure.core-test.conj 1 0
|
||||||
|
clojure.core-test.contains-qmark 3 0
|
||||||
|
clojure.core-test.counted-qmark 1 0
|
||||||
|
clojure.core-test.dec 1 0
|
||||||
|
clojure.core-test.denominator 0 3
|
||||||
|
clojure.core-test.derive 21 0
|
||||||
|
clojure.core-test.descendants 4 0
|
||||||
|
clojure.core-test.double 0 4
|
||||||
|
clojure.core-test.double-qmark 3 0
|
||||||
|
clojure.core-test.empty 1 0
|
||||||
|
clojure.core-test.eq 2 0
|
||||||
|
clojure.core-test.eval 0 3
|
||||||
|
clojure.core-test.even-qmark 1 0
|
||||||
|
clojure.core-test.float 4 4
|
||||||
|
clojure.core-test.get 0 1
|
||||||
|
clojure.core-test.gt 0 2
|
||||||
|
clojure.core-test.gt-eq 0 2
|
||||||
|
clojure.core-test.ifn-qmark 2 0
|
||||||
|
clojure.core-test.inc 1 0
|
||||||
|
clojure.core-test.int 4 5
|
||||||
|
clojure.core-test.int-qmark 3 0
|
||||||
|
clojure.core-test.intern 2 0
|
||||||
|
clojure.core-test.keys 0 4
|
||||||
|
clojure.core-test.lazy-seq 3 0
|
||||||
|
clojure.core-test.long 2 5
|
||||||
|
clojure.core-test.lt 0 2
|
||||||
|
clojure.core-test.lt-eq 0 2
|
||||||
|
clojure.core-test.max 3 1
|
||||||
|
clojure.core-test.min 3 1
|
||||||
|
clojure.core-test.minus 2 0
|
||||||
|
clojure.core-test.mod 12 34
|
||||||
|
clojure.core-test.neg-int-qmark 1 0
|
||||||
|
clojure.core-test.not-eq 3 0
|
||||||
|
clojure.core-test.nth 0 1
|
||||||
|
clojure.core-test.num 2 1
|
||||||
|
clojure.core-test.number-qmark 3 0
|
||||||
|
clojure.core-test.numerator 0 3
|
||||||
|
clojure.core-test.odd-qmark 1 0
|
||||||
|
clojure.core-test.parents 10 0
|
||||||
|
clojure.core-test.parse-uuid 3 0
|
||||||
|
clojure.core-test.peek 2 0
|
||||||
|
clojure.core-test.plus 11 0
|
||||||
|
clojure.core-test.plus-squote 11 0
|
||||||
|
clojure.core-test.pop 0 1
|
||||||
|
clojure.core-test.pos-int-qmark 1 0
|
||||||
|
clojure.core-test.quot 12 31
|
||||||
|
clojure.core-test.rand-nth 0 1
|
||||||
|
clojure.core-test.rational-qmark 3 0
|
||||||
|
clojure.core-test.rationalize 10 0
|
||||||
|
clojure.core-test.realized-qmark 3 0
|
||||||
|
clojure.core-test.reduce 0 1
|
||||||
|
clojure.core-test.rem 12 30
|
||||||
|
clojure.core-test.remove-watch 0 1
|
||||||
|
clojure.core-test.run-bang 1 0
|
||||||
|
clojure.core-test.select-keys 2 0
|
||||||
|
clojure.core-test.seqable-qmark 1 0
|
||||||
|
clojure.core-test.short 7 5
|
||||||
|
clojure.core-test.shuffle 1 0
|
||||||
|
clojure.core-test.slash 2 48
|
||||||
|
clojure.core-test.some-fn 3 0
|
||||||
|
clojure.core-test.sort-by 2 0
|
||||||
|
clojure.core-test.special-symbol-qmark 20 0
|
||||||
|
clojure.core-test.star 22 0
|
||||||
|
clojure.core-test.star-squote 19 0
|
||||||
|
clojure.core-test.transient 23 0
|
||||||
|
clojure.core-test.underive 7 0
|
||||||
|
clojure.core-test.update 1 0
|
||||||
|
clojure.core-test.vals 0 3
|
||||||
|
clojure.core-test.vec 1 0
|
||||||
|
clojure.core-test.when-let 1 0
|
||||||
|
clojure.core-test.with-precision 17 0
|
||||||
|
clojure.edn-test.read-string 0 1
|
||||||
|
clojure.string-test.capitalize 0 4
|
||||||
|
clojure.string-test.ends-with-qmark 1 4
|
||||||
|
clojure.string-test.escape 1 0
|
||||||
|
clojure.string-test.lower-case 0 4
|
||||||
|
clojure.string-test.starts-with-qmark 1 10
|
||||||
|
clojure.string-test.upper-case 0 4
|
||||||
1
vendor/clojure-test-suite
vendored
Submodule
1
vendor/clojure-test-suite
vendored
Submodule
|
|
@ -0,0 +1 @@
|
||||||
|
Subproject commit 489b6743e8421687ef96cec557830acf258d1886
|
||||||
Loading…
Add table
Add a link
Reference in a new issue