Run core.memoize's test suite on jolt

Shaking out clojure.core.memoize (207 assertions, 0 fail) cleared several
general gaps:

- deref/@ on a deftype or reify implementing clojure.lang.IDeref dispatches to
  its deref method (RetryingDelay / make-derefable).
- deftype mutable fields (^:unsynchronized-mutable / ^:volatile-mutable) are
  read live: a set! within a method is observed by a later read in the same
  invocation, not the entry-time capture. Needed for double-checked locking.
  Immutable fields stay let-bound. Field reads rewrite to (.-field inst) with
  lexical-shadow tracking.
- def metadata values are evaluated, like Clojure: ^{:k (f)} stores (f)'s
  result and ^{:af some-fn} the fn. :tag stays a literal hint.
- try dispatches catch clauses by class in order via the exception supertype
  hierarchy; a non-matching value re-throws, an untyped host condition is caught
  by a RuntimeException/Exception/Throwable clause. Previously the last clause
  won and the class was ignored.
- locking takes a real per-object monitor (recursive Chez mutex) now that
  futures/agents/threads share one heap; it was a no-op.
- supers/ancestors reflect a small modeled JVM interface hierarchy, so
  (ancestors (class f)) yields Runnable/Callable (core.memoize's arg check).
- AssertionError / Error constructors.

JOLT_FEATURES is gone from the docs: it isn't read anywhere on Chez, and the
reader already includes :clj in its default feature set. RFC 0002's
{:jolt :default} design was reverted in the reader; docs now match the code.

Raises the SCI floor 205 -> 210.

jolt-core/jolt/analyzer.clj

@@ -215,11 +215,14 @@
                        rest-items))
       :else (uncompilable "fn: bad params"))))
 
+;; class names that catch everything (the JVM root types); a (catch Throwable e …)
+;; clause matches any thrown value unconditionally.
+(def ^:private catch-all-names #{"Throwable" "java.lang.Throwable" "Object" "java.lang.Object"})
+
 (defn- analyze-try [ctx items env]
   (let [clauses (rest items)
         body (atom [])
-        catch-sym (atom nil)
-        catch-body (atom nil)
+        catches (atom [])           ; ordered vector of (catch class binding body*) clauses
         finally-body (atom nil)]
     (doseq [c clauses]
       (let [head (when (form-list? c) (first (vec (form-elements c))))
@@ -233,22 +236,43 @@
               ;; form-sym-name crash on a non-symbol.
               (when (or (< (count cl) 3) (not (form-sym? (nth cl 2))))
                 (throw "Unable to parse catch clause; expected (catch class binding body*)"))
-              (reset! catch-sym (form-sym-name (nth cl 2)))
-              (reset! catch-body (drop 3 cl)))
+              (swap! catches conj cl))
           (= hname "finally")
             (reset! finally-body (rest (vec (form-elements c))))
           :else (swap! body conj c))))
-    ;; Add :catch-sym/:catch-body/:finally ONLY when present (same discipline as
-    ;; the arity :rest key above). Assoc'ing them nil-when-absent would give the
-    ;; node a nil-valued key, which makes it a phm in jolt's map representation
-    ;; and forces the back end to densify it (norm-node) before reading :op — the
-    ;; map-nil-representation trap, also avoided for def/fn/arity nodes. The
-    ;; back end reads each key with a nil-safe (node :k) and gates on it, so an
-    ;; absent key is indistinguishable from a present-nil one.
+    ;; Multiple catch clauses dispatch on the thrown value's class, in order. Lower
+    ;; them to ONE guard binding a fresh local, then a nested-if chain testing each
+    ;; clause's class with (instance? C e) — which respects the exception supertype
+    ;; hierarchy — plus __catch-broad? for an untyped host condition. No match
+    ;; re-throws. (The earlier single-catch IR ignored the class and caught
+    ;; everything; this gives real per-class dispatch.) :catch-sym/:catch-body/
+    ;; :finally are added only when present — an absent key must stay absent (a
+    ;; nil-valued key would make the node a phm and force back-end densification).
     (let [n {:op :try :body (analyze-seq ctx @body env)}
-          n (if @catch-body
-              (assoc n :catch-sym @catch-sym
-                       :catch-body (analyze-seq ctx @catch-body (add-locals env [@catch-sym])))
+          n (if (seq @catches)
+              (let [evar-name (gen-name "catch")
+                    evar (symbol evar-name)
+                    dispatch
+                    (reduce
+                      (fn [else cl]
+                        (let [cform (nth cl 1)
+                              bindsym (nth cl 2)
+                              bodyf (drop 3 cl)
+                              letform (cons 'let (cons (vector bindsym evar) bodyf))
+                              fullname (when (form-sym? cform) (form-sym-name cform))
+                              catch-all? (or (not (form-sym? cform))
+                                             (contains? catch-all-names fullname))]
+                          (if catch-all?
+                            letform
+                            (list 'if (list 'or
+                                            (list 'instance? cform evar)
+                                            (list '__catch-broad? fullname evar))
+                                  letform else))))
+                      (list 'throw evar)
+                      (reverse @catches))]
+                (assoc n :catch-sym evar-name
+                         :catch-body (analyze-seq ctx (list dispatch)
+                                                  (add-locals env [evar-name]))))
               n)
           n (if @finally-body
               (assoc n :finally (analyze-seq ctx @finally-body env))
@@ -284,6 +308,22 @@
 (defn- field-head? [nm]
   (and (> (count nm) 2) (= ".-" (subs nm 0 2))))
 
+;; Clojure evaluates def metadata values as expressions: ^{:k (f)} stores the
+;; result of (f), ^{:a some-fn} stores the fn value. Build an IR map that evaluates
+;; each value at def time. :tag keeps the resolved class-name string (jolt models a
+;; type hint as its class name, not a runtime expression). nil when there's no
+;; metadata, so a plain def keeps the cheap static path.
+(defn- def-meta-expr [ctx base env]
+  (when (pos? (count base))
+    (map-node (mapv (fn [p]
+                      (let [k (first p) v (second p)]
+                        ;; :tag stays a literal (a resolved class-name string or a
+                        ;; primitive-hint symbol like `double`) — quote it rather
+                        ;; than evaluate it. Everything else is evaluated.
+                        [(const k)
+                         (if (= k :tag) (quote-node v) (analyze ctx v env))]))
+                    (seq base)))))
+
 (defn- analyze-def [ctx items env]
   (let [name-sym (nth items 1)]
     ;; ^{:map} metadata reads as (def (with-meta name m) v): the metadata is a
@@ -316,7 +356,9 @@
             node-meta (if has-doc (assoc base-meta :doc (nth items 2)) base-meta)]
         (host-intern! ctx cur nm)
         ;; a ^double/^long return hint on the name applies to all arities of the fn.
-        (def-node cur nm (with-ret-nhint (analyze ctx val-form env) (tag->nkind tag)) node-meta)))))
+        (let [node (def-node cur nm (with-ret-nhint (analyze ctx val-form env) (tag->nkind tag)) node-meta)
+              me (def-meta-expr ctx node-meta env)]
+          (if me (assoc node :meta-expr me) node))))))
 
 ;; (set! (.-field obj) v) mutates a deftype instance field in place; (set! *var* v)
 ;; sets the var's innermost thread binding, else its root. A local target (jolt

jolt-core/jolt/backend_scheme.clj

@@ -302,6 +302,14 @@
 ;; A def's :meta is a jolt map value. Non-empty? (a plain def carries {}).
 (defn- jmeta-nonempty? [m] (and (map? m) (pos? (count m))))
 
+;; The meta argument to def-var-with-meta!. When the analyzer attached a
+;; :meta-expr (metadata with values to evaluate, e.g. ^{:a some-fn}), emit it as a
+;; runtime expression; otherwise the static :meta map as quoted data.
+(defn- emit-def-meta [node]
+  (if (:meta-expr node)
+    (emit (:meta-expr node))
+    (emit-quoted (:meta node))))
+
 (defn- emit-binding [b]
   (str "(" (munge-name (nth b 0)) " " (emit (nth b 1)) ")"))
 
@@ -629,7 +637,7 @@
            (str "(declare-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) ")")
            (jmeta-nonempty? (:meta node))
            (str "(def-var-with-meta! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " "
-                (emit (:init node)) " " (emit-quoted (:meta node)) ")")
+                (emit (:init node)) " " (emit-def-meta node) ")")
            :else
            (str "(def-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " "
                 (emit (:init node)) ")"))
