Merge pull request #263 from jolt-lang/conformance/spec-alpha

spec.alpha: symbol-of-var, demunge, MultiFn methods, fn class names, namespaced maps

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))
 

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=

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)

host/chez/java/host-class.ss

@@ -35,7 +35,11 @@
     ((jolt-atom? x) "clojure.lang.Atom")
     ((char? x) "java.lang.Character")
     ((regex-t? x) "java.util.regex.Pattern")
-    ((procedure? x) "clojure.lang.IFn")
+    ;; an anonymous / unregistered fn — like the JVM, where (class #(..)) is a
+    ;; concrete ns$fn__N subclass. The $fn marker lets clojure.spec.alpha's fn-sym
+    ;; recognize it as anonymous and return ::s/unknown. A named fn is registered
+    ;; (proc-name-tbl) and handled by a class-arm with its real ns$name.
+    ((procedure? x) "clojure.lang.AFunction$fn")
     ;; an exception value (ex-info / host-constructed throwable) reports its JVM
     ;; class, so (= clojure.lang.ExceptionInfo (class e)) and clojure.test's
     ;; (thrown? Class …) match (records.ss ex-info-map?/ex-info-class).
@@ -59,9 +63,28 @@
 ;; (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")
+  (lambda (x) (let ((p (assoc (chez-condition-exc-class x) class-token-alist)))
-                  "clojure.lang.ArityException"
+                (if p (cdr p) "java.lang.IllegalArgumentException"))))
-                  "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))

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

host/chez/java/io.ss

@@ -487,6 +487,11 @@
 (register-host-methods! "thread"
   (list (cons "getContextClassLoader" (lambda (self) the-classloader))
         (cons "getName" (lambda (self) "main"))
+        ;; no reified call stack (jolt does TCO, so caller frames are erased) — an
+        ;; empty StackTraceElement[]. clojure.spec.test.alpha's instrument reads it
+        ;; to name the caller var; it degrades to no ::caller, the conform error
+        ;; (the ExceptionInfo) is still thrown.
+        (cons "getStackTrace" (lambda (self) (jolt-vector)))
         (cons "interrupt" (lambda (self)
                             (when (box? (jhost-state self)) (set-box! (jhost-state self) #t))
                             jolt-nil))

host/chez/java/records-interop.ss

@@ -68,6 +68,18 @@
          (and (string? m)
               (cond ((ri-substring? "incorrect number of arguments" m) "ArityException")
                     ((ri-substring? "not seqable" m) "IllegalArgumentException")
+                    ;; Chez's numeric ops raise "~s is not a real number" on a bad
+                    ;; operand. The JVM throws NullPointerException for a nil operand
+                    ;; (null deref) and ClassCastException for a non-number (can't
+                    ;; cast to Number) — clojure.spec.alpha's conform-explain relies
+                    ;; on the distinction. The offending value rides in the irritants.
+                    ((or (ri-substring? "is not a real number" m)
+                         (ri-substring? "is not a number" m))
+                     (if (and (irritants-condition? v)
+                              (let loop ((xs (condition-irritants v)))
+                                (and (pair? xs) (or (jolt-nil? (car xs)) (loop (cdr xs))))))
+                         "NullPointerException"
+                         "ClassCastException"))
                     (else #f))))))
 
 ;; instance-check: (type-sym val) — type/protocol membership. Host shims loaded

host/chez/reader.ss

@@ -495,6 +495,43 @@
                          (string-append "Unreadable constructor form: #" tok)
                          (empty-pmap)))))))
 
+;; #:ns{…} namespaced map literal: a bare keyword/symbol key gets `ns`, a `:_/x`
+;; key is un-namespaced, an already-qualified key stays. #::{…} uses the current
+;; ns; #::alias{…} resolves the alias.
+(define (rdr-nsmap-key mapns k)
+  (cond
+    ((keyword? k)
+     (let ((kns (keyword-t-ns k)) (kn (keyword-t-name k)))
+       (cond ((and (string? kns) (string=? kns "_")) (keyword #f kn))
+             (kns k)
+             (else (keyword mapns kn)))))
+    ((symbol-t? k)
+     (let ((kns (symbol-t-ns k)) (kn (symbol-t-name k)))
+       (cond ((and (string? kns) (string=? kns "_")) (jolt-symbol #f kn))
+             (kns k)
+             (else (jolt-symbol mapns kn)))))
+    (else k)))
+(define (rdr-nsmap-kvs mapns es)
+  (cond ((null? es) '())
+        ((null? (cdr es)) es)
+        (else (cons (rdr-nsmap-key mapns (car es))
+                    (cons (cadr es) (rdr-nsmap-kvs mapns (cddr es)))))))
+(define (rdr-read-ns-map s i end)        ; i points just past "#:"
+  (let* ((auto? (and (< i end) (char=? (string-ref s i) #\:)))
+         (i2 (if auto? (+ i 1) i)))
+    (let loop ((j i2))
+      (cond
+        ((>= j end) (jolt-throw (jolt-ex-info "EOF in namespaced map literal" (empty-pmap))))
+        ((char=? (string-ref s j) #\{)
+         (let* ((nstok (substring s i2 j))
+                (mapns (if auto?
+                           (if (string=? nstok "") (chez-current-ns)
+                               (let ((a (chez-resolve-alias (chez-current-ns) nstok))) (if a a nstok)))
+                           nstok)))
+           (let-values (((es k) (rdr-read-seq s (+ j 1) end #\})))
+             (values (rdr-make-map (rdr-nsmap-kvs mapns es)) k))))
+        (else (loop (+ j 1)))))))
+
 (define (rdr-read-dispatch s i end)      ; i points just past the '#'
   (when (>= i end) (jolt-throw (jolt-ex-info "EOF after #" (empty-pmap))))
   (let ((c (string-ref s i)))
@@ -533,6 +570,8 @@
                  j)))
       ((char=? c #\?)                    ; #?(...) / #?@(...) reader conditional
        (rdr-read-reader-cond s (+ i 1) end))
+      ((char=? c #\:)                    ; #:ns{...} namespaced map literal
+       (rdr-read-ns-map s (+ i 1) end))
       (else                              ; #tag form -> tagged {:tag :#tag :form ...}
        (let-values (((tok j) (rdr-read-token s i end)))
          (let-values (((form k) (rdr-read-form s j end)))

host/chez/records.ss

@@ -926,6 +926,12 @@
 ;; the protocol short-names it implements (for satisfies?/instance?).
 (define-record-type jreify (fields methods protos) (nongenerative chez-jreify-v1))
 (define (reified-methods obj) (and (jreify? obj) (jreify-methods obj)))
+;; (get reify k) / (:k reify) routes to a reify's ILookup valAt — clojure.spec.alpha
+;; reifies fspec/regex specs as clojure.lang.ILookup and reads (:args spec) off them.
+(register-get-arm! jreify?
+  (lambda (coll k d)
+    (let ((m (and (reified-methods coll) (hashtable-ref (reified-methods coll) "valAt" #f))))
+      (if m (jolt-invoke m coll k d) d))))
 (define (make-reified methods-map . proto-names)
   (let ((ht (make-hashtable string-hash string=?))
         (protos (if (and (pair? proto-names) (null? (cdr proto-names)) (jolt-coll-pred? (car proto-names)))

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

host/chez/seed/image.ss

@@ -209,7 +209,7 @@
 (guard (e (#t #f))
   (def-var-with-meta! "jolt.backend-scheme" "emit-quoted-map-value" (letrec ((emit-quoted-map-value (lambda (m) (let fnrec7679 ((m m)) (let* ((pairs (jolt-invoke (var-deref "clojure.core" "sort") (let* ((_a$7685 (lambda (k) (let fnrec7680 ((k k)) (let* ((_a$7681 (var-deref "clojure.core" "str")) (_a$7682 (jolt-invoke (var-deref "jolt.backend-scheme" "emit-quoted") k)) (_a$7683 " ") (_a$7684 (jolt-invoke (var-deref "jolt.backend-scheme" "emit-quoted") (jolt-get m k)))) (jolt-invoke _a$7681 _a$7682 _a$7683 _a$7684))))) (_a$7686 (jolt-keys m))) (jolt-map _a$7685 _a$7686))))) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-hash-map " (jolt-invoke (var-deref "clojure.string" "join") " " pairs) ")")))))) emit-quoted-map-value) (let* ((_o$7687 (keyword #f "private")) (_o$7688 #t)) (jolt-hash-map _o$7687 _o$7688))))
 (guard (e (#t #f))
-  (def-var-with-meta! "jolt.backend-scheme" "emit-quoted" (letrec ((emit-quoted (lambda (form) (let fnrec7689 ((form form)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-char?") form)) (jolt-invoke (var-deref "jolt.backend-scheme" "emit-const") form) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-literal?") form)) (jolt-invoke (var-deref "jolt.backend-scheme" "emit-const") form) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-sym?") form)) (let* ((m (jolt-invoke (var-deref "jolt.host" "form-sym-meta") form)) (sns (jolt-invoke (var-deref "jolt.host" "form-sym-ns") form)) (nm (jolt-invoke (var-deref "jolt.host" "form-sym-name") form))) (if (jolt-truthy? (let* ((and__25__auto m)) (if (jolt-truthy? and__25__auto) (jolt-pos? (jolt-count m)) and__25__auto))) (let* ((_a$7690 (var-deref "clojure.core" "str")) (_a$7691 "(jolt-symbol/meta ") (_a$7692 (if (jolt-truthy? sns) (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") sns) "#f")) (_a$7693 " ") (_a$7694 (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") nm)) (_a$7695 " ") (_a$7696 (emit-quoted m)) (_a$7697 ")")) (jolt-invoke _a$7690 _a$7691 _a$7692 _a$7693 _a$7694 _a$7695 _a$7696 _a$7697)) (let* ((_a$7698 (var-deref "clojure.core" "str")) (_a$7699 "(jolt-symbol ") (_a$7700 (if (jolt-truthy? sns) (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") sns) "#f")) (_a$7701 " ") (_a$7702 (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") nm)) (_a$7703 ")")) (jolt-invoke _a$7698 _a$7699 _a$7700 _a$7701 _a$7702 _a$7703)))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-set?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-hash-set " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-invoke (var-deref "clojure.core" "sort") (jolt-map emit-quoted (jolt-invoke (var-deref "jolt.host" "form-set-items") form)))) ")") (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-list?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-list " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-map emit-quoted (jolt-invoke (var-deref "jolt.host" "form-elements") form))) ")") (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-vec?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-vector " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-map emit-quoted (jolt-invoke (var-deref "jolt.host" "form-vec-items") form))) ")") (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-map?") form)) (jolt-invoke (var-deref "jolt.backend-scheme" "emit-quoted-map") (jolt-invoke (var-deref "jolt.host" "form-map-pairs") form)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-regex?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-regex " (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") (jolt-invoke (var-deref "jolt.host" "form-regex-source") form)) ")") (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "map?") form)) (jolt-invoke (var-deref "jolt.backend-scheme" "emit-quoted-map-value") form) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "vector?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-vector " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-map emit-quoted form)) ")") (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "set?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-hash-set " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-invoke (var-deref "clojure.core" "sort") (jolt-map emit-quoted form))) ")") (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "seq?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-list " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-map emit-quoted form)) ")") (if (jolt-truthy? (keyword #f "else")) (jolt-throw (let* ((_a$7704 (jolt-invoke (var-deref "clojure.core" "str") "emit-quoted: unsupported quoted form " (jolt-invoke (var-deref "clojure.core" "pr-str") form))) (_a$7705 (jolt-hash-map))) (jolt-ex-info _a$7704 _a$7705))) jolt-nil))))))))))))))))) emit-quoted) (let* ((_o$7706 (keyword #f "private")) (_o$7707 #t)) (jolt-hash-map _o$7706 _o$7707))))
+  (def-var-with-meta! "jolt.backend-scheme" "emit-quoted" (letrec ((emit-quoted (lambda (form) (let fnrec7689 ((form form)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-char?") form)) (jolt-invoke (var-deref "jolt.backend-scheme" "emit-const") form) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-literal?") form)) (jolt-invoke (var-deref "jolt.backend-scheme" "emit-const") form) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-sym?") form)) (let* ((m (jolt-invoke (var-deref "jolt.host" "form-sym-meta") form)) (sns (jolt-invoke (var-deref "jolt.host" "form-sym-ns") form)) (nm (jolt-invoke (var-deref "jolt.host" "form-sym-name") form))) (if (jolt-truthy? (let* ((and__25__auto m)) (if (jolt-truthy? and__25__auto) (jolt-pos? (jolt-count m)) and__25__auto))) (let* ((_a$7690 (var-deref "clojure.core" "str")) (_a$7691 "(jolt-symbol/meta ") (_a$7692 (if (jolt-truthy? sns) (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") sns) "#f")) (_a$7693 " ") (_a$7694 (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") nm)) (_a$7695 " ") (_a$7696 (emit-quoted m)) (_a$7697 ")")) (jolt-invoke _a$7690 _a$7691 _a$7692 _a$7693 _a$7694 _a$7695 _a$7696 _a$7697)) (let* ((_a$7698 (var-deref "clojure.core" "str")) (_a$7699 "(jolt-symbol ") (_a$7700 (if (jolt-truthy? sns) (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") sns) "#f")) (_a$7701 " ") (_a$7702 (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") nm)) (_a$7703 ")")) (jolt-invoke _a$7698 _a$7699 _a$7700 _a$7701 _a$7702 _a$7703)))) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-set?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-hash-set " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-invoke (var-deref "clojure.core" "sort") (jolt-map emit-quoted (jolt-invoke (var-deref "jolt.host" "form-set-items") form)))) ")") (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-list?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-list " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-map emit-quoted (jolt-invoke (var-deref "jolt.host" "form-elements") form))) ")") (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-vec?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-vector " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-map emit-quoted (jolt-invoke (var-deref "jolt.host" "form-vec-items") form))) ")") (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-map?") form)) (jolt-invoke (var-deref "jolt.backend-scheme" "emit-quoted-map") (jolt-invoke (var-deref "jolt.host" "form-map-pairs") form)) (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-regex?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-regex " (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") (jolt-invoke (var-deref "jolt.host" "form-regex-source") form)) ")") (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-inst?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-inst-from-string " (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") (jolt-invoke (var-deref "jolt.host" "form-inst-source") form)) ")") (if (jolt-truthy? (jolt-invoke (var-deref "jolt.host" "form-uuid?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-uuid-from-string " (jolt-invoke (var-deref "jolt.backend-scheme" "chez-str-lit") (jolt-invoke (var-deref "jolt.host" "form-uuid-source") form)) ")") (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "map?") form)) (jolt-invoke (var-deref "jolt.backend-scheme" "emit-quoted-map-value") form) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "vector?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-vector " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-map emit-quoted form)) ")") (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "set?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-hash-set " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-invoke (var-deref "clojure.core" "sort") (jolt-map emit-quoted form))) ")") (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "seq?") form)) (jolt-invoke (var-deref "clojure.core" "str") "(jolt-list " (jolt-invoke (var-deref "clojure.string" "join") " " (jolt-map emit-quoted form)) ")") (if (jolt-truthy? (keyword #f "else")) (jolt-throw (let* ((_a$7704 (jolt-invoke (var-deref "clojure.core" "str") "emit-quoted: unsupported quoted form " (jolt-invoke (var-deref "clojure.core" "pr-str") form))) (_a$7705 (jolt-hash-map))) (jolt-ex-info _a$7704 _a$7705))) jolt-nil))))))))))))))))))) emit-quoted) (let* ((_o$7706 (keyword #f "private")) (_o$7707 #t)) (jolt-hash-map _o$7706 _o$7707))))
 (guard (e (#t #f))
   (def-var-with-meta! "jolt.backend-scheme" "jmeta-nonempty?" (letrec ((jmeta-nonempty? (lambda (m) (let fnrec7708 ((m m)) (let* ((and__25__auto (jolt-invoke (var-deref "clojure.core" "map?") m))) (if (jolt-truthy? and__25__auto) (jolt-pos? (jolt-count m)) and__25__auto)))))) jmeta-nonempty?) (let* ((_o$7709 (keyword #f "private")) (_o$7710 #t)) (jolt-hash-map _o$7709 _o$7710))))
 (guard (e (#t #f))

jolt-core/clojure/core/00-syntax.clj

@@ -212,16 +212,16 @@
                  (let* [g (symbol (str (gensym)))
                         gm (symbol (str (gensym)))
                         ;; kwargs: a map pattern may bind against the sequential rest
-                        ;; of a fn — (& {:keys [...]}) — which is a seq of alternating
+                        ;; of a fn — (& {:keys [...]}) — a seq of alternating k/v args,
-                        ;; k/v args, or a single trailing map. Coerce like Clojure (and
+                        ;; optionally with a trailing map (Clojure 1.11: (f :a 1 {:b 2})
-                        ;; like the interpreter's destructure-bind, so interpret/compile
+                        ;; merges the map over the pairs; (f {:a 1}) is just the map).
-                        ;; agree): a sequential value with one map element is that map,
+                        ;; An odd count means the last arg is that trailing map. A real
-                        ;; otherwise (apply hash-map). A real map value is used as-is, so
+                        ;; map value is used as-is, so ordinary map destructuring is
-                        ;; ordinary map destructuring is unaffected. g holds init once;
+                        ;; unaffected. g holds init once; gm is the coerced map every
-                        ;; gm is the coerced map every lookup (and :as) reads from.
+                        ;; lookup (and :as) reads from.
                         coerce `(if (sequential? ~g)
-                                  (if (and (= 1 (count ~g)) (map? (first ~g)))
+                                  (if (odd? (count ~g))
-                                    (first ~g)
+                                    (merge (apply hash-map (butlast ~g)) (last ~g))
                                     (apply hash-map ~g))
                                   ~g)
                         or-map (get pat :or)

jolt-core/jolt/backend_scheme.clj

@@ -12,7 +12,8 @@
                                form-list? form-vec? form-map? form-set? form-char?
                                form-literal? form-elements form-vec-items
                                form-map-pairs form-set-items form-char-code
-                               form-regex? form-regex-source]]))
+                               form-regex? form-regex-source
+                               form-inst? form-inst-source form-uuid? form-uuid-source]]))
 
 ;; Hot clojure.core primitives lowered to native Scheme.
 ;; `=` is the exactness-aware jolt= from values.ss; inc/dec/
@@ -335,6 +336,11 @@
     (form-map? form) (emit-quoted-map (form-map-pairs form))
     ;; a quoted #"…" regex value -> reconstruct it (same as the :regex IR leaf).
     (form-regex? form) (str "(jolt-regex " (chez-str-lit (form-regex-source form)) ")")
+    ;; quoted #inst / #uuid literals construct their value, like the JVM reader
+    ;; (which builds the Date/UUID at read time, so a quoted/macro form carries the
+    ;; value, not the raw tagged form). Same emit as the :inst / :uuid IR leaves.
+    (form-inst? form) (str "(jolt-inst-from-string " (chez-str-lit (form-inst-source form)) ")")
+    (form-uuid? form) (str "(jolt-uuid-from-string " (chez-str-lit (form-uuid-source form)) ")")
     ;; plain jolt VALUES (metadata maps and anything nested in them)
     (map? form) (emit-quoted-map-value form)
     (vector? form) (str "(jolt-vector " (str/join " " (map emit-quoted form)) ")")

test/chez/corpus.edn

@@ -1,4 +1,8 @@
 [
+  {:suite "host-interop / reify ILookup" :label "(get reify k) / (:k reify) / (get reify k d) route to valAt" :expected "[1 1 :dflt]" :actual "(let [r (reify clojure.lang.ILookup (valAt [_ k] (get {:a 1} k)) (valAt [_ k d] (get {:a 1} k d)))] [(:a r) (get r :a) (get r :z :dflt)])"}
+  {:suite "numbers / comparison error class" :label "nil operand is NPE, non-number is CCE" :expected "[\"java.lang.NullPointerException\" \"java.lang.ClassCastException\"]" :actual "[(try (> nil 5) (catch Throwable e (.getName (class e)))) (try (> :k 5) (catch Throwable e (.getName (class e))))]"}
+  {:suite "reader / quoted #inst constructs a value" :label "a quoted #inst literal is the constructed Date, not a tagged form" :expected "\"(f #inst \\\"1939-01-01T00:00:00.000-00:00\\\")\"" :actual "(pr-str (quote (f #inst \"1939\")))"}
+  {:suite "fn / kwargs trailing map" :label "(f :k v {map}) and (f {map}) both bind & {:as m}" :expected "[{:x 1 :y 2} {:x 1 :y 2}]" :actual "[((fn [a & {:as m}] m) 1 :x 1 {:y 2}) ((fn [a & {:as m}] m) 1 {:x 1 :y 2})]"}
   {:suite "destructure / :or" :label "map default when key absent" :expected "9" :actual "(let [{x :x :or {x 9}} {}] x)"}
   {:suite "destructure / :or" :label "kwargs default when key absent" :expected "9" :actual "((fn [& {x :x :or {x 9}}] x))"}
   {:suite "destructure / :or" :label "default not used when key present" :expected "5" :actual "(let [{x :x :or {x 9}} {:x 5}] x)"}
@@ -3386,4 +3390,8 @@
   {: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 / 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))])"}
+  {:suite "reader / namespaced map literal" :label "#:ns{...} qualifies bare keys; :_/x stays unqualified" :expected "[:search 2 nil]" :actual "[(:event/type #:event{:type :search :id 5}) (count #:x{:a 1 :b 2}) (:k #:_{:k 9})]"}
 ]

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"}