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.
This commit is contained in:
Yogthos
parent
3dde290f1a
commit
d21ab77e7e
18 changed files with 1179 additions and 939 deletions
|
|
@ -57,7 +57,10 @@ aren't implemented; a few are accepted but no-ops (noted inline).
|
|||
`.hashCode` `.equals` `.getClass` work on any value.
|
||||
- **`java.lang.Class`** — `forName` (throws a catchable `ClassNotFoundException`
|
||||
for a class jolt can't back, so `(try (Class/forName "opt.Dep") (catch …))`
|
||||
dependency probes work).
|
||||
dependency probes work). There is no reflection, but a few common interfaces
|
||||
carry a modeled ancestry so `(supers c)` / `(ancestors c)` answer like the JVM —
|
||||
e.g. `(ancestors (class f))` for a function yields `Runnable` and `Callable`,
|
||||
the check `core.memoize` uses to validate a memoizable argument.
|
||||
|
||||
### Strings and text
|
||||
|
||||
|
|
@ -138,8 +141,13 @@ aren't implemented; a few are accepted but no-ops (noted inline).
|
|||
`IllegalArgumentException` `IllegalStateException` `IOException`
|
||||
`NumberFormatException` `ArithmeticException` `NullPointerException`
|
||||
`ClassCastException` `IndexOutOfBoundsException` `FileNotFoundException`
|
||||
`UnsupportedOperationException` and the common network exceptions, each with
|
||||
the `(E.)` / `(E. msg)` / `(E. msg cause)` / `(E. cause)` constructors.
|
||||
`UnsupportedOperationException` `Error` `AssertionError` and the common network
|
||||
exceptions, each with the `(E.)` / `(E. msg)` / `(E. msg cause)` / `(E. cause)`
|
||||
constructors. `try` dispatches its `catch` clauses by class in order, respecting
|
||||
the exception supertype hierarchy (`(catch Exception e …)` catches a
|
||||
`RuntimeException` but not an `Error`); a thrown value matching no clause
|
||||
re-throws. An untyped host condition (e.g. from `(/ 1 0)`) is caught by a
|
||||
`RuntimeException`/`Exception`/`Throwable` clause.
|
||||
|
||||
What's deliberately absent: STM (`clojure.lang.LockingTransaction/isRunning`
|
||||
returns `false`), reflection, `gen-class`/`proxy` of Java classes, and
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
# Clojure libraries known to work with Jolt
|
||||
|
||||
Libraries confirmed to load and pass their conformance checks on Jolt. A library
|
||||
listed here works; some need `JOLT_FEATURES` including `clj` (noted below). See
|
||||
the [examples](https://github.com/jolt-lang/examples), e.g. the
|
||||
[ring-app example](https://github.com/jolt-lang/examples/tree/main/ring-app).
|
||||
listed here works. See the [examples](https://github.com/jolt-lang/examples),
|
||||
e.g. the [ring-app example](https://github.com/jolt-lang/examples/tree/main/ring-app).
|
||||
|
||||
* [aero](https://github.com/juxt/aero) — EDN configuration with tag literals
|
||||
(`#ref`/`#env`/`#or`/`#profile`/`#long`/…)
|
||||
|
|
@ -20,7 +19,7 @@ the [examples](https://github.com/jolt-lang/examples), e.g. the
|
|||
[jolt-lang/jolt-crypto](https://github.com/jolt-lang/jolt-crypto) (OpenSSL)
|
||||
* [reitit-core](https://github.com/metosin/reitit) — data-driven routing; the
|
||||
`reitit.Trie` Java class is mirrored by
|
||||
[jolt-lang/router](https://github.com/jolt-lang/router). `JOLT_FEATURES` `clj`.
|
||||
[jolt-lang/router](https://github.com/jolt-lang/router).
|
||||
* [integrant](https://github.com/weavejester/integrant) — data-driven system
|
||||
configuration (`#ig/ref`), with its
|
||||
[dependency](https://github.com/weavejester/dependency) and
|
||||
|
|
@ -36,7 +35,7 @@ the [examples](https://github.com/jolt-lang/examples), e.g. the
|
|||
* [migratus](https://github.com/yogthos/migratus) — database migrations over the
|
||||
next.jdbc layer
|
||||
* [malli](https://github.com/metosin/malli) — data schema validation, on the
|
||||
malli-app example. `JOLT_FEATURES` `clj`.
|
||||
malli-app example.
|
||||
* [markdown-clj](https://github.com/yogthos/markdown-clj) — Markdown → HTML, on the
|
||||
markdown-app example
|
||||
* [hiccup](https://github.com/weavejester/hiccup) — HTML from Clojure data, on the
|
||||
|
|
@ -44,11 +43,11 @@ the [examples](https://github.com/jolt-lang/examples), e.g. the
|
|||
* [clojure.data.json](https://github.com/clojure/data.json) — JSON reading and writing
|
||||
* [clojure.spec.alpha](https://github.com/clojure/spec.alpha) — data specs
|
||||
* [core.match](https://github.com/clojure/core.match) — pattern matching.
|
||||
`JOLT_FEATURES` `clj`.
|
||||
* [core.cache](https://github.com/clojure/core.cache) — caching (Basic/FIFO/LRU/
|
||||
LU/TTL/Soft + the wrapped atom API), over
|
||||
[data.priority-map](https://github.com/clojure/data.priority-map).
|
||||
`JOLT_FEATURES` `clj`.
|
||||
* [core.memoize](https://github.com/clojure/core.memoize) — function memoization
|
||||
over [core.cache](https://github.com/clojure/core.cache).
|
||||
* [tick](https://github.com/juxt/tick) — date/time over Jolt's `java.time`;
|
||||
`#time/…` literals via `time-literals`. `JOLT_FEATURES` `clj`.
|
||||
`#time/…` literals via `time-literals`.
|
||||
* [transit-jolt](https://github.com/jolt-lang/transit-jolt) — Transit (JSON) read/write
|
||||
|
|
|
|||
|
|
@ -1,9 +1,22 @@
|
|||
# RFC 0002 — Reader-Conditional Feature Set
|
||||
|
||||
- **Status**: Accepted (implemented; measured)
|
||||
- **Status**: Superseded (2026-06-25) — jolt now includes `:clj` in the default
|
||||
set; see the note below.
|
||||
- **Created**: 2026-06-10
|
||||
- **Spec**: `docs/spec/02-reader.md` §2.3 S18
|
||||
|
||||
> **Update (2026-06-25).** The default set is now **`#{:jolt :clj :default}`** —
|
||||
> `:clj` is satisfied by default. The clj ecosystem's `.cljc` libraries gate
|
||||
> their host code behind `#?(:clj …)` with no `:jolt`/`:default` fallback, so
|
||||
> the conformance libraries (core.cache, core.match, tick, malli, …) only load
|
||||
> with `:clj` present; requiring an opt-in for each was friction with no payoff
|
||||
> once jolt's `clojure.lang.*`/`java.*` emulation was broad enough to run those
|
||||
> `:clj` branches. Matching is still by **clause order**, so a library can place
|
||||
> a `:jolt` branch first to override. There is no `JOLT_FEATURES` environment
|
||||
> variable; a loading context overrides the set at runtime with
|
||||
> `reader-features-set!`. The rest of this RFC is the original (reverted)
|
||||
> design.
|
||||
|
||||
## Summary
|
||||
|
||||
jolt's reader-conditional feature set is **`#{:jolt :default}`**, matched in
|
||||
|
|
|
|||
|
|
@ -159,9 +159,10 @@ checks → UNVERIFIED (rows to add).
|
|||
key the platform satisfies wins (`#?(:default 5 :clj 6)` is `5` everywhere)
|
||||
— not by key priority. Implementations SHOULD provide a per-loading-context
|
||||
compatibility override for foreign-dialect libraries. (jolt:
|
||||
`#{:jolt :default}`, opt-in via `reader-features-set!`/`JOLT_FEATURES`;
|
||||
decision + A/B data in RFC 0002 — inheriting `:clj` cost 146 suite
|
||||
assertions and 38 errors.)
|
||||
`#{:jolt :clj :default}` — jolt emulates `clojure.lang.*`/`java.*`, so it
|
||||
reads the `:clj` branch of a `.cljc` library by default; a library can put a
|
||||
`:jolt` branch first to override, or a loading context can call
|
||||
`reader-features-set!`. History in RFC 0002.)
|
||||
- Reader conditionals MUST be an error outside `.cljc`-style reading unless
|
||||
the implementation documents otherwise.
|
||||
|
||||
|
|
|
|||
|
|
@ -260,6 +260,12 @@
|
|||
(jolt-promise-deref-timed x (car opts) (cadr opts))))
|
||||
((jolt-agent? x) (jolt-agent-state x))
|
||||
((jolt-delay? x) (jolt-delay-force x))
|
||||
;; a record/reify implementing clojure.lang.IDeref: @x calls its `deref`
|
||||
;; method with the value itself as the leading `this`.
|
||||
((and (jrec? x) (find-method-any-protocol (jrec-tag x) "deref"))
|
||||
=> (lambda (m) (jolt-invoke m x)))
|
||||
((and (reified-methods x) (hashtable-ref (reified-methods x) "deref" #f))
|
||||
=> (lambda (m) (jolt-invoke m x)))
|
||||
(else (apply %pre-conc-deref x opts)))))
|
||||
|
||||
;; realized? for a future/promise/delay. Wrapped over the overlay version in
|
||||
|
|
@ -289,6 +295,26 @@
|
|||
(def-var! "clojure.core" "delay?" jolt-delay?)
|
||||
(def-var! "clojure.core" "deref" jolt-deref)
|
||||
|
||||
;; --- object monitors (locking) ----------------------------------------------
|
||||
;; (locking obj body…) takes obj's monitor for the body — a real per-object lock
|
||||
;; now that futures/agents/threads share one heap. Each object gets a recursive
|
||||
;; Chez mutex (a thread may re-enter a monitor it already holds, like the JVM),
|
||||
;; held in an identity-keyed weak table so monitors are reclaimed with their
|
||||
;; objects. dynamic-wind releases on normal, exceptional, and continuation exit.
|
||||
(define monitor-table (make-weak-eq-hashtable))
|
||||
(define monitor-table-lock (make-mutex))
|
||||
(define (object-monitor obj)
|
||||
(with-mutex monitor-table-lock
|
||||
(or (hashtable-ref monitor-table obj #f)
|
||||
(let ((m (make-mutex))) (hashtable-set! monitor-table obj m) m))))
|
||||
(define (jolt-with-monitor obj thunk)
|
||||
(let ((m (object-monitor obj)))
|
||||
(dynamic-wind
|
||||
(lambda () (mutex-acquire m))
|
||||
thunk
|
||||
(lambda () (mutex-release m)))))
|
||||
(def-var! "jolt.host" "with-monitor" jolt-with-monitor)
|
||||
|
||||
;; --- cooperative thread interrupt -------------------------------------------
|
||||
;; Chez has no force-kill, but its engine timer (set-timer + timer-interrupt-
|
||||
;; handler, thread-local) is polled at procedure-call / loop back-edges — so a
|
||||
|
|
|
|||
|
|
@ -456,7 +456,8 @@
|
|||
'("Throwable" "Exception" "RuntimeException" "IllegalArgumentException" "IllegalStateException"
|
||||
"InterruptedException" "UnsupportedOperationException" "IOException" "NumberFormatException"
|
||||
"ArithmeticException" "NullPointerException" "ClassCastException" "IndexOutOfBoundsException"
|
||||
"FileNotFoundException" "UnsupportedEncodingException" "EOFException" "java.io.EOFException"))
|
||||
"FileNotFoundException" "UnsupportedEncodingException" "EOFException" "java.io.EOFException"
|
||||
"Error" "AssertionError"))
|
||||
|
||||
;; ---- URLEncoder / URLDecoder (www-form-urlencoded) --------------------------
|
||||
(define (url-unreserved? b)
|
||||
|
|
@ -742,3 +743,42 @@
|
|||
|
||||
;; (jolt.host/table? x) — is x a host tagged-table?
|
||||
(def-var! "jolt.host" "table?" (lambda (x) (if (htable? x) #t #f)))
|
||||
|
||||
;; --- minimal JVM class/interface ancestry -----------------------------------
|
||||
;; A handful of libraries reflect over the class hierarchy — e.g. core.memoize
|
||||
;; validates its first argument with (some #{IFn AFn Runnable Callable}
|
||||
;; (ancestors (class f))). jolt models a class as its name string and has no
|
||||
;; reflection, so supers/ancestors return nothing on their own. This table gives
|
||||
;; the common interfaces the direct supers the JVM reports, and the overlay's
|
||||
;; supers/ancestors fold it in. Keyed by canonical class name; value = direct
|
||||
;; supers. Extend as more interfaces are exercised.
|
||||
(define class-supers-tbl (make-hashtable string-hash string=?))
|
||||
(define (reg-class-supers! name supers) (hashtable-set! class-supers-tbl name supers))
|
||||
(reg-class-supers! "clojure.lang.IFn" '("java.lang.Runnable" "java.util.concurrent.Callable"))
|
||||
(reg-class-supers! "clojure.lang.AFn" '("clojure.lang.IFn" "java.lang.Runnable" "java.util.concurrent.Callable"))
|
||||
(reg-class-supers! "clojure.lang.AFunction" '("clojure.lang.AFn" "clojure.lang.IFn" "clojure.lang.Fn"
|
||||
"java.lang.Runnable" "java.util.concurrent.Callable"))
|
||||
|
||||
;; 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 '()))
|
||||
(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))
|
||||
(cons (car pending) seen))))))
|
||||
|
||||
;; (jolt.host/class-supers name) / (jolt.host/class-ancestors name) — a jolt seq of
|
||||
;; super / ancestor class-name strings, or nil when jolt models no hierarchy for it.
|
||||
(def-var! "jolt.host" "class-supers"
|
||||
(lambda (x)
|
||||
(let ((name (class-key x)))
|
||||
(if (and name (hashtable-contains? class-supers-tbl name))
|
||||
(list->cseq (hashtable-ref class-supers-tbl name '()))
|
||||
jolt-nil))))
|
||||
(def-var! "jolt.host" "class-ancestors"
|
||||
(lambda (x)
|
||||
(let ((name (class-key x)))
|
||||
(if name
|
||||
(let ((as (class-ancestors-list name)))
|
||||
(if (null? as) jolt-nil (list->cseq as)))
|
||||
jolt-nil))))
|
||||
|
|
|
|||
|
|
@ -119,3 +119,26 @@
|
|||
;; records.ss, so this set! sees the registry — forward refs resolve at call time.
|
||||
|
||||
(def-var! "clojure.core" "instance-check" instance-check)
|
||||
|
||||
;; Broad-catch fallback for catch-clause dispatch (analyze-try desugars
|
||||
;; (catch C e …) to (or (instance? C e) (__catch-broad? "C" e))). A jolt host
|
||||
;; condition or a raw raised value carries no jolt exception class, so instance?
|
||||
;; can't place it; a Clojure (catch C e) over such a value matches when C is
|
||||
;; RuntimeException (or a subclass) / Exception / Throwable — most host runtime
|
||||
;; errors are RuntimeExceptions. Typed throwables (ex-info, (SomeException. …)) are
|
||||
;; recognized by instance? as Throwable, so untyped? is false and they dispatch
|
||||
;; precisely through the instance? arm instead.
|
||||
(define throwable-type-sym (jolt-symbol #f "Throwable"))
|
||||
(define (simple-class-name nm)
|
||||
(let loop ((i (- (string-length nm) 1)))
|
||||
(cond ((< i 0) nm)
|
||||
((char=? (string-ref nm i) #\.) (substring nm (+ i 1) (string-length nm)))
|
||||
(else (loop (- i 1))))))
|
||||
(define (jolt-catch-broad? nm v)
|
||||
(and (not (instance-check throwable-type-sym v))
|
||||
(let ((s (simple-class-name nm)))
|
||||
(or (exception-isa? s "RuntimeException")
|
||||
(string=? s "Exception")
|
||||
(string=? s "Throwable")))))
|
||||
(def-var! "clojure.core" "__catch-broad?"
|
||||
(lambda (nm v) (if (jolt-catch-broad? nm v) #t #f)))
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
;; run-sci.ss — SCI conformance: load borkdude/sci's own source (vendor/sci) through
|
||||
;; joltc and require its forms to compile+eval. A real-world Clojure-compatibility
|
||||
;; stress test. Floor-gated like the corpus: a regression below
|
||||
;; the floor (or the count today, 205/218) fails. Raise the floor as host gaps close
|
||||
;; the floor (or the count today, 210/218) fails. Raise the floor as host gaps close
|
||||
;; (the tail is genuine gaps — set! on vars, some macro/def shapes).
|
||||
;;
|
||||
;; chez --script host/chez/run-sci.ss
|
||||
;; JOLT_SCI_FLOOR=N override the floor (default 205)
|
||||
;; JOLT_SCI_FLOOR=N override the floor (default 210)
|
||||
;; SCI_VERBOSE=1 print each failing form's error
|
||||
(import (chezscheme))
|
||||
|
||||
|
|
@ -74,7 +74,7 @@
|
|||
load-order)
|
||||
|
||||
(printf "\nSCI load: ~a/~a forms ok (~a fail)\n" total-ok (+ total-ok total-fail) total-fail)
|
||||
(define floor (let ((s (getenv "JOLT_SCI_FLOOR"))) (if s (string->number s) 205)))
|
||||
(define floor (let ((s (getenv "JOLT_SCI_FLOOR"))) (if s (string->number s) 210)))
|
||||
(when (< total-ok floor)
|
||||
(printf "REGRESSION: ~a forms loaded < floor ~a\n" total-ok floor))
|
||||
(flush-output-port)
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
|
|
@ -311,7 +311,12 @@
|
|||
|
||||
(defn ancestors
|
||||
([tag] (ancestors (deref global-hierarchy) tag))
|
||||
([h tag] (not-empty (get (get h :ancestors) tag))))
|
||||
([h tag]
|
||||
;; the user hierarchy plus any modeled JVM ancestry (jolt.host/class-ancestors)
|
||||
;; so (ancestors (class x)) answers like the JVM for the common interfaces.
|
||||
(let [hier (get (get h :ancestors) tag)
|
||||
host (jolt.host/class-ancestors tag)]
|
||||
(not-empty (if host (into (or hier #{}) host) hier)))))
|
||||
|
||||
(defn descendants
|
||||
([tag] (descendants (deref global-hierarchy) tag))
|
||||
|
|
|
|||
|
|
@ -344,8 +344,12 @@
|
|||
(defn numerator [x] (throw (ex-info "numerator requires a ratio (Jolt has no ratios)" {})))
|
||||
(defn denominator [x] (throw (ex-info "denominator requires a ratio (Jolt has no ratios)" {})))
|
||||
|
||||
;; No class hierarchy on this host.
|
||||
(defn supers [x] #{})
|
||||
;; jolt has no reflection, but a few common JVM interfaces carry a modeled
|
||||
;; ancestry (jolt.host/class-supers) so reflective checks like
|
||||
;; (ancestors (class f)) answer like the JVM.
|
||||
(defn supers [x]
|
||||
(let [s (jolt.host/class-supers x)]
|
||||
(if s (set s) #{})))
|
||||
|
||||
;; Like Clojure's munge: rewrite dashes to underscores, preserving the argument's
|
||||
;; type — a symbol munges to a symbol, anything else to a string. (jolt only
|
||||
|
|
|
|||
|
|
@ -69,10 +69,10 @@
|
|||
`(instance-check ~t ~x)
|
||||
`(instance-check (quote ~t) ~x)))
|
||||
|
||||
;; Single-threaded host: evaluate the monitor expr (for its effects, matching
|
||||
;; Clojure's evaluation order) and the body — no lock to take.
|
||||
;; Take x's monitor for the duration of body (futures/agents/threads share one
|
||||
;; heap, so this is a real per-object lock), releasing on any exit.
|
||||
(defmacro locking [x & body]
|
||||
`(do ~x ~@body))
|
||||
`(jolt.host/with-monitor ~x (fn* [] ~@body)))
|
||||
|
||||
;; defonce: define name only if it isn't already bound to a non-nil root;
|
||||
;; returns the existing var untouched otherwise.
|
||||
|
|
@ -310,16 +310,61 @@
|
|||
;; in-place field write the analyzer compiles to jolt-set-field!.
|
||||
mutable-syms (map first (filter second (map vector fields field-muts)))
|
||||
mutable? (fn [s] (boolean (some (fn [m] (= m s)) mutable-syms)))
|
||||
rewrite-set (fn rw [inst form]
|
||||
(cond
|
||||
(and (seq? form) (seq form) (symbol? (first form))
|
||||
(= "set!" (name (first form)))
|
||||
(symbol? (second form)) (mutable? (second form)))
|
||||
(list 'set! (list (symbol (str ".-" (name (second form)))) inst)
|
||||
(rw inst (nth form 2)))
|
||||
(seq? form) (map (fn [x] (rw inst x)) form)
|
||||
(vector? form) (mapv (fn [x] (rw inst x)) form)
|
||||
:else form))
|
||||
;; rewrite a method body: (set! mut-field v) -> an in-place (.-field inst)
|
||||
;; write, and a READ of a mutable field -> (.-field inst) so it observes the
|
||||
;; live value after a set! (the double-checked-locking idiom re-reads a field
|
||||
;; after taking a lock). Immutable fields stay let-bound (captured once is
|
||||
;; correct and cheaper). Tracks lexical shadowing through let/loop/fn/letfn so
|
||||
;; a same-named local wins over a field.
|
||||
rewrite-body
|
||||
(fn rw [inst shadowed form]
|
||||
(cond
|
||||
(and (seq? form) (seq form) (symbol? (first form))
|
||||
(= "set!" (name (first form)))
|
||||
(symbol? (second form)) (mutable? (second form))
|
||||
(not (contains? shadowed (second form))))
|
||||
(list 'set! (list (symbol (str ".-" (name (second form)))) inst)
|
||||
(rw inst shadowed (nth form 2)))
|
||||
;; let/loop-style vector-binding forms: rewrite inits, then shadow the
|
||||
;; bound names in the body.
|
||||
(and (seq? form) (seq form) (symbol? (first form))
|
||||
(contains? #{"let" "let*" "loop" "binding" "when-let" "if-let"
|
||||
"when-some" "if-some"} (name (first form)))
|
||||
(vector? (second form)))
|
||||
(let [bv (second form) n (count bv)
|
||||
bv' (loop [i 0 acc []]
|
||||
(if (< i n)
|
||||
(recur (+ i 2)
|
||||
(let [a (conj acc (nth bv i))]
|
||||
(if (< (inc i) n) (conj a (rw inst shadowed (nth bv (inc i)))) a)))
|
||||
acc))
|
||||
sh (loop [i 0 acc shadowed]
|
||||
(if (< i n)
|
||||
(recur (+ i 2) (if (symbol? (nth bv i)) (conj acc (nth bv i)) acc))
|
||||
acc))]
|
||||
(cons (first form) (cons bv' (map (fn [x] (rw inst sh x)) (drop 2 form)))))
|
||||
;; fn/fn*: shadow each arity's params in its body.
|
||||
(and (seq? form) (seq form) (symbol? (first form))
|
||||
(contains? #{"fn" "fn*"} (name (first form))))
|
||||
(let [head (first form) tail (rest form)
|
||||
named? (and (seq tail) (symbol? (first tail)))
|
||||
fname (when named? (first tail))
|
||||
arts (if named? (rest tail) tail)
|
||||
psyms (fn [pv] (loop [p (seq pv) acc shadowed]
|
||||
(if p
|
||||
(recur (next p)
|
||||
(if (and (symbol? (first p)) (not= (name (first p)) "&"))
|
||||
(conj acc (first p)) acc))
|
||||
acc)))
|
||||
do-art (fn [ar] (cons (first ar) (map (fn [x] (rw inst (psyms (first ar)) x)) (rest ar))))
|
||||
arts' (if (vector? (first arts)) (do-art arts) (map do-art arts))]
|
||||
(concat (list head) (when named? (list fname)) arts'))
|
||||
;; a bare read of a mutable field -> live field access
|
||||
(and (symbol? form) (mutable? form) (not (contains? shadowed form)))
|
||||
(list (symbol (str ".-" (name form))) inst)
|
||||
(seq? form) (map (fn [x] (rw inst shadowed x)) form)
|
||||
(vector? form) (mapv (fn [x] (rw inst shadowed x)) form)
|
||||
:else form))
|
||||
;; inline impls register for dispatch but are NOT extenders of the
|
||||
;; protocol (the JVM compiles them into the class) — register-inline-method,
|
||||
;; not extend-type.
|
||||
|
|
@ -329,8 +374,11 @@
|
|||
mk-clause (fn [spec]
|
||||
(let [argv (nth spec 1)
|
||||
inst (first argv)
|
||||
binds (vec (mapcat (fn [f] [f `(get ~inst ~(keyword (name f)))]) fields))
|
||||
mbody (map (fn [bf] (rewrite-set inst bf)) (drop 2 spec))]
|
||||
;; let-bind only immutable fields; mutable ones are read live
|
||||
;; via rewrite-body so a set! within the method is observed.
|
||||
binds (vec (mapcat (fn [f] [f `(get ~inst ~(keyword (name f)))])
|
||||
(filter (fn [f] (not (mutable? f))) fields)))
|
||||
mbody (map (fn [bf] (rewrite-body inst #{} bf)) (drop 2 spec))]
|
||||
(list argv (list* 'let binds mbody))))
|
||||
groups (group-by-head body)
|
||||
;; merge clauses by method NAME across ALL protocols into one multi-arity
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;; Verbatim from clojure.template (Stuart Sierra) — pure Clojure over
|
||||
;; clojure.walk, which jolt ships. Added so honeysql's :clj branch (which
|
||||
;; requires clojure.template) loads under JOLT_FEATURES including clj.
|
||||
;; requires clojure.template) loads.
|
||||
(ns clojure.template
|
||||
"Macros that expand to repeated copies of a template expression."
|
||||
(:require [clojure.walk :as walk]))
|
||||
|
|
|
|||
|
|
@ -11,6 +11,19 @@
|
|||
{:suite "interop / iterator-seq" :label "iterator-seq over .iterator" :expected "[:a :b]" :actual "(vec (iterator-seq (.iterator [:a :b])))"}
|
||||
{:suite "deftype / IPersistentStack" :label "peek/pop dispatch" :expected "[1 [2 3]]" :actual "(do (deftype Stk [v] clojure.lang.IPersistentStack (peek [_] (first v)) (pop [_] (->Stk (rest v)))) [(peek (->Stk [1 2 3])) (vec (.v (pop (->Stk [1 2 3]))))])"}
|
||||
{:suite "deftype / equiv" :label "(= deftype other) uses equiv method" :expected "true" :actual "(do (deftype EqT [m] clojure.lang.IPersistentCollection (equiv [_ o] (= o m)) clojure.lang.Seqable (seq [_] (seq m))) (= (->EqT {:a 1}) {:a 1}))"}
|
||||
{:suite "deftype / IDeref" :label "@ dispatches to the deref method" :expected "7" :actual "(do (deftype Box [v] clojure.lang.IDeref (deref [_] v)) (deref (->Box 7)))"}
|
||||
{:suite "reify / IDeref" :label "@ dispatches to the deref method" :expected "7" :actual "(deref (reify clojure.lang.IDeref (deref [_] 7)))"}
|
||||
{:suite "deftype / mutable field" :label "set! is observed by a later read in the same method" :expected "9" :actual "(do (deftype B [^:unsynchronized-mutable v] clojure.lang.IDeref (deref [_] (set! v 9) v)) (deref (->B 0)))"}
|
||||
{:suite "def / metadata evaluation" :label "a symbol metadata value evaluates to its var" :expected "true" :actual "(do (def ^{:af rest} mv 1) (fn? (:af (meta (var mv)))))"}
|
||||
{:suite "def / metadata evaluation" :label "an expression metadata value is evaluated" :expected "3" :actual "(do (def ^{:k (+ 1 2)} mv2 1) (:k (meta (var mv2))))"}
|
||||
{:suite "interop / class ancestry" :label "(ancestors (class fn)) includes a callable interface" :expected "true" :actual "(boolean (some #{java.lang.Runnable java.util.concurrent.Callable} (ancestors (class identity))))"}
|
||||
{:suite "interop / AssertionError" :label "construct + catch as Throwable" :expected "\"boom\"" :actual "(try (throw (AssertionError. \"boom\")) (catch Throwable e (.getMessage e)))"}
|
||||
{:suite "try / multi-catch" :label "dispatches to the matching class clause, not the first" :expected ":rte" :actual "(try (throw (RuntimeException. \"x\")) (catch NullPointerException _ :npe) (catch RuntimeException _ :rte) (catch Exception _ :exc))"}
|
||||
{:suite "try / multi-catch" :label "Error is not caught by an Exception clause" :expected ":thr" :actual "(try (throw (Error. \"e\")) (catch Exception _ :exc) (catch Throwable _ :thr))"}
|
||||
{:suite "try / multi-catch" :label "no matching clause re-throws to an outer catch" :expected ":outer" :actual "(try (try (throw (RuntimeException. \"x\")) (catch NullPointerException _ :npe)) (catch Exception _ :outer))"}
|
||||
{:suite "try / multi-catch" :label "a host condition is caught by its RuntimeException subclass" :expected ":arith" :actual "(try (/ 1 0) (catch ArithmeticException _ :arith) (catch Throwable _ :other))"}
|
||||
{:suite "locking" :label "returns the body value" :expected "42" :actual "(let [o (Object.)] (locking o 42))"}
|
||||
{:suite "locking" :label "reentrant on the same object" :expected "42" :actual "(let [o (Object.)] (locking o (locking o 42)))"}
|
||||
{:suite "interop / Thread" :label "start + join runs the thunk" :expected "7" :actual "(let [a (atom 0) t (Thread. (fn [] (reset! a 7)))] (.start t) (.join t) (deref a))"}
|
||||
{:suite "interop / CountDownLatch" :label "countDown to zero, await returns" :expected "0" :actual "(let [l (java.util.concurrent.CountDownLatch. 1)] (.countDown l) (.await l) (.getCount l))"}
|
||||
{:suite "interop / SoftReference" :label "get returns the referent" :expected ":v" :actual "(.get (java.lang.ref.SoftReference. :v))"}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue