f856c16f06
jolt's own throw sites raised untyped Chez conditions with the class name buried
in an English message, so (class e) reported the opaque :object and only a broad
catch worked:
(class (try (Long/parseLong "xyz") (catch Throwable e e))) => :object
; JVM: java.lang.NumberFormatException
Raise typed throwables (jolt-host-throwable) at the Long/Double parse and
StringTokenizer sites so (class e) / .getMessage / a specific catch all reflect
the real class. And fold the exception supertype table (exception-parent) into
the one class graph: exception-isa? now resolves the simple name to its graph key
and asks jch-isa?, so exceptions and every other class share a single hierarchy.
Runtime only, no re-mint. make test green (0 new/stale), +2 corpus rows.
163 lines
9.1 KiB
Scheme
163 lines
9.1 KiB
Scheme
;; 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")))
|
|
;; Is `wanted` (simple name) `cls` or a supertype of it? The exception hierarchy
|
|
;; lives in the one class graph (class-hierarchy.ss) — resolve the simple name to
|
|
;; its graph key and ask jch-isa?, so exceptions and every other class share a
|
|
;; single source of truth (ExceptionInfo -> IExceptionInfo is a graph edge).
|
|
(define (exception-isa? cls wanted)
|
|
(jch-isa? (jch-fqn-of-simple cls) wanted))
|
|
|
|
;; A raw Chez condition (an arity or non-seqable error Chez itself raised, not a
|
|
;; jolt ex-info) carries no jolt exception class. Map the ones Clojure raises a
|
|
;; specific class for, by message, so (class e) and (instance? C e) match the JVM.
|
|
;; Returns a simple class name or #f.
|
|
(define (ri-substring? needle hay)
|
|
(let ((nl (string-length needle)) (hl (string-length hay)))
|
|
(let loop ((i 0))
|
|
(cond ((> (+ i nl) hl) #f)
|
|
((string=? needle (substring hay i (+ i nl))) #t)
|
|
(else (loop (+ i 1)))))))
|
|
(define (chez-condition-exc-class v)
|
|
(and (condition? v) (message-condition? v)
|
|
(let ((m (condition-message v)))
|
|
(and (string? m)
|
|
(cond ((ri-substring? "incorrect number of arguments" m) "ArityException")
|
|
((ri-substring? "not seqable" m) "IllegalArgumentException")
|
|
;; Chez's numeric ops raise "~s is not a real number" on a bad
|
|
;; operand. The JVM throws NullPointerException for a nil operand
|
|
;; (null deref) and ClassCastException for a non-number (can't
|
|
;; cast to Number) — clojure.spec.alpha's conform-explain relies
|
|
;; on the distinction. The offending value rides in the irritants.
|
|
((or (ri-substring? "is not a real number" m)
|
|
(ri-substring? "is not a number" m))
|
|
(if (and (irritants-condition? v)
|
|
(let loop ((xs (condition-irritants v)))
|
|
(and (pair? xs) (or (jolt-nil? (car xs)) (loop (cdr xs))))))
|
|
"NullPointerException"
|
|
"ClassCastException"))
|
|
(else #f))))))
|
|
|
|
;; instance-check: (type-sym val) — type/protocol membership. Host shims loaded
|
|
;; later (io, inst-time, natives-array, natives-queue, host-static-classes)
|
|
;; 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)))
|
|
|
|
;; (instance? C raw-condition): match when C is the condition's mapped class or a
|
|
;; supertype of it (ArityException is also an IllegalArgumentException, etc.).
|
|
(register-instance-check-arm!
|
|
(lambda (type-sym val)
|
|
(let ((k (chez-condition-exc-class val)))
|
|
(if k (if (exception-isa? k (last-dot (symbol-t-name type-sym))) #t #f) 'pass))))
|
|
|
|
;; Object / java.lang.Object is the root of the type hierarchy: every non-nil
|
|
;; value is an instance of Object; nil is not an instance of anything.
|
|
(register-instance-check-arm!
|
|
(lambda (type-sym val)
|
|
(let ((tn (symbol-t-name type-sym)))
|
|
(if (or (string=? tn "Object") (string=? tn "java.lang.Object"))
|
|
(not (jolt-nil? val))
|
|
'pass))))
|
|
|
|
(define (instance-check-base type-sym val)
|
|
(let ((tname (symbol-t-name type-sym)))
|
|
(cond
|
|
((jrec? val)
|
|
(let ((tag (jrec-tag val)))
|
|
(or (string=? tag tname)
|
|
;; a simple name matches a qualified tag only at a `.` boundary:
|
|
;; "a.b.IntervalFD" is an IntervalFD, but "a.b.MultiIntervalFD" is NOT
|
|
;; (a raw string-suffix would wrongly match the latter).
|
|
(let ((tl (string-length tag)) (nl (string-length tname)))
|
|
(and (fx>? tl nl)
|
|
(char=? (string-ref tag (fx- (fx- tl nl) 1)) #\.)
|
|
(string=? (substring tag (fx- tl nl) tl) tname)))
|
|
;; a protocol/interface the type implements (defprotocol generates an
|
|
;; interface; (instance? SomeProtocol record) is true when the record
|
|
;; implements it — core.match dispatches on instance? IPatternCompile).
|
|
(type-satisfies? tag tname)
|
|
(type-satisfies? tag (last-dot tname)))))
|
|
((jreify? val) (let ((short (last-dot tname)))
|
|
;; every Clojure reify implements IObj/IMeta (carries metadata).
|
|
(or (member short '("IObj" "IMeta"))
|
|
(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-sym0 val)
|
|
;; a Class value as the type arg (instance? (class x) y) -> use its name string.
|
|
(let* ((type-sym (if (jclass? type-sym0) (jclass-name type-sym0) type-sym0))
|
|
(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))
|
|
((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)
|
|
|
|
;; Broad-catch fallback for catch-clause dispatch (analyze-try desugars
|
|
;; (catch C e …) to (or (instance? C e) (__catch-broad? "C" e))). A jolt host
|
|
;; condition or a raw raised value carries no jolt exception class, so instance?
|
|
;; can't place it; a Clojure (catch C e) over such a value matches when C is
|
|
;; RuntimeException (or a subclass) / Exception / Throwable — most host runtime
|
|
;; errors are RuntimeExceptions. Typed throwables (ex-info, (SomeException. …)) are
|
|
;; recognized by instance? as Throwable, so untyped? is false and they dispatch
|
|
;; precisely through the instance? arm instead.
|
|
(define throwable-type-sym (jolt-symbol #f "Throwable"))
|
|
(define (simple-class-name nm)
|
|
(let loop ((i (- (string-length nm) 1)))
|
|
(cond ((< i 0) nm)
|
|
((char=? (string-ref nm i) #\.) (substring nm (+ i 1) (string-length nm)))
|
|
(else (loop (- i 1))))))
|
|
(define (jolt-catch-broad? nm v)
|
|
(and (not (instance-check throwable-type-sym v))
|
|
(let ((s (simple-class-name nm)))
|
|
(or (exception-isa? s "RuntimeException")
|
|
(string=? s "Exception")
|
|
(string=? s "Throwable")))))
|
|
(def-var! "clojure.core" "__catch-broad?"
|
|
(lambda (nm v) (if (jolt-catch-broad? nm v) #t #f)))
|