diff --git a/host/chez/java/host-class.ss b/host/chez/java/host-class.ss index 1deaac0..1043322 100644 --- a/host/chez/java/host-class.ss +++ b/host/chez/java/host-class.ss @@ -62,6 +62,26 @@ (lambda (x) (if (string=? (chez-condition-exc-class x) "ArityException") "clojure.lang.ArityException" "java.lang.IllegalArgumentException"))) +;; A fn def'd into a var reports a JVM-style class name "ns$munged-name" (the +;; forward CHAR_MAP), so clojure.spec.alpha's fn-sym (which splits on $ and +;; demunges) recovers the predicate's symbol. Anonymous / unregistered fns stay +;; clojure.lang.IFn (fn-sym yields :unknown, as on the JVM). +(define class-munge-map + '((#\? . "_QMARK_") (#\! . "_BANG_") (#\* . "_STAR_") (#\+ . "_PLUS_") + (#\> . "_GT_") (#\< . "_LT_") (#\= . "_EQ_") (#\/ . "_SLASH_") (#\- . "_") + (#\& . "_AMPERSAND_") (#\% . "_PERCENT_") (#\~ . "_TILDE_") (#\^ . "_CARET_") + (#\| . "_BAR_") (#\: . "_COLON_"))) +(define (class-munge-name s) + (let ((out (open-output-string))) + (string-for-each + (lambda (c) (let ((t (assv c class-munge-map))) (if t (display (cdr t) out) (write-char c out)))) + s) + (get-output-string out))) +(register-class-arm! + (lambda (x) (and (procedure? x) (hashtable-ref proc-name-tbl x #f))) + (lambda (x) (let ((p (hashtable-ref proc-name-tbl x #f))) + (string-append (car p) "$" (class-munge-name (cdr p)))))) + (define (jolt-class-name x) (let loop ((as jolt-class-arms)) (cond ((null? as) (jolt-class-base x)) diff --git a/host/chez/java/host-static-classes.ss b/host/chez/java/host-static-classes.ss index 34da8ee..5e525eb 100644 --- a/host/chez/java/host-static-classes.ss +++ b/host/chez/java/host-static-classes.ss @@ -953,12 +953,21 @@ (reg-class-supers! "clojure.lang.LazySeq" '("clojure.lang.ISeq" "clojure.lang.IPersistentCollection" "clojure.lang.Sequential" "clojure.lang.Seqable" "java.lang.Iterable")) (reg-class-supers! "clojure.lang.Cons" '("clojure.lang.ASeq" "clojure.lang.ISeq" "clojure.lang.Sequential" "clojure.lang.Seqable" "java.lang.Iterable")) +;; A munged fn class name "ns$name" (jolt-class for a def'd fn) isn't in the table; +;; like the JVM (a fn extends clojure.lang.AFunction) its super is AFunction, whose +;; registered supers give AFn / IFn / Fn / Runnable / Callable transitively. +(define (str-has-dollar? s) + (let loop ((i 0)) (and (< i (string-length s)) (or (char=? (string-ref s i) #\$) (loop (+ i 1)))))) +(define (class-direct-supers name) + (or (hashtable-ref class-supers-tbl name #f) + (and (str-has-dollar? name) '("clojure.lang.AFunction")) + '())) ;; transitive closure of direct supers (set semantics via an accumulator list) (define (class-ancestors-list name) - (let loop ((pending (hashtable-ref class-supers-tbl name '())) (seen '())) + (let loop ((pending (class-direct-supers name)) (seen '())) (cond ((null? pending) (reverse seen)) ((member (car pending) seen) (loop (cdr pending) seen)) - (else (loop (append (hashtable-ref class-supers-tbl (car pending) '()) (cdr pending)) + (else (loop (append (class-direct-supers (car pending)) (cdr pending)) (cons (car pending) seen)))))) ;; (instance? Class e) on a throwable tagged-table carrying a JVM :class matches the diff --git a/host/chez/rt.ss b/host/chez/rt.ss index 84ec463..fab5338 100644 --- a/host/chez/rt.ss +++ b/host/chez/rt.ss @@ -114,7 +114,16 @@ ;; evaluates to #'ns/name (a first-class var), so (var? (def x 1)) is true and ;; (pr-str (def x 1)) is "#'ns/x". The prelude's def-var! forms discard the ;; return, so this is transparent there. -(define (def-var! ns name v) (let ((c (jolt-var ns name))) (var-cell-root-set! c v) (var-cell-defined?-set! c #t) c)) +;; proc -> (ns . name) for the var it was def'd into, so (class a-fn) can report a +;; JVM-style class name and clojure.spec.alpha's fn-sym can recover the symbol of a +;; bare-fn predicate. Weak so GC'd fns drop out. Last def of a given proc wins. +(define proc-name-tbl (make-weak-eq-hashtable)) +(define (def-var! ns name v) + ;; first def of a given proc wins, so an alias like (def inc' inc) — which binds + ;; the SAME proc to a second var — doesn't rename inc. + (when (and (procedure? v) (not (hashtable-contains? proc-name-tbl v))) + (hashtable-set! proc-name-tbl v (cons ns name))) + (let ((c (jolt-var ns name))) (var-cell-root-set! c v) (var-cell-defined?-set! c #t) c)) ;; jolt.host/throwable — build a typed throwable a library can throw so (class …), ;; instance?, .getMessage and ex-message all reflect the named JVM class (e.g. an ;; http client throwing java.net.ConnectException). Strictly better than a diff --git a/test/chez/corpus.edn b/test/chez/corpus.edn index 0bc2b1c..9f71847 100644 --- a/test/chez/corpus.edn +++ b/test/chez/corpus.edn @@ -3387,5 +3387,6 @@ {:suite "host-interop / UUID + Long + shiftLeft" :label "(UUID. msb lsb), .shiftLeft, (Long. n)" :expected "[\"00000000-0000-007b-0000-0000000001c8\" 40 10 42]" :actual "[(str (java.util.UUID. 123 456)) (.shiftLeft 5 3) (.shiftRight 40 2) (Long. 42)]"} {:suite "host-interop / ThreadLocal proxy" :label "(proxy [ThreadLocal] [] (initialValue [] v)) get/set" :expected "[42 7]" :actual "(let [tl (proxy [ThreadLocal] [] (initialValue [] 42))] [(.get tl) (do (.set tl 7) (.get tl))])"} {:suite "host-interop / Compiler/demunge" :label "demunge reverses name munging" :expected "\"a/b?\"" :actual "(clojure.lang.Compiler/demunge \"a$b_QMARK_\")"} + {:suite "host-interop / a fn reports its munged class" :label "(class a-def'd-fn) is ns$munged-name, with the IFn hierarchy as ancestors" :expected "[\"clojure.core$odd_QMARK_\" true]" :actual "[(.getName (class odd?)) (boolean (some #{java.lang.Runnable} (ancestors (class odd?))))]"} {:suite "host-interop / MultiFn methods" :label ".getMethod / .dispatchFn on a multimethod" :expected "[true true true]" :actual "(do (defmulti mmc identity) (defmethod mmc :a [_] 1) [(some? (.getMethod mmc :a)) (nil? (.getMethod mmc :z)) (ifn? (.dispatchFn mmc))])"} ] diff --git a/test/chez/unit.edn b/test/chez/unit.edn index fa8dcd1..5a1b018 100644 --- a/test/chez/unit.edn +++ b/test/chez/unit.edn @@ -479,7 +479,7 @@ {:suite "type" :expr "(type (filter odd? [1 2 3]))" :expected "clojure.lang.PersistentList"} {:suite "type" :expr "(type (lazy-seq (cons 1 nil)))" :expected "clojure.lang.LazySeq"} {:suite "type" :expr "(type (take 2 (iterate inc 0)))" :expected "clojure.lang.PersistentList"} - {:suite "type" :expr "(type inc)" :expected "clojure.lang.IFn"} + {:suite "type" :expr "(type inc)" :expected "clojure.core$inc"} {:suite "type" :expr "(type (sorted-map :a 1))" :expected ":map"} {:suite "type" :expr "(type (sorted-set 1))" :expected ":jolt/sorted-set"} {:suite "type" :expr "(type (with-meta [1] {:type :custom}))" :expected ":custom"}