diff --git a/host/chez/host-class.ss b/host/chez/host-class.ss index e9feafa..7a25f52 100644 --- a/host/chez/host-class.ss +++ b/host/chez/host-class.ss @@ -41,11 +41,17 @@ ;; (thrown? Class …) match (records.ss ex-info-map?/ex-info-class). ((ex-info-map? x) (ex-info-class x)) (else (jolt-str-render-one (jolt-type x))))) -(define (jolt-class x) +;; 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. +(define (jolt-class-name x) (let loop ((as jolt-class-arms)) (cond ((null? as) (jolt-class-base x)) (((caar as) x) ((cdar as) x)) (else (loop (cdr as)))))) +(define (jolt-class x) + (let ((n (jolt-class-name x))) + (if (jolt-nil? n) jolt-nil (make-class-obj n)))) (def-var! "clojure.core" "class" jolt-class) diff --git a/host/chez/host-static-classes.ss b/host/chez/host-static-classes.ss index 06c3381..ba5bfba 100644 --- a/host/chez/host-static-classes.ss +++ b/host/chez/host-static-classes.ss @@ -643,5 +643,29 @@ (else 'none)))) (if (eq? hit 'none) 'pass (if hit #t #f)))))) +;; java.lang.Class value: (class x) / (.getClass x) return one. It renders like +;; the JVM — str/.toString -> "class ", pr -> "", .getName -> "" +;; — but stays = and hash equal to its name STRING, so (= (class x) String), +;; class-keyed maps/sets, multimethod dispatch on class, and instance? all keep +;; working against the bare class-name tokens. +(define (make-class-obj name) (make-jhost "class" (vector name))) +(define (jclass? x) (and (jhost? x) (string=? (jhost-tag x) "class"))) +(define (jclass-name x) (vector-ref (jhost-state x) 0)) +(define (class-key x) (cond ((jclass? x) (jclass-name x)) ((string? x) x) (else #f))) +(register-eq-arm! (lambda (a b) (or (jclass? a) (jclass? b))) + (lambda (a b) (let ((ka (class-key a)) (kb (class-key b))) + (and ka kb (string=? ka kb) #t)))) +(register-hash-arm! jclass? (lambda (x) (jolt-hash (jclass-name x)))) +(register-str-render! jclass? (lambda (x) (string-append "class " (jclass-name x)))) +(register-pr-arm! jclass? (lambda (x) (jclass-name x))) +(register-host-methods! "class" + (list (cons "getName" (lambda (self) (jclass-name self))) + (cons "getCanonicalName" (lambda (self) (jclass-name self))) + (cons "getSimpleName" (lambda (self) (hsc-last-segment (jclass-name self)))) + (cons "toString" (lambda (self) (string-append "class " (jclass-name self)))) + (cons "isArray" (lambda (self) (let ((n (jclass-name self))) + (and (fx>? (string-length n) 0) (char=? (string-ref n 0) #\[))))) + (cons "getClass" (lambda (self) (make-class-obj "java.lang.Class"))))) + ;; (jolt.host/table? x) — is x a host tagged-table? (def-var! "jolt.host" "table?" (lambda (x) (if (htable? x) #t #f))) diff --git a/host/chez/records-interop.ss b/host/chez/records-interop.ss index 0ef0c0a..cdc0e3d 100644 --- a/host/chez/records-interop.ss +++ b/host/chez/records-interop.ss @@ -72,11 +72,10 @@ ((ex-info-map? val) (exception-isa? (last-dot (ex-info-class val)) (last-dot tname))) (else (case-string tname val))))) -(define (instance-check type-sym val) - ;; normalize a bare (non-array) string class token to a symbol so every arm and - ;; the base table can read its name; array tokens ("[I") stay strings for the - ;; natives-array arm. - (let ((ts (if (and (string? type-sym) +(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) diff --git a/stdlib/clojure/test.clj b/stdlib/clojure/test.clj index 789c350..3b55eac 100644 --- a/stdlib/clojure/test.clj +++ b/stdlib/clojure/test.clj @@ -74,8 +74,9 @@ (let [w (last-seg wanted)] (if (or (= w "Exception") (= w "Throwable")) true - (let [c (class e)] - (and (string? c) (= (last-seg c) w)))))) + (let [c (class e) + cn (cond (nil? c) nil (string? c) c :else (.getName c))] + (and cn (= (last-seg cn) w)))))) ;; --- assertion macros ------------------------------------------------------ diff --git a/test/chez/corpus.edn b/test/chez/corpus.edn index 92e5625..12401f4 100644 --- a/test/chez/corpus.edn +++ b/test/chez/corpus.edn @@ -548,6 +548,11 @@ {:suite "host-interop / class tokens & readers" :label "(class x) matches the token" :expected "true" :actual "(= String (class \"abc\"))"} {:suite "host-interop / class tokens & readers" :label "defmulti on class dispatches" :expected ":str" :actual "(do (defmulti cm (fn [x] (class x))) (defmethod cm String [x] :str) (cm \"a\"))"} {:suite "host-interop / class tokens & readers" :label "defmethod on nil dispatch value" :expected ":nil" :actual "(do (defmulti cn (fn [x] (class x))) (defmethod cn nil [x] :nil) (defmethod cn String [x] :str) (cn nil))"} + {:suite "host-interop / class tokens & readers" :label "Class str is class-prefixed" :expected "\"class java.lang.String\"" :actual "(str (class \"\"))"} + {:suite "host-interop / class tokens & readers" :label "Class getName" :expected "\"java.lang.String\"" :actual "(.getName (class \"\"))"} + {:suite "host-interop / class tokens & readers" :label "Class getSimpleName" :expected "\"Long\"" :actual "(.getSimpleName (class 5))"} + {:suite "host-interop / class tokens & readers" :label "Class of equal-typed values is =" :expected "true" :actual "(= (class 5) (class 6))"} + {:suite "host-interop / class tokens & readers" :label "Class in a thrown message" :expected "\"of class java.lang.String\"" :actual "(try (throw (Exception. (str \"of \" (class \"\")))) (catch Exception e (.getMessage e)))"} {:suite "host-interop / class tokens & readers" :label "ctor sugar still constructs" :expected "\"x\"" :actual "(.toString (StringBuilder. \"x\"))"} {:suite "host-interop / class tokens & readers" :label "return-hinted defn parses" :expected "7" :actual "(do (defn- hb ^bytes [b] b) (hb 7))"} {:suite "host-interop / class tokens & readers" :label "hinted multi-arity parses" :expected ":two" :actual "((fn ([x] :one) (^String [x y] :two)) 1 2)"}