Split records.ss: lift the JVM-emulation taxonomy into records-interop.ss

records.ss mixed the record/protocol/reify model with JVM exception emulation.
Move the contiguous ex-info accessors, the exception supertype hierarchy,
instance-check, case-string, and the instance-check def-var into records-interop.ss,
loaded right after records.ss. Those are only called at runtime, so the relocated
forms resolve fine; records.ss is now the value model and protocol dispatch.
Runtime shim — no seed change.
This commit is contained in:
Yogthos 2026-06-23 04:22:02 -04:00
parent 23f6fee250
commit 864af8ef7e
3 changed files with 92 additions and 85 deletions

View file

@ -410,90 +410,6 @@
;; 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.
;; pmap? guard: ex-info maps are plain hash-maps, never sorted-map htables — and a
;; bare jolt-get on a sorted-map would invoke its comparator on :jolt/type and throw.
(define (ex-info-map? v)
(and (pmap? v) (jolt=2 (jolt-get v jolt-kw-ex-type jolt-nil) jolt-kw-ex-info)))
(define (ex-info-class v)
(let ((c (jolt-get v jolt-kw-class jolt-nil)))
(if (string? c) c "clojure.lang.ExceptionInfo")))
;; immediate-parent chain of the JVM exception hierarchy (simple names). Drives
;; instance? across exception supertypes — (instance? Throwable (ex-info …)) etc.
(define exception-parent
'(("ExceptionInfo" . "RuntimeException")
("RuntimeException" . "Exception")
("IllegalArgumentException" . "RuntimeException")
("NumberFormatException" . "IllegalArgumentException")
("IllegalStateException" . "RuntimeException")
("UnsupportedOperationException" . "RuntimeException")
("ArithmeticException" . "RuntimeException")
("NullPointerException" . "RuntimeException")
("ClassCastException" . "RuntimeException")
("IndexOutOfBoundsException" . "RuntimeException")
("ConcurrentModificationException" . "RuntimeException")
("NoSuchElementException" . "RuntimeException")
("UncheckedIOException" . "RuntimeException")
("InterruptedException" . "Exception")
("IOException" . "Exception")
("FileNotFoundException" . "IOException")
("UnsupportedEncodingException" . "IOException")
("UnknownHostException" . "IOException")
("SocketException" . "IOException")
("ConnectException" . "IOException")
("SocketTimeoutException" . "IOException")
("MalformedURLException" . "IOException")
("SSLException" . "IOException")
("Exception" . "Throwable")
("Error" . "Throwable")
("AssertionError" . "Error")
("Throwable" . "Object")))
;; Is `wanted` (simple name) `cls` or a supertype of it? ExceptionInfo also
;; implements the IExceptionInfo interface.
(define (exception-isa? cls wanted)
(let loop ((c cls))
(cond ((not c) #f)
((string=? c wanted) #t)
((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)
(let ((tname (symbol-t-name type-sym)))
(cond
((jrec? val)
(let ((tag (jrec-tag val)))
(or (string=? tag tname)
(and (> (string-length tag) (string-length tname))
(string=? (substring tag (- (string-length tag) (string-length tname)) (string-length tag)) tname)))))
((jreify? val) (let ((short (last-dot tname)))
(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 (case-string tname val)
(cond
((member tname '("Number" "java.lang.Number")) (number? val))
((member tname '("Long" "java.lang.Long" "Integer" "java.lang.Integer"))
(and (number? val) (exact? val) (integer? val)))
((member tname '("Double" "java.lang.Double" "Float" "java.lang.Float")) (and (number? val) (flonum? val)))
((member tname '("Ratio" "clojure.lang.Ratio")) (and (number? val) (exact? val) (rational? val) (not (integer? val))))
((member tname '("String" "java.lang.String" "CharSequence" "java.lang.CharSequence")) (string? val))
((member tname '("Boolean" "java.lang.Boolean")) (boolean? val))
((member tname '("Character" "java.lang.Character")) (char? val))
((member tname '("Keyword" "clojure.lang.Keyword")) (keyword? val))
((member tname '("Symbol" "clojure.lang.Symbol")) (jolt-symbol? val))
((member tname '("Atom" "clojure.lang.Atom")) (jolt-atom? val))
((member tname '("IFn" "clojure.lang.IFn" "Fn" "clojure.lang.Fn")) (procedure? val))
((member tname '("Pattern" "java.util.regex.Pattern")) (regex-t? val))
((member tname '("URI" "java.net.URI"))
(and (jhost? val) (string=? (jhost-tag val) "uri")))
((member tname '("File" "java.io.File")) (jfile? val))
((member tname '("UUID" "java.util.UUID")) (juuid? val))
(else #f)))
;; str of a record uses a custom (Object toString) impl if the type defines one
;; (deftype with no default toString relies on this); otherwise the map form
;; without the leading # (Clojure's record .toString). converters.ss loads before
;; records.ss, so this set! sees the registry — forward refs resolve at call time.
(define %r-str-render-one jolt-str-render-one)
(set! jolt-str-render-one
(lambda (v)
@ -516,6 +432,5 @@
(def-var! "clojure.core" "protocol-dispatch" (lambda (pn mn obj rest) (protocol-dispatch pn mn obj rest)))
(def-var! "clojure.core" "satisfies?" jolt-satisfies?)
(def-var! "clojure.core" "extenders" extenders)
(def-var! "clojure.core" "instance-check" instance-check)
(def-var! "clojure.core" "make-reified" (lambda (mm . rest) (apply make-reified mm rest)))
(def-var! "clojure.core" "record-method-dispatch" (lambda (obj m rest) (record-method-dispatch obj m rest)))