From 48908f3a9b77beb5714f69bdee051dd38c779d34 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Sat, 27 Jun 2026 20:46:33 -0400 Subject: [PATCH] spec.alpha: (symbol var), Compiler/demunge, MultiFn .dispatchFn/.getMethod, fn .applyTo MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit General fixes from clojure.spec.alpha's test suite. - (symbol a-var) returns the var's qualified symbol (clojure.spec.alpha/->sym). - clojure.lang.Compiler/demunge reverses Clojure's name munging ("clojure.core$odd_QMARK_" -> clojure.core/odd?); spec's fn-sym uses it. - clojure.lang.MultiFn .dispatchFn / .getMethod — spec's multi-spec walks a multimethod through them. - (.applyTo f args) applies a fn to a seq of args (spec instrument). Most of spec.alpha's conform/explain/describe suite passes. Remaining gaps: explain-data's :pred for a BARE fn predicate (jolt fns don't carry their defining symbol, so fn-sym can't recover it), #inst form rendering, and instrument — follow-up. make test green (+3 corpus rows, 0 new divergences), runtime only (no re-mint). --- host/chez/compile-eval.ss | 31 ++++++++++++++++++++++++++++++- host/chez/converters.ss | 2 ++ host/chez/java/dot-forms.ss | 15 +++++++++++++++ test/chez/corpus.edn | 3 +++ 4 files changed, 50 insertions(+), 1 deletion(-) diff --git a/host/chez/compile-eval.ss b/host/chez/compile-eval.ss index 518dbfb..05d86c3 100644 --- a/host/chez/compile-eval.ss +++ b/host/chez/compile-eval.ss @@ -44,8 +44,37 @@ (fold-left (lambda (m s) (jolt-assoc1 m (jolt-symbol #f s) #t)) (jolt-assoc1 (jolt-hash-map) (jolt-symbol "clojure.core" "import*") #t) unq))) +;; clojure.lang.Compiler/demunge — reverse the name munging Clojure applies to +;; build JVM class/method names, so "clojure.core$odd_QMARK_" -> clojure.core/odd?. +;; clojure.spec.alpha's fn-sym uses it to recover a symbol from a fn's class name. +;; Longest tokens first; a standalone _ is a hyphen; $ separates ns from name. +(define demunge-token-map + '(("_DOUBLEQUOTE_" . "\"") ("_SINGLEQUOTE_" . "'") ("_AMPERSAND_" . "&") ("_PERCENT_" . "%") + ("_LBRACE_" . "{") ("_RBRACE_" . "}") ("_LBRACK_" . "[") ("_RBRACK_" . "]") + ("_BSLASH_" . "\\") ("_TILDE_" . "~") ("_CIRCA_" . "@") ("_SHARP_" . "#") ("_BANG_" . "!") + ("_CARET_" . "^") ("_COLON_" . ":") ("_QMARK_" . "?") ("_SLASH_" . "/") ("_PLUS_" . "+") + ("_STAR_" . "*") ("_BAR_" . "|") ("_GT_" . ">") ("_LT_" . "<") ("_EQ_" . "=") ("_DOT_" . "."))) +(define (compiler-demunge s) + (let* ((s (if (string? s) s (jolt-str-render-one s))) + (n (string-length s)) + (out (open-output-string))) + (let loop ((i 0)) + (if (>= i n) (get-output-string out) + (let ((tok (let scan ((ts demunge-token-map)) + (cond ((null? ts) #f) + ((let ((t (caar ts))) + (and (<= (+ i (string-length t)) n) + (string=? (substring s i (+ i (string-length t))) t))) + (car ts)) + (else (scan (cdr ts))))))) + (cond + (tok (display (cdr tok) out) (loop (+ i (string-length (car tok))))) + ((char=? (string-ref s i) #\_) (write-char #\- out) (loop (+ i 1))) + ((char=? (string-ref s i) #\$) (write-char #\/ out) (loop (+ i 1))) + (else (write-char (string-ref s i) out) (loop (+ i 1))))))))) (let ((members (list (cons "LINE" compiler-line-cell) (cons "COLUMN" compiler-column-cell) - (cons "specials" compiler-specials)))) + (cons "specials" compiler-specials) + (cons "demunge" compiler-demunge)))) (register-class-statics! "Compiler" members) (register-class-statics! "clojure.lang.Compiler" members)) diff --git a/host/chez/converters.ss b/host/chez/converters.ss index d13ed85..d8572ed 100644 --- a/host/chez/converters.ss +++ b/host/chez/converters.ss @@ -132,6 +132,8 @@ (jolt-symbol (substring a 0 i) (substring a (+ i 1) slen))) (else (loop (- i 1)))))))) ((keyword? a) (jolt-symbol (keyword-t-ns a) (keyword-t-name a))) + ;; (symbol a-var) -> the var's qualified symbol (clojure.spec.alpha/->sym). + ((var-cell? a) (jolt-symbol (var-cell-ns a) (var-cell-name a))) (else (error #f "symbol: requires string/symbol" a))))) ;; (symbol ns name): a nil namespace is the no-ns sentinel #f (NOT jolt-nil), ;; so (symbol nil "x") equals (symbol "x") and the reader literal 'x — jolt= diff --git a/host/chez/java/dot-forms.ss b/host/chez/java/dot-forms.ss index 40d35a9..0ec81ad 100644 --- a/host/chez/java/dot-forms.ss +++ b/host/chez/java/dot-forms.ss @@ -96,6 +96,21 @@ ;; (.getClass x) universal — the class token for any value, before the ;; collection/map field-lookup arms below would read it as a missing key. ((string=? method-name "getClass") (jolt-class obj)) + ;; clojure.lang.MultiFn .dispatchFn / .getMethod — clojure.spec.alpha's + ;; multi-spec walks a multimethod through these. + ((jolt-multifn? obj) + (cond + ((string=? mname "dispatchFn") (jolt-multifn-dispatch-fn obj)) + ((string=? mname "getMethod") + (let ((methods (jolt-multifn-methods obj)) (dv (car rest))) + (or (hashtable-ref methods dv #f) + (mm-find-isa obj dv) + (hashtable-ref methods (jolt-multifn-default obj) #f) + jolt-nil))) + (else (%dot-rmd obj method-name rest-args)))) + ;; (.applyTo f args): apply a fn to a seq of args (clojure.spec instrument). + ((and (procedure? obj) (string=? mname "applyTo")) + (apply jolt-invoke obj (seq->list (jolt-seq (car rest))))) ;; a transient (ITransientCollection/Set/Map): .contains / .valAt / .count — ;; test.check's distinct-collection gen uses (.contains transient-set k). ((jolt-transient? obj) diff --git a/test/chez/corpus.edn b/test/chez/corpus.edn index 51a1098..2ea135c 100644 --- a/test/chez/corpus.edn +++ b/test/chez/corpus.edn @@ -3386,4 +3386,7 @@ {:suite "seq / take infinite count" :label "(take +Infinity coll) takes the whole coll" :expected "7" :actual "(count (take (/ 1.0 0.0) (range 7)))"} {: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 / symbol of a var" :label "(symbol var) returns its qualified symbol" :expected "clojure.core/inc" :actual "(symbol (var clojure.core/inc))"} + {:suite "host-interop / Compiler/demunge" :label "demunge reverses name munging" :expected "\"a/b?\"" :actual "(clojure.lang.Compiler/demunge \"a$b_QMARK_\")"} + {: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))])"} ]