diff --git a/host/chez/java/class-hierarchy.ss b/host/chez/java/class-hierarchy.ss index 5966610..04a1b4b 100644 --- a/host/chez/java/class-hierarchy.ss +++ b/host/chez/java/class-hierarchy.ss @@ -104,11 +104,30 @@ (or (hashtable-ref jch-known-cache wanted #f) (hashtable-ref jch-known-cache (jch-last-segment wanted) #f))) -;; A register also invalidates the known-name cache. +;; simple last-segment -> canonical FQN for a modeled class (first registered +;; wins). Lets a simple exception name (from chez-condition-exc-class) resolve to +;; its graph key so the exception hierarchy answers through the one graph. +(define jch-simple->fqn-cache #f) +(define (jch-fqn-of-simple name) + (when (not jch-simple->fqn-cache) + (set! jch-simple->fqn-cache (make-hashtable string-hash string=?)) + (let-values (((keys vals) (hashtable-entries jvm-class-parents))) + (vector-for-each + (lambda (k supers) + (for-each (lambda (n) + (let ((seg (jch-last-segment n))) + (when (not (hashtable-ref jch-simple->fqn-cache seg #f)) + (hashtable-set! jch-simple->fqn-cache seg n)))) + (cons k supers))) + keys vals))) + (or (hashtable-ref jch-simple->fqn-cache name #f) name)) + +;; A register also invalidates the derived caches. (define jch-register-supers!-inner jch-register-supers!) (set! jch-register-supers! (lambda (name supers) (set! jch-known-cache #f) + (set! jch-simple->fqn-cache #f) (jch-register-supers!-inner name supers))) ;; ---- seed the built-in graph: direct supers only, faithful to the JVM --------- diff --git a/host/chez/java/host-static-classes.ss b/host/chez/java/host-static-classes.ss index 253b775..8e21e34 100644 --- a/host/chez/java/host-static-classes.ss +++ b/host/chez/java/host-static-classes.ss @@ -455,7 +455,7 @@ (let ((toks (vector-ref (jhost-state self) 0)) (p (vector-ref (jhost-state self) 1))) (if (< p (length toks)) (begin (vector-set! (jhost-state self) 1 (+ p 1)) (list-ref toks p)) - (error #f "NoSuchElementException"))))) + (jolt-throw (jolt-host-throwable "java.util.NoSuchElementException" "no more tokens")))))) ;; StringTokenizer implements java.util.Enumeration — enumeration-seq drives ;; it through these, so alias them onto the token methods. (cons "hasMoreElements" (lambda (self) (< (vector-ref (jhost-state self) 1) (length (vector-ref (jhost-state self) 0))))) @@ -463,7 +463,7 @@ (let ((toks (vector-ref (jhost-state self) 0)) (p (vector-ref (jhost-state self) 1))) (if (< p (length toks)) (begin (vector-set! (jhost-state self) 1 (+ p 1)) (list-ref toks p)) - (error #f "NoSuchElementException"))))))) + (jolt-throw (jolt-host-throwable "java.util.NoSuchElementException" "no more tokens")))))))) ;; ---- String / BigInteger / MapEntry constructors ---------------------------- ;; (String. bytes [charset]) decodes bytes (a bytevector OR a jolt byte-array) diff --git a/host/chez/java/host-static.ss b/host/chez/java/host-static.ss index 00cfd42..a579803 100644 --- a/host/chez/java/host-static.ss +++ b/host/chez/java/host-static.ss @@ -194,8 +194,9 @@ (and n (integer? n) (->num n)))) (define (parse-int-or-throw s radix what) (or (parse-int-str s radix) - (error #f (string-append "NumberFormatException: For input string: \"" - (if (string? s) s (jolt-str-render-one s)) "\"")))) + (jolt-throw (jolt-host-throwable "java.lang.NumberFormatException" + (string-append "For input string: \"" + (if (string? s) s (jolt-str-render-one s)) "\""))))) (define (char-code c) (if (char? c) (char->integer c) (jnum->exact c))) ;; parse a double string (Double/parseDouble, (Double. s)); JVM accepts NaN / @@ -209,7 +210,8 @@ (else (let ((n (string->number t))) (and n (real? n) (exact->inexact n))))))) (define (parse-double-or-throw s) (or (parse-double-str s) - (error #f (string-append "NumberFormatException: For input string: \"" - (if (string? s) s (jolt-str-render-one s)) "\"")))) + (jolt-throw (jolt-host-throwable "java.lang.NumberFormatException" + (string-append "For input string: \"" + (if (string? s) s (jolt-str-render-one s)) "\""))))) (define (->double x) (if (number? x) (exact->inexact x) (parse-double-or-throw x))) diff --git a/host/chez/java/records-interop.ss b/host/chez/java/records-interop.ss index c54d2b2..826db96 100644 --- a/host/chez/java/records-interop.ss +++ b/host/chez/java/records-interop.ss @@ -10,47 +10,12 @@ (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") - ("ArityException" . "IllegalArgumentException") - ("NumberFormatException" . "IllegalArgumentException") - ("IllegalStateException" . "RuntimeException") - ("UnsupportedOperationException" . "RuntimeException") - ("ArithmeticException" . "RuntimeException") - ("NullPointerException" . "RuntimeException") - ("ClassCastException" . "RuntimeException") - ("IndexOutOfBoundsException" . "RuntimeException") - ("ConcurrentModificationException" . "RuntimeException") - ("NoSuchElementException" . "RuntimeException") - ("UncheckedIOException" . "RuntimeException") - ("DateTimeException" . "RuntimeException") - ("DateTimeParseException" . "DateTimeException") - ("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. +;; 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) - (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)))))))) + (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 diff --git a/test/chez/corpus.edn b/test/chez/corpus.edn index 344a85d..a99b970 100644 --- a/test/chez/corpus.edn +++ b/test/chez/corpus.edn @@ -3511,4 +3511,6 @@ {:suite "host-interop / getClass" :label ".getClass is a universal Object method, reached on every value type" :expected "[\"java.util.Date\" \"java.io.File\"]" :actual "[(.getName (.getClass (java.util.Date.))) (.getName (.getClass (java.io.File. \"x\")))]"} {:suite "reduce / IReduceInit" :label "reduce drives a deftype's own reduce method (init arity)" :expected "110" :actual "(do (deftype Rng [n] clojure.lang.IReduceInit (reduce [_ f init] (loop [i 0 acc init] (if (< i n) (recur (inc i) (f acc i)) acc)))) (reduce + 100 (->Rng 5)))"} {:suite "reduce / IReduceInit" :label "a deftype reduce honors reduced short-circuit" :expected "3" :actual "(do (deftype Rng [n] clojure.lang.IReduceInit (reduce [_ f init] (loop [i 0 acc init] (if (< i n) (let [a (f acc i)] (if (reduced? a) @a (recur (inc i) a))) acc)))) (reduce (fn [acc x] (if (= x 3) (reduced acc) (+ acc x))) 0 (->Rng 10)))"} + {:suite "exceptions / typed throw" :label "a jolt-raised NumberFormatException reports its real class and message" :expected "[\"java.lang.NumberFormatException\" \"For input string: \\\"xyz\\\"\"]" :actual "(try (Long/parseLong \"xyz\") (catch Throwable e [(.getName (class e)) (.getMessage e)]))"} + {:suite "exceptions / hierarchy catch" :label "a typed throwable matches its superclasses, not unrelated ones" :expected "[true true true false]" :actual "(let [e (try (Long/parseLong \"z\") (catch Throwable e e))] [(instance? NumberFormatException e) (instance? IllegalArgumentException e) (instance? Exception e) (instance? java.io.IOException e)])"} ]