diff --git a/host/chez/java/host-class.ss b/host/chez/java/host-class.ss index 72fb6ca..b2844c1 100644 --- a/host/chez/java/host-class.ss +++ b/host/chez/java/host-class.ss @@ -54,6 +54,14 @@ ;; the class NAME of x (string), or nil for nil. (class x) wraps it in a Class ;; value (make-class-obj, host-static-classes.ss) so it renders like a JVM Class ;; while staying = its name string. +;; a raw Chez condition Clojure raises a specific class for (records-interop.ss +;; chez-condition-exc-class) reports that JVM class, so (class e) and a +;; (thrown? ArityException …) test match — not the opaque :object fallback. +(register-class-arm! + (lambda (x) (and (chez-condition-exc-class x) #t)) + (lambda (x) (if (string=? (chez-condition-exc-class x) "ArityException") + "clojure.lang.ArityException" + "java.lang.IllegalArgumentException"))) (define (jolt-class-name x) (let loop ((as jolt-class-arms)) (cond ((null? as) (jolt-class-base x)) @@ -94,6 +102,7 @@ ("Charset" . "java.nio.charset.Charset") ("Base64" . "java.util.Base64") ("Exception" . "java.lang.Exception") ("IllegalArgumentException" . "java.lang.IllegalArgumentException") + ("ArityException" . "clojure.lang.ArityException") ("IllegalStateException" . "java.lang.IllegalStateException") ("RuntimeException" . "java.lang.RuntimeException") ("UnsupportedOperationException" . "java.lang.UnsupportedOperationException") @@ -165,7 +174,7 @@ "java.lang.IndexOutOfBoundsException" "java.io.FileNotFoundException" "java.io.UnsupportedEncodingException" ;; clojure.lang.ExceptionInfo / IExceptionInfo compared against (class e) - "clojure.lang.ExceptionInfo" "clojure.lang.IExceptionInfo" + "clojure.lang.ExceptionInfo" "clojure.lang.IExceptionInfo" "clojure.lang.ArityException" "java.util.regex.Pattern" "java.net.URI" "java.util.UUID" "clojure.lang.PersistentQueue" "clojure.lang.Keyword" "clojure.lang.Symbol" "clojure.lang.Ratio" "clojure.lang.Atom")) diff --git a/host/chez/java/records-interop.ss b/host/chez/java/records-interop.ss index bfafb3a..b8c564b 100644 --- a/host/chez/java/records-interop.ss +++ b/host/chez/java/records-interop.ss @@ -16,6 +16,7 @@ '(("ExceptionInfo" . "RuntimeException") ("RuntimeException" . "Exception") ("IllegalArgumentException" . "RuntimeException") + ("ArityException" . "IllegalArgumentException") ("NumberFormatException" . "IllegalArgumentException") ("IllegalStateException" . "RuntimeException") ("UnsupportedOperationException" . "RuntimeException") @@ -51,6 +52,24 @@ ((and (string=? c "ExceptionInfo") (string=? wanted "IExceptionInfo")) #t) (else (let ((p (assoc c exception-parent))) (loop (and p (cdr p)))))))) +;; 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") + (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 @@ -61,6 +80,13 @@ (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)))) + (define (instance-check-base type-sym val) (let ((tname (symbol-t-name type-sym))) (cond diff --git a/test/chez/corpus.edn b/test/chez/corpus.edn index 36bc392..ea4405b 100644 --- a/test/chez/corpus.edn +++ b/test/chez/corpus.edn @@ -1834,6 +1834,9 @@ {:suite "dynamic vars / portable defaults" :label "binding *read-eval*" :expected "false" :actual "(binding [*read-eval* false] *read-eval*)"} {:suite "special forms / letfn" :label "mutual recursion" :expected "true" :actual "(letfn [(e? [n] (if (zero? n) true (o? (dec n)))) (o? [n] (if (zero? n) false (e? (dec n))))] (e? 10))"} {:suite "core vars / present and callable" :label "*out* *err* *warn-on-reflection* await restart-agent" :expected "[true true false true true]" :actual "[(boolean *out*) (boolean *err*) *warn-on-reflection* (ifn? await) (ifn? restart-agent)]"} + {:suite "exceptions / runtime error classes" :label "arity error is ArityException" :expected "true" :actual "(instance? clojure.lang.ArityException (try ((fn [a b] a) 1) (catch Throwable e e)))"} + {:suite "exceptions / runtime error classes" :label "ArityException is an IllegalArgumentException" :expected "true" :actual "(instance? IllegalArgumentException (try ((fn [a b] a) 1) (catch Throwable e e)))"} + {:suite "exceptions / runtime error classes" :label "non-seqable is IllegalArgumentException" :expected "true" :actual "(instance? IllegalArgumentException (try (doall (mapcat identity 0)) (catch Throwable e e)))"} {:suite "dynamic vars / portable defaults" :label "*data-readers* map, *math-context* nil" :expected "[true true]" :actual "[(map? *data-readers*) (nil? *math-context*)]"} {:suite "regex / re-pattern & string ops" :label "re-pattern build" :expected "\"hi\"" :actual "(re-find (re-pattern \"\\\\w+\") \"hi!\")"} {:suite "regex / re-pattern & string ops" :label "re-pattern is regex?" :expected "true" :actual "(regex? (re-pattern \"a\"))"}