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
parent
23f6fee250
commit
864af8ef7e
3 changed files with 92 additions and 85 deletions
91
host/chez/records-interop.ss
Normal file
91
host/chez/records-interop.ss
Normal file
|
|
@ -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)
|
||||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue