From 283a0f0eece2e957b7b8e7ae9e1dfefd18504d33 Mon Sep 17 00:00:00 2001 From: Dmitri Sotnikov Date: Fri, 26 Jun 2026 20:18:27 +0000 Subject: [PATCH] instance? matches a thrown :class envelope by its class hierarchy (#242) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A library that throws an ex-info envelope carrying a JVM :class (jolt.host/ tagged-table with a "class" entry — e.g. http-client's UnknownHostException on a DNS failure) was caught only by a broad (catch Throwable …): (class e) read the class but (instance? C e) — which catch dispatch lowers to — always returned false, so clj-http-lite's (catch UnknownHostException e …) for :ignore-unknown-host? never matched and the condition propagated. Add an instance? arm matching such an envelope against the carried class or any ancestor (full name or last segment), and register the common exception hierarchy (Throwable/Exception/RuntimeException/IOException + the java.net socket/host exceptions) so (catch IOException e) / (instance? Throwable e) also match. A non-throwable class (RuntimeException over an IOException, String) stays false. Fixes http-client's :ignore-unknown-host? test (116/0/0, was 1 error). make test green, 0 new divergences. Runtime .ss, no re-mint. Co-authored-by: Yogthos --- host/chez/java/host-static-classes.ss | 30 +++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/host/chez/java/host-static-classes.ss b/host/chez/java/host-static-classes.ss index 46379e2..a07fc29 100644 --- a/host/chez/java/host-static-classes.ss +++ b/host/chez/java/host-static-classes.ss @@ -836,6 +836,18 @@ (reg-class-supers! "clojure.lang.AFn" '("clojure.lang.IFn" "java.lang.Runnable" "java.util.concurrent.Callable")) (reg-class-supers! "clojure.lang.AFunction" '("clojure.lang.AFn" "clojure.lang.IFn" "clojure.lang.Fn" "java.lang.Runnable" "java.util.concurrent.Callable")) +;; common exception hierarchy, so (instance? IOException e) / (catch IOException e) +;; match a more specific throwable a library threw (e.g. http-client's +;; UnknownHostException, caught by clj-http-lite's :ignore-unknown-host?). +(reg-class-supers! "java.lang.Throwable" '("java.lang.Object")) +(reg-class-supers! "java.lang.Exception" '("java.lang.Throwable" "java.lang.Object")) +(reg-class-supers! "java.lang.RuntimeException" '("java.lang.Exception" "java.lang.Throwable" "java.lang.Object")) +(reg-class-supers! "java.io.IOException" '("java.lang.Exception" "java.lang.Throwable" "java.lang.Object")) +(reg-class-supers! "java.io.InterruptedIOException" '("java.io.IOException" "java.lang.Exception" "java.lang.Throwable" "java.lang.Object")) +(reg-class-supers! "java.net.SocketException" '("java.io.IOException" "java.lang.Exception" "java.lang.Throwable" "java.lang.Object")) +(reg-class-supers! "java.net.UnknownHostException" '("java.io.IOException" "java.lang.Exception" "java.lang.Throwable" "java.lang.Object")) +(reg-class-supers! "java.net.ConnectException" '("java.net.SocketException" "java.io.IOException" "java.lang.Exception" "java.lang.Throwable" "java.lang.Object")) +(reg-class-supers! "java.net.SocketTimeoutException" '("java.io.InterruptedIOException" "java.io.IOException" "java.lang.Exception" "java.lang.Throwable" "java.lang.Object")) ;; transitive closure of direct supers (set semantics via an accumulator list) (define (class-ancestors-list name) @@ -845,6 +857,24 @@ (else (loop (append (hashtable-ref class-supers-tbl (car pending) '()) (cdr pending)) (cons (car pending) seen)))))) +;; (instance? Class e) on a throwable tagged-table carrying a JVM :class matches the +;; carried class or any of its ancestors (full name or last segment), so a library's +;; (catch UnknownHostException e …) / (catch IOException e …) matches the ex-info +;; envelope it threw. Mirrors the (class e) arm (host-table.ss) for catch dispatch, +;; which lowers to (instance? C e). Non-match returns 'pass so other arms still run. +(register-instance-check-arm! + (lambda (type-sym val) + (if (and (htable? val) (string? (hashtable-ref (htable-h val) "class" #f))) + (let* ((cls (hashtable-ref (htable-h val) "class" #f)) + (want (symbol-t-name type-sym)) + (want-seg (hsc-last-segment want))) + (let loop ((names (cons cls (class-ancestors-list cls)))) + (cond ((null? names) 'pass) + ((or (string=? want (car names)) + (string=? want-seg (hsc-last-segment (car names)))) #t) + (else (loop (cdr names)))))) + 'pass))) + ;; (jolt.host/class-supers name) / (jolt.host/class-ancestors name) — a jolt seq of ;; super / ancestor class-name strings, or nil when jolt models no hierarchy for it. (def-var! "jolt.host" "class-supers"