From 864af8ef7e86268fd29e82c38587d71b43267ca6 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Tue, 23 Jun 2026 04:22:02 -0400 Subject: [PATCH] Split records.ss: lift the JVM-emulation taxonomy into records-interop.ss MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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. --- host/chez/records-interop.ss | 91 ++++++++++++++++++++++++++++++++++++ host/chez/records.ss | 85 --------------------------------- host/chez/rt.ss | 1 + 3 files changed, 92 insertions(+), 85 deletions(-) create mode 100644 host/chez/records-interop.ss diff --git a/host/chez/records-interop.ss b/host/chez/records-interop.ss new file mode 100644 index 0000000..6f56618 --- /dev/null +++ b/host/chez/records-interop.ss @@ -0,0 +1,91 @@ +;; records-interop.ss — JVM-emulation taxonomy split out of records.ss: the +;; ex-info class accessors, the exception supertype hierarchy, and instance-check +;; / case-string (the (instance? Class x) decision table). Loaded right after +;; records.ss; instance-check forward-refs nothing in records.ss at load time. + +;; 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. + +(def-var! "clojure.core" "instance-check" instance-check) diff --git a/host/chez/records.ss b/host/chez/records.ss index f361185..3828468 100644 --- a/host/chez/records.ss +++ b/host/chez/records.ss @@ -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))) diff --git a/host/chez/rt.ss b/host/chez/rt.ss index 03bb6e2..5b507ad 100644 --- a/host/chez/rt.ss +++ b/host/chez/rt.ss @@ -237,6 +237,7 @@ ;; the dispatchers/printers it wraps (collections/seq/values/converters/printing/ ;; transients). (load "host/chez/records.ss") +(load "host/chez/records-interop.ss") ; exception hierarchy + instance-check taxonomy ;; metadata: meta / with-meta over an identity-keyed ;; side-table. After records.ss (jrec) + the collection ctors it copies.