diff --git a/docs/spec/coverage.md b/docs/spec/coverage.md index 7d93ce5..cad2def 100644 --- a/docs/spec/coverage.md +++ b/docs/spec/coverage.md @@ -3,16 +3,16 @@ Generated 2026-06-26 by `tools/spec_coverage.py` — do not edit by hand. Surface: **694** clojure.core vars (ClojureDocs export; 648 with -community examples). jolt interns 591 of them. +community examples). jolt interns 594 of them. | Status | Count | Meaning | |---|---|---| -| implemented+tested | 587 | in jolt and exercised by spec/conformance | +| implemented+tested | 590 | in jolt and exercised by spec/conformance | | implemented-untested | 4 | in jolt, no direct test — spec entries will add them | | resolvable-not-interned | 0 | works in code but invisible to ns introspection (conformance finding) | | missing-portable | 0 | portable semantics, jolt lacks it — implementation gap | | special-form | 16 | specified in §3, not a library var | -| dynamic-var | 14 | classification needed: portable default vs host-dependent | +| dynamic-var | 11 | classification needed: portable default vs host-dependent | | agents-taps | 16 | out of scope pending concurrency design note | | stm-refs | 11 | out of scope pending concurrency design note | | jvm-specific | 46 | catalogued, not specified | @@ -39,7 +39,7 @@ UNVERIFIED field; that column will be added as entries land. | `*compile-path*` | dynamic-var | ✓ | | `*compiler-options*` | dynamic-var | ✓ | | `*data-readers*` | implemented+tested | ✓ | -| `*default-data-reader-fn*` | dynamic-var | ✓ | +| `*default-data-reader-fn*` | implemented+tested | ✓ | | `*e` | implemented+tested | ✓ | | `*err*` | implemented+tested | ✓ | | `*file*` | implemented-untested | ✓ | @@ -50,8 +50,8 @@ UNVERIFIED field; that column will be added as entries land. | `*ns*` | implemented+tested | ✓ | | `*out*` | implemented+tested | ✓ | | `*print-dup*` | implemented+tested | ✓ | -| `*print-length*` | dynamic-var | ✓ | -| `*print-level*` | dynamic-var | ✓ | +| `*print-length*` | implemented+tested | ✓ | +| `*print-level*` | implemented+tested | ✓ | | `*print-meta*` | implemented+tested | ✓ | | `*print-namespace-maps*` | implemented-untested | ✓ | | `*print-readably*` | implemented+tested | ✓ | diff --git a/host/chez/dynamic-var-defaults.ss b/host/chez/dynamic-var-defaults.ss index 68e0655..9520dfa 100644 --- a/host/chez/dynamic-var-defaults.ss +++ b/host/chez/dynamic-var-defaults.ss @@ -29,11 +29,19 @@ ;; *print-meta* — when true, pr prints metadata with a ^ prefix; default false. (def-var! "clojure.core" "*print-meta*" #f) +;; *print-length* / *print-level* — collection print limits, honored by both +;; printers (rt.ss jolt-pr-str + printing.ss jolt-pr-readable). nil = unlimited +;; (the default); a number truncates elements / collapses depth to "#". +;; *print-length* limits a lazy/infinite seq before realizing it. +(def-var! "clojure.core" "*print-length*" jolt-nil) +(def-var! "clojure.core" "*print-level*" jolt-nil) +;; *default-data-reader-fn* — a (fn [tag value]) the reader consults for an +;; unregistered #tag before raising; nil = no default handler. +(def-var! "clojure.core" "*default-data-reader-fn*" jolt-nil) + ;; Portable clojure.core dynamic vars whose DEFAULT already matches jolt's ;; behaviour, so exposing them is sound (resolve/binding work, reads return the -;; right value) — not a silent divergence. The ones that change observable output -;; if set non-default (*print-length* / *print-level* / *default-data-reader-fn*) -;; are deliberately NOT interned until the printer/reader honour them. +;; right value) — not a silent divergence. ;; ;; *read-eval* — gates #=() read-eval. jolt's reader has no #=, so it reads true ;; (no eval-on-read happens regardless); a lib can (binding [*read-eval* false] …). diff --git a/host/chez/printing.ss b/host/chez/printing.ss index 464c9ee..5df1dbf 100644 --- a/host/chez/printing.ss +++ b/host/chez/printing.ss @@ -47,25 +47,22 @@ ((jolt-transient? x) (case (jolt-transient-kind x) ((vec) "#") ((set) "#") (else "#"))) - ((pvec? x) - (let ((acc '())) - (let loop ((i (fx- (pvec-count x) 1))) - (when (fx>=? i 0) - (set! acc (cons (jolt-pr-readable (pvec-nth-d x i jolt-nil)) acc)) - (loop (fx- i 1)))) - (string-append "[" (jolt-str-join acc) "]"))) - ((pset? x) - (string-append "#{" (jolt-str-join (pset-fold x (lambda (e a) (cons (jolt-pr-readable e) a)) '())) "}")) - ((pmap? x) - (string-append "{" (jolt-str-join - (pmap-fold x (lambda (k v a) - (cons (string-append (jolt-pr-readable k) " " (jolt-pr-readable v)) a)) '())) "}")) - ((empty-list-t? x) "()") - ((cseq? x) - (string-append "(" (jolt-str-join - (let loop ((s x) (acc '())) - (if (jolt-nil? s) (reverse acc) - (loop (jolt-seq (seq-more s)) (cons (jolt-pr-readable (seq-first s)) acc))))) ")")) + ((pvec? x) (if (jolt-print-hash?) "#" + (with-deeper-print + (string-append "[" (jolt-str-join (jolt-limited-vec-strs x jolt-pr-readable)) "]")))) + ((pset? x) (if (jolt-print-hash?) "#" + (with-deeper-print + (string-append "#{" (jolt-str-join (jolt-limited-list-strs + (pset-fold x (lambda (e a) (cons (jolt-pr-readable e) a)) '()))) "}")))) + ((pmap? x) (if (jolt-print-hash?) "#" + (with-deeper-print + (string-append "{" (jolt-str-join (jolt-limited-list-strs + (pmap-fold x (lambda (k v a) + (cons (string-append (jolt-pr-readable k) " " (jolt-pr-readable v)) a)) '()))) "}")))) + ((empty-list-t? x) (if (jolt-print-hash?) "#" "()")) + ((cseq? x) (if (jolt-print-hash?) "#" + (with-deeper-print + (string-append "(" (jolt-str-join (jolt-limited-seq-strs x jolt-pr-readable)) ")")))) (else (jolt-pr-str x)))) (define (jolt-pr-readable-dispatch x) (let loop ((as jolt-pr-readable-arms)) diff --git a/host/chez/reader.ss b/host/chez/reader.ss index 85b1608..c3494a6 100644 --- a/host/chez/reader.ss +++ b/host/chez/reader.ss @@ -631,16 +631,38 @@ (guard (e (#t #f)) (let ((fn (var-deref (symbol-t-ns v) (symbol-t-name v)))) (and (procedure? fn) fn))))))))) +;; the bare tag SYMBOL for a :#name / :#ns/name reader keyword (strip the leading +;; #, split a qualified tag on /). *default-data-reader-fn* receives it. +(define (rdr-tag->symbol tag) + (let* ((nm (keyword-t-name tag)) + (bare (if (and (> (string-length nm) 0) (char=? (string-ref nm 0) #\#)) + (substring nm 1 (string-length nm)) nm))) + (let loop ((i 0)) + (cond ((>= i (string-length bare)) (jolt-symbol #f bare)) + ((char=? (string-ref bare i) #\/) + (jolt-symbol (substring bare 0 i) (substring bare (+ i 1) (string-length bare)))) + (else (loop (+ i 1))))))) +;; *default-data-reader-fn* — a (fn [tag value]) consulted for an unregistered +;; tag, or #f when unset/nil. Honors a `binding` (var-deref reads the stack). +(define (rdr-default-data-reader-fn) + (guard (e (#t #f)) + (let ((v (var-deref "clojure.core" "*default-data-reader-fn*"))) + (and (not (jolt-nil? v)) (procedure? v) v)))) + ;; read-string / read data seam: construct the value for a #tag literal. #inst, -;; #uuid and #"regex" are built in; any other tag is applied from *data-readers*. -;; An unregistered tag stays a tagged FORM (lenient — clojure.edn raises instead). +;; #uuid and #"regex" are built in; any other tag is applied from *data-readers*, +;; then *default-data-reader-fn*. An unregistered tag with no default handler stays +;; a tagged FORM (lenient — clojure.edn raises instead). (define (rdr-construct-tag tag inner) (cond ((eq? tag (keyword #f "#inst")) (jolt-inst-from-string inner)) ((eq? tag (keyword #f "#uuid")) (jolt-uuid-from-string inner)) ((eq? tag (keyword #f "regex")) (jolt-re-pattern inner)) (else (let ((fn (rdr-data-reader-fn tag))) - (if fn (jolt-invoke fn inner) (rdr-make-tagged tag inner)))))) + (if fn (jolt-invoke fn inner) + (let ((dfn (rdr-default-data-reader-fn))) + (if dfn (jolt-invoke dfn (rdr-tag->symbol tag) inner) + (rdr-make-tagged tag inner)))))))) (define (rdr-form->data x) (cond @@ -695,13 +717,16 @@ (cond ((eq? tag (keyword #f "#uuid")) (jolt-uuid-from-string form)) ((eq? tag (keyword #f "#inst")) (jolt-inst-from-string form)) - ;; No registered reader: throw a clean, catchable ex-info naming the tag, like - ;; the JVM's "No reader function for tag foobar" (empty-pmap is a VALUE — the - ;; old (empty-pmap) applied it as a procedure and crashed the Chez VM). - (else (let* ((nm (keyword-t-name tag)) - (bare (if (and (> (string-length nm) 0) (char=? (string-ref nm 0) #\#)) - (substring nm 1 (string-length nm)) nm))) - (jolt-throw (jolt-ex-info (string-append "No reader function for tag " bare) empty-pmap)))))) + ;; No registered reader: consult *default-data-reader-fn*, else throw a clean, + ;; catchable ex-info naming the tag, like the JVM's "No reader function for tag + ;; foobar" (empty-pmap is a VALUE — the old (empty-pmap) applied it as a + ;; procedure and crashed the Chez VM). + (else (let ((dfn (rdr-default-data-reader-fn))) + (if dfn (jolt-invoke dfn (rdr-tag->symbol tag) form) + (let* ((nm (keyword-t-name tag)) + (bare (if (and (> (string-length nm) 0) (char=? (string-ref nm 0) #\#)) + (substring nm 1 (string-length nm)) nm))) + (jolt-throw (jolt-ex-info (string-append "No reader function for tag " bare) empty-pmap)))))))) (def-var! "clojure.core" "read-string" jolt-read-string) (def-var! "clojure.core" "__parse-next" jolt-parse-next) diff --git a/host/chez/rt.ss b/host/chez/rt.ss index bc5e4a5..24d6659 100644 --- a/host/chez/rt.ss +++ b/host/chez/rt.ss @@ -185,6 +185,55 @@ ;; bare nil renders as the empty string (a nil ELEMENT inside a collection still ;; prints "nil", which jolt-pr-str handles). (define (jolt-final-str x) (if (jolt-nil? x) "" (jolt-pr-str x))) +;; --- *print-level* / *print-length* ----------------------------------------- +;; Both vars default to nil (= unlimited). A non-nil number limits collection +;; nesting depth / element count in BOTH printers (jolt-pr-str here and +;; jolt-pr-readable in printing.ss). Cells captured lazily — the vars are def'd +;; after rt.ss. The nil default takes a fast path: jolt-print-hash? is #f and the +;; limited-string walkers never truncate. +(define plevel-cell #f) +(define plength-cell #f) +(define (jolt-print-level) + (unless plevel-cell (set! plevel-cell (jolt-var "clojure.core" "*print-level*"))) + (let ((v (jolt-var-get plevel-cell))) (and (number? v) v))) +(define (jolt-print-length) + (unless plength-cell (set! plength-cell (jolt-var "clojure.core" "*print-length*"))) + (let ((v (jolt-var-get plength-cell))) (and (number? v) v))) +(define jolt-print-depth (make-thread-parameter 0)) +;; A collection at depth >= *print-level* renders as "#". The top-level collection +;; is depth 0, so *print-level* 0 collapses any collection, 1 keeps the outermost. +(define (jolt-print-hash?) + (let ((lvl (jolt-print-level))) (and lvl (fx>=? (jolt-print-depth) lvl)))) +;; Rendered element strings of a vector (by index), honoring *print-length*: at +;; most N, then "...". render-one runs at the current (already bumped) depth. +(define (jolt-limited-vec-strs x render-one) + (let ((len (pvec-count x)) (lim (jolt-print-length))) + (let loop ((i 0) (acc '())) + (cond ((fx>=? i len) (reverse acc)) + ((and lim (fx>=? i lim)) (reverse (cons "..." acc))) + (else (loop (fx+ i 1) (cons (render-one (pvec-nth-d x i jolt-nil)) acc))))))) +;; Rendered element strings of a seq, walked lazily so an infinite seq is realized +;; only up to *print-length*. +(define (jolt-limited-seq-strs s render-one) + (let ((lim (jolt-print-length))) + (let loop ((s s) (i 0) (acc '())) + (cond ((jolt-nil? s) (reverse acc)) + ((and lim (fx>=? i lim)) (reverse (cons "..." acc))) + (else (loop (jolt-seq (seq-more s)) (fx+ i 1) (cons (render-one (seq-first s)) acc))))))) +;; Truncate an already-collected element-string list (set / map, finite) to +;; *print-length*, appending "..." when more remain. +(define (jolt-limited-list-strs strs) + (let ((lim (jolt-print-length))) + (if (not lim) strs + (let loop ((s strs) (i 0) (acc '())) + (cond ((null? s) (reverse acc)) + ((fx>=? i lim) (reverse (cons "..." acc))) + (else (loop (cdr s) (fx+ i 1) (cons (car s) acc)))))))) +;; bump the print depth around a collection's element rendering. +(define-syntax with-deeper-print + (syntax-rules () + ((_ body ...) (parameterize ((jolt-print-depth (fx+ (jolt-print-depth) 1))) body ...)))) + ;; A host shim registers a type's str-style rendering via register-pr-str-arm! (or ;; register-pr-arm! in printing.ss for both printers at once) instead of ;; set!-wrapping jolt-pr-str. Disjoint types, checked before the base cases. @@ -205,18 +254,23 @@ (if (or (jolt-nil? ns) (not ns) (eq? ns '())) (symbol-t-name x) (string-append ns "/" (symbol-t-name x))))) ((regex-t? x) (string-append "#\"" (regex-t-source x) "\"")) - ((pvec? x) (let ((acc '())) (let loop ((i (fx- (pvec-count x) 1))) - (when (fx>=? i 0) (set! acc (cons (jolt-pr-str (pvec-nth-d x i jolt-nil)) acc)) (loop (fx- i 1)))) - (string-append "[" (jolt-str-join acc) "]"))) - ((pset? x) (string-append "#{" (jolt-str-join (pset-fold x (lambda (e a) (cons (jolt-pr-str e) a)) '())) "}")) - ((pmap? x) (string-append "{" (jolt-str-join - (pmap-fold x (lambda (k v a) (cons (string-append (jolt-pr-str k) " " (jolt-pr-str v)) a)) '())) "}")) - ;; lists / cons / lazy seqs all print as (...) — forces a finite seq. - ((empty-list-t? x) "()") - ((cseq? x) (string-append "(" (jolt-str-join - (let loop ((s x) (acc '())) - (if (jolt-nil? s) (reverse acc) - (loop (jolt-seq (seq-more s)) (cons (jolt-pr-str (seq-first s)) acc))))) ")")) + ((pvec? x) (if (jolt-print-hash?) "#" + (with-deeper-print + (string-append "[" (jolt-str-join (jolt-limited-vec-strs x jolt-pr-str)) "]")))) + ((pset? x) (if (jolt-print-hash?) "#" + (with-deeper-print + (string-append "#{" (jolt-str-join (jolt-limited-list-strs + (pset-fold x (lambda (e a) (cons (jolt-pr-str e) a)) '()))) "}")))) + ((pmap? x) (if (jolt-print-hash?) "#" + (with-deeper-print + (string-append "{" (jolt-str-join (jolt-limited-list-strs + (pmap-fold x (lambda (k v a) (cons (string-append (jolt-pr-str k) " " (jolt-pr-str v)) a)) '()))) "}")))) + ;; lists / cons / lazy seqs all print as (...) — forces a finite seq (or up to + ;; *print-length* of an infinite one). + ((empty-list-t? x) (if (jolt-print-hash?) "#" "()")) + ((cseq? x) (if (jolt-print-hash?) "#" + (with-deeper-print + (string-append "(" (jolt-str-join (jolt-limited-seq-strs x jolt-pr-str)) ")")))) (else (format "~a" x)))) (define (jolt-pr-str x) (let loop ((as jolt-pr-str-arms)) diff --git a/test/chez/corpus.edn b/test/chez/corpus.edn index ea4405b..649d819 100644 --- a/test/chez/corpus.edn +++ b/test/chez/corpus.edn @@ -3251,4 +3251,14 @@ {:suite "vectors / large trie" :label "assoc in a large vector" :expected "[1098 :x 1100]" :actual "(let [v (assoc (vec (range 1100)) 1099 :x)] [(nth v 1098) (nth v 1099) (count v)])"} {:suite "vectors / large trie" :label "pop down across a level boundary" :expected "[1023 1022]" :actual "(let [p (pop (vec (range 1024)))] [(count p) (peek p)])"} {:suite "vectors / large trie" :label "pop to empty then rebuild" :expected "[0 5]" :actual "(let [e (loop [v (vec (range 100))] (if (seq v) (recur (pop v)) v))] [(count e) (count (into e (range 5)))])"} + {:suite "printer / print-length" :label "truncates an infinite seq before realizing it" :expected "true" :actual "(= \"(0 1 2 ...)\" (binding [*print-length* 3] (pr-str (range))))"} + {:suite "printer / print-length" :label "truncates a vector with ellipsis" :expected "true" :actual "(= \"[1 2 ...]\" (binding [*print-length* 2] (pr-str [1 2 3 4])))"} + {:suite "printer / print-length" :label "exactly N elements prints no ellipsis" :expected "true" :actual "(= \"(0 1 2)\" (binding [*print-length* 3] (pr-str (range 3))))"} + {:suite "printer / print-length" :label "nil default is unlimited" :expected "true" :actual "(= \"[1 2 3 4 5]\" (pr-str [1 2 3 4 5]))"} + {:suite "printer / print-level" :label "collapses a collection past the level to #" :expected "true" :actual "(= \"[:a [:b #]]\" (binding [*print-level* 2] (pr-str [:a [:b [:c 1]]])))"} + {:suite "printer / print-level" :label "level 0 collapses the top collection" :expected "true" :actual "(= \"#\" (binding [*print-level* 0] (pr-str [1 2])))"} + {:suite "printer / print-level" :label "level 1 keeps the outermost collection" :expected "true" :actual "(= \"[# 3]\" (binding [*print-level* 1] (pr-str [[1 2] 3])))"} + {:suite "printer / print-level" :label "scalars print regardless of level" :expected "true" :actual "(= \"[1 2]\" (binding [*print-level* 1] (pr-str [1 2])))"} + {:suite "reader / default-data-reader-fn" :label "consulted for an unregistered tag" :expected "true" :actual "(= [(quote foo) 42] (binding [*default-data-reader-fn* (fn [tag v] [tag v])] (read-string \"#foo 42\")))"} + {:suite "printer / print-vars" :label "print-length / print-level / default-data-reader-fn default to nil" :expected "[true true true]" :actual "[(nil? *print-length*) (nil? *print-level*) (nil? *default-data-reader-fn*)]"} ]