diff --git a/host/chez/bigdec.ss b/host/chez/bigdec.ss index e99b62b..598acae 100644 --- a/host/chez/bigdec.ss +++ b/host/chez/bigdec.ss @@ -68,8 +68,7 @@ (else (%bd-jolt=2 a b))))) ;; str drops the M; pr/pr-str keep it. -(define %bd-str-render jolt-str-render-one) -(set! jolt-str-render-one (lambda (x) (if (jbigdec? x) (jbigdec->string x) (%bd-str-render x)))) +(register-str-render! jbigdec? jbigdec->string) (define %bd-pr-str jolt-pr-str) (set! jolt-pr-str (lambda (x) (if (jbigdec? x) (string-append (jbigdec->string x) "M") (%bd-pr-str x)))) (define %bd-pr-readable jolt-pr-readable) diff --git a/host/chez/converters.ss b/host/chez/converters.ss index 5f5e589..04bf7c4 100644 --- a/host/chez/converters.ss +++ b/host/chez/converters.ss @@ -3,8 +3,19 @@ ;; the printer. int/long truncate toward zero to an exact integer; compare returns ;; an exact -1/0/1; double yields a flonum. -;; str: nil -> "", string raw, char bare (not \c), regex -> raw source, else the -;; printer (which renders collections with readable elements). +;; str rendering for the value types not handled by the fast arms below. A host +;; shim loaded later (records, host-table, inst-time, …) registers an arm with +;; register-str-render! instead of set!-wrapping jolt-str-render-one — the arms +;; are type-disjoint, so the full behavior is the base arms here plus the +;; registry, gathered in one place rather than scattered across a set! chain. +;; Newest registration is checked first (matches the old outermost-wins order). +(define str-render-registry '()) ; list of (pred . render), checked front-to-back +(define (register-str-render! pred render) + (set! str-render-registry (cons (cons pred render) str-render-registry))) + +;; str: nil -> "", string raw, char bare (not \c), regex -> raw source, a +;; registered host type via its arm, else the printer (which renders collections +;; with readable elements). (define (jolt-str-render-one v) (cond ((jolt-nil? v) "") @@ -16,7 +27,12 @@ ((and (flonum? v) (fl= v +inf.0)) "Infinity") ((and (flonum? v) (fl= v -inf.0)) "-Infinity") ((and (flonum? v) (not (fl= v v))) "NaN") - (else (jolt-pr-str v)))) + (else + (let loop ((rs str-render-registry)) + (cond + ((null? rs) (jolt-pr-str v)) + (((caar rs) v) ((cdar rs) v)) + (else (loop (cdr rs)))))))) (define (jolt-str . xs) (let loop ((xs xs) (acc '())) (if (null? xs) diff --git a/host/chez/host-static-objects.ss b/host/chez/host-static-objects.ss index e1da1a5..c0fffc4 100644 --- a/host/chez/host-static-objects.ss +++ b/host/chez/host-static-objects.ss @@ -487,16 +487,14 @@ ;; 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 '()) -(define %hs-instance-check instance-check) -(set! instance-check +(register-instance-check-arm! (lambda (type-sym val) (let ((tname (symbol-t-name type-sym))) (let loop ((fs user-instance-checks)) (if (null? fs) - (%hs-instance-check type-sym val) + 'pass (let ((r ((car fs) tname val))) (if (jolt-nil? r) (loop (cdr fs)) (if (jolt-truthy? r) #t #f)))))))) -(def-var! "clojure.core" "instance-check" instance-check) (def-var! "clojure.core" "__register-instance-check!" (lambda (f) (set! user-instance-checks (append user-instance-checks (list f))) jolt-nil)) diff --git a/host/chez/host-table.ss b/host/chez/host-table.ss index 67a4bcf..bd2ed29 100644 --- a/host/chez/host-table.ss +++ b/host/chez/host-table.ss @@ -160,8 +160,7 @@ (set! jolt-pr-readable (lambda (x) (if (htable-sorted? x) (sorted-render x jolt-pr-readable) (%h-pr-readable x)))) (define %h-pr-str jolt-pr-str) (set! jolt-pr-str (lambda (x) (if (htable-sorted? x) (sorted-render x jolt-pr-str) (%h-pr-str x)))) -(define %h-str-render-one jolt-str-render-one) -(set! jolt-str-render-one (lambda (x) (if (htable-sorted? x) (sorted-render x jolt-str-render-one) (%h-str-render-one x)))) +(register-str-render! htable-sorted? (lambda (x) (sorted-render x jolt-str-render-one))) ;; --- protocol dispatch over builtins (extend-protocol Map/Set on sorted) ------ ;; value-host-tags (records.ss) drives extend-protocol on host values; a diff --git a/host/chez/inst-time.ss b/host/chez/inst-time.ss index e14899b..55434bd 100644 --- a/host/chez/inst-time.ss +++ b/host/chez/inst-time.ss @@ -255,8 +255,7 @@ (set! jolt-pr-str (lambda (x) (if (jinst? x) (inst-pr x) (%it-pr-str x)))) (define %it-pr-readable jolt-pr-readable) (set! jolt-pr-readable (lambda (x) (if (jinst? x) (inst-pr x) (%it-pr-readable x)))) -(define %it-str-render jolt-str-render-one) -(set! jolt-str-render-one (lambda (x) (if (jinst? x) (inst-rfc3339 x) (%it-str-render x)))) +(register-str-render! jinst? inst-rfc3339) (define %it-type jolt-type) (set! jolt-type (lambda (x) (if (jinst? x) inst-type-kw (%it-type x)))) @@ -266,8 +265,7 @@ ;; matching jhost tag. The instance? macro passes the class-name symbol. (define (class-short tn) (let loop ((i (- (string-length tn) 1))) (cond ((< i 0) tn) ((char=? (string-ref tn i) #\.) (substring tn (+ i 1) (string-length tn))) (else (loop (- i 1)))))) -(define %it-instance-check instance-check) -(set! instance-check +(register-instance-check-arm! (lambda (type-sym val) (let ((tn (class-short (symbol-t-name type-sym)))) (cond @@ -275,11 +273,10 @@ ;; (on the JVM a Date is not a Timestamp), so answer Timestamp explicitly #f. ((jinst? val) (cond ((string=? tn "Date") #t) ((string=? tn "Timestamp") #f) - (else (%it-instance-check type-sym val)))) - ((and (jhost? val) (string=? (jhost-tag val) "instant")) (if (string=? tn "Instant") #t (%it-instance-check type-sym val))) - ((and (jhost? val) (string=? (jhost-tag val) "local-dt")) (if (string=? tn "LocalDateTime") #t (%it-instance-check type-sym val))) - (else (%it-instance-check type-sym val)))))) -(def-var! "clojure.core" "instance-check" instance-check) + (else 'pass))) + ((and (jhost? val) (string=? (jhost-tag val) "instant")) (if (string=? tn "Instant") #t 'pass)) + ((and (jhost? val) (string=? (jhost-tag val) "local-dt")) (if (string=? tn "LocalDateTime") #t 'pass)) + (else 'pass))))) ;; inst-ms* is a seed native (the overlay inst-ms reads (get x :ms), now answered). (def-var! "clojure.core" "inst-ms*" (lambda (i) (jinst-ms i))) diff --git a/host/chez/io.ss b/host/chez/io.ss index de4bae8..04ce13b 100644 --- a/host/chez/io.ss +++ b/host/chez/io.ss @@ -221,9 +221,7 @@ ;; --- str / type / instance? integration ------------------------------------ ;; str of a jfile is its path (Clojure's File.toString). -(define %io-str-render jolt-str-render-one) -(set! jolt-str-render-one - (lambda (v) (if (jfile? v) (jfile-path v) (%io-str-render v)))) +(register-str-render! jfile? jfile-path) ;; stdin line seam: the clojure.core *in* reader (50-io.clj) drives read-line / ;; read / read+string through __stdin-read-line. Return the next line (newline @@ -241,16 +239,14 @@ ;; (instance? java.io.File f): the instance? macro passes the class-name symbol; ;; match "File" / "java.io.File" (and any *.File) against a jfile. -(define %io-instance-check instance-check) -(set! instance-check +(register-instance-check-arm! (lambda (type-sym val) (let ((tname (symbol-t-name type-sym))) (if (and (jfile? val) (or (string=? tname "File") (string=? tname "java.io.File") (string=? (path-last-segment tname) "File"))) #t - (%io-instance-check type-sym val))))) -(def-var! "clojure.core" "instance-check" instance-check) + 'pass)))) ;; --- def-var! the native names the overlay file-seq + str/slurp use ---- (def-var! "clojure.core" "__make-file" jolt-make-file) @@ -475,9 +471,8 @@ (cons "equals" (lambda (u o) (and (jhost? o) (string=? (jhost-tag o) "uri") (string=? (uri-field u 'string) (uri-field o 'string))))))) ;; str / pr-str of a uri -> its string form. -(define %uri-str-render-one jolt-str-render-one) -(set! jolt-str-render-one - (lambda (x) (if (and (jhost? x) (string=? (jhost-tag x) "uri")) (uri-field x 'string) (%uri-str-render-one x)))) +(register-str-render! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "uri"))) + (lambda (x) (uri-field x 'string))) (define %uri-pr-readable jolt-pr-readable) (set! jolt-pr-readable (lambda (x) (if (and (jhost? x) (string=? (jhost-tag x) "uri")) diff --git a/host/chez/lazy-bridge.ss b/host/chez/lazy-bridge.ss index 0c563be..0b2da74 100644 --- a/host/chez/lazy-bridge.ss +++ b/host/chez/lazy-bridge.ss @@ -69,8 +69,7 @@ (set! jolt-pr-str (lambda (x) (if (jolt-lazyseq? x) (%ls-pr-str (jolt-seq x)) (%ls-pr-str x)))) (define %ls-pr-readable jolt-pr-readable) (set! jolt-pr-readable (lambda (x) (if (jolt-lazyseq? x) (%ls-pr-readable (jolt-seq x)) (%ls-pr-readable x)))) -(define %ls-str-render-one jolt-str-render-one) -(set! jolt-str-render-one (lambda (x) (if (jolt-lazyseq? x) (%ls-str-render-one (jolt-seq x)) (%ls-str-render-one x)))) +(register-str-render! jolt-lazyseq? (lambda (x) (jolt-str-render-one (jolt-seq x)))) ;; seq? — a lazy seq IS a seq (predicates.ss's jolt-seq? predates the lazyseq ;; record). Unlike the native-op dispatchers above (called via a direct top-level diff --git a/host/chez/natives-array.ss b/host/chez/natives-array.ss index ed3712b..de130fb 100644 --- a/host/chez/natives-array.ss +++ b/host/chez/natives-array.ss @@ -158,21 +158,18 @@ (set! jolt-type (lambda (x) (if (jolt-array? x) (na-array-class-name x) (%na-type x)))) (def-var! "clojure.core" "type" jolt-type) -;; instance? over an array class token ([I, [C, …). The token reaches us as a -;; string (Class/forName "[C") or symbol; normalize, and pass a non-array string -;; token on as a symbol so the inner wrappers' symbol-t-name doesn't choke. -(define %na-instance-check instance-check) -(set! instance-check +;; instance? over an array class token ([I, [C, …). An array token reaches us as +;; a string ("[C", from (Class/forName "[C")) — the dispatcher leaves it a string +;; (non-array string tokens are already normalized to symbols there); decide it +;; here, deferring everything else. +(register-instance-check-arm! (lambda (type-sym val) (let ((tname (cond ((string? type-sym) type-sym) ((symbol-t? type-sym) (symbol-t-name type-sym)) (else #f)))) - (cond - ((and tname (> (string-length tname) 0) (char=? (string-ref tname 0) #\[)) - (and (jolt-array? val) (string=? (na-array-class-name val) tname))) - ((string? type-sym) (%na-instance-check (jolt-symbol #f type-sym) val)) - (else (%na-instance-check type-sym val)))))) -(def-var! "clojure.core" "instance-check" instance-check) + (if (and tname (> (string-length tname) 0) (char=? (string-ref tname 0) #\[)) + (and (jolt-array? val) (string=? (na-array-class-name val) tname)) + 'pass)))) ;; clojure.java.io/reader over a char-array reads its chars (the JVM char[] branch). (def-var! "clojure.java.io" "reader" diff --git a/host/chez/natives-misc.ss b/host/chez/natives-misc.ss index ed8ed2c..1b9c84d 100644 --- a/host/chez/natives-misc.ss +++ b/host/chez/natives-misc.ss @@ -51,8 +51,7 @@ ;; the prelude would clobber a def-var! here — they're asserted in post-prelude.ss. ;; str of a uuid -> the bare 36-char string; pr-str -> #uuid "…". -(define %m-str-render-one jolt-str-render-one) -(set! jolt-str-render-one (lambda (x) (if (juuid? x) (juuid-s x) (%m-str-render-one x)))) +(register-str-render! juuid? juuid-s) (define (juuid-pr u) (string-append "#uuid \"" (juuid-s u) "\"")) (define %m-pr-str jolt-pr-str) (set! jolt-pr-str (lambda (x) (if (juuid? x) (juuid-pr x) (%m-pr-str x)))) diff --git a/host/chez/natives-queue.ss b/host/chez/natives-queue.ss index 79b657e..a888017 100644 --- a/host/chez/natives-queue.ss +++ b/host/chez/natives-queue.ss @@ -46,15 +46,13 @@ (define (jolt-seq-or-empty x) (let ((s (jolt-seq x))) (if (jolt-nil? s) jolt-empty-list s))) (define %q-pr-readable jolt-pr-readable) (set! jolt-pr-readable (lambda (x) (if (jolt-queue? x) (%q-pr-readable (jolt-seq-or-empty x)) (%q-pr-readable x)))) -(define %q-str-render-one jolt-str-render-one) -(set! jolt-str-render-one (lambda (x) (if (jolt-queue? x) (%q-str-render-one (jolt-seq-or-empty x)) (%q-str-render-one x)))) +(register-str-render! jolt-queue? (lambda (x) (jolt-str-render-one (jolt-seq-or-empty x)))) ;; class / type / instance? recognize a queue. (define %q-class jolt-class) (set! jolt-class (lambda (x) (if (jolt-queue? x) "clojure.lang.PersistentQueue" (%q-class x)))) (def-var! "clojure.core" "class" jolt-class) -(define %q-instance-check instance-check) -(set! instance-check +(register-instance-check-arm! (lambda (type-sym val) (if (jolt-queue? val) (let ((tn (cond ((string? type-sym) type-sym) @@ -62,8 +60,7 @@ (and (member (last-dot tn) '("PersistentQueue" "IPersistentCollection" "Sequential" "Collection" "Object")) #t)) - (%q-instance-check type-sym val)))) -(def-var! "clojure.core" "instance-check" instance-check) + 'pass))) ;; clojure.lang.PersistentQueue/EMPTY + a queue? predicate. (register-class-statics! "PersistentQueue" (list (cons "EMPTY" jolt-queue-empty))) diff --git a/host/chez/ns.ss b/host/chez/ns.ss index 1d52cae..e36c1bc 100644 --- a/host/chez/ns.ss +++ b/host/chez/ns.ss @@ -348,5 +348,4 @@ (set! jolt-pr-str (lambda (x) (if (jns? x) (jns-name x) (%ns-pr-str x)))) (define %ns-pr-readable jolt-pr-readable) (set! jolt-pr-readable (lambda (x) (if (jns? x) (jns-name x) (%ns-pr-readable x)))) -(define %ns-str-render-one jolt-str-render-one) -(set! jolt-str-render-one (lambda (x) (if (jns? x) (jns-name x) (%ns-str-render-one x)))) +(register-str-render! jns? jns-name) diff --git a/host/chez/records-interop.ss b/host/chez/records-interop.ss index 6f56618..3ab5141 100644 --- a/host/chez/records-interop.ss +++ b/host/chez/records-interop.ss @@ -49,8 +49,17 @@ ((and (string=? c "ExceptionInfo") (string=? wanted "IExceptionInfo")) #t) (else (let ((p (assoc c exception-parent))) (loop (and p (cdr p)))))))) -;; instance-check: (type-sym val) — type/protocol membership. -(define (instance-check type-sym val) +;; instance-check: (type-sym val) — type/protocol membership. Host shims loaded +;; later (io, inst-time, natives-array, natives-queue, host-static-objects) +;; register an arm with register-instance-check-arm! instead of set!-wrapping +;; instance-check; an arm returns #t/#f to decide or 'pass to defer to the next. +;; Newest arm is checked first (matches the old outermost-wins set! order). +;; instance-check-base is the JVM taxonomy fallback when no arm decides. +(define instance-check-registry '()) +(define (register-instance-check-arm! f) ; f: (type-sym val) -> #t | #f | 'pass + (set! instance-check-registry (cons f instance-check-registry))) + +(define (instance-check-base type-sym val) (let ((tname (symbol-t-name type-sym))) (cond ((jrec? val) @@ -62,6 +71,21 @@ (and (memp (lambda (p) (string=? (last-dot p) short)) (jreify-protos val)) #t))) ((ex-info-map? val) (exception-isa? (last-dot (ex-info-class val)) (last-dot tname))) (else (case-string tname val))))) + +(define (instance-check type-sym val) + ;; normalize a bare (non-array) string class token to a symbol so every arm and + ;; the base table can read its name; array tokens ("[I") stay strings for the + ;; natives-array arm. + (let ((ts (if (and (string? type-sym) + (or (= 0 (string-length type-sym)) + (not (char=? (string-ref type-sym 0) #\[)))) + (jolt-symbol #f type-sym) + type-sym))) + (let loop ((rs instance-check-registry)) + (if (null? rs) + (instance-check-base ts val) + (let ((r ((car rs) ts val))) + (if (eq? r 'pass) (loop (cdr rs)) r)))))) (define (case-string tname val) (cond ((member tname '("Number" "java.lang.Number")) (number? val)) diff --git a/host/chez/records.ss b/host/chez/records.ss index 3828468..1174c9e 100644 --- a/host/chez/records.ss +++ b/host/chez/records.ss @@ -410,14 +410,11 @@ ;; jolt exception values (ex-info + host-constructed throwables) are ex-info-shaped ;; maps tagged :jolt/type :jolt/ex-info; (class …)/instance? read the JVM class off ;; the optional :jolt/class key, defaulting to clojure.lang.ExceptionInfo. -(define %r-str-render-one jolt-str-render-one) -(set! jolt-str-render-one +(register-str-render! jrec? (lambda (v) - (if (jrec? v) - (let ((f (find-protocol-method (jrec-tag v) "Object" "toString"))) - (if f (jolt-invoke f v) - (let ((s (jrec-pr v))) (substring s 1 (string-length s))))) - (%r-str-render-one v)))) + (let ((f (find-protocol-method (jrec-tag v) "Object" "toString"))) + (if f (jolt-invoke f v) + (let ((s (jrec-pr v))) (substring s 1 (string-length s))))))) ;; `type` lives in natives-meta.ss: it needs jolt-meta for the :type ;; override and a total value->taxonomy mapping, so it sits with meta — a record diff --git a/host/chez/vars.ss b/host/chez/vars.ss index bc451e3..123fb1a 100644 --- a/host/chez/vars.ss +++ b/host/chez/vars.ss @@ -45,8 +45,7 @@ (set! jolt-pr-str (lambda (x) (if (var-cell? x) (var->str x) (%v-pr-str x)))) (define %v-pr-readable jolt-pr-readable) (set! jolt-pr-readable (lambda (x) (if (var-cell? x) (var->str x) (%v-pr-readable x)))) -(define %v-str-render-one jolt-str-render-one) -(set! jolt-str-render-one (lambda (x) (if (var-cell? x) (var->str x) (%v-str-render-one x)))) +(register-str-render! var-cell? var->str) ;; bound? — native (the overlay's (get v :root) is nil on a var-cell record). (define (jolt-var-bound-one? v) (and (var-cell? v) (not (eq? (var-cell-root v) jolt-unbound))))