5c1fdfc336
Add a Janet-free gate so correctness can be judged with only Chez + Clojure: - host/chez/run-corpus.ss: corpus.edn vs JVM expecteds, lifting the per-case ns isolation from the old Janet driver; reads corpus.edn via the jolt reader. - host/chez/run-unit.ss + test/chez/unit.edn: the host-specific unit cases, evaluated in-process and compared to baked expecteds. - host/chez/selfcheck.sh: self-host fixpoint (bootstrap.ss rebuild == checked-in seed). - host/chez/smoke.sh: real bin/joltc CLI smoke. - host/chez/remint.sh: re-mint the seed to a byte-fixpoint after a source change. - Makefile: 'make test' runs the lot; 'make remint' rebuilds the seed. Numbers match the Janet gate: corpus 2679/2757 0 new div, unit 450/450, certify 0 new/0 stale. jolt-cf1q.6
103 lines
4.9 KiB
Scheme
103 lines
4.9 KiB
Scheme
;; run-unit.ss — host-specific unit gate, pure Chez. NO Janet.
|
|
;;
|
|
;; Loads the checked-in seed + spine, reads test/chez/unit.edn, and for each case
|
|
;; evaluates :expr (wrapped in (do ...), as `joltc -e` does) and compares its PRINTED
|
|
;; value (jolt-final-str) to the literal :expected string. :expected :throws asserts
|
|
;; the case raises. These cover host-specific behavior (dot-forms, java statics, io,
|
|
;; reader, walk, …) that isn't in the JVM-portable corpus. Global state is reset
|
|
;; between cases for per-case isolation.
|
|
;;
|
|
;; chez --script host/chez/run-unit.ss
|
|
(import (chezscheme))
|
|
|
|
(load "host/chez/rt.ss")
|
|
(set-chez-ns! "clojure.core")
|
|
(load "host/chez/seed/prelude.ss")
|
|
(load "host/chez/post-prelude.ss")
|
|
(set-chez-ns! "user")
|
|
(load "host/chez/host-contract.ss")
|
|
(load "host/chez/seed/image.ss")
|
|
(load "host/chez/compile-eval.ss")
|
|
|
|
(define (slurp path)
|
|
(call-with-input-file path
|
|
(lambda (p)
|
|
(let loop ((cs '()) (c (read-char p)))
|
|
(if (eof-object? c) (list->string (reverse cs))
|
|
(loop (cons c cs) (read-char p)))))))
|
|
|
|
(define cases (jolt-read-string (slurp "test/chez/unit.edn")))
|
|
(define kw-suite (keyword #f "suite"))
|
|
(define kw-expr (keyword #f "expr"))
|
|
(define kw-expected (keyword #f "expected"))
|
|
(define kw-throws (keyword #f "throws"))
|
|
|
|
;; --- per-case isolation (snapshot the world after setup, restore each case) -------
|
|
(define zj-base (let ((h (make-hashtable string-hash string=?)))
|
|
(vector-for-each (lambda (k) (hashtable-set! h k #t)) (hashtable-keys var-table)) h))
|
|
(define zj-roots '())
|
|
(vector-for-each (lambda (k) (let ((c (hashtable-ref var-table k #f)))
|
|
(when c (set! zj-roots (cons (cons c (var-cell-root c)) zj-roots)))))
|
|
(hashtable-keys var-table))
|
|
(define (zj-snap ht) (let ((h (make-hashtable string-hash string=?)))
|
|
(vector-for-each (lambda (k) (hashtable-set! h k #t)) (hashtable-keys ht)) h))
|
|
(define (zj-prune! ht base) (vector-for-each
|
|
(lambda (k) (unless (hashtable-ref base k #f) (hashtable-delete! ht k))) (hashtable-keys ht)))
|
|
(define zj-ns-base (zj-snap ns-registry))
|
|
(define zj-type-base (zj-snap type-registry))
|
|
(define zj-ghier (var-cell-lookup "clojure.core" "global-hierarchy"))
|
|
(define (zj-reset!)
|
|
(vector-for-each (lambda (k) (unless (hashtable-ref zj-base k #f) (hashtable-delete! var-table k)))
|
|
(hashtable-keys var-table))
|
|
(for-each (lambda (cr) (unless (eq? (var-cell-root (car cr)) (cdr cr))
|
|
(var-cell-root-set! (car cr) (cdr cr)))) zj-roots)
|
|
(zj-prune! ns-registry zj-ns-base)
|
|
(zj-prune! type-registry zj-type-base)
|
|
(hashtable-clear! ns-alias-table)
|
|
(hashtable-clear! ns-refer-table)
|
|
(when zj-ghier (jolt-invoke (var-deref "clojure.core" "reset!")
|
|
(var-cell-root zj-ghier) (jolt-invoke (var-deref "clojure.core" "make-hierarchy"))))
|
|
(set-chez-ns! "user"))
|
|
|
|
;; --- run ------------------------------------------------------------------------
|
|
(define pass 0)
|
|
(define fails '()) ; (suite expr msg)
|
|
(define suite-pass (make-hashtable string-hash string=?))
|
|
(define suite-total (make-hashtable string-hash string=?))
|
|
(define (bump! ht k) (hashtable-set! ht k (+ 1 (hashtable-ref ht k 0))))
|
|
|
|
(let loop ((i 0))
|
|
(when (< i (pvec-count cases))
|
|
(let* ((row (pvec-nth-d cases i jolt-nil))
|
|
(suite (jolt-get row kw-suite))
|
|
(expr (jolt-get row kw-expr))
|
|
(expected (jolt-get row kw-expected))
|
|
(throws? (eq? expected kw-throws))
|
|
(sink (open-output-string)))
|
|
(bump! suite-total suite)
|
|
(guard (e (#t (if throws?
|
|
(begin (set! pass (+ pass 1)) (bump! suite-pass suite))
|
|
(set! fails (cons (list suite expr "raised") fails)))))
|
|
(let ((got (jolt-final-str
|
|
(parameterize ((current-output-port sink))
|
|
(jolt-compile-eval (string-append "(do " expr ")") "user")))))
|
|
(cond
|
|
(throws? (set! fails (cons (list suite expr (string-append "expected throw; got " got)) fails)))
|
|
((string=? got expected) (begin (set! pass (+ pass 1)) (bump! suite-pass suite)))
|
|
(else (set! fails (cons (list suite expr
|
|
(string-append "want `" expected "` got `" got "`")) fails))))))
|
|
(zj-reset!))
|
|
(loop (+ i 1))))
|
|
|
|
(printf "\nunit gate: ~a/~a passed\n" pass (pvec-count cases))
|
|
(let-values (((ks vs) (hashtable-entries suite-total)))
|
|
(for-each (lambda (p)
|
|
(printf " ~a/~a ~a\n" (hashtable-ref suite-pass (car p) 0) (cdr p) (car p)))
|
|
(list-sort (lambda (a b) (string<? (car a) (car b)))
|
|
(vector->list (vector-map cons ks vs)))))
|
|
(when (> (length fails) 0)
|
|
(printf "\n~a FAIL(s):\n" (length fails))
|
|
(for-each (lambda (f) (printf " [~a] ~a\n ~a\n" (car f) (caddr f) (cadr f)))
|
|
(list-head (reverse fails) (min 40 (length fails)))))
|
|
(flush-output-port)
|
|
(exit (if (> (length fails) 0) 1 0))
|