@@ -660,7 +668,7 @@
       (let [init (emit (:init node))]
         (if (jmeta-nonempty? (:meta node))
           (str "(begin (define " b " " init ") (def-var-with-meta! "
-               (chez-str-lit ns) " " (chez-str-lit nm) " " b " " (emit-quoted (:meta node)) "))")
+               (chez-str-lit ns) " " (chez-str-lit nm) " " b " " (emit-def-meta node) "))")
           (str "(begin (define " b " " init ") (def-var! "
                (chez-str-lit ns) " " (chez-str-lit nm) " " b "))"))))
     :else (emit node)))

jolt-core/jolt/ir.clj

@@ -118,7 +118,10 @@
       (= op :recur)  (assoc node :args (mapv f (get node :args)))
       (= op :fn)     (assoc node :arities (mapv (fn [a] (assoc a :body (f (get a :body))))
                                                 (get node :arities)))
-      (= op :def)    (assoc node :init (f (get node :init)))
+      (= op :def)    (let [n (assoc node :init (f (get node :init)))]
+                       (if (get node :meta-expr)
+                         (assoc n :meta-expr (f (get node :meta-expr)))
+                         n))
       (= op :host-call) (assoc node :target (f (get node :target))
                                     :args (mapv f (get node :args)))
       (= op :host-new) (assoc node :args (mapv f (get node :args)))
@@ -159,7 +162,8 @@
       (= op :loop) (f (reduce (fn [a b] (f a (nth b 1))) acc (get node :bindings)) (get node :body))
       (= op :recur) (reduce f acc (get node :args))
       (= op :fn) (reduce (fn [a ar] (f a (get ar :body))) acc (get node :arities))
-      (= op :def) (if (get node :init) (f acc (get node :init)) acc)
+      (= op :def) (let [a (if (get node :init) (f acc (get node :init)) acc)]
+                    (if (get node :meta-expr) (f a (get node :meta-expr)) a))
       (= op :host-call) (reduce f (f acc (get node :target)) (get node :args))
       (= op :host-new) (reduce f acc (get node :args))
       (= op :try)