Compare commits

...
Sign in to create a new pull request.

281 commits

Author SHA1 Message Date
0598f8e7c5 Allowed the boot script to check multiple names for the chez executable.
Some checks failed
tests / test (push) Has been cancelled
2026-07-06 17:09:51 +01:00
Dmitri Sotnikov
855fbc4794
Merge pull request #306 from jolt-lang/trace-source-lines
JOLT_TRACE: map tail-frame history to ns/name (file:line)
2026-07-04 21:20:16 +00:00
Yogthos
6c88198115 JOLT_TRACE: map tail-frame history to ns/name (file:line)
The eval path recorded only a frame's munged name, so a JOLT_TRACE backtrace was
a list of bare names. Register source for a runtime-compiled fn def when tracing
is on (keyed by the same munged name the entry push records), reusing the
source-registry the renderer already maps to "ns/name (file:line)". Direct-link
builds already registered via emit-def-cached; this covers the open-world eval
path. trace-off output is byte-identical (returns "" — seed mint / `jolt build`
unchanged), seed re-minted. A name shared across namespaces (e.g. -main) stays
bare, the existing ambiguity guard.

smoke asserts a file-backed project run maps a frame to ns/name (file:line).
2026-07-04 17:09:44 -04:00
Dmitri Sotnikov
e297a74501
Merge pull request #305 from jolt-lang/fix-jolt-trace-aot-binary
JOLT_TRACE: honor the env at runtime in a built joltc
2026-07-04 20:51:03 +00:00
Yogthos
c8167e1c05 JOLT_TRACE: honor the env at runtime in a built joltc
The JOLT_TRACE opt-in was a top-level form in compile-eval.ss, so in a
self-contained joltc it ran at heap-build time — where JOLT_TRACE is always
unset — and never at runtime. `JOLT_TRACE=1 joltc -M:run` therefore produced no
trace from the distributed binary (it worked only under the source-loaded dev
launcher). REPL/nREPL tracing was unaffected (those enable at runtime).

Make it a jolt-trace-init-from-env! fn called from the runtime entrypoints — the
cli.ss dispatch and the built-joltc launcher — before any app namespace compiles,
so the app's own code is traced. While here, drop a redundant trace print in the
joltc launcher (jolt-report-throwable already emits it) that double-printed the
block once tracing actually produced one.

joltc-selfbuild-smoke asserts JOLT_TRACE=1 through the built binary yields exactly
one tail-frame trace.
2026-07-04 16:40:14 -04:00
Dmitri Sotnikov
bff1c288b0
Merge pull request #304 from jolt-lang/tail-frame-history
Recover TCO-elided frames in uncaught-error stack traces
2026-07-04 20:01:51 +00:00
Yogthos
94d3bcca20 AOT: run -main with *ns* = user, matching clojure.main
A built binary loaded each namespace with (set-chez-ns! <ns>) and no restore, so
-main ran with *ns* left at the entry ns. clojure.main (and interpreted joltc)
run -main with *ns* = user, where a runtime (resolve 'alias/sym) is nil because
the alias lives in the entry ns, not user. Reset the current ns to user in the
launcher before -main so a compiled binary matches. build-smoke asserts it via a
separate two-namespace app (kept apart from the tree-shake app — a `resolve`
defeats tree-shaking).
2026-07-04 15:51:13 -04:00
Yogthos
79002526bb JOLT_TRACE: one case-insensitive off-check for both enable paths
Review turned up that the disable vocabulary was the exact lowercase strings
"0"/"false"/"no", so JOLT_TRACE=off (or FALSE, No, n) fell through and ENABLED
tracing — the opposite of intent — and the whole-run and dev-mode checks
disagreed on the empty string. Fold both into one jolt-trace-env-off? predicate
(case-insensitive, incl. off/n); empty/unset carries no signal (dev still traces,
a whole run still doesn't).
2026-07-04 15:51:13 -04:00
Yogthos
7167af4830 Trace by default in REPL-driven development
A repl or nREPL session now turns tail-frame tracing on, so an uncaught error in
evaluated/reloaded code shows a tail-frame backtrace with no JOLT_TRACE set. The
REPL and nREPL catch errors themselves rather than going through the uncaught
reporter, so they now print the history backtrace via a new jolt.host/backtrace-
string (history-only — the live continuation in a REPL is just REPL machinery).

Because the recording is baked in at compile time, only code compiled while a
session is live is traced; reload a namespace to trace already-loaded code.
JOLT_TRACE=1 still forces it on for a whole run (a plain -M:run traces its own
load); JOLT_TRACE=0 forces it off even in a session.

No seed change — jolt.main/jolt.nrepl are runtime-loaded and compile-eval.ss /
source-registry.ss are host files.
2026-07-04 15:23:17 -04:00
Yogthos
a3e2365217 Recover TCO-elided frames in uncaught-error stack traces
On the eval path nothing registers a source map, so jolt-backtrace-string
dropped every walkable frame and printed no trace at all. Keep any named,
non-plumbing continuation frame (rendered as a bare name when unmapped) so a
runtime error shows the surviving non-tail spine — "print what is available".

Add an opt-in tail-frame history behind JOLT_TRACE for the frames TCO erases.
Each compiled fn records itself on entry into a bounded ring-of-rings, MIT
Scheme's "history" shape: the outer ring holds one rib per non-tail subproblem,
each rib a small inner ring of the tail-calls made at that level. A tight tail
loop churns one rib instead of flushing the spine, so the non-tail caller
context survives and total space stays bounded. The reporter prefers this
history over the continuation when it's present, and resets it per top-level
form so an error's trace isn't padded with earlier REPL frames.

The emitter marks a tail call with (jolt-trace-mark! #t) so the runtime routes
the callee into the current rib vs a fresh one; a *tail?* dynamic var tracks
tail position (cleared by default, passed through if/do/let/loop/fn-body). It's
all gated on trace-frames?, which compile-eval turns on for JOLT_TRACE and
emit-image/`jolt build` force off — so non-trace emitted output is byte-identical
(prelude unchanged, seed re-minted), and a built binary carries no per-call cost.
2026-07-04 15:00:52 -04:00
Dmitri Sotnikov
773e647b4a
Merge pull request #303 from jolt-lang/clojure-1.13-parity
Clojure 1.13 parity + no-main build fix
2026-07-04 14:56:22 +00:00
Yogthos
dbc5afac32 build: a no-main entry namespace runs as a script instead of crashing
jolt build -m ns on a namespace with only top-level side effects and no
-main produced a binary that printed its output, then crashed calling a nil
-main ("nil cannot be cast to IFn"). The launcher now calls -main only when
the entry ns actually defines one; otherwise the top-level forms (already run
at heap build) are the whole program and it exits cleanly. Regression case
added to build-smoke.sh.
2026-07-04 10:18:57 -04:00
Yogthos
403c3f302f Clojure 1.13 parity: req!, checked-keys destructuring, keyword array maps
Bring the language up to the 1.13.0-alpha1 changes that apply off the JVM:

- req! (CLJ-2949): a get-variant that throws "Expected key: k" on a missing
  key, without nil-punning. The primitive behind checked destructuring.
- Checked-keys destructuring (CLJ-2961): :keys!/:syms!/:strs! bind and throw
  when a key is absent; keys after & are declared-only (required for the !
  variants, accepted otherwise) and create no binding.
- & is no longer a legal local binding in let/loop (CLJ-2954).
- Keyword-only array maps grow to 64 entries before going hash (was 8),
  across the literal, assoc, and transient paths, so the common keyword map
  keeps insertion order up to 64.

Skipped CLJ-2891 (JVM __init bytecode, JVM-only). 1.13 is still alpha, so
this tracks alpha1 and may shift. Regression tests in test/chez/unit.edn
(ahead of the JVM 1.12.5 the corpus certifies against). Seed re-minted.
2026-07-04 10:18:51 -04:00
Dmitri Sotnikov
1ed9656a0c
Merge pull request #302 from jolt-lang/windows-nrepl-and-version
Fix nREPL on Windows; add a version string
2026-07-04 04:36:47 +00:00
Yogthos
f9fcbc37fd Skip org.clojure/clojure in deps.edn without warning
jolt is Clojure, so a dep on org.clojure/clojure is always satisfied
intrinsically — the "skipping unsupported coordinate" warning on its
:mvn/version coordinate was just noise. Other unsupported mvn coords
still warn.
2026-07-04 00:26:07 -04:00
Yogthos
4398e2cf6c Fix nREPL on Windows; add a version string
The nREPL server bound its loopback socket through libc process symbols,
which don't carry the socket entry points on Windows — they live in
ws2_32.dll and aren't in joltc.exe's export table, so --nrepl-server died
with "no entry for socket". Load ws2_32 before the foreign bindings there,
call WSAStartup once, and use Winsock's closesocket and int-typed
recv/send. Also fix SOL_SOCKET/SO_REUSEADDR, which the old macos-only
check got wrong on Windows.

Bake a version string into the self-contained binary at build time (from
$JOLT_VERSION, else git describe) and expose it via jolt.host/jolt-version:
--version / -V print it, and it shows in --help, the repl banner, and the
nREPL startup line. Dev runs off bin/joltc read it from git describe.

Add -e to the help output.
2026-07-04 00:11:25 -04:00
Yogthos
5467c1d98d Fail actionably when vendor submodules are missing
A user downloaded the auto-generated 'Source code' zip from the release
(no submodules) and hit the raw 'load failed for vendor/irregex/irregex.scm'.
cli.ss and make now check for vendor/irregex up front and print the fix
(clone --recurse-submodules / git submodule update --init --recursive);
README documents both and warns that GitHub's source archives can't build.
Release notes updated with the same pointer.
2026-07-02 19:08:41 -04:00
Yogthos
dbc4298c0a Export joltc.exe symbols so foreign-entry finds the embedded bundles
The -e path worked but jolt build died: jolt_petite_boot_len wasn't
foreign-entry-visible. -rdynamic's Windows equivalent for an exe is an
export table; -Wl,--export-all-symbols provides one.
2026-07-02 18:47:40 -04:00
Yogthos
af12f77dcd Resolve optional libc entries at runtime, not boot load
A literal (foreign-procedure "chmod" ...) in compiled code becomes a fasl
relocation resolved when the boot loads — on Windows (no chmod/sigemptyset/
sigaddset in the CRT) that killed joltc.exe before any guard could run
(msvcrt abort, exit 3). jolt-foreign-proc-safe defers the lookup through
eval at evaluation time, where the guard works and a missing entry just
yields the fallback. chmod also skips the /bin/sh fallback on nt (execute
is by extension).
2026-07-02 18:36:40 -04:00
Yogthos
225073a11b Windows: static link (single-file exe) + a binary inspection step
The built joltc.exe exited 3 (msvcrt abort) with no output on the -e smoke.
Link -static so the exe carries no libwinpthread/libgcc/lz4 DLL deps (needed
for distribution regardless), and add an ntldd + direct-run debug step.
2026-07-02 18:22:53 -04:00
Yogthos
9382c67e48 Windows link set gains -luuid (FOLDERID_* GUIDs) 2026-07-02 15:43:27 -04:00
Yogthos
24c2280246 Route build shell commands through sh on Windows
Chez's system/process use cmd.exe on nt; every build command here is
written for sh. bld-sh-wrap spills the command to a temp script and runs
sh on it (no cmd quoting), identity on other platforms.
2026-07-02 15:33:11 -04:00
Yogthos
0afd2095e3 msys2 inherits the runner PATH (GITHUB_PATH additions were invisible) 2026-07-02 15:21:32 -04:00
Yogthos
c63a18aae1 Windows Chez: skip make install, assemble the csv layout from the build tree
zuo's install target shells the unix installsh through cmd and dies. The
build tree already has everything: scheme.exe (boot files beside it, where
the Windows kernel looks), and scheme.h/libkernel.a/boots into a csv dir
that JOLT_CHEZ_CSV points the jolt build at.
2026-07-02 15:10:36 -04:00
Yogthos
80f3206a6e Fix release.yml: literal newlines inside printf broke the YAML
The Windows PATH step embedded real newlines in its printf strings, which
broke the block scalar and invalidated the whole workflow file (the push
run failed at parse; workflow_dispatch refused). The wrappers are plain
echo pairs now.
2026-07-02 14:59:51 -04:00
Dmitri Sotnikov
7add315394
Merge pull request #301 from jolt-lang/release/windows-v011
Windows release binaries (x86_64) via MSYS2/MinGW
2026-07-02 18:57:46 +00:00
Yogthos
5ca7437826 Restore the :portability tags lost in the rebase 2026-07-02 14:46:13 -04:00
Yogthos
a67dbdb93d rand-nth follows the reference shape; refresh doc counts and the corpus floor
rand-nth vec'd its argument, so (rand-nth nil) hit index-out-of-bounds
through the empty vector where the reference's (nth coll (rand-int (count
coll))) returns nil (and a set throws) — the last genuinely-fixable row in
the suite baseline; rand-nth is fully clean now. Corpus/README counts
updated to the current ~3570 rows, the run-corpus regression floor raised
from 2730 to 3390 to match current parity, and the stale traceability line
dropped.
2026-07-02 14:46:13 -04:00
Yogthos
ab10e68218 Retry the Clojure installer download in CI
A transient CDN timeout handed bash a 2-minute HTML error page instead of
linux-install.sh and failed the run. curl now fails on HTTP errors and
retries, and the script is sanity-checked before running.
2026-07-02 14:46:00 -04:00
Yogthos
b2aa757af2 Windows release binaries (x86_64) via MSYS2/MinGW
Adds a windows-latest job to the release matrix: MSYS2/MinGW-w64 toolchain,
Chez 10.4.1 built from source (ta6nt), the same build-joltc flow, packaged
as a zip of joltc.exe. The whole job runs in the msys2 shell so cc/xxd/paths
behave; the produced binary is a plain Windows executable.

Platform seams: bld-nt? with the winsock/COM/registry link set, no -rdynamic
under MinGW, GetModuleFileName as the launcher's self-path on _WIN32, and
built binaries (joltc itself and jolt-build outputs) normalize to a .exe
suffix. workflow_dispatch added so the matrix can be dry-run without tagging;
the release upload step only fires on tags.

For #205.
2026-07-02 14:46:00 -04:00
Dmitri Sotnikov
58ef0c8fa1
Merge pull request #300 from jolt-lang/corpus/portability-key
Tag every corpus row with :portability (:common vs :jvm)
2026-07-02 18:15:01 +00:00
Yogthos
d6d11d5748 Tag every corpus row with :portability (:common vs :jvm)
Dialects without JVM interop can now filter the conformance corpus: :jvm
marks rows exercising host interop (java.*/clojure.lang.* class references,
dot forms, ctors, statics, arrays, proxy/bean), :common is portable Clojure
any dialect must satisfy. 3565 rows tagged (3175 common / 390 jvm), the key
documented in the row schema, and regen-corpus preserves it on rewrite.

Closes #289.
2026-07-02 14:03:47 -04:00
Dmitri Sotnikov
7b4369145d
Merge pull request #299 from jolt-lang/docs/superset-traceability
Contract fixes from the baseline audit; every residual suite failure traced
2026-07-02 18:03:15 +00:00
Yogthos
ce8e89ca86 Contract fixes from the baseline audit; every residual suite failure traced
Auditing the remaining cts baseline for R7 exposed real contract gaps hiding
among the model residue — all fixed to reference behavior:

- stale no-ratio-era stubs: numerator/denominator now work over jolt's exact
  rationals (non-ratio is the Ratio cast failure); rational? includes decimals
- casts and pending: peek/pop demand an IPersistentStack (pop nil is nil),
  realized? demands an IPending (a plain list/range throws), transient demands
  an editable COLLECTION (non-colls throw; the RFC 0003 sorted/list/seq
  superset keeps the copy-on-write fallback), empty on a plain record throws
- nil and empties: (nth nil i) is nil, (nth nil i d) is d, a nil index is NPE,
  keys/vals of anything empty are nil, (conj nil) is nil
- lookups: contains? on a string is index-only (other keys IAE), get on an
  array is lenient (nth still throws), a VECTOR invocation has nth semantics
  (([1 2] 5) throws — call position and jolt-invoke both)
- into only transients editable collections; a PersistentQueue/sorted target
  folds through conj (RT's IEditableCollection split)
- numbers: number?/num accept BigDecimal, quot/rem throw on an Infinite/NaN
  quotient, even?/odd? demand integers
- ordering: keywords compare namespace-first with nil first (Symbol.compareTo)
- misc: run! honors reduced, eval self-evaluates non-form values, intern
  demands an existing namespace, counted? excludes strings, seqable? includes
  arrays, shuffle rejects maps, sort-by rejects a collection comparator,
  when-let demands one binding pair, case*/deftype*/letfn*/reify*/& are
  special symbols

Two mis-certified corpus rows fixed (they threw on the JVM too and hid in the
tolerated bucket): a raw \d string escape and duplicate literal map keys.

SPEC.md gains the baseline-traceability section: every one of the 146
remaining suite failures maps to a documented divergence (integer-box,
no-single-float, RFC 0003 transients, seq/chunking model, stm-refs,
parse-uuid strictness, vec-array adoption). cts baseline 5955 -> 6042 pass,
5 errors, 30 namespaces. 9 JVM-certified corpus rows.
2026-07-02 13:52:59 -04:00
Dmitri Sotnikov
3fb8082802
Merge pull request #298 from jolt-lang/edn/strict-reader
Strict reader tokens; edn mode with the reference's error contracts
2026-07-02 17:22:54 +00:00
Yogthos
44d4875a24 Strict reader tokens; edn mode with the reference's error contracts
The reader now rejects what the JVM reader rejects: a token that starts
like a number but doesn't parse is NumberFormatException (1a, 08, 0x2g,
2r2 — never a symbol); ratio parts are digit runs (1/-1 invalid) with a
zero denominator throwing ArithmeticException; empty ns/name parts are
invalid tokens (:, ::, foo/, /foo) while /, ns//, and :/ stay valid;
duplicate map keys and set elements throw at read; unsupported string
escapes and octal escapes past \377 throw; a stray close delimiter is
'Unmatched delimiter'; \r ends line comments. #inst validates its
calendar fields progressively (leap years included) and #uuid demands
canonical hex. 1-arg symbol splits its ns at the FIRST slash
(Symbol.intern): (symbol "foo/bar/baz") is foo/"bar/baz".

clojure.edn gets its own strict seam (__read-form-edn): auto-resolved
keywords are invalid there, every #_ discarded form validates through the
same :readers/:default pipeline (an unreadable tagged element throws even
when discarded), built-in tags win over :default, M literals construct
BigDecimals, lists satisfy list?, and EOF honors :eof — an opts map
without :eof makes end-of-input an error.

clojure.edn-test.read-string goes 246 pass / 46 fail / 5 errors -> 297/0/0
(fully clean). cts baseline 5904 -> 5955 pass, 23 errors, 56 baselined
namespaces. 9 JVM-certified corpus rows; reader spec section.
2026-07-02 12:00:13 -04:00
Dmitri Sotnikov
95186a6782
Merge pull request #297 from jolt-lang/string/tostring-coercion
clojure.string toString coercion; some-fn/ifn? reference semantics; misc host gaps
2026-07-02 15:48:52 +00:00
Yogthos
e17bcfd0af clojure.string toString coercion; some-fn/ifn? reference semantics; misc host gaps
The clojure.string case fns and searches now take any Object s through its
toString like the reference's ^CharSequence signatures ((upper-case :kw) is
":KW", (capitalize 1) is "1"); nil throws, and a nil substr in
starts-with?/ends-with? throws. some-fn re-ported with the reference
arities: (some-fn) is an arity error and a no-match result is the last
predicate's own falsy value (false, not nil). ifn? covers multimethods,
promises (which are now invocable — calling one delivers, via a cold-path
invoke-arm registry that costs the hot dispatch nothing), and deftypes
implementing IFn's invoke.

One structural find on the way: defmulti/defmethod deferred inside a fn
body (the deftest pattern) interned/resolved in whatever namespace was
current when they RAN, not the one they were written in — the macros now
bake their expansion ns and the setups honor it.

Also: Boolean/Integer/Double wrapper ctors, primitive TYPE statics
(Integer/TYPE etc.), .reduce on collections (IReduce), and Long/TYPE.

cts baseline 5857 -> 5904 pass, 58 -> 28 errors, 57 baselined namespaces —
the string cluster, some-fn, ifn-qmark, boolean-qmark, and reduce
namespaces are all fully clean. 7 JVM-certified corpus rows; spec entry.
2026-07-02 11:38:37 -04:00
Dmitri Sotnikov
a9542077fc
Merge pull request #296 from jolt-lang/casts/checked-narrow
Checked narrow casts; fix runtime require in self-contained-built binaries
2026-07-02 13:52:34 +00:00
Yogthos
d0e1a11934 Checked narrow casts; fix runtime require in self-contained-built binaries
byte/short/int/long/char silently wrapped or passed out-of-range values
through; the JVM range-checks (RT.byteCast family). One checked-cast
helper now carries the ranges: a double range-checks ITSELF before
truncating ((byte 1.1) is 1, (byte 127.000001) throws), NaN casts to 0,
ratios and bigdecs truncate, a non-number is CCE, and the throw carries
the JVM message. float range-checks against Float/MAX_VALUE. The
unchecked-* casts now genuinely wrap and sign-fold ((unchecked-byte 200)
is -56 — the old bit-and lost the sign) with doubles saturating like
Java's conversions; unchecked-long/int are host natives. double/float of
a bigdec convert instead of crashing. The no-single-float residue stays
accepted (SPEC.md).

Also fixes #290: a binary built by the SELF-CONTAINED joltc died with
'variable var-deref is not bound' when a namespace loaded at runtime.
The in-process build compiled flat.ss against a clean copy-environment,
which orphans every top-level define in locations the binary's runtime
eval can't see. It now compiles against the default interaction
environment (defines land in the real symbol cells, same as the legacy
fresh-Chez path) and a generated prologue pre-binds each kernel name the
runtime redefines to its kernel value, so the earliest boot reads match
the legacy path's primitive references. requiring-resolve is implemented
(the issue's dynamic-require pattern), and the release workflow smokes a
runtime require in a built binary.

Cast namespaces byte/short/int/long/char now fully clean; cts baseline
5805 -> 5857 pass, 67 baselined namespaces. 7 JVM-certified corpus rows.
2026-07-02 09:42:06 -04:00
Dmitri Sotnikov
2610cb3ac3
Merge pull request #295 from jolt-lang/iref/watches-validators-meta
One IRef seam: watches/validators/meta over atom, var, and agent
2026-07-02 13:17:53 +00:00
Yogthos
f80f9aab4b One IRef seam: watches/validators/meta over atom, var, and agent
add-watch/remove-watch/set-validator!/get-validator were atom-only; the
atom ctor ignored :meta and :validator; watching a var crashed. Now the
ARef contract is one seam: atoms keep their record slots (hot path
unchanged), every other reference type registers a predicate and stores
watches/validators in identity-keyed side tables, and notifies at its
mutation points. Vars notify on root changes (def on a watched var,
var-set outside a thread binding, alter-var-root — thread-binding sets
don't notify, like the JVM); agents notify per action. The def-var! wrap
costs two weak-table probes per def and does IRef work only on a watched
var.

Ctor options follow ARef: the validator gates the initial value
(IllegalStateException 'Invalid reference state' — also the class for
rejected swap!/reset!), :meta must be a map (else ClassCastException),
nil allowed. meta reads any reference through the identity side-table
(the type-gated fall-through is gone); alter-meta!/reset-meta! work on
non-var references.

Runtime-only (no re-mint). 9 JVM-certified corpus rows; spec entry; cts
baseline 5781 -> 5805 pass, 73 baselined namespaces (the residual error
in the watch namespaces is their STM ref section — refs stay out of
scope).
2026-07-02 09:07:00 -04:00
Dmitri Sotnikov
257f822825
Merge pull request #294 from jolt-lang/hierarchy/reference-contracts
Hierarchy fns follow the reference contracts; deftype classes join the class graph
2026-07-02 12:58:33 +00:00
Yogthos
6e333b3020 Hierarchy fns follow the reference contracts; deftype classes join the class graph
derive/underive/ancestors/descendants/parents/isa? re-ported from
clojure.core with the argument assertions and throw contracts intact:
derive asserts tag/parent shapes (AssertionError) and throws on redundant
or cyclic derivation; underive/derive on a non-hierarchy value throw at the
parents lookup (the map is called as a function, like the reference);
(descendants h SomeClass) throws UnsupportedOperationException. isa? gains
the reference's supers arm (a relationship derived on a class's super
applies to the class).

The class arms now answer fully through the one class graph: parents of a
class are its direct supers (bases), ancestors are the transitive set
rooted at java.lang.Object for concrete classes (interfaces are marked and
don't root at Object, matching getSuperclass semantics). deftype/defrecord
classes register into the graph at definition — protocol interfaces they
implement appear as supers (JVM-munged ns spelling), records carry the
record interfaces (IRecord/IPersistentMap/... whose closure supplies
Associative/Seqable), bare deftypes carry IType. The type NAME var still
holds the ctor (a jolt-ism); class-key maps it back to the class so
(ancestors TypeName)/(isa? x TypeName) work. canonical-host-tag learned to
NOT canonicalize deftype names through the graph arm (extend-type on a
deftype was registering under the bare segment its values never report).

Five old corpus rows used non-namespaced derive tags that throw on the JVM
too; now namespaced. 8 new JVM-certified corpus rows; spec entries for the
hierarchy family; cts baseline 5730 -> 5781 pass (ancestors/derive/
descendants/parents/underive namespaces fully clean), 74 baselined
namespaces.
2026-07-02 08:48:30 -04:00
Dmitri Sotnikov
7e1df2c600
Merge pull request #293 from jolt-lang/numeric/ops-dispatch
Numbers-style category dispatch for binary numeric ops
2026-07-02 12:21:22 +00:00
Yogthos
e66a91750e Numbers-style category dispatch for binary numeric ops
Arithmetic and comparisons lowered to raw Chez ops, so an operand outside
Chez's tower (BigDecimal) crashed with a raw condition, and Chez contagion
leaked: (* 1.0 0) gave exact 0 where the JVM gives 0.0, (* ##Inf 0) gave 0
instead of ##NaN, (/ 1 0) raised an untyped error.

One seam now (host/chez/seq.ss): call position emits jolt-n* macros with the
both-Chez-numbers fast path open-coded; value position folds through the same
binary ops. Anything outside the tower falls to per-op slow hooks that
java/bigdec.ss extends, so bigdec arithmetic works in every position (the old
static-only :bigdec typing limitation is gone). JVM rules patched into the
fast path: a double operand wins, an exact zero divisor throws
ArithmeticException while a double zero divisor yields Inf/NaN, quot/rem/mod
cover ratios and doubles, min/max return the original operand with NaN
winning, a nil operand is NPE and a non-number CCE, zero-arg -// throw
ArityException at runtime instead of failing expansion.

Also: with-precision now binds *math-context* and bigdec results round with
real RoundingMode semantics (UNNECESSARY throws; division rounds to precision
instead of throwing); rationalize goes through the shortest decimal print
like BigDecimal.valueOf (the identity stub is gone); ratios coerce to bigdec
like Numbers.toBigDecimal; min/max int-literal operands no longer coerce to
flonum in the numeric pass.

Perf neutral: fib and seq benches unchanged (the fast path is two type checks
the optimizer folds); hinted fl/fx paths untouched. 19 JVM-certified corpus
rows; cts baseline 5614->5730 pass, 192->88 errors, 84->79 baselined
namespaces.
2026-07-02 06:41:45 -04:00
Dmitri Sotnikov
38abc1be84
Merge pull request #292 from jolt-lang/fix/are-clojure-template
clojure.test/are substitutes via clojure.template
2026-07-02 10:08:48 +00:00
Yogthos
86e36e8bee clojure.test/are substitutes via clojure.template
are let-bound its template vars, so a var inside quote never substituted:
(are [x] (special-symbol? 'x) if def) tested the literal symbol x twice.
Rebuild are on clojure.template/do-template (postwalk substitution), the
same architecture as upstream, with the same arg-count check.

This un-aborts every suite namespace whose are rows need substitution:
cts baseline moves 5302->5614 pass, 236->192 errors, 88->84 baselined
namespaces. The newly-reachable assertions also surface real divergences
now baselined and filed (edn reader strictness, Boolean ctor).
2026-07-02 05:57:57 -04:00
Dmitri Sotnikov
53a8aac2d0
Merge pull request #291 from jolt-lang/conformance/clojure-test-suite
Vendor clojure-test-suite as a standing gate (make cts)
2026-07-02 09:28:58 +00:00
Yogthos
edfd67a322 Vendor clojure-test-suite as a standing gate (make cts)
jank-lang/clojure-test-suite (per-core-fn clojure.test suites shared across
Clojure dialects) joins the default gate as vendor/clojure-test-suite, run by
host/chez/cts.sh: one joltc process per test namespace (a hang or crash is
contained by a per-process timeout), through the test/chez/cts-app project and
its cts-run runner, parallel workers.

Gating is exact per namespace against test/chez/cts-known-failures.txt, like
certify's allowlist: a namespace doing worse than the baseline fails, and one
doing better also fails as stale until the baseline is updated in the same
change. JOLT_CTS_WRITE_BASELINE=1 regenerates it; JOLT_CTS_NS runs a subset
verbosely.

Current standing: 243 namespaces, 5302 assertions pass, 340 fail + 236 error
across 88 namespaces pinned in the baseline (dominant clusters: BigDecimal
arithmetic operands, derive/ancestors hierarchy, transients, special-symbol?,
clojure.string case fns, the accepted narrow-int and seq-type-model
divergences). Two consecutive full runs produce identical counts. Wired into
make ci; skips cleanly when the submodule isn't checked out.
2026-07-02 03:46:57 -04:00
Yogthos
8ffc2f68c5 Fix general divergences surfaced by clojure-test-suite
Five fixes shaken out by running jank-lang/clojure-test-suite:

- = short-circuits on identity like Util.equiv's k1 == k2, so (= s s) on an
  infinite lazy seq answers true instead of walking forever. Numbers keep the
  exactness-aware arm ((= ##NaN ##NaN) stays false like the JVM's).
- Calling a non-fn names the operator's CLASS in the ClassCastException, like
  the JVM — never the value, whose printed form may be unbounded: ((range))
  must throw, not hang rendering an infinite seq.
- realized? on a seq cell answers by its forced flag (the rest of a realized
  lazy chain is a cseq under jolt's seq model), and the overlay's unsupported-
  type error names the class, not the (possibly infinite) value.
- clojure.test/is dispatches a REGISTERED assert-expr method before its by-name
  inline paths, like clojure.test where the built-ins are just pre-registered
  methods — so an alias-qualified p/thrown? (the suite's portability helper)
  isn't captured by the built-in thrown? path, which read its body as a class.
- clojure.test tracks tests and fixtures per namespace: deftest records its
  defining ns, use-fixtures registers under the calling ns (no more cross-ns
  clobbering), (run-tests 'ns ...) runs only those namespaces like clojure.test,
  and each run-tests call prints/returns its own summary (global counters stay
  cumulative for the n-pass/n-fail harness API).

Re-mint (20-coll.clj is seed; prelude only). +2 JVM-certified corpus rows;
the clojure-test fixture pins the alias-qualified assert-expr, per-call
summaries, and ns filtering.
2026-07-02 03:46:57 -04:00
Yogthos
51dec5fd2c Drop x86_64-macos from releases (GitHub retired the Intel runner)
The macos-13 Intel runner no longer gets allocated, so the x86_64-macos release
job queues forever. Ship prebuilt binaries for x86_64-linux and aarch64-macos;
Intel Macs build from source. The install script now says so instead of 404ing
on a missing asset.
2026-07-01 18:13:57 -04:00
Yogthos
eb768b13c1 docs: delist next.jdbc (JVM/JDBC-driver dependent)
next.jdbc's own source needs clojure.datafy + clojure.java.data and its tests
need JVM JDBC drivers, so it doesn't run on jolt. Keep clojure.jdbc (via
jolt-lang/db's jdbc.core over FFI SQLite) as the supported JDBC surface; point
migratus at jolt-lang/db.
2026-07-01 17:49:35 -04:00
Yogthos
802fb29b07 Link joltc with -rdynamic so build can spill its boots on Linux
The self-contained build reads the bundled Chez petite/scheme boots from the
joltc binary via foreign-entry on the embedded jolt_* symbols. On Linux dlsym
can't see an executable's symbols unless they're in the dynamic symbol table, so
'build' died with 'foreign-entry: no entry for jolt_petite_boot_len'. -rdynamic
exports them (macOS already resolves them). The new release self-contained-build
smoke caught this on the Linux runner.
2026-07-01 17:31:18 -04:00
Yogthos
db08ecc1bc Embed runtime source so a self-contained joltc can build apps
`joltc build` inlines the runtime (host/chez/rt.ss and everything it loads, the
seed, compile-eval, loader, ffi, the vendored irregex) into each app binary by
reading those files off disk. That works from a jolt checkout but not from the
installed self-contained binary, which has no source tree:

  joltc build -m app.core
  => Exception in call-with-input-file: failed for host/chez/rt.ss: no such file

build-joltc now bakes the exact transitive closure of files the build inlines
into the binary as embedded resources (keyed by the path the `(load "…")` forms
use), and build.ss/dce.ss read runtime source through bld-source-string, which
takes the embedded copy when present and falls back to disk otherwise. So the
same joltc builds apps both from a checkout and standalone.

The release workflow now smoke-tests a self-contained build (compile a tiny app
from an isolated dir, run it) — this is exactly what shipped broken, so it now
gates the release. buildsmoke/shakesmoke/staticnativesmoke unchanged and green.

Build tooling only — no re-mint, no runtime change.
2026-07-01 17:24:50 -04:00
Yogthos
f6bd2c6de5 readme: note the Homebrew install option 2026-07-01 16:52:02 -04:00
Yogthos
b460875772 Add an install script for the prebuilt joltc binary
install (root) downloads the self-contained joltc release asset for the host
platform, verifies its sha256, and drops the binary in /usr/local/bin (--dir /
--version override). Resolves the latest release via the GitHub API, clears the
macOS quarantine flag, and backs up an existing joltc. Modeled on babashka's
installer. README gets a one-line curl|bash install.
2026-07-01 16:38:43 -04:00
Yogthos
b5998f4b4a docs: register-class-supers! for library class hierarchies
Document the register-class-supers! seam next to the other host-class hooks:
when a library class belongs to a hierarchy (a custom exception caught as
IOException, a value matching instance? across its supertypes and dispatching a
protocol extended to any of them), declare its supers once and instance?/isa?/
supers/extend-protocol all derive.
2026-07-01 16:31:43 -04:00
Dmitri Sotnikov
21445375fa
Merge pull request #287 from jolt-lang/conformance/reader-literal-registry
Read an unknown #tag as a tagged-literal value
2026-07-01 20:24:52 +00:00
Dmitri Sotnikov
6500f968ce
Merge pull request #286 from jolt-lang/conformance/typed-throwables
Throw typed exceptions; one exception hierarchy
2026-07-01 20:24:16 +00:00
Dmitri Sotnikov
a59a32a0b0
Merge pull request #288 from jolt-lang/conformance/deftype-method-seam
Route deftype/reify interface dispatch through one seam
2026-07-01 20:23:26 +00:00
Dmitri Sotnikov
bd089f0845
Merge pull request #284 from jolt-lang/conformance/dispatch-arm-registry
Resolve .method calls through a priority arm registry
2026-07-01 20:20:54 +00:00
Yogthos
b4d9eaa527 Read an unknown #tag as a tagged-literal value
An unknown reader tag produced the reader's internal form
{:jolt/type :jolt/tagged :tag :#foo :form bar}, which tagged-literal? didn't
recognize and which leaked as a raw map when printed:

  (tagged-literal? (read-string "#foo bar"))  => false   ; want true
  (pr-str (quote [#foo bar]))                 => "[{:jolt/type :jolt/tagged ...}]"

Both the data path (rdr-construct-tag) and the compile path (emit-quoted) now
build a real tagged-literal for a tag with no registered reader, like Clojure's
*default-data-reader-fn*, so tagged-literal? / :tag / :form / printing all work.
clojure.edn reads raw forms through a separate __read-form-raw path and applies
:readers/:default itself, so it is unaffected.

Re-mint (backend + reader are seed sources); prelude byte-identical, image only.
make test green (selfhost holds, 0 new/stale), +2 unit rows.
2026-07-01 16:17:52 -04:00
Yogthos
f856c16f06 Throw typed exceptions; one exception hierarchy
jolt's own throw sites raised untyped Chez conditions with the class name buried
in an English message, so (class e) reported the opaque :object and only a broad
catch worked:

  (class (try (Long/parseLong "xyz") (catch Throwable e e)))  =>  :object
                                                              ; JVM: java.lang.NumberFormatException

Raise typed throwables (jolt-host-throwable) at the Long/Double parse and
StringTokenizer sites so (class e) / .getMessage / a specific catch all reflect
the real class. And fold the exception supertype table (exception-parent) into
the one class graph: exception-isa? now resolves the simple name to its graph key
and asks jch-isa?, so exceptions and every other class share a single hierarchy.

Runtime only, no re-mint. make test green (0 new/stale), +2 corpus rows.
2026-07-01 16:06:00 -04:00
Yogthos
01f98c2e89 Route deftype/reify interface dispatch through one seam
The "does value V declare method M; if so call it" decision was re-derived in a
dozen places with two different lookup helpers — records.ss jrec-cl and
collections.ss rec-coll-method were a byte-for-byte duplicate — and reduce only
honored a reify's own reduce method, not a deftype's:

  (reduce + 100 (->Rng 5))  ; Rng deftype implementing IReduceInit
  => "not seqable"          ; JVM: 110

Add iface-method / iface-call: one lookup that resolves a method for a deftype OR
a reify, with arity, and is the seam a core fn's interface arm collapses to.
jrec-cl now aliases rec-coll-method (the duplicate is gone). reduce routes its
IReduceInit arm through iface-method, so a deftype's reduce drives the reduction
like a reify's, reduced short-circuit included.

Runtime only, no re-mint. make test green (0 new/stale), +2 corpus rows.
2026-07-01 15:59:01 -04:00
Yogthos
0b07b376bb Resolve .method calls through a priority arm registry
record-method-dispatch was rebound with (set! record-method-dispatch ...) in six
files, each wrapping the previous binding, so precedence was whatever the rt.ss
load order happened to be — the true outermost arm was inst-time's Date arm, not
the one you'd guess. A type-gated wrapper that only whitelists its own methods
then errored on everything else, stealing universal Object methods from the arms
beneath it: (.getClass (java.util.Date.)) threw "No method getClass on Date",
same for File, while (class ...) and (.getClass "s") worked.

Replace the wrapper stack with an ordered list of arms (register-method-arm!,
ascending priority), each returning 'pass to defer. getClass is now one arm at
the top reached by every value, so it can't be shadowed; the three duplicate
getClass checks (dot-forms, host-static, base) collapse into it. Each former
wrapper is an arm at an explicit priority instead of an implicit load-order slot.
A library can register its own arm rather than set!-wrapping the dispatcher.

Runtime only, no re-mint. make test green (0 new/stale divergences), +1 corpus
row for getClass on Date/File.
2026-07-01 15:52:24 -04:00
Yogthos
d4acd69a73 Derive class identity from one hierarchy graph
instance?, extend-protocol dispatch, isa?/supers/ancestors, and the exception
hierarchy each read their own hand-kept table, and those tables had drifted:
(instance? clojure.lang.Associative [1 2]) was true but a protocol extended to
Associative wouldn't dispatch to a vector; keyword/IFn and seq/Seqable had the
same split; (isa? ExceptionInfo RuntimeException) was false and
(supers NumberFormatException) was empty.

Add one FQN -> direct-supers graph (class-hierarchy.ss) and derive the views
from it. value-host-tags builds on the graph closure so a vector reports
Associative/Indexed/ILookup/Counted/Seqable, a keyword reports IFn, a seq
reports Seqable/List/Counted, etc. instance? now tests membership in that same
list, so it can't disagree with dispatch. canonical-host-tag recognizes any
modeled class (was a separate literal set missing Seqable/ILookup/...).
class-direct-supers unions the graph edges and class-supers returns the
transitive closure, so the exception hierarchy answers isa?/supers/ancestors.

The graph is open: jolt.host/register-class-supers! lets a library graft its
own classes on and get every view for free.

Runtime only, no re-mint. make test green (0 new/stale divergences), +3
JVM-certified corpus rows.
2026-07-01 15:38:04 -04:00
Dmitri Sotnikov
d7dad2b450
Merge pull request #283 from jolt-lang/rewrite-clj-full-suite
Fix seven more JVM divergences (rewrite-clj full suite)
2026-07-01 18:35:14 +00:00
Dmitri Sotnikov
20d88324f4
Merge pull request #282 from jolt-lang/windows-sigint-fix
Don't abort startup on Windows resolving POSIX signal fns
2026-07-01 18:28:59 +00:00
Yogthos
cb03e36088 Don't abort startup on Windows resolving POSIX signal fns
joltc failed to start on Windows — "Exception in foreign-procedure: no entry for
pthread_sigmask". concurrency.ss resolves pthread_sigmask/sigemptyset/sigaddset at
load with a top-level (foreign-procedure …), which resolves its symbol eagerly;
those POSIX signal fns don't exist on Windows, so the whole runtime aborted.

Guard the three resolutions (like sched_yield/chmod already are) so a non-POSIX
host yields #f, and make jolt-set-sigint-blocked a no-op when they're unavailable.
The per-thread SIGINT mask is a POSIX-only optimization for the nREPL accept loop;
Windows delivers ^C through the console, and park-until-interrupt still parks on a
condition variable. macOS/Linux resolve the symbols as before — unchanged.
2026-07-01 14:23:19 -04:00
Yogthos
9bcac13fd2 Fix seven more JVM divergences (rewrite-clj full suite)
Running the whole rewrite-clj test suite (159 tests) surfaced seven more bugs;
with these it passes 3377/0/0. Each is a general jolt/JVM divergence:

- *out* was pinned to the startup stdout port, so (.write *out* …) escaped a
  with-out-str capture (z/print writes via *out*). It now resolves the live
  current-output-port, like print/__write, so a redirect is seen.
- nth / assoc past the end of a vector or seq threw a bare Chez error (class
  :object). Throw IndexOutOfBoundsException, matching the JVM.
- A number's .toString(radix) ignored the base. Render in the base, lowercase
  (rewrite-clj rebuilds 0xff / 0377 / 2r1001 through it).
- A required namespace's own :as aliases leaked into its requirer: the loaded ns
  form compiles while (chez-current-ns) is still the requirer, so ce-scan-requires!
  registered the loaded ns's aliases under the wrong ns and clobbered a same-named
  alias there. Register an (ns NAME …) form's aliases under NAME.
- A quoted collection dropped its metadata; now it keeps USER metadata (drops the
  reader's :line/:column/:file), like a Clojure quoted constant.
- enumeration-seq only did (seq e); it now drives a java.util.Enumeration through
  hasMoreElements/nextElement, and StringTokenizer implements them.

Regressions: corpus rows (with-out-str/*out*, nth/assoc bounds, toString radix,
quote metadata, enumeration-seq) certified against JVM; a smoke fixture for the
alias leak (a required ns's alias must not leak). tools.reader + rewrite-clj added
to docs/libraries.md. make test green.
2026-07-01 14:17:03 -04:00
Dmitri Sotnikov
53112d06fb
Merge pull request #281 from jolt-lang/irregex-submatch-clear
Compile capturing regexes with the backtracking matcher
2026-07-01 16:54:06 +00:00
Yogthos
7c4f9bb974 Compile capturing regexes with the backtracking matcher
irregex builds a POSIX leftmost-longest DFA for a pattern when it can, and jolt
used it for everything. For a pattern with an alternation whose branches have
capturing groups, that DFA leaks a non-participating branch's group: e.g.
#"(?:([0-9])|([0-9])r([0-9]+))" on "2r11" left group 1 = "2" instead of nil, so
tools.reader (rewrite-clj's dep) misread 2r1100 as 2 and 16rFF as 16.

java.util.regex is itself a leftmost-first backtracking engine, so compile a
capturing pattern with irregex's backtracking matcher ('backtrack): its submatch
semantics match the JVM and it clears a losing branch's group. Non-capturing
patterns keep the DFA — with no groups to read, its whole-match result is all a
caller sees, and it avoids backtracking's worst case. The submatch count comes
from a first cheap compile; a capturing pattern recompiles once and caches.

This clears the last rewrite-clj parser-test failure (now 772/0/0). Corpus rows
for the alternation-group case and the radix read. make test green.
2026-07-01 12:48:12 -04:00
Dmitri Sotnikov
e2d842b073
Merge pull request #280 from jolt-lang/rewrite-clj-conformance-fixes
Fix six JVM divergences surfaced by rewrite-clj
2026-07-01 16:31:06 +00:00
Yogthos
77e80dab9c Fix six JVM divergences surfaced by rewrite-clj
Running the rewrite-clj test suite under jolt exposed six bugs, each fixed here:

- `for`/`doseq` `:let` bindings never went through `destructure`, so a
  destructuring pattern (`:let [{:keys [y]} x]`) hit `let*` raw and failed to
  compile. Emit `let`, like Clojure.
- `with-open` couldn't close a deftype/defrecord that implements a `close` method
  (java.io.Closeable / AutoCloseable, e.g. tools.reader's readers) — `__close`
  only knew jhost readers and map `:close` fns. Dispatch a record's `close`.
- A deftype/defrecord method param named like a field didn't shadow the field
  (the field's let-binding wrapped the params). Params now shadow, as in Clojure.
- A deftype whose simple name collided with a built-in host class clobbered it in
  the global ctor table, so `(java.io.PushbackReader. …)` built tools.reader's
  same-named deftype. Register deftypes/built-ins by FQN, don't let a deftype
  overwrite a built-in's simple name, and qualify a bare `(Name. …)` to the
  deftype's FQN only in the ns that defined it.
- `clojure.walk` was lazy over a non-list seq (missing `doall`), so a walk whose
  fn has side effects read stale state. Make it eager, like Clojure.
- `Character/isWhitespace` used an ASCII-only check that missed U+2028 and other
  Unicode whitespace. Use the JVM's Unicode set (minus the no-break spaces it
  excludes).

Regressions: corpus rows (for-let destructure, method-param shadow, walk eager,
isWhitespace), a unit row (with-open closes a record), and smoke checks (the
class-name collision, run in a fresh -e process so the deftype doesn't leak).

One divergence remains unfixed: a submatch from a losing regex alternation branch
leaks when the winning branch has a quantified group (a bug in the vendored
irregex engine, not jolt) — tracked separately.
2026-07-01 12:25:05 -04:00
Dmitri Sotnikov
0bad467372
Merge pull request #279 from jolt-lang/data-reader-code-forms
Compile data readers that return code forms
2026-07-01 15:03:43 +00:00
Yogthos
908ad63caa Compile data readers that return code forms
A registered #tag data reader whose fn returns a FORM (borkdude/html's #html
expands to (->Html (str …))) was rewritten to a runtime call (reader-fn 'inner),
so the returned code became a runtime list value instead of being compiled —
(str #html [:div]) rendered the code, not "<div>". Clojure applies a data reader
at read time and substitutes its result as code.

loader.ss now applies the reader at load time: a code form (a list) is spliced in
to be compiled, a value (time-literals #time/date -> a Date) keeps the runtime
call, which also keeps a non-serializable constant out of an AOT build. The build
emit path never applied data readers at all (a #tag literal failed a `jolt build`
with "unsupported form"); emit-image.ss gets an ei-emit-form-hook the build sets
to the same rewrite, left as a no-op elsewhere so the seed mint (which doesn't
load loader.ss) is unaffected and the self-host byte-fixpoint holds.

Also make clojure.test report the actual values of a failing (is (= a b)) — it
printed only the form. Restricted to the common pure predicates so a macro head
still takes the plain path.

Fixture test/chez/datareader-app + a smoke check (interpreted) and a build-smoke
check (AOT). make test green, no corpus change.
2026-07-01 10:57:55 -04:00
Dmitri Sotnikov
1008e922d8
Merge pull request #278 from jolt-lang/dynamic-c-linking
Static-link :jolt/native C libraries into built binaries by default
2026-07-01 13:57:40 +00:00
Yogthos
d79ad6dc6a Static-link :jolt/native C libraries into built binaries by default
A :jolt/native spec can now carry a :static archive; `jolt build` links it
into the executable, so the app calls the C code with no shared object on the
target. --dynamic (or :jolt/build {:dynamic-natives true}) keeps the old
runtime load-shared-object behavior; a spec with no :static is unchanged.

The cc link force-loads the archive (-force_load on macOS, --whole-archive on
Linux) and exports the executable's symbols (-rdynamic on Linux) so the baked-in
symbols resolve via (load-shared-object #f) + foreign-procedure at startup. Build
step 1 evaluates the app's foreign-procedure forms in-process, so a static
archive is preloaded there as a throwaway shared object to resolve them.

The distributed self-contained joltc has no external cc/Chez but must build these
apps, so it now bundles the Chez kernel (libkernel.a + scheme.h) and the launcher
source and re-links a custom stub with the archives baked in — needing only a
system cc, no Chez. run/repl skip static-only specs (nothing to load); keep a
:darwin/:linux candidate to use such a lib interpreted.

Adds static-native-smoke (cc path) to ci and a static phase to the joltc
self-build smoke (distributed path).
2026-07-01 09:52:00 -04:00
Dmitri Sotnikov
a2e99fff45
Merge pull request #277 from jolt-lang/improved-error-handling
Make the REPL read multi-line forms and render real error messages
2026-07-01 04:16:36 +00:00
Yogthos
e4cbbb8912 fix REPL treating a regex literal as an unbalanced form
repl-form-complete? entered the :regex state on '#' but only consumed the
'#', so the opening '"' was then read by the :regex handler as the CLOSING
quote. The regex body got scanned in :code state, and any delimiter or quote
inside it (a group like #"(a)", a char class #"[0-9]+") threw off the
paren/string count — so a one-line regex form was judged incomplete and the
REPL hung waiting for continuation lines. Consume the '#"' together.

Adds a self-checking predicate test (test/chez/repl-reader-test.clj, run via
joltc so jolt.main resolves) and an end-to-end regex REPL case in smoke.sh.
2026-06-30 23:44:22 -04:00
Yogthos
4889505204 fix corpus crash on 'replace on a seq is lazy'
The :expected was a bare list "(0 :a 2)", but run-corpus evals :expected as
source, so it applied 0 as a fn -> "0 cannot be cast to IFn". Every other
list-valued :expected is self-evaluating; this one slipped in unquoted.
Vectorize it to [0 :a 2], matching what regen-corpus.clj produces.
2026-06-30 23:24:47 -04:00
Yogthos
f625099ddf fix clojure.core/max shadowed by a local 2026-06-30 23:05:04 -04:00
Yogthos
4a1dec277e fix tests 2026-06-30 21:25:33 -04:00
Yogthos
240458d994 Make the REPL read multi-line forms and render real error messages
The REPL evaluated one line at a time, so a form split across lines
(e.g. `(+` then `1 2)`) raised instead of waiting. The read loop now
accumulates lines until delimiters are balanced — skipping string,
char, regex and comment context — printing a `... ` continuation prompt
for each extra line.

Reader/runtime errors rendered as Chez's "attempt to apply
non-procedure #[chez-pmap...]" instead of their real message. Two causes:

jolt-throw raised the thrown value raw. When a throw crossed the host
`eval` boundary, Chez re-wrapped the non-condition into a compound
condition whose message extraction applies the value, losing the message
and crashing on ex-info's empty-map :data. jolt-throw now raises a
&jolt-throw condition wrapping the value; catch (lowered to `guard`),
jolt-report-uncaught and jolt-render-throwable unwrap it back via
jolt-unwrap-throw, so ex-data/ex-message and the backtrace tag survive.

Every reader/post-prelude EOF-throw site used `(empty-pmap)` (with
parens), applying the empty-map value as a procedure and crashing during
ex-info construction before jolt-throw ran. Fixed to `empty-pmap`.

Re-minted the seed; smoke 23/23, unit 574/574.
2026-06-30 20:36:06 -04:00
Dmitri Sotnikov
a58bca3bee
Merge pull request #276 from jolt-lang/clean-nrepl-exit
Fix nREPL server ^C shutdown crash
2026-06-30 23:15:35 +00:00
Yogthos
8c7553fe55 update readme 2026-06-30 19:14:53 -04:00
Yogthos
46c9c7b4d9 Fix nREPL server ^C shutdown crash
^C to a running `joltc --nrepl-server` aborted with "thread does not
own mutex" because the accept-loop thread absorbed SIGINT in its foreign
accept() call, where Chez can't run the keyboard-interrupt handler, and
run-main-pump's tight condition-wait loop wasn't interruptible anyway.

Block SIGINT in the primordial thread before starting the server so the
accept loop inherits a blocked mask, park in a single interruptible
condition-wait via the new park-until-interrupt, and run registered
shutdown hooks (newest-first, each isolated) from the keyboard-interrupt
handler before (exit 0). The stop fn now drops .nrepl-port via the new
jolt.host/delete-file seam — clojure.java.io/delete-file doesn't exist
in Jolt and silently no-ops, so .nrepl-port was never removed.
2026-06-30 19:08:13 -04:00
Yogthos
8c2bd60257 cleanup 2026-06-30 17:14:44 -04:00
Dmitri Sotnikov
7275eb54a5
Merge pull request #275 from jolt-lang/repl-quit-command
Add :repl/quit and :exit gestures to the REPL
2026-06-30 19:10:16 +00:00
Yogthos
649e33fe3b Add :repl/quit and :exit gestures to the REPL
^D (EOF) exits cleanly in canonical mode but some terminals and editors
don't deliver it, leaving the user stuck. Accepting :repl/quit or :exit
as the first form of a line gives a reliable keyword exit that works
everywhere. The check parses the line with read-string rather than
checking the evaluated value, so a nested value that happens to print
as the keyword can't trigger an exit.
2026-06-30 14:33:26 -04:00
Dmitri Sotnikov
9e53ba4248
Merge pull request #274 from jolt-lang/clojure-lift
Clojure lift
2026-06-30 15:24:41 +00:00
Yogthos
bbca8bc0de Migrate list?/ratio?/rational? to the overlay; narrow jolt.host exposure
list?, ratio?, and rational? are the predicate-web members that are
genuinely safe to migrate: not extended at runtime, not on the compiler
emit/inference path, not reached by the kernel tier. They now live in the
overlay (clojure/core/20-coll.clj) built on the jolt.host tower/rep tests,
lowering to the same code the native shims did. Removed their native
definitions (predicates.ss) and, for ratio?/rational?, the now-redundant
post-prelude re-assertions. Also dropped the dead all-flonum overlay
ratio?/rational?/decimal? stubs.

The rest of the web stays native and is documented as such: map?/set?/
seq?/coll? are extended with sorted/record/lazy arms, decimal? is extended
by the optional bigdec module, integer?/float? are on the emit/inference
path, vector? is reached by the kernel-tier peek. jolt.host exposure is
therefore narrowed to just the tests these three consume (exact?,
rational-type?, cseq?, cseq-list?, empty-list?).

Numeric probe is byte-identical to pre-migration; list? correct across
list/vector/lazy/empty/cons/rest cases. Selfhost fixpoint holds, values/
unit/smoke/corpus green, bench flat within noise.
2026-06-30 11:10:36 -04:00
Yogthos
12058d2dcf Expose raw host type-test primitives under jolt.host
The clojure.core type predicates bottom out at host tests that overlay
Clojure can't reach. Expose them under jolt.host so the predicate web can
be built as pure compositions that lower to exactly these calls:

  numeric tower: exact? flonum? integer-type? rational-type?
  collection reps: pvec? pmap? pset? cseq? empty-list? cseq-list? lazyseq?

exact? is wrapped to be total (Chez's raw exact? errors on a non-number;
the others return #f for a non-match). lazyseq? is exposed in
lazy-bridge.ss because jolt-lazyseq? is defined there, after predicates.ss.

map?/set?/seq? are deliberately not reduced to a single rep test: they are
extended at runtime with sorted-collection/record/lazy arms, so only the
rep predicates are exposed, not those unions. Additive only (new bindings,
nothing references them yet); bench unchanged within noise.
2026-06-30 10:58:44 -04:00
Yogthos
1481a806b7 Document why reader-conditional stays a native shim
Attempting to migrate the reader-conditional constructor to the overlay
revealed that an overlay defn returning a :jolt/type-tagged map literal
silently fails to bind during the seed mint: the guard around each
prelude form swallows the load-time error, leaving the var unbound. This
is the same reason every other tagged-value constructor (atom,
volatile!, tagged-literal) is native, so reader-conditional is
reclassified STAY-PRIMITIVE rather than a safe migration.
2026-06-30 10:42:49 -04:00
Yogthos
d77b4e6420 Migrate clojure.core/set from a native shim to the kernel overlay tier
set was a native shim (apply jolt-hash-set (seq->list coll)). It is a
pure composition, so the Clojure version (apply hash-set (seq coll))
lowers to the same code. The compiler uses set, but only off the emit
path (the backend's bare-native-names def and type inference), so it can
live in the kernel tier: compiling that tier never calls set, and by the
time those callers run the tier is already bound.

This is distinct from boolean, which the backend calls for every :if
node on the emit path. Moving boolean even to the kernel tier deadlocks
(compiling the tier that defines boolean needs boolean), so boolean stays
native. Added a comment in predicates.ss recording that.

Re-mint converges in 3 passes and the benchmark suite is unchanged
within noise (collections 43.3 vs 43.1, binary-trees 367 vs 367, the
rest flat).
2026-06-30 10:35:57 -04:00
Yogthos
3d0cbed3c5 Remove dead native transduce shim (overlay already provides it)
The overlay defines transduce in clojure/core/22-coll.clj as a pure
composition (xf (reduce xf init coll)), and it shadows the native
jolt-transduce by load order. The compiled overlay version is already
what gets baked into the seed, so the native binding in
natives-transduce.ss was dead weight.

transduce is not used by the self-hosted compiler and no overlay tier
before 22-coll references it, so removing the native binding is safe.
Re-minting produces a byte-identical seed, which proves the runtime is
unchanged. sequence stays native (its transformer iterator drives the
reduced box and lazy realization directly).
2026-06-30 10:27:27 -04:00
Dmitri Sotnikov
7f163faf2e
Merge pull request #273 from jolt-lang/proper-chunking
Chunk range/map/filter to match JVM Clojure
2026-06-30 02:09:29 +00:00
Yogthos
bd33d605ef Chunk range/map/filter to match JVM Clojure
range, map, and filter were fully element-by-element lazy, so
(map f (range 1 50)) realized one element per first/nth where JVM
Clojure realizes a whole 32-element chunk. range is a chunked
LongRange on the JVM and map/filter are chunk-preserving, so the
observable side-effect timing differed.

Following clojure.lang.LongRange, ChunkedCons, ChunkBuffer and
core.clj, this adds a crest field to the cseq record and a
cseq-chunked constructor modeling ChunkedCons (a standalone chunk
pvec, an offset, and the after-chunk seq). The chunk accessors move
to seq.ss next to the representation they read. map/filter/remove
take a chunked branch when the source is chunked, realizing the whole
chunk and chunk-cons'ing it onto a lazy rest, so their output is
itself chunked and chained transforms each batch by 32. Bounded range
is now an eager chunked seq, and the reduce fast path flows through a
ChunkedCons rest. The chunk-buffer/chunk/chunk-cons builder API in
natives-array.ss now produces a real ChunkedCons.

Single-arg (range), multi-coll map, and plain lazy seqs stay
element-by-element, like the JVM.

Adds a lazy / chunking suite to the corpus that observes realization
timing via an atom counter: first over a chunked map realizes 32,
crossing a chunk boundary realizes 49, chained maps batch [32 32],
filter applies the predicate to the whole first block, and a plain
lazy seq still realizes one element at a time. Two cases that
documented the old over-laziness now assert the JVM value of 32 and
were dropped from the allowlist. certify against JVM Clojure 1.12.3
reports 0 new and 0 stale divergences.
2026-06-29 22:02:06 -04:00
Dmitri Sotnikov
c0a0ec98ee
Merge pull request #272 from jolt-lang/feature/self-contained-joltc
Self-contained joltc binary + release workflow
2026-06-30 01:25:23 +00:00
Yogthos
df4653e57f Add release workflow: build joltc binaries on a v* tag
On a pushed v* tag, build the self-contained joltc (make joltc-release) for
x86_64-linux, x86_64-macos, and aarch64-macos, package each as a tar.gz plus a
SHA256, and attach them to the GitHub Release. Linux builds Chez from source like
tests.yml (the apt package lacks the kernel dev files build-joltc cc-links
against); macOS uses Homebrew chezscheme, which ships chez and the csv kernel
files. No notarization, matching dirge — macOS tarball users de-quarantine once
or install via a Homebrew tap.

The Homebrew tap update job is a separate follow-on; this covers building and
publishing the release assets.
2026-06-29 21:16:26 -04:00
Yogthos
242eeac5c6 Build joltc as a self-contained binary (make joltc-release / joltc-debug)
host/chez/build-joltc.ss builds joltc into target/<profile>/joltc: it emits a
flat source of the full runtime + compiler image + inlined build.ss + every
jolt-core/stdlib file as a baked string literal + a cli.ss-style launcher, then
(in a fresh Chez, so the inlined runtime's redefinition of error doesn't strand
early references and runtime eval still sees the runtime's top-level procedures)
compiles it and cc-links it with the Chez petite/scheme boots and the launcher
stub embedded as C arrays. The launcher reads those arrays via FFI on
(jolt-materialize-bundles!) and registers them so build-self-contained can spill
them. joltc itself is cc-linked (clean signature for Homebrew); only the apps it
later builds use the appended-stub path.

build.ss: skip the csv toolchain check on the self-contained path and create the
build dir with a subprocess-free bld-mkdir-p, so a  from the
distributed binary shells out to nothing.

release = optimize-level 3 + no inspector info + compressed; debug =
optimize-level 0 + inspector + procedure source + debug-on-exception.

joltc-selfbuild-smoke.sh (make joltcsmoke) builds joltc and, with an empty
environment (no chez/cc/PATH), drives it through the build-app fixture, asserting
the produced binary's output. .gitignore ignores target/.
2026-06-29 21:04:23 -04:00
Yogthos
0420cd4d79 Self-contained build foundation: embedded-bytes helpers, launcher stub, in-process app link
Adds the pieces a toolchain-free joltc needs to compile apps with no external
Chez or cc:

- host/chez/java/io.ss: register-embedded-bytes!/jolt-embedded-bytes,
  read-file-bytes, jolt-spill-embedded!, jolt-append-payload! (frames an app
  boot onto the stub as [stub][boot][len:le64]["JOLTBOOT"]), and jolt-chmod-755
  via load-shared-object #f (no subprocess).
- host/chez/stub/launcher.c: a native stub that locates its own executable,
  reads the trailing frame, and hands the appended boot to the Chez kernel.
- host/chez/loader.ss: resolve-on-roots consults the embedded source store before
  disk; ldr-read-source reads baked source. Dev (empty store) is unaffected.
- host/chez/build.ss: build-binary step 4 splits into build-self-contained
  (in-process compile-file/make-boot-file with the system error restored, then
  append the boot to a copy of the embedded stub) and build-with-cc (the existing
  dev path). The self-contained path is taken only when the stub is embedded.

The legacy cc path is unchanged behaviorally; make buildsmoke still passes.
2026-06-29 20:48:44 -04:00
Yogthos
0abb958955 Merge fix/chunked-seq-stub-comment: correct the chunked-seq? stub comment 2026-06-29 14:36:25 -04:00
Yogthos
f82568281e Correct the misleading chunked-seq? stub comment
The overlay comment claimed Jolt has no chunked seqs and that chunked-seq?
is always false. That is no longer true: a vector's seq is a real chunked
seq, and post-prelude.ss rebinds chunked-seq? to na-chunked-seq?, which
returns true for a vector seq. The defn here is only a placeholder so
references compile during overlay load. Updated the comment to say so.
2026-06-29 14:33:31 -04:00
Dmitri Sotnikov
2a8783649e
Merge pull request #271 from jolt-lang/fix/nrepl-startup-and-shutdown
nREPL: surface startup failures and close the listen socket on shutdown
2026-06-29 18:17:26 +00:00
Dmitri Sotnikov
baf78c63bd
Merge pull request #270 from jolt-lang/fix/graceful-main-pump-shutdown
Make main-pump shutdown graceful and stop-main-pump race-free
2026-06-29 18:17:24 +00:00
Yogthos
ad5affe89f nREPL: surface startup failures and close the listen socket on shutdown
Two pre-existing issues in the nrepl command, exposed when #269 moved the accept
loop into a future.

jolt.nrepl/start was invoked inside (future ...), so binding the socket happened
on a background thread. A bind failure such as the port already being in use was
captured into a future that nothing derefs and silently swallowed, leaving the
main thread parked in run-main-pump forever with no server and no error. start
now binds the socket synchronously before returning, so that failure propagates
to the caller and the process exits with a visible message. Only the blocking
accept loop runs on a worker thread.

There was also no shutdown path: the accept loop ran forever and the listen
socket was never closed. start now returns a stop fn that breaks the accept
loop, closes the socket to free the port, and removes .nrepl-port. main.clj runs
run-main-pump and then calls the stop fn, so a stop-main-pump (from a glimmer app
on quit, or from nrepl-evaluated code) shuts the server down cleanly and the
process exits.
2026-06-29 14:09:05 -04:00
Yogthos
e76816d9fc Reset main-pump active flag and make stop-main-pump work race-free
PR #269 added the main-thread executor (call-on-main-thread, run-main-pump,
stop-main-pump) so the nREPL accept loop can run on a worker thread while the
primordial thread owns the GUI main loop. Two problems made stop-main-pump
unusable as a graceful-shutdown or external API.

run-main-pump set jolt-main-pump-active to #t on entry but never cleared it on
exit, so after the pump returned the flag stayed #t. call-on-main-thread also
read that flag outside the queue mutex, so even with a reset there was a window
where a job could be enqueued just as the pump left, then block forever on a
pump that was gone.

Both are now decided under jolt-main-queue-mu. The pump clears active in the
same critical section where it sees the stop flag and an empty queue, and
call-on-main-thread reads active and enqueues atomically under that lock. A
caller that loses the race sees the pump inactive and runs the thunk inline,
the same fallback used when no pump is running, rather than blocking. A
dynamic-wind around the loop also clears active on an abnormal exit so a later
run-main-pump starts clean.
2026-06-29 13:49:50 -04:00
Dmitri Sotnikov
d21feba486
Merge pull request #269 from jolt-lang/nrepl-thread
update nrepl to run in a thread
2026-06-29 03:33:30 +00:00
Yogthos
8bba526c8c update nrepl to run in a thread 2026-06-28 20:02:56 -04:00
Dmitri Sotnikov
28ee005855
Merge pull request #268 from jolt-lang/cli/nrepl-server-flag
cli: rename nrepl command to --nrepl-server flag
2026-06-28 21:33:21 +00:00
Dmitri Sotnikov
4b29594eff
Merge pull request #267 from jolt-lang/docs/bench-arith-numbers
bench: document 64-bit arithmetic + generator numbers vs JVM
2026-06-28 21:33:02 +00:00
Yogthos
823bc5bcc6 cli: rename nrepl command to --nrepl-server flag
Match babashka's spelling: the nREPL server now starts with
`bin/joltc --nrepl-server [port]` instead of `bin/joltc nrepl`. Port
parsing and JOLT_NREPL_PORT are unchanged.

Also wire up --help/-h to print usage (previously only the no-arg
invocation did), and fix the usage listing to show the real flag.
Smoke now asserts --help mentions --nrepl-server. Docs updated to match.
2026-06-28 17:26:03 -04:00
Yogthos
ba58d7ec85 bench: document 64-bit arithmetic + generator numbers vs JVM
The AOT suite doesn't cover 64-bit integer arithmetic (Chez fixnums are 61-bit,
so genuine 64-bit values are bignums) — the SplitMix PRNG behind test.check is
the worst case. Add the measured jolt-vs-JVM numbers for the PRNG/mix-64 and the
generator workload: the bitwise native-ops + var-cell caching took mix-64 from
~18x to ~3.2x JVM and the PRNG from ~30x to ~12x; the residual is the open-world
generator dispatch/allocation and the bignum floor, not arithmetic.
2026-06-28 15:39:17 -04:00
Dmitri Sotnikov
1375a59568
Merge pull request #266 from jolt-lang/conformance/laziness-semantics
Conformance hardening + perf: seq semantics, chunked-seq O(n^2), bitwise/var-cache codegen
2026-06-28 16:40:50 +00:00
Yogthos
04180c1e4e backend: cache resolved var cells per reference site (run-path ~5x)
Profiling jolt-i5if showed <=60-bit arithmetic is already native-fast; the real
general overhead in the run/-e/-m path is var resolution. Every var reference
compiled to (var-deref ns name), which builds + hashes a fresh "ns/name" string
and does a hashtable lookup per access (~45ns). The var cell is interned and
def-var! mutates it in place, so caching the resolved cell is sound under
redefinition.

Generalize the devirt per-site cache-cell mechanism to var value references: a
ref inside a fn resolves its cell once into the def's closure, then reads it via
var-cell-deref (a field read after the first). var-cell-deref is the cell-based
var-deref — binding-aware (dynamic vars + *ns* still resolve) and lenient on an
unbound root (a forward-declared var doesn't throw, unlike jolt-var-get).

Gated by a runtime flag: ON for runtime-compiled code (compile-eval.ss), OFF for
the seed mint and AOT build (emit-image.ss) so the seed stays a byte-fixpoint --
prelude.ss is unchanged, only image.ss picks up the new backend. ~5x on a
var-ref-heavy loop (1058ms->205ms); ~1.2x on test.check (its generators are more
deftype/dispatch-bound than var-deref-bound). No C/FFI.

Corpus rows pin redefinition / dynamic binding / forward ref through a cached
ref. make test + shakesmoke green, selfhost holds, SCI 211/218, certify 0-new.
2026-06-28 12:36:35 -04:00
Yogthos
f17b68ccfe backend: emit bitwise ops as native ops (test.check PRNG ~2.4x)
Profiling the test.check distribution/large-sample slowness (jolt-i5if): the
hot path is the SplitMix PRNG, dominated by 64-bit mix arithmetic, and the
bitwise ops (bit-and/or/xor/not, shifts) were NOT in the backend native-ops
table — so (bit-xor a b) compiled to a var-deref through the variadic overlay
(__bit-xor) instead of a direct call, the way +/-/* already emit.

Map bit-and/or/xor/not to the Chez bitwise-and/ior/xor/not primitives (inlined
to native code; a non-integer operand now errors like the JVM instead of being
silently truncated) and the shifts to a direct helper call. bit-and-not stays on
its overlay — its only Scheme impl is 2-arg, so a value-position arity-3 use
would mis-emit.

mix-64 arithmetic 2.7x faster, raw split+rand-long 2.4x, gen/vector ~1.4x. The
remaining gap is the bignum-vs-native-long floor (~20x, substrate) plus the
generator machinery (deftype/fn dispatch, separate). Corpus rows added for value
position, bit-not, apply, and a full-64-bit unsigned shift.
2026-06-28 11:25:52 -04:00
Yogthos
b5ea06c5c2 clojure.test: assert-expr / do-report / report extension points
jolt's `is` was a fixed macro with no assert-expr multimethod, and the runner
bypassed the report multimethod, so libraries couldn't register custom
assertions or custom report types (e.g. test.check's ::trial/::shrunk).

Add assert-expr (2-arg [msg form], dispatch on the form's first symbol /
:default / :always-fail), do-report routing through report, and report
:pass/:fail/:error methods that feed the counters. `is` dispatches to an
explicitly-registered assert-expr method before its inline path, so thrown?/
thrown-with-msg?/= and every built-in form stay byte-identical.

Runtime stdlib only, no re-mint. test/chez/clojure-test.clj self-checks the
extension points + full is/are/testing/thrown?/use-fixtures surface; smoke gate
runs it.
2026-06-28 10:37:59 -04:00
Yogthos
4a72897dfd conformance: document narrow-int unification (byte/short/int -> Long)
jolt unifies every integer as one exact-integer type, so (byte/short/int n)
report Long not Byte/Short/Integer and instance? Byte is false. Confirmed
substrate-inherent: (byte 5) is a Chez immediate identical? to 5 (nothing to
tag, numbers carry no metadata), and arithmetic compiles to a raw Chez + that a
boxed narrow type would crash. Value/arithmetic/equality are correct.

Certify the value-correctness (= to plain int, arithmetic promotes, is a Number)
and pin the class/instance? divergence under a new :integer-box-model category.
Data/doc only.
2026-06-28 10:28:10 -04:00
Yogthos
59cfa5f53f conformance: audit + pin seq semantics (laziness, eagerness, chunking, type)
A 62-case jolt-vs-JVM probe across seq type identity, chunking
granularity, eagerness, and realization timing. Findings: the whole
producer family is lazy at construction (no eager bugs remain), and the
26 divergences fall into two classes that diverge by representation, not
value.

Lock in the laziness contract as certified corpus rows: construction=0
for keep/keep-indexed/map-indexed/distinct/partition-by/partition-all/
interpose/interleave/take-nth/reductions/tree-seq/replace, sequence
realizes 1, next realizes 2, rest realizes 1.

Pin the two accepted divergence classes (allowlisted, gate-guarded):
- seq-type-model: jolt reifies seqs as PersistentList/LazySeq vs JVM's
  Cons/Iterate/LongRange/Repeat/Cycle/ChunkedSeq/StringSeq/KeySeq/RSeq/
  ArraySeq/SubVector (jolt-aei7)
- chunking-model: unchunked, realizes one where JVM realizes a 32-chunk;
  mapcat/dedupe fully lazy at construction (jolt-mm6v)

known-divergences.edn gains both categories; SPEC.md documents the seq
semantics contract. Data/doc only, no re-mint. certify 0 new / 0 stale.
2026-06-28 03:22:47 -04:00
Yogthos
6d441e2d00 chunk-first: pull the trie leaf instead of flattening the whole vector
A pvec is a 32-way trie, but na-chunk-first built each block by calling
pvec-v on the full backing vector — materializing all n elements to a
flat Scheme vector — then copying the 32-wide window out of it. That made
chunk-first O(n), so walking a vector chunk-by-chunk (Clojure's real
chunked map/filter fast path) was O(n^2): a ported chunked map over 500K
elements took 39s, superlinear to ~700s at 2M.

na-chunk-size equals pv-width and blocks are 32-aligned, so a block is
exactly one trie leaf — pv-chunk-for hands it back in O(log n). Copy that
leaf directly; fall back to per-index reads for the rare window that
crosses a leaf boundary. Chunked map is now linear, ~133x faster at 500K
(293ms) and within ~2.3x of the native seq loop, which makes a
clojure-in-clojure seq tier viable.

Corpus rows pin chunk-first window contents + chunk-rest boundaries
against JVM; fixed a stale 'always false' chunked-seq? label.
2026-06-28 01:56:26 -04:00
Yogthos
6940b2c7f5 corpus: certify seq realization order, count, and memoization
The corpus compares values, so eager-vs-lazy was invisible (identical
values). Add rows that reduce laziness to a value via a side-effect
counter: realization order (map/filter left-to-right), exact realization
count under take/nth/drop (no over-realization), and lazy-seq
memoization (realize-once across repeated walks). Sourced through
unchunked producers (iterate, lists) so jolt's unchunked model matches
the JVM. All certify against Clojure 1.12.5.
2026-06-28 01:40:51 -04:00
Dmitri Sotnikov
83ff96c3c8
Merge pull request #265 from jolt-lang/conformance/lazy-map
seq fns are lazy by default (LazySeq), like Clojure
2026-06-28 05:31:25 +00:00
Dmitri Sotnikov
f921e97c90
Merge pull request #264 from jolt-lang/numeric/unchecked-ratio
unchecked arithmetic: ratio correctness + in-range fast path
2026-06-28 05:30:59 +00:00
Yogthos
b879430618 seq fns are lazy by default, like Clojure (LazySeq, not eager-headed)
map/filter/remove/take/drop/concat/take-while/drop-while/mapcat/partition
built an eager-headed cseq: the first element (and the fn application) ran
at construction, so a side-effecting (map f coll) fired f immediately and
(class (map …)) was PersistentList instead of LazySeq. This diverged from
Clojure, which wraps the whole body in lazy-seq. It went unnoticed because
the conformance gate certifies values, not realization — eager and lazy
heads produce identical values — and unit.edn even baked PersistentList in
as expected. test.check's for-all-takes-multiple-expressions (which counts
side effects in a for-all body) exposed it.

Wrap each native producer's result in a lazy-seq node so the body, incl.
the first element, defers until forced — the forced cseq still has eager
heads, so reduce/count/dorun/etc. force on walk and there's no per-element
cost. dedupe's (seq coll) is moved inside its lazy-seq. A jolt LazySeq is
now recognized by coll?/empty, the analyzer's form predicates (a macro can
build its expansion with map), value-host-tags + instance? (LazySeq/ISeq/
Sequential), and reports clojure.lang.LazySeq.

Kept the native Scheme implementations rather than porting Clojure's: a
straight lazy-seq+cons port is 3x slower and Clojure's chunked fast path is
288x slower because jolt's chunk machinery is unoptimized (filed jolt-j9dz);
the wrapped natives are Clojure-lazy at native speed.

+12 corpus rows (laziness at construction, LazySeq type, both JVM-certified).
make test + shakesmoke green, selfhost holds, 0 new divergences.
2026-06-28 00:16:47 -04:00
Yogthos
a49ca3b5ea jolt-wrap64 fast path: skip the mask when already in signed-64 range
Chez fixnums are 61-bit, so the bignum bitwise-and mask allocates for any
value past 2^60 — and unchecked-* ran it on every result, even small
in-range ones. An exact integer already in [-2^63, 2^63) is its own wrap,
so return it directly; only an out-of-range result (a multiply overflowing
into 128 bits) needs the mask. ~30% on in-range unchecked-add loops,
neutral on full-64-bit multiply.

Note: the 64-bit arithmetic floor on Chez stays ~31ns/multiply (bignum, no
native 64-bit int); the test.check distribution hangs are dominated by
generator/dispatch overhead, not arithmetic — this is a general win for
long-heavy code, not a fix for those.
2026-06-27 23:12:16 -04:00
Yogthos
253d64b1e7 unchecked-* on a ratio (or any non-long) shouldn't wrap to 64-bit
jolt-unc{add,sub,mul,inc,dec,neg}2 wrapped every non-flonum result to a
signed 64-bit integer, so (unchecked-add 2/3 2/3) truncated to 1 instead
of 4/3. Under *unchecked-math* the analyzer rewrites +/-/* to unchecked-*,
so any ratio arithmetic in such a file silently floored. Clojure's
unchecked-add falls back to regular arithmetic for non-primitives; only
long math wraps. Wrap iff both operands are exact integers.

Shaken out by test.check's gen/ratio monoid property (the + and 0 monoid
held for small-integers but failed for ratios).
2026-06-27 22:49:42 -04:00
Dmitri Sotnikov
92368b49f1
Merge pull request #263 from jolt-lang/conformance/spec-alpha
spec.alpha: symbol-of-var, demunge, MultiFn methods, fn class names, namespaced maps
2026-06-28 02:01:27 +00:00
Dmitri Sotnikov
c75d698815
Merge pull request #262 from jolt-lang/conformance/test-check
test.check generators: unchecked-math/rand-double, ThreadLocal proxy, and host interop
2026-06-28 02:01:02 +00:00
Yogthos
522ff10d62 spec.alpha: reify ILookup get, NPE/CCE, quoted #inst/#uuid, anon-fn class, kwargs map
Close clojure.spec.alpha's remaining gaps — its conform/explain/describe/multi-spec
suite (clojure.test-clojure.spec, multi-spec) now passes fully.

- (get reify k) / (:k reify) routes to a reify's clojure.lang.ILookup valAt. spec
  reifies fspec/regex specs as ILookup and reads (:args spec) off them, so before
  this instrument never saw the args spec.
- A failed numeric comparison reports the JVM class: a nil operand is
  NullPointerException, a non-number is ClassCastException (was an opaque :object
  condition). conform-explain checks the thrown class.
- A quoted / macro-form #inst / #uuid literal constructs its Date/UUID value, like
  the JVM reader (which builds it at read time). emit-quoted was emitting the raw
  tagged form, so #inst "1939" and #inst "1939-01-01T00:00:00.000-00:00" weren't =.
- An anonymous fn reports class clojure.lang.AFunction$fn (the $fn marker), so
  spec's fn-sym returns ::s/unknown for it, matching the JVM's ns$fn__N.
- A fn with & {:as m} kwargs accepts a trailing map (Clojure 1.11): (f :a 1 {:b 2})
  and (f {:a 1}) both bind m, by merging an odd trailing map over the pairs.
- A thread responds to .getStackTrace (empty — jolt does TCO).

clojure.test-clojure.instr does not fully pass: its ::caller assertions need the
calling fn's stack frame, which TCO erases (an inherent host divergence, like the
JVM keeping tail frames).

make test green (+4 corpus rows, 0 new divergences), shakesmoke byte-identical.
Re-mint (backend emit-quoted + the destructure macro).
2026-06-27 21:56:04 -04:00
Yogthos
219d1e52c9 reader: #:ns{...} namespaced map literals
jolt's reader had no case for #: , so #:event{:type :search} died as an unknown
tagged literal. Now #:ns{...} qualifies each bare keyword/symbol key with ns
(:_/x stays unqualified, an already-qualified key is left alone); #::{...} uses
the current ns and #::alias{...} resolves the alias — matching Clojure.

clojure.spec.alpha's multi-spec test (which builds #:event{...} event maps) now
passes.

make test green (+1 corpus row, 0 new divergences), shakesmoke byte-identical.
One re-mint (the reader is a seed source).
2026-06-27 21:12:27 -04:00
Yogthos
0becba7f93 A fn def'd into a var reports a JVM-style class name (clojure.core$odd_QMARK_)
jolt fns reported (class f) = clojure.lang.IFn, so they carried no defining
symbol — clojure.spec.alpha's fn-sym (which reads a fn's class name to recover its
symbol) produced garbage, so explain-data's :pred for a bare-fn predicate was `/`
instead of e.g. clojure.core/keyword?.

Now def-var! records proc -> (ns . name) (first def of a proc wins, so an alias
like (def inc' inc) doesn't rename inc), and jolt-class-name returns "ns$munged"
for a known fn — matching the JVM, where (class odd?) is clojure.core$odd_QMARK_.
A munged fn class's ancestors include clojure.lang.AFunction's hierarchy
(IFn/AFn/Fn/Runnable/Callable), so (ancestors (class f)) still holds. Anonymous /
unregistered fns stay clojure.lang.IFn (fn-sym yields :unknown, as on the JVM).

This fixes explain-data / s/form / s/describe of bare-fn predicates in
clojure.spec.alpha (and unblocks parts of its suite + test.check's reporter test).

make test green (+1 corpus row, the (type inc) unit row updated to the JVM value),
shakesmoke byte-identical, runtime only (no re-mint).
2026-06-27 21:03:12 -04:00
Yogthos
10592fa746 drop (symbol var) corpus row — certify harness mis-evals (var ...); value is correct 2026-06-27 20:48:53 -04:00
Yogthos
48908f3a9b spec.alpha: (symbol var), Compiler/demunge, MultiFn .dispatchFn/.getMethod, fn .applyTo
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).
2026-06-27 20:46:33 -04:00
Yogthos
4d61145e9c proxy [ThreadLocal] via thread-parameter; clojure.test/*testing-vars*
- (proxy [ThreadLocal] [] (initialValue [] body)) now builds a real per-thread
  store backed by a Chez thread-parameter, with a lazy initialValue; .get/.set/
  .remove work. Other proxies stay nil. test.check's no-seed PRNG (next-rng) uses
  one, so gen/sample and gen/generate (and everything built on them) now work.
- clojure.test/*testing-vars* (+ *report-counters*) are bound vars now, so a
  defspec run through its :test metadata / default reporter doesn't hit an unbound
  var.

make test green (+1 corpus row), shakesmoke byte-identical. One re-mint (proxy).
2026-06-27 19:51:49 -04:00
Yogthos
f32bd335e3 test.check generators: rand-double, take +Inf, UUID/Long/shiftLeft, transient
More general fixes from clojure.test.check's own suite.

- *unchecked-math* on doubles: unchecked-* only wrap integer math; on a flonum
  operand they're an ordinary float op (Clojure: (unchecked-multiply 1.5 2.0) =>
  3.0). test.check's rand-double is (* double-unit shifted) under *unchecked-math*
  and was truncating to a long 0, so every distribution-driven generator (choose,
  vector, …) collapsed to its lower bound.
- (take Double/POSITIVE_INFINITY coll) takes the whole coll instead of throwing
  on the infinite count coercion (rose-tree unchunk relies on it).
- (java.util.UUID. msb lsb) 2-long constructor (the uuid generator), formatted as
  the canonical lowercase 8-4-4-4-12 string; (Long. n) constructor; BigInteger
  .shiftLeft / .shiftRight (size-bounded-bigint); number methods now receive args.
- A transient (ITransientSet) responds to .contains / .valAt / .count
  (distinct-collection generators).

make test green (+3 corpus rows, 0 new divergences), runtime only (no re-mint).
2026-06-27 19:08:34 -04:00
Yogthos
992fc0af34 *unchecked-math* on macro-emitted arithmetic + local shadowing a bare native op
Two general fixes shaken out by clojure.test.check's own suite (its splittable
PRNG mixes 64-bit longs and binds locals named min/max).

- *unchecked-math* now wraps arithmetic a macro emits. The analyzer rewrote a
  bare (+/-/*) to its wrapping unchecked-* under *unchecked-math*, but a macro's
  syntax-quote produces clojure.core/* (qualified), which was skipped — so e.g.
  test.check's mix-64 multiply grew to a bignum instead of a 64-bit long. The
  rewrite now also fires on the clojure.core-qualified form.
- A local binding named like a bare-emitted native op no longer shadows it. ops
  where native-ops maps the name to itself (+ - * / < > min max …) emit as the
  bare Scheme name; a local `max` emitted the same token, so
  (fn [max] (clojure.core/max …)) called the param. munge-name now prefixes such
  locals, like reserved words (derived from native-ops so they can't drift).

make test green (+1 corpus row, 0 new divergences), shakesmoke byte-identical.
One re-mint (analyzer + backend).
2026-06-27 18:19:14 -04:00
Dmitri Sotnikov
75652de1ad
Merge pull request #261 from jolt-lang/conformance/algo-monads
algo.monads: a seq reports IPersistentList for protocol dispatch
2026-06-27 21:43:15 +00:00
Yogthos
d38402eb57 algo.monads: a seq reports IPersistentList for protocol dispatch
algo.monads' writer monad extends a protocol to clojure.lang.IPersistentList,
but jolt's lists only reported ASeq/ISeq in value-host-tags, so writer-m-add
didn't dispatch ("No method writer-m-add"). jolt models every seq as a list (no
distinct LazySeq — (class (map inc xs)) is PersistentList), so a seq now also
reports PersistentList / IPersistentList / IPersistentStack, in value-host-tags
and host-type-set. extend-protocol clojure.lang.IPersistentList then dispatches
on a list.

algo.monads passes its whole suite (11/11) over tools.macro. Listed in docs +
site. Runtime only, no re-mint. make test green (+1 corpus row, 0 new
divergences), shakesmoke byte-identical.
2026-06-27 17:38:48 -04:00
Dmitri Sotnikov
65cf6ac3d4
Merge pull request #260 from jolt-lang/conformance/letfn-star
letfn is a macro over a letfn* special form (Clojure semantics)
2026-06-27 21:30:58 +00:00
Yogthos
21cd88deee letfn is a macro over a letfn* special form (Clojure semantics)
jolt modelled letfn as a special form directly, so (macroexpand-1 '(letfn …))
returned the form unchanged. Clojure's letfn is a macro that expands to letfn*,
and macroexpansion tooling (tools.macro, tools.analyzer) depends on that — its
special-form handlers key on letfn*, not letfn.

Split it the Clojure way:
- letfn* is now the special form (analyzer), taking flat name/fn-form pairs
  [name1 fn1 name2 fn2 …] — the letrec :let lowering is unchanged.
- letfn is a macro (00-syntax) turning each (name [params] body*) spec into a
  name + (fn name [params] body*) binding, so it expands to letfn*.

So (macroexpand-1 '(letfn [(f [x] x)] (f 1))) now yields
(letfn* [f (fn f [x] x)] (f 1)), and clojure.tools.macro passes its whole suite
(macrolet / symbol-macrolet / mexpand-all). Listed in docs + site.

make test green (+1 corpus row, 0 new divergences), shakesmoke byte-identical.
One re-mint (analyzer + the letfn macro); selfhost holds.
2026-06-27 17:26:18 -04:00
Dmitri Sotnikov
7891fa0d55
Merge pull request #259 from jolt-lang/conformance/ns-vector-clauses
ns: accept vector reference clauses; add Compiler/specials
2026-06-27 21:14:01 +00:00
Yogthos
192ef66e7e ns: accept vector reference clauses; add Compiler/specials
Two general fixes shaken out by clojure/tools.macro.

- The ns macro now accepts a vector reference clause [:require …] / [:use …],
  not just the list form (:require …). Clojure dispatches on (first clause) and
  accepts both; jolt silently dropped vector clauses, so a ns written with them
  loaded with nothing required/used (tools.macro's test ns uses [:use …]).
- clojure.lang.Compiler/specials is now a static whose keys are the special-form
  symbols (matching Clojure 1.2/1.3). Macroexpansion tooling reads
  (keys Compiler/specials) to know which heads not to expand.

tools.macro itself isn't fully passing yet — its mexpand-all works, but the
macrolet/symbol-macrolet tests need letfn to macroexpand to letfn* (jolt models
letfn as a special form, not a macro over letfn*), so it stays off the list.

make test green (+1 corpus row, 0 new divergences), shakesmoke byte-identical.
One re-mint (the ns macro).
2026-06-27 17:08:50 -04:00
Dmitri Sotnikov
1ba79aa223
Merge pull request #258 from jolt-lang/conformance/data-priority-map
data.priority-map: deftype interop fixes (rseq, arity-overload, empty, Sorted)
2026-06-27 20:52:54 +00:00
Yogthos
75f6bc79d1 data.priority-map: deftype interop fixes (rseq, arity-overload, empty, Sorted)
data.priority-map's whole suite passes (4/4). It leans on deftype/collection
interop jolt got wrong; four general fixes:

- rseq dispatches to a deftype's clojure.lang.Reversible.rseq method instead of
  always demanding a vector/sorted-coll (natives-seq.ss).
- a deftype method declared at two arities from two interfaces now dispatches by
  arity: the priority-map has seq[this] (Seqable) and seq[this ascending]
  (Sorted), so (.seq pm false) must reach the 2-arg one. find-method-any-protocol
  now matches the call's arg count via procedure-arity-mask, and a deftype's own
  declared method wins over the generic collection interop in dot-forms.
- (empty x) on a deftype/record with its own empty method uses it rather than
  returning {} (jolt.host/jrec-method? gate in clojure.core/empty).
- clojure.lang.Sorted (comparator / entryKey / seqFrom) works on jolt's
  sorted-map/set, so subseq/rsubseq run — including the priority-map delegating
  .comparator to its backing sorted-map (dot-forms.ss + host-static.ss).

Listed in docs/libraries.md + the site. One re-mint (clojure.core/empty);
everything else runtime. make test green (0 new divergences), shakesmoke
byte-identical.
2026-06-27 16:48:14 -04:00
Dmitri Sotnikov
8a4df7b204
Merge pull request #257 from jolt-lang/numeric/unchecked-math-wrap
Long compatibility: *unchecked-math* wrapping + ^long is 64-bit (unblocks test.check)
2026-06-27 20:10:07 +00:00
Yogthos
3340635714 ^long is a 64-bit long: fast-path-with-fallback ops + logical unsigned shift
Completes the JVM long-compatibility gap so clojure.test.check (and the
property-based suites built on it, e.g. data.codec) run on jolt.

A ^long is 64-bit but a Chez fixnum is only 61-bit, so the backend's fast fx
comparison / quot / min / max / inc / dec ops raised on a full-width long (one
from the PRNG or wrapping arithmetic). They now go through the jolt-l* macros
(host/chez/seq.ss): the fx fast path when the operands ARE fixnums, the generic
op otherwise — so e.g. ((fn [^long a ^long b] (< a b)) Long/MAX 1) is false, not
an error. Arithmetic +/-/* keep the raw fx ops (under *unchecked-math* they're
already the wrapping unchecked-*).

Also fixes unsigned-bit-shift-right: it was an arithmetic (sign-propagating)
shift, now a logical shift over the 64-bit two's-complement window, so
(unsigned-bit-shift-right -1 1) is 2^63-1 like the JVM.

Result: test.check 1.1.3 loads and runs (generators, quick-check, shrinking);
data.codec's base64 property suite passes (12/12 defspecs; the 2 deftests check
clojure.lang.IFn$OLLOL, a JVM primitive-fn interface, N/A). Both added to
docs/libraries.md + the site.

re-mint (backend/seed). make test green (+3 corpus rows, 0 new divergences,
numeric gate updated to the jolt-l* ops), shakesmoke byte-identical.
2026-06-27 16:04:19 -04:00
Yogthos
a028cab04f Unchecked / *unchecked-math* arithmetic wraps to signed 64-bit
clojure.core's unchecked-* (and +/-/*/inc/dec under *unchecked-math*) are long
ops that WRAP on overflow; jolt's checked arithmetic is arbitrary-precision and
its unchecked-* were plain non-wrapping (+ x y), diverging from the JVM. Now they
truncate to the low 64 bits as a signed long, matching Clojure:

  (unchecked-add 9223372036854775807 1)        => -9223372036854775808
  (unchecked-multiply 9223372036854775807 …)   => 1

- host/chez/seq.ss: jolt-wrap64 + binary jolt-unc{add,sub,mul,inc,dec,neg}2 and
  the variadic clojure.core/unchecked-* fns (def-var!'d in natives-seq.ss, where
  def-var! is bound). The overlay's plain unchecked-* defns are removed.
- backend lng-ops: unchecked-+/-/* emit the wrapping jolt-unc* helpers (the
  raising fx ops can't wrap on Chez's 61-bit fixnums); unchecked-inc/dec too.
- *unchecked-math* is honored: the analyzer reads it (jolt.host/unchecked-math?)
  and rewrites +/-/*/inc/dec to their unchecked-* for the rest of a file that
  (set!)s it, like the JVM.
- jolt->fx: a ^long value that overflows the 61-bit fixnum range passes through
  as an exact integer instead of erroring (a full-width long from wrapping math).

Also adds Long/bitCount / numberOfLeadingZeros / reverse and Math/getExponent /
scalb (test.check's splittable PRNG uses them).

This lets clojure.test.check load and run quick-check on jolt. re-mint (analyzer/
backend/overlay are seed sources). make test green (+6 corpus rows, 0 new
divergences, numeric gate updated), shakesmoke byte-identical.
2026-06-27 15:41:35 -04:00
Dmitri Sotnikov
86dd9650b6
Merge pull request #256 from jolt-lang/conformance/tools-reader
conformance: general fixes from tools.reader, core.contracts, data.zip, data.csv (+ math.combinatorics)
2026-06-27 19:06:19 +00:00
Yogthos
44837f01ab data.csv: fully passes, three general fixes
clojure.data.csv runs its whole suite on jolt (4/4 reading/writing/eof/line-
endings). Three general gaps fixed, all runtime, no re-mint, JVM-certified:

- The prefix-list form of :require/:use — (:require (clojure [string :as str]))
  means clojure.string :as str — now expands (loader.ss). It silently failed
  before, trying to load a "clojure" namespace.
- extend-protocol to java.io.Reader / Writer / StringReader / PushbackReader now
  dispatches: those reader/writer host tags carry the right class names in
  value-host-tags AND are in host-type-set, so extend-protocol registers under
  the canonical tag instead of a local ns tag (records.ss). data.csv's
  Read-CSV-From protocol extends to String / Reader / PushbackReader.
- (str StringWriter) returns its accumulated content (register-str-render for the
  "writer" jhost), not the opaque host object — data.csv writes CSV to one and
  reads it back.

Listed in docs/libraries.md + the site.

make test green (+2 corpus rows, 0 new divergences), shakesmoke byte-identical.
2026-06-27 15:02:32 -04:00
Yogthos
745d22260f data.zip: add clojure.zip/xml-zip; clojure.xml lives in jolt-lang/xml
clojure.zip was missing xml-zip — a zipper over xml {:tag :content} elements,
which clojure.data.zip and any xml-zipper code needs. Added (runtime, loaded on
require). clojure.data.zip's whole xml suite (9/9) then passes, once XML parsing
is provided: clojure.xml/parse now ships in jolt-lang/xml over its
javax.xml.stream pull parser (committed there).

Listed in docs/libraries.md + the site.
2026-06-27 14:49:49 -04:00
Yogthos
a83ff6ce40 core.contracts: fully passes, two general fixes
clojure.core.contracts (over core.unify) now runs its whole suite on jolt —
14/14 across contracts/constraints/with-constraints/provide tests. Two general
gaps fixed:

- Symbol and Keyword now report IFn (and Fn/Runnable/Callable) in the modeled
  class hierarchy, so a (class x)-dispatched multimethod with an IFn method
  matches a symbol or keyword, like the JVM (both implement IFn — they're
  callable). core.contracts' funcify* dispatches on (class constraint) and a
  bare predicate symbol must hit the IFn arm. Runtime, no re-mint.
- A live Var value spliced into a form by a macro (defcurry-from resolves a var
  and emits (~v l r)) now compiles: analyze treats a var-cell form as a
  :the-var reference by ns+name, the same node as (var ns/name), mirroring the
  existing spliced-namespace (~*ns*) case. analyzer.clj + host-contract.ss,
  re-mint (prelude stays byte-identical; only the analyzer image changes).

Listed in docs/libraries.md + the site.

make test green (+2 corpus rows, 0 new divergences), shakesmoke byte-identical.
2026-06-27 14:32:57 -04:00
Yogthos
2c5b7dd918 libraries: add math.combinatorics
Its full suite (18 deftests) passes on jolt unchanged — pure Clojure over
seqs, no host interop.
2026-06-27 14:18:05 -04:00
Yogthos
e16085402b General fixes shaken out by clojure/tools.reader
Running clojure.tools.reader's own suite on jolt surfaced a batch of general
gaps (all runtime, JVM-certified, no re-mint — reader.ss is loaded at runtime
and jolt-core has no octal literals, so selfhost holds):

Reader:
- (load "rel") resolves a non-/ path against the current namespace's directory,
  like Clojure — (load "common_tests") from clojure.tools.reader-test loads
  clojure/tools/common_tests.clj. Was resolved against the roots directly.
- Octal integer literals: 042 reads as 34, not decimal 42; octal string escapes
  (\377 is one char, not \0 + "00"). \oNNN char octal already worked.
- (symbol nil name) now equals (symbol name) and the reader literal — a nil
  namespace is the #f no-ns sentinel, not jolt-nil (jolt= compares ns by equal?).

clojure.test:
- thrown-with-msg? honors the class hierarchy (instance?) before falling back to
  a simple-name match, so (thrown-with-msg? RuntimeException ...) matches an
  ExceptionInfo, like thrown? already did.

Host interop (java layer):
- java.util.regex: Pattern.matcher / Matcher.matches / .group / .groupCount /
  .find, and Pattern/compile.
- clojure.lang: RT/map, PersistentList/create, PersistentHashSet/createWithCheck.
- java.lang.Character: digit / isDigit / isWhitespace / valueOf.
- java.util.LinkedList (Deque surface over the ArrayList backing); ArrayList /
  LinkedList are now seqable.
- BigInteger 2-arg ctor (string, radix) + .negate / .bitLength / .signum / .abs;
  BigInt/fromBigInteger and Numbers/reduceBigInt (identity on jolt's exact ints).

Suite: reader_test 22/30, reader-edn_test 13/16. The remaining failures are
fundamental numeric-model differences (no BigDecimal type; BigInt and Long are
one exact-integer type) or need JVM reflection (record/ctor tagged literals via
getConstructors) — out of scope.

make test green (+8 corpus rows, 0 new divergences), shakesmoke byte-identical.
2026-06-27 14:11:02 -04:00
Dmitri Sotnikov
850a84c272
Merge pull request #255 from jolt-lang/conformance/core-typed
core.typed runtime contracts: instance? Object + Compiler/LINE
2026-06-27 17:37:18 +00:00
Yogthos
720734a481 Two general fixes shaken out by core.typed's runtime contract suite
Running clojure.core.typed's runtime contract tests (typed/runtime.jvm,
test_contract — 5/5 pass) surfaced two general jolt gaps, both runtime, both
JVM-certified:

- instance? Object / java.lang.Object returned false for everything. Object is
  the root of the type hierarchy: every non-nil value is an instance of Object,
  nil is not. core.typed's (instance-c Object) contract depends on this; many
  libraries do.
- @Compiler/LINE and @Compiler/COLUMN (clojure.lang.Compiler statics — Vars on
  the JVM holding the line/column of the form being compiled) were unresolved.
  Macros read @Compiler/LINE as a fallback when &form carries no position. Now
  backed by derefable cells updated per top-level form, like *current-source*.

The core.typed type checker itself (tools.analyzer.jvm + ASM bytecode +
clojure.lang.Compiler internals) and the cljs runtime are not portable, so the
checker/check-ns surface is out of scope; this is the runtime contract layer.

make test green (+4 corpus rows, 0 new divergences), shakesmoke byte-identical.
2026-06-27 13:33:30 -04:00
Dmitri Sotnikov
9805620997
Merge pull request #254 from jolt-lang/license/epl-2.0
Relicense under EPL-2.0
2026-06-27 17:21:02 +00:00
Yogthos
5c99ff8c79 Relicense under EPL-2.0
EPL-1.0 is superseded by EPL-2.0 (clearer jurisdiction/patent terms). Updates
the LICENSE file and README. Clojure-derived files under stdlib/ and the
vendored sci keep their original EPL-1.0 headers per the weak-copyleft terms.

Closes #206
2026-06-27 13:17:19 -04:00
Dmitri Sotnikov
c479010536
Merge pull request #253 from jolt-lang/conformance/core-async
core.async: higher-level API over native channels + general fixes
2026-06-27 17:09:20 +00:00
Yogthos
4cf95dc27c core.async: higher-level API over native channels + two general fixes
Adds clojure.core.async's higher-level dataflow API as a Clojure overlay
(stdlib/clojure/core/async.clj) over jolt's native channel primitives, plus
clojure.core.async.lab. The native layer (host/chez/java/async.ss) gains
offer!/poll!, put specs and :priority/:default in alts!, a transducer
ex-handler arg to chan, unblocking-buffer?, promise-buffer, and on-caller?
handling for put!/take!. The overlay covers alts!/pipe/pipeline/split/
reduce/transduce/into/take/mult/mix/pub-sub/map/merge/onto-chan/to-chan and
the deprecated map</map>/filter>/... family (rewritten as go-loops since the
JVM versions reify the impl handler protocol jolt doesn't expose).

Loading: the native primitives pre-seed clojure.core.async, so the loader now
drops it from the loaded set and a require pulls the overlay from the source
roots like clojure.test (AOT-bundled into built binaries).

Running clojure/core.async's own suite shook out two general bugs:
- :refer with a list form, (:require [ns :refer (a b c)]), dropped the names
  (only the vector form was handled) — chez-register-spec! now accepts both.
- (range 0) / (range 5 5) returned nil instead of the empty seq () — empty
  ranges now match Clojure, so (= () (range 0)) holds.

Suite: async_test 15/20, pipeline_test 7/7, timers_test 2/2, lab_test 2/2.
The five non-passing async_test cases all assert JVM go-machine limitations
jolt's thread-based model is a superset of (the 1024 pending-op cap, parking
ops that must throw outside a go block, expanding-transducer buffer
backpressure) or dispatch-thread identity, not data semantics.

make test green (0 new divergences, +4 range corpus rows), shakesmoke
byte-identical.
2026-06-27 13:05:19 -04:00
Dmitri Sotnikov
4007af8d6a
Merge pull request #252 from jolt-lang/conformance/core-logic-fd
core.logic fd + &env: instance? boundary, ~ unquote, macro &form/&env
2026-06-27 16:06:04 +00:00
Yogthos
438742702a Macros receive &form and &env
A macro body can now read &form (the call form) and &env (a map of the in-scope
local symbols), like Clojure. This is what core.logic's matche/defne use to tell
a pattern symbol that names an enclosing local from a fresh pattern var — so
locals-membero and the recursive checko in `matches` now compute correctly. The
suite reaches 535/2/0 (the last two are constraint reification ORDER, where the
constraint set is right but it is spliced from a set whose iteration order differs
from the JVM — a host set-ordering divergence, not a bug).

&form/&env are clojure.core dynamic vars bound around each expander call rather
than prepended params, so the macro calling convention is unchanged and the mint
stays consistent (the seed prelude is byte-identical; only the analyzer carries
the env into form-expand-1). macroexpand-1 passes an empty env.

corpus.edn: the ~@ unquote row is now a boolean compare (a bare clojure.core/
unquote-splicing symbol evaluates to an unbound var, not the symbol).
2026-06-27 11:54:47 -04:00
Yogthos
f46772d576 fd subsystem: instance? name-boundary + ~ reads as clojure.core/unquote
Two general fixes that clear core.logic's finite-domain -difference, safefd, and
the defne quoted-list patterns (form->ast), taking the suite to 532/5/0.

- instance? on a deftype matched a simple type name against the qualified tag by
  raw string suffix, so "a.b.MultiIntervalFD" tested true for IntervalFD. The
  suffix must land on a "." boundary. core.logic's fd dispatches on
  (interval? x) = (instance? IntervalFD x), and a MultiIntervalFD wrongly counted
  as an interval, so -difference/safefd computed the wrong set.
- the reader reads ~ / ~@ as clojure.core/unquote(-splicing), like the JVM reader,
  instead of a bare unquote. Code that inspects quoted pattern/template data —
  core.logic's defne checks (= f 'clojure.core/unquote) — now sees the symbol it
  expects, so '(fn ~args . ~body) patterns compile. hc-head-is? accepts the
  qualified head in syntax-quote lowering; the value-preserving change leaves the
  minted seed byte-identical.

corpus.edn: 2 JVM-certified unquote rows. unit.edn: two reader rows updated to the
qualified unquote. make test + shakesmoke green, 0 new divergences, self-host holds.
2026-06-27 11:22:01 -04:00
Dmitri Sotnikov
42c163bacb
Merge pull request #251 from jolt-lang/conformance/core-logic-clp
core.logic constraint layer: CLP/unifier fixes
2026-06-27 15:07:32 +00:00
Yogthos
580e3a1407 A defrecord exposes its clojure.lang interfaces for protocol dispatch
value-host-tags returned only ("Object") for a record, so a protocol extended to
clojure.lang.IRecord / IPersistentMap / Associative / Seqable / … (and not to the
record's own type) dispatched to the Object default. core.logic extends IWalkTerm
to IRecord, and walking a record value hit Object's (walk-term [v f] (f v)) — which
re-enters walk* and loops forever (the test-53-lossy-records hang).

A defrecord now carries the map/record interface tags it genuinely satisfies. The
record's own type is still tried first (jrec-tag, before these tags), so a direct
extend to the record type wins, and record equality / map? / record? are unchanged.
A bare deftype stays opaque (its tag + Object; declared interfaces dispatch via its
inline methods). Runtime only, no re-mint.
2026-06-27 10:57:37 -04:00
Yogthos
5411db3729 Track :refer-clojure :exclude so syntax-quote qualifies an excluded name to the current ns
A name a namespace excludes from clojure.core (:refer-clojure :exclude) is not
clojure.core/name even before the ns defines its own — syntax-quote must qualify
it to the current ns, like Clojure. refer-clojure was a no-op, so a syntax-quoted
excluded name (core.logic.fd's `==`, referenced by a constraint's -rator before fd
defines ==) resolved to clojure.core/==.

jolt-refer-clojure now records the :exclude set per ns; hc-sq-symbol consults it
before falling back to clojure.core. Fixes core.logic's fd constraint -rator names.
Runtime only, no re-mint.
2026-06-27 10:46:52 -04:00
Yogthos
e6aa2aace7 core.logic constraint layer: fixes for the CLP/unifier failures
Follow-on to the core.logic relational-engine work. These clear every crash in
core.logic's constraint-logic-programming and unifier layers (33 errors -> 0) and
most of the value mismatches; the suite goes 504 -> 523 passing assertions. All
are general gaps, not core.logic-specific.

- symbols intern their ns/name strings (JVM Symbol.intern .intern()s them): two
  separately-read `?a` symbols now share one name-string object. core.logic's
  non-unique lvars compare names by identity (via (str sym)), so without this a
  term's lvar and a constraint's lvar built from different `?a` reads never matched
  and constraints silently never fired.
- (str x) of a single arg returns its rendering directly instead of copying through
  string-append, and a symbol stringifies to its (interned) name — JVM (str x) is
  x.toString(). Needed for the identity comparison above.
- a clojure.core-qualified special form dispatches correctly: syntax-quote
  namespace-qualifies a macro like letfn to clojure.core/letfn (matching Clojure,
  where it's a macro), and the analyzer now maps that back to the special form
  instead of treating it as an invoke of a nil var. core.logic's fnc/defnc emit
  (clojure.core/letfn ...). Re-mint.
- (disj nil ...) is nil (JVM), instead of crashing in the set path — core.logic's
  constraint store does (disj (get km v) id) where the get can be nil.

corpus.edn: 4 JVM-certified rows. make test + shakesmoke green, 0 new divergences,
self-host fixpoint holds.
2026-06-27 10:37:32 -04:00
Dmitri Sotnikov
36105ba702
Merge pull request #250 from jolt-lang/conformance/core-logic
General fixes shaken out by running core.logic
2026-06-27 14:00:15 +00:00
Yogthos
9dbfd7e5c1 General fixes shaken out by running core.logic's test suite
Running clojure/core.logic's own suite surfaced a batch of general jolt gaps.
None are core.logic-specific; each is a language/host behavior that was wrong or
missing. With these, the core relational engine (unify, run/fresh/conde,
conso/membero/appendo, reification to _0/_1, lcons) runs; the remaining failures
are in core.logic's constraint-logic-programming and finite-domain layers
(tracked separately).

- analyzer: accept the list-member dot form (. target (method args)), sugar for
  (. target method args). Re-mint.
- identical? is reference identity (eq?), not value equality. It was aliased to =,
  which infinite-loops when a deftype's .equals short-circuits on (identical? this o)
  (core.logic's Substitutions) and is wrong for distinct equal collections.
- jrecs use a deftype's declared hashCode/equals/equiv for map/set keying instead
  of structural field comparison, so metadata-wrapped keys still match (core.logic
  keys substitutions on lvar id, ignoring metadata).
- meta/with-meta dispatch to a deftype's clojure.lang.IObj meta/withMeta methods
  when present, so metadata threaded through the type's own assoc/withMeta survives
  (previously kept in an identity side-table the reconstructed instances didn't share).
- coll?/seqable? on a deftype require IPersistentCollection (cons) or ISeq (first);
  ILookup(valAt)/Indexed(nth)/Counted(count)/Seqable(seq) alone no longer qualify,
  matching the JVM.
- syntax-quote resolves a bare symbol to the compile ns's own def before
  clojure.core, so a name the ns excluded and redefined (core.logic's == after
  :refer-clojure :exclude) qualifies correctly in macro output.
- reader: record literals #ns.Type{...} / #ns.Type[...] expand to the map->/->
  factory call.
- structmap API: defstruct/create-struct/struct-map/struct/accessor (map-backed,
  insertion-ordered). Re-mint.
- .hashCode on strings/symbols (Java String.hashCode, Symbol Util.hashCombine);
  Class.isInstance; java.util.Collection.contains over vector/list/set;
  clojure.lang.RT/nextID and clojure.lang.Util hash/hasheq/equiv/identical statics.

corpus.edn: 8 JVM-certified rows. unit.edn: a Counted+Seqable deftype is coll?=false
(was a stale expectation encoding the old behavior).
2026-06-27 09:20:11 -04:00
Dmitri Sotnikov
af91dbbaa6
Merge pull request #249 from jolt-lang/conformance/map-insertion-order
Small maps preserve insertion order
2026-06-27 12:14:26 +00:00
Yogthos
bfa2cbf49d Small maps preserve insertion order
jolt maps were HAMTs with hash iteration order; Clojure keeps small maps as
PersistentArrayMap (insertion order), converting to PersistentHashMap past a
threshold. Map literals, array-map, assoc, into/transient, merge, zipmap,
select-keys, update-keys/vals, frequencies and group-by now iterate in insertion
order for <=8 entries, matching the JVM. hash-map and >8-entry maps stay hash
order; sets stay hash order.

The pmap record gains an order field (the insertion-order key list, or #f once
hashed); the HAMT still backs the values so equality/hash/lookup are unchanged.
pmap-fold visits an array-mode map last-to-first so the runtime's cons-accumulate
idiom reconstructs insertion order without touching its many call sites, and
hash-mode output stays byte-identical; pmap-fold-fwd visits in order for the few
sites that build a value directly. Transient maps track insertion order and
promote to hash past max(8, source-count), matching TransientArrayMap.

The hash-map native-op retargets to a hash-order builder so (hash-map ...) stays
hash-ordered while {...} literals are ordered; syntax-quote builds maps via the
hash builder (Clojure expands `{...} to apply hash-map). The core overlay map
builders seed from {} instead of (hash-map) to keep order.

Threshold is 8 for any key (the keyword exception in newer Clojure isn't in
1.12.5). honeysql now passes 832/0/0; 19 JVM-certified corpus rows added.
2026-06-27 05:48:17 -04:00
Dmitri Sotnikov
e2efff6c8e
Merge pull request #248 from jolt-lang/conformance/reitit-aero-honeysql
Conformance: reitit 327/0/0, aero 59/0/0, honeysql 638/6
2026-06-27 08:57:08 +00:00
Yogthos
a99991a818 defn- marks :private; ns-publics drops private vars
defn- now adds :private to the var metadata (like Clojure), and ns-publics
filters those out while ns-interns/ns-map keep them — they were all the same
unfiltered scan before. A lib that introspects ns-publics (honeysql asserts
every public helper has a docstring, and that the clause set matches the public
helpers) saw the private defn- helpers and failed; now honeysql 636/8 -> 638/6
(the rest are map key-order).
2026-06-27 01:27:47 -04:00
Yogthos
4df3d0fa34 Add a java.util.Locale shim (no-op default locale)
jolt's case ops are codepoint-based and locale-independent, so the default
locale is a no-op token: getDefault/setDefault/forLanguageTag + ROOT/US/ENGLISH.
honeysql sets and restores the locale around formatting to assert output is
locale-stable (its Turkish-İ regression guard) — that test errored on the
missing Locale/setDefault static, now passes (honeysql 635/8/1 -> 636/8/0).
2026-06-27 01:21:42 -04:00
Yogthos
135bad9d3a edn: read raw forms so a #tag goes through :readers/:default
clojure.edn/read built the built-in #inst/#uuid eagerly (via read-string), so a
:readers override couldn't win and #inst applied to a non-string form (aero's
#inst ^:ref […]) threw. Read the raw form instead and let edn->value route every
tag through :readers then :default then the built-in — matching clojure.edn,
where a reader from opts wins. edn->value now also converts the (recursively
converted) metadata, since the raw path skips the read-string data seam. aero
suite: 59/0/0 (full pass). clojure.edn baked, re-minted.
2026-06-27 01:15:33 -04:00
Yogthos
3491312ca1 with-meta on a list/seq returns a fresh copy, not the original
meta-copy keyed metadata on the SAME cseq/lazyseq object (the else branch), so
(with-meta xs m) mutated the original list in place — Clojure's PersistentList
is immutable and withMeta returns a new list. (with-meta xs {:k xs}) thus built
a self-referential cycle (the list's metadata pointed at the list), which looped
*print-meta* printing forever — the root of aero's meta-preservation hang. Now
copies the cseq/lazyseq node like the other collections. aero suite completes:
58/0/1 (was hanging).
2026-06-27 01:10:34 -04:00
Yogthos
afc733a439 edn: apply tag readers inside a set literal
clojure.edn/read with :readers/:default recursed into vectors/maps/seqs but
not a constructed set, so a tagged literal in #{…} (aero's #ref in a set) kept
its raw form. edn->value now recurses into a set. clojure.edn is baked into the
seed, re-minted. Fixes aero #ref-in-set + falsey-user-return.
2026-06-27 00:07:49 -04:00
Yogthos
eb64240e29 Read metadata as data, consistently (sets, empty lists)
Clojure's reader reads a ^{…} map with the same read() as any value, so a set/
tagged literal in metadata is a value, not a form. jolt's data seam converted a
set-form to a set in the VALUE but left it as the tagged form inside the
METADATA, and dropped metadata on an empty list entirely (a wrong 'interned, =
Clojure' special case in rdr-attach-meta — Clojure's MetaReader withMetas () via
IObj). rdr-form->data now always converts + carries the (recursively converted)
metadata, whether or not the value structure changed; rdr-attach-meta no longer
skips (). Fixes aero's meta-preservation (set/map/vector/empty-list ds round-
trip). All runtime .ss (data seam), no re-mint.
2026-06-26 23:52:22 -04:00
Yogthos
6b99591266 Fix [_ _] inline method field binding + Var protocol dispatch
Two gaps reitit-core surfaced (now 322/0/1 -> 327/0/0):

- A deftype/defrecord inline method with two _ params, (m [_ _] field), read
  the field as nil: mk-clause bound fields off (get _ :field) where _ was the
  first param, but the second _ shadowed it. Each _ param is now renamed to a
  fresh symbol so the instance is unambiguous.

- A var did not dispatch to a protocol's clojure.lang.Var extension (reitit
  extends Expand to Var for a #'handler route): value-host-tags gained a var arm
  (Var/clojure.lang.Var/IDeref/IFn) and host-type-set gained Var/IDeref so the
  extension keys under Var.

deftype/defrecord is a seed source, re-minted.
2026-06-26 23:22:22 -04:00
Dmitri Sotnikov
9404512b97
Merge pull request #247 from jolt-lang/conformance/lib-fixes
More conformance fixes: defn attr-map, set-in-macro, record interop, Byte/Short
2026-06-27 03:09:09 +00:00
Yogthos
2fd9763d94 Add java.lang.Byte / Short / Float class tokens + Byte/Short statics
jolt had Long/Integer/Double class tokens but not Byte/Short/Float, and no
Byte/Short MIN_VALUE/MAX_VALUE/valueOf/parse* statics. clojure.test.check (a
malli dependency) references Byte/MIN_VALUE and Byte/MAX_VALUE. The values are
plain integers on jolt; the statics expose the JVM ranges (127/-128, 32767/
-32768).
2026-06-26 23:04:55 -04:00
Yogthos
ed1ea46ca2 Records delegate their clojure.lang interface methods to the map fns
A defrecord is Associative/ILookup/IPersistentMap/Seqable/Counted on the JVM,
so (.assoc r k v) / (.valAt r k) / (.without r k) / (.containsKey r k) /
(.cons r x) / (.count r) / (.seq r) / (.equiv r o) / (.entryAt r k) now work
via Java interop, delegating to the map fns when not overridden by a declared
method. reitit's impl calls (.assoc match k v) directly. A bare deftype uses
its own declared methods (record-only branch). reitit-core 58/1/18 -> 321/1/1
with the router lib's Trie shim.
2026-06-26 22:49:51 -04:00
Yogthos
5cd8d15ae7 A set literal reaches a macro as a set value
#{...} reads as the tagged set-form for the analyzer, but a macro saw that
map instead of a set (set? false / map? true, unlike a vector). hc-expand-1
now converts a set-form argument to a real set before calling the expander, so
(set? arg)/conj/seq work — hiccup's compiler introspects a literal set this way
(str (html #{"<>"}) was empty, now #{&quot;&lt;&gt;&quot;}). Elements stay as
read; a deeply-nested set literal inside another form is left for the analyzer.
hiccup 382->383. Jolt-side unit guards (macro def+use in one form isn't
JVM-portable).
2026-06-26 22:42:19 -04:00
Yogthos
bd645a68d6 defn: support the attr-map form
(defn name docstring? {:k v} arglists...) and the multi-arity name+attr-map
now merge the attr-map into the var metadata like Clojure — jolt was parsing
the map out of the body and discarding it. The metadata (the name's own ^{},
the attr-map, and the docstring as :doc) is attached to the def name symbol,
which analyze-def reads and evaluates. defn is in the earliest tier, so the
macro uses only conj/assoc/meta/with-meta (not merge/last). The rare trailing
attr-map (after the last arity) is not yet handled. Fixes hiccup's defelem
meta + honeysql docstring tests.
2026-06-26 22:29:47 -04:00
Dmitri Sotnikov
ab63966ab6
Merge pull request #246 from jolt-lang/fix/conj-on-lazyseq
Fix two regressions from the lazy-seq / deftype work (#245)
2026-06-27 02:20:08 +00:00
Yogthos
b74dbfd2f0 Symbols are IFn (invoke as a map lookup)
('sym coll) / ('sym coll default) now do (get coll 'sym ...), like keywords —
a symbol is IFn on the JVM. jolt threw "cannot be cast to clojure.lang.IFn".
Pre-existing gap (not a regression), surfaced by honeysql's :checking mode,
which does ('where dsl) to look up a clause. honeysql 623/13/8 -> 635/8/1.
Corpus rows added.
2026-06-26 22:05:21 -04:00
Yogthos
3dc5de91e5 Fix map? for a deftype implementing IPersistentMap
The deftype-is-not-a-map change (#245) gated map? on jrec-record?, so only a
defrecord was map?. But a deftype that implements clojure.lang.IPersistentMap is
map? on the JVM — clojure.core.cache's caches are exactly that, and its TTL
factory asserts (map? base) on an LRUCache passed as the base (its suite went
1314 -> 2 errors). map? now also covers a deftype whose without/dissoc method is
registered — the IPersistentMap-distinctive op a vector or set lacks. An opaque
deftype (RawString) stays non-map?; a defrecord stays both. Guards added to
unit.edn (jolt-side: a full IPersistentMap impl will not compile on the JVM
corpus oracle).
2026-06-26 21:37:32 -04:00
Yogthos
271411b3e2 Fix conj on a lazy-seq, add lazy-seq interop regression rows
The rest = more() change made (rest coll) return a jolt-lazyseq, so the very
common (conj (rest xs) y) hit jolt-conj1's base case, which doesn't recognize a
lazyseq, and threw "conj: unsupported collection" (caught by core.match's
seq-pattern compiler). conj on a lazy-seq now prepends like conj on any seq.

The corpus had no row exercising a collection op on a rest-derived seq, so the
class slipped past the gate; add a seqs/lazy-seq-interop suite (conj/into/first/
count/nth/reduce/map/filter/apply/cons/=/empty?/seq over (rest …) and lazy-seq),
all JVM-certified.
2026-06-26 21:25:10 -04:00
Dmitri Sotnikov
1d55d9fa27
Merge pull request #245 from jolt-lang/conformance/close-gaps
Close conformance gaps: regex, exceptions, printer vars, lazy-seq model, deftype/str/print
2026-06-27 01:05:33 +00:00
Yogthos
28d938c396 Review fixes: print fast-path + regex zero-width advance
- with-deeper-print only parameterizes the print depth when *print-level* is
  set, so printing pays no parameterize on the common nil-default path.
- re-find (the matcher) and re-seq advance past a zero-width match relative to
  the match's own start, not the search origin — a zero-width match found past
  the origin (lookahead/boundary) no longer repeats. (re-seq #"a*" "aba") now
  matches the JVM.
2026-06-26 21:01:55 -04:00
Yogthos
cc26e3abba Expose jolt.host/throwable
A library that throws a typed host exception (an http client raising
java.net.ConnectException) needs (class e), instance?, .getMessage and
ex-message to all reflect the named class. jolt-host-throwable already builds
that value; expose it as a jolt.host seam so libraries stop hand-rolling a
:jolt/ex-info table that carries only the class (its .getMessage/ex-message
return nil).
2026-06-26 20:42:14 -04:00
Yogthos
3d80bdc10b Fix general gaps the hiccup suite shook out
Six correctness fixes, each a general gap (not hiccup-specific):

- deftype is not a map. jolt treated every deftype instance as a map
  (map?/record?/seqable over its fields); in Clojure only a defrecord is
  map-like, a bare deftype is an opaque object. defrecord now marks its type;
  map?/record?/coll?/seq/empty? gate on it, while a deftype implementing a
  collection interface still dispatches through its methods.

- cross-ns extend-protocol on an imported deftype. register-method built the
  type tag from the *calling* ns + bare name, so (extend-protocol P Raw …) in
  one ns missed a Raw value defined in another. A simple-name index resolves
  the bare name to the type's real tag (local ns still wins).

- str vs print. str of a collection is its readable form (nested strings
  quoted: (str ["x"]) => ["x"]); print leaves them raw. jolt defined print
  as str, conflating the two. Split via a __print1 seam.

- clojure.test thrown? now honors the exception hierarchy (instance?), so
  (thrown? IllegalArgumentException …) matches an ArityException subclass.

- java.net.URI is value-equal (= and hash by string form).

- clojure.walk/macroexpand-all was missing; an unresolved qualified var made
  the analyzer report "Unknown class walk".

deftype/defrecord + print are seed sources, re-minted. hiccup 365->381 of its
own suite; the rest are charset-encoding / var-meta niches.
2026-06-26 20:15:39 -04:00
Yogthos
448611a5df Match Clojure's lazy seq realization model
jolt's seq layer realized one element ahead of Clojure, so a side-effecting
lazy seq ran its producer too eagerly. Four changes bring it in line:

- rest is Clojure's more(): it returns the tail without realizing it. An
  unforced tail (vector / string / lazy-seq cell) comes back as a deferred
  seq, so (rest (iterate f x)) does not call f. next still realizes one.
- iterate applies f lazily, inside the tail thunk, so (first (iterate f x))
  is x with no call to f (clojure.lang.Iterate parity).
- take realizes exactly n: the last element terminates without touching the
  rest, instead of forcing one more element of the source.
- an empty realized lazy seq is still a sequence value, printing "()" not
  "nil" (a JVM LazySeq is never nil).

Also: the map transducer's step fn now takes multiple inputs
([result input & inputs]) so a multi-collection transduce applies f across
all of them. Fixes medley's join/window/sequence-padded laziness and
multi-input transducer tests (now 293/293). The rest change also fixed a
latent overrun in distinct/dedupe over a map's empty tail.

iterate is a seed source, re-minted.
2026-06-26 19:41:02 -04:00
Yogthos
331a41ee26 Honor *print-length* / *print-level* / *default-data-reader-fn*
Both printers (jolt-pr-str, jolt-pr-readable) now thread a print depth and
read the two limit vars. *print-length* truncates each collection to N
elements + "...", walking seqs lazily so an infinite seq prints under the
limit without realizing it. *print-level* renders a collection at depth >=
the level as "#". The reader consults *default-data-reader-fn* for an
unregistered #tag before falling back (tagged form on the data seam, throw
on the edn seam). All three interned with nil defaults.
2026-06-26 19:04:42 -04:00
Yogthos
a9ecae9a29 Map raw Chez runtime errors to their JVM exception classes
A wrong-arity or non-seqable error that Chez raises carried no jolt exception
class, so (class e) was :object and (thrown? ArityException …) / (thrown?
IllegalArgumentException …) never matched. Classify these by message:
incorrect-number-of-arguments -> clojure.lang.ArityException, not-seqable ->
java.lang.IllegalArgumentException, with ArityException modeled as a subclass of
IllegalArgumentException. (class e) and instance? now match the JVM.

All java-layer (records-interop.ss classifies, host-class.ss reports the class +
the ArityException token). medley 281 -> 283 passing.

jolt-o9dc
2026-06-26 17:55:30 -04:00
Yogthos
5f72ec9bcb Close portable clojure.core gaps: re-groups, letfn, REPL + dynamic vars
Spec coverage dashboard had 6 missing-portable and 24 dynamic-var entries. The
portable ones are now implemented (missing-portable -> 0, dynamic-var -> 14):

- Stateful matcher: re-matcher now returns a real mutable Matcher; re-find over
  it steps through matches and re-groups returns the last match's groups (was an
  inert tagged map). Closes re-groups.
- letfn is interned as a clojure.core var so (resolve 'letfn) matches the JVM. It
  stays a special form (the value is never invoked, not marked a macro).
- *1 *2 *3 *e interned (nil outside a REPL).
- Portable dynamic vars whose default already matches jolt's behaviour:
  *read-eval* *print-dup* *print-namespace-maps* *flush-on-newline*
  *compile-files* *math-context* *command-line-args* *file*.

The remaining 14 dynamic-var entries are host-internal (compile-path,
compiler-options, fn-loader, reader-resolver, repl, source-path, ...) or deferred
pending printer/reader support (*print-length* *print-level*
*default-data-reader-fn*). Corpus rows added for each closed gap; coverage.md
regenerated.
2026-06-26 17:48:21 -04:00
Yogthos
8a877662dc Regex: accept Java-compatible char-class dash and (X+)* quantifier
irregex rejected two patterns the JVM accepts, which blocked library loads:

- [\w-_] errored with bad char-set because a - after a shorthand class was
  read as a range start. Java reads it as a literal hyphen. Preprocess the
  pattern to escape such a dash.
- (X+)* errored with duplicate repetition because sre-repeater? recurses
  through submatch, treating a quantified group like a dangling a**. Override
  it to a bare leading * / + check, matching the JVM (which only rejects the
  dangling case).

Both in regex.ss (runtime). Unblocks cuerdas (was load-fail, now 292 passing)
and aws-api config-test. Also documents the host/chez/java source-layering rule
in host-interop.md.

jolt-l8so
2026-06-26 17:35:08 -04:00
Dmitri Sotnikov
687dc60af6
type returns the JVM class (Clojure semantics) (#244)
(type x) was jolt's internal taxonomy keyword (:string/:set/:jolt/inst), which
breaks any library dispatching a multimethod on [(type a) (type b)] against
java/clojure.lang classes (e.g. clojure.tools.logging.test's matchers). Make the
PUBLIC clojure.core/type Clojure's (or (:type meta) (class x)).

The taxonomy keyword stays the core model: natives-meta.ss keeps jolt-type and
exposes it as __type-tag, which print-method/print-dup dispatch on (so #uuid/#regex/
records still print). The JVM mapping lives in the java host layer — host-class.ss
defines the public type next to (class …), and a jinst now reports java.util.Date
(was :jolt/inst). So the core emits the taxonomy and the java layer remaps it in one
place. unit.edn's type suite updated to the class names. make test green.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 21:14:06 +00:00
Dmitri Sotnikov
6c03dffd00
Class/forName honesty + class/isa? conformance for builtins (#243)
Class/forName claimed every java.*/clojure.* name found (and any "x.y.Class"
matched the registered Class via a short-name fallback), so a library's
(class-found? "optional.Dep") feature-probe always said yes — tools.logging then
tried to build the java.util.logging / log4j backends jolt lacks and crashed.
Resolve forName by exact registry lookup + an honest prefix that excludes the
unbacked optional packages (java.util.logging, javax.management), so the probe
sees them absent and skips the backend.

class of a persistent collection / namespace now reports its JVM class name
(clojure.lang.PersistentHashSet, …Namespace, …) instead of jolt's internal :set/
:object tag, and isa? consults JVM class assignability — Object as every class's
root plus a modeled clojure.lang/java.util hierarchy — so (isa? (class x) C) and a
class-keyed multimethod dispatch like the JVM (e.g. (isa? Keyword Object) was
false). Adds the bare class tokens (Fn/Namespace/Set/…) these dispatch on.

(type x) is unchanged — it keeps jolt's documented internal-keyword form. Six
JVM-certified corpus rows. make test green, 0 new divergences.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 21:02:44 +00:00
Dmitri Sotnikov
283a0f0eec
instance? matches a thrown :class envelope by its class hierarchy (#242)
A library that throws an ex-info envelope carrying a JVM :class (jolt.host/
tagged-table with a "class" entry — e.g. http-client's UnknownHostException on a
DNS failure) was caught only by a broad (catch Throwable …): (class e) read the
class but (instance? C e) — which catch dispatch lowers to — always returned
false, so clj-http-lite's (catch UnknownHostException e …) for :ignore-unknown-host?
never matched and the condition propagated.

Add an instance? arm matching such an envelope against the carried class or any
ancestor (full name or last segment), and register the common exception hierarchy
(Throwable/Exception/RuntimeException/IOException + the java.net socket/host
exceptions) so (catch IOException e) / (instance? Throwable e) also match. A
non-throwable class (RuntimeException over an IOException, String) stays false.

Fixes http-client's :ignore-unknown-host? test (116/0/0, was 1 error). make test
green, 0 new divergences. Runtime .ss, no re-mint.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 20:18:27 +00:00
Dmitri Sotnikov
301cda2e46
Add java.util.Optional (#241)
A value class libraries return from getters (java.time, and the java.net.http
client shim that aws-api's java backend builds on). Statics of/ofNullable/empty,
methods isPresent/isEmpty/get/orElse/orElseGet/ifPresent/toString, value-equal so
(= (Optional/of x) (Optional/of x)). Five JVM-certified corpus rows. Runtime .ss,
no re-mint.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 20:08:23 +00:00
Dmitri Sotnikov
27d99db4bc
java.time: parse fractional seconds in formatter-based date parsing (#240)
parse-ms ignored sub-second fractions: a formatter parse of
"2020-07-06T10:59:13.417Z" dropped the .417 (and the ISO_OFFSET_DATE_TIME pattern
"…ssXXX" then mis-aligned, reading ".417Z" as the offset). java.time's ISO
formatters accept an optional fractional second, so jolt should too.

After parsing the seconds field, consume an optional .fff from the input (to
millis) when the pattern carries no fraction field — which is how the ISO_*
constants are modeled here (ss, no S). Also handle the S pattern letter for
explicit .SSS patterns. Carry the fraction into the result.

Fixes aws-api shape iso8601 parse (1 FAIL -> 0; cognitect.aws.util/parse-date now
returns the right Date). Two JVM-certified corpus rows. make test green, 0 new
divergences. Runtime .ss — no re-mint.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 19:49:49 +00:00
Dmitri Sotnikov
b3ffd357a2
java.time: complete LocalTime/LocalDate/Year/YearMonth ChronoField coverage (#239)
tick's fields-test walks every ChronoField a temporal supports and reads it,
which crashed on fields jolt didn't implement. Fill the gaps:

- LocalTime: CLOCK_HOUR_OF_DAY (1..24), HOUR_OF_AMPM, CLOCK_HOUR_OF_AMPM,
  MICRO_OF_DAY — both isSupported and getLong.
- LocalDate: the aligned-* group (ALIGNED_DAY_OF_WEEK_IN_MONTH/_YEAR,
  ALIGNED_WEEK_OF_MONTH/_YEAR).
- LocalDateTime field routing now asks which part supports the field instead of a
  hardcoded date list, so a date field never misroutes to the time part (the actual
  cause of "LocalTime has no field ALIGNED_DAY_OF_WEEK_IN_MONTH" — a ZonedDateTime's
  date field fell through to its time).
- Year / YearMonth gain isSupported / get / getLong.

tick api_test 344/0/1 -> 599/0/0. Seven JVM-certified corpus rows. make test green,
0 new divergences. Runtime .ss — no re-mint.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 19:12:40 +00:00
Dmitri Sotnikov
dcfa607dc2
bench: mono-dispatch 48x->15x after the devirt inline cache (#238)
The per-site inline cache (#237) resolves a statically-proven monomorphic devirt
once instead of per call, so mono-dispatch is no longer worse than megamorphic.
The remaining dispatch lever is the megamorphic case (a runtime receiver-type-keyed
cache).

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 18:36:52 +00:00
Dmitri Sotnikov
a31c1af8c4
Devirt: cache the resolved impl in a per-site cell (inline cache) (#237)
A devirtualized protocol call resolved its impl with devirt-resolve on EVERY call
— but the tag/proto/method are compile-time constants, so the resolved fn is a
runtime constant (closed world). That per-call find-protocol-method (three
hashtable lookups) was the cost: on mono-dispatch, dispatch was ~75% of the time
(ablation: same arithmetic direct-call 166ms vs dispatch 673ms).

Resolve once. When emitting a direct-link def, each devirt site gets a fresh cache
cell, bound to #f in a let wrapping the def (so it persists across calls and is
shared by every invocation); the site resolves into it on first use ((or cell
(let ((_f (devirt-resolve ..))) (set! cell _f) _f))) and reuses it after — the
inline cache the JVM gets for free. First call still passes the real receiver, so
the Object/host-tag fallback (devirt-resolve) is unchanged.

mono-dispatch 673ms -> 214ms (~3.15x), 47.5x -> ~15x JVM, near the 166ms
direct-call floor. run-devirt.ss gains the cached-path checks (cell present, 1st
call caches + 2nd reuses, both == dispatch). make test / shakesmoke green, selfhost
holds, 0 new divergences.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 18:34:13 +00:00
Dmitri Sotnikov
f923d52cad
bench: refresh the jolt/JVM scorecard (#236)
The type-proving / native-record / bare-field-read / inference work collapsed
the dispatch + allocation gaps by an order of magnitude (binary-trees ~140x->~10x,
mono-dispatch ~330x->~48x, dispatch ~130x->~12x) and brought compute to parity
(fib now beats JVM, collections ~4x, mandelbrot ~7.5x). mono-dispatch is now the
standout gap — a runtime-monomorphic call site the JVM inline-caches to near-free.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 18:20:11 +00:00
Dmitri Sotnikov
f920ff6ea2
Nilable record types + flow-sensitive nil narrowing (#235)
A record-or-nil (a protocol method whose impls return a record in one branch and
nil in another, or an `if` over a ctor and nil) now types as a NILABLE record
instead of widening to :any. A nilable record still bare-indexes its field reads
(jrec-field-at falls back to jolt-get on nil), but some?/nil? do NOT fold on it, so
a runtime guard is preserved — and inside (if (some? x) ..) / (if x ..) the then-
branch narrows x to the non-nil record, so its reads bare-index AND unbox there.

This is what lets the bounced ray type without a hint: scatter returns
ScatterResult-or-nil (Metal absorbs some rays), and the consumer reads
(:ray scattered) only under (if (some? scattered) ..). The narrowing proves
scattered non-nil there.

lattice: :nil type; :nil ∨ struct -> nilable struct, ∨ anything else -> :any;
nilability is contagious through a struct join, which also now preserves :type when
both sides agree (needed so a record ∨ its nilable self stays that record).
truthy-type?/field-type/pred-on treat a nilable struct as maybe-nil. types: nil
literal -> :nil; an `if` whose test is (some? x)/(nil? x)/x narrows the nilable
local x in the proven branch.

Ray tracer with NO hints: 38.4s -> 23.9s (~1.6x) — hit-sphere now types fully
(0 jolt-get, 57 jrec-field-at, 38 fl-ops), identical to the hand-hinted build.

run-narrow.ss gate, incl. the load-bearing check that the nil case still takes the
else branch (the guard is not folded away). make test / shakesmoke green, selfhost
holds, 0 new divergences.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 17:16:16 +00:00
Dmitri Sotnikov
f124701393
Infer monomorphic protocol-method return types (#234)
A protocol method whose impls all return the same record type has a monomorphic
return. collect-pm-rets! scans the unit's (register-(inline-)method ..) forms,
infers each impl fn's return type, and joins them per method; call-ret-type then
types a (method recv ..) call as that record, so a field read off the result
bare-indexes — e.g. (:ray (scatter m ..)) reads off a Ray. A disagreeing impl
joins to :any and keeps the generic path.

run-protoret.ss: a method with all-record impls bare-indexes + unboxes the field
read; a mixed-return method (one impl returns a number) stays generic. make test /
shakesmoke green, selfhost holds, 0 new divergences.

Foundation for auto-typing record values that flow through protocol dispatch. Does
not yet move the ray tracer: its scatter returns ScatterResult-or-nil (Metal
absorbs some rays), and the nil widens the join to :any — typing a nullable return
soundly needs flow-sensitive narrowing (a guarded (some? x) proves non-nil), filed
separately.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 16:59:35 +00:00
Dmitri Sotnikov
8c9cba44b3
WP: don't let a recursive pass-through poison a param to :any (#233)
The whole-program fixpoint collects a self-recursive call's arg types into the
fn's own params. When a recursive call threads a param straight through unchanged
(same arg, same position — e.g. ray-cast passing `hittables` to itself), that arg's
type is the param's own current type: :any until external callers determine it. And
:any is absorbing, so collecting it pinned the param at :any forever — the type a
caller supplied (a vector of records) was lost, and the fn's field reads stayed
generic.

Skip a same-position pass-through arg in the self-recursion collection (contribute
the join identity). It can't add information — param i ⊇ param i is trivial — so
dropping it is sound; the param is still constrained by every external caller and
by any non-pass-through recursive arg. Applies to both self-recursion paths: a
`defn` recursing through its var, and a named fn literal recursing via its
self-local.

This is why ray-cast's `ray` typed (its recursion passes a fresh ray) but
`hittables` didn't (passed through). With the fix, hittables keeps its
vec<Sphere> element type, so hit-all's reduce element — and hit-sphere's reads —
type without any hint: ray tracer 38.4s -> 31.3s (~1.23x) with no annotations.

run-wp.ss: a recursive fn threading a vec param through keeps its element type.
make test / shakesmoke green, selfhost holds, 0 new divergences.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 16:29:46 +00:00
Dmitri Sotnikov
09345f10c2
Make ^Record param hints work (resolve the record tag) (#232)
jolt.host/record-ctor-key and record-type? were stubs returning nil since the
rehost, so phint-of always produced nil — a ^Record param hint (^Sphere s) was
silently dead. The inference only ever typed a record param when its callers
passed a concrete ctor (whole-program), so a fn called with an untyped value (a
vector element, a value threaded through recursion) read its fields generically.

Resolve the tag against the record registry (records.ss): chez-find-ctor-key maps
a ^Type tag to the ctor-key "ns/->Name" the inference seeds with, preferring the
compile ns and falling back to any registered record of that simple name (cross-ns
/ imported). record-type? / record-ctor-key call it. Runtime .ss — no re-mint (the
analyzer reaches record-ctor-key through the host var).

With this, a ^Sphere/^Ray-hinted hit-sphere in the ray tracer types its params, so
its 48 generic jolt-get field reads + boxed arithmetic become bare-index reads +
fl-ops: ray tracer 38.4s -> 23.9s (~1.6x), make test / shakesmoke green, selfhost
holds, 0 new divergences. A wrong hint stays safe — jrec-field-at falls back to
jolt-get for a non-record.

run-fieldnum.ss: a ^V-hinted param (no inferable caller) bare-indexes + unboxes,
with no generic jolt-get left.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 16:03:57 +00:00
Dmitri Sotnikov
4671e1b67e
Unbox ^double record field reads (#231)
A record field tagged ^double now reads back as a flonum and feeds the numeric
pass, so hintless arithmetic over those fields lowers to fl-ops — the leaf-numeric
analog of the ^Vec3 nested-field hints. Combined with the whole-program :double
param inference, a vec3-dot over a ^double-fielded record unboxes end to end with
no per-fn hints.

records.ss: a ^double field tag passes through resolution, and the ctor (and a
mutable-field set!) coerce a ^double field to a flonum — JVM primitive-field
parity (jolt returned an exact 1, not 1.0, before), and what makes reading the
field back as :double sound for an fl-op.

types.clj: field-type-from-tag maps "double" -> :double, and a keyword/get lookup
whose result is :double annotates the node :num-read :double. numeric.clj reads
that annotation and classifies the field read as a :double operand, so the
enclosing arithmetic specializes — the read itself keeps its jrec-field-at/jolt-get
emit.

run-fieldnum.ss gate: ctor coercion (int field -> flonum), field-field arithmetic
emitting fl*/fl+, and an untagged field staying generic. make test / shakesmoke
green, selfhost holds, 0 new divergences.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 14:43:00 +00:00
Dmitri Sotnikov
8ae45057d6
Hintless whole-program double inference (#230)
The closed-world fixpoint (#226) flowed record types across fn boundaries; this
adds a numeric refinement so a hintless fn whose every call site passes a flonum
has its param unboxed to fl-ops, no ^double hint needed.

Lattice gains :double, a flonum refinement of :num: two doubles join to :double,
a double joined with anything else widens to :num — so a param is :double only
when every contributing value is a flonum, which is what makes the fl-op sound.
infer types a flonum literal and flonum arithmetic (+ - * / min max inc dec over
double/int-literal operands) as :double, and the fixpoint joins those across call
sites and return types like any other lattice value.

The bridge to the existing hint-directed pass is a synthetic [param :double]
nhint: wp-infer! stashes the :double params separately from the structural seeds,
and run-passes injects them as nhints before numeric/annotate, so the fl-op
emission and the exact->inexact entry coercion (a no-op on a proven flonum) apply
unchanged.

Sound subset only: :double, never :long — an untyped integer can be a bignum and
fx-ops would overflow/diverge from jolt's arbitrary precision. So an integer
caller leaves a param generic; an escaped fn (unknown callers) keeps :any.

run-numwp.ss gate: cross-fn :double propagation incl. through a flonum-returning
helper, the integer-caller and escape negatives, and the full run-passes path
emitting fl* + entry coercion. make test / shakesmoke green, selfhost holds, 0
new divergences.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 14:18:10 +00:00
Dmitri Sotnikov
e6e3612332
Devirt: fall back to dispatch when the static tag has no direct impl (#229)
The devirtualized protocol call emitted find-protocol-method on the inferred
record tag, but a record can satisfy a protocol via an Object/host-tag default
rather than a direct impl — find-protocol-method on its own tag misses that,
while protocol-resolve walks to the default. So a record relying on
(extend-protocol P Object ...) resolved under ordinary dispatch but applied #f
under devirt and crashed. Closed-world opt builds only; the gate previously
covered just direct inline/extend-type impls so it shipped green.

Emit devirt-resolve, which tries the static tag and falls back to
protocol-resolve on a miss — same fast path, correct regardless of how the
record satisfies the protocol. Mirrors jrec-field-at falling back to jolt-get.
The receiver binds to one temp so it feeds the resolve and the application
without double-evaluating a side-effecting arg 0.

Also widen the whole-program fixpoint to :any on hitting the iteration cap: a
non-converged pre-fixpoint is more specific than the least fixpoint, so seeding
it would be unsound. Not reached in practice (~2 passes); a defensive floor.

run-devirt.ss gains an Object-default case. make test / shakesmoke green,
selfhost holds, 0 new divergences.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 13:58:23 +00:00
Dmitri Sotnikov
de31221573
Bare-index field reads for statically-known records (#228)
When the inference types a keyword-lookup receiver as a record — it carries the
field-order :shape and :hint :struct from the whole-program fixpoint — the back
end reads the field by its declared slot via jrec-field-at instead of jolt-get.
That skips the jolt-get case-lambda, the dispatch fn, and the field-key
hashtable lookup, leaving a jrec? check + a static-index vector-ref.

jrec-field-at falls back to jolt-get when the receiver isn't the expected record
(a map downgraded by dissoc, or a value the inference mistyped), so it stays
correct if the static type is wrong. Only the no-default form takes the bare
path (a declared field is always present).

Sound only for non-nil records: a self-recursive param that can be nil (e.g.
binary-trees check-tree, whose untagged child is nil at leaves) types :any and
keeps jolt-get — the whole-program fixpoint demotes it. The target is non-nil
record params, like a Vec3 dot product (~5% there; boxed-flonum arithmetic
dominates the rest, a separate numeric lever).

run-fieldread.ss gate: emitted form uses jrec-field-at at the right slot and
matches jolt-get for each declared field; a non-field key and a default-arg form
keep the generic path. make test / shakesmoke green, 0 new divergences.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 11:29:14 +00:00
Dmitri Sotnikov
af11aaa7ff
Devirtualize monomorphic protocol calls (#227)
When the inference proves a protocol call's receiver is one record type, the
back end resolves the impl by that static tag (find-protocol-method) instead of
routing through the protocol var -> jolt-invoke -> protocol-resolve, which
re-derives the tag and walks the type table. Same table lookup, minus the
var-deref, the rest-cons, and the receiver-type computation.

Fires only on a monomorphic site: a megamorphic receiver joins to :any and
carries no :devirt-type, so it keeps ordinary dispatch (the dispatch bench is
unaffected). The annotation comes from the whole-program fixpoint typing a
reduce/HOF element or a ctor return as a specific record.

Modest on the dispatch benchmarks (~6% on mono-dispatch) — float boxing in the
reduce accumulator dominates there, a separate numeric lever — but it removes
the dispatch overhead wherever a typed receiver is known.

run-devirt.ss gate: emitted form uses find-protocol-method, and evaluating it
matches ordinary dispatch for an inline impl, an extend-type impl, and the
non-devirt path. make test / shakesmoke green, 0 new divergences.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 11:16:19 +00:00
Dmitri Sotnikov
09712ec575
Whole-program param-type inference (closed world) (#226)
Re-derive each app fn's param types from its call sites under --opt, so a
record type flows across fn boundaries: a ctor's return reaches a callee
param, and a typed vector's element reaches a HOF closure's param. The back
end can then bare-index field reads and devirtualize protocol calls at those
sites (it reads the resulting :hint/:devirt annotations; consuming them is
separate work).

This rebuilds the inter-procedural driver the Janet host had — the API
(infer-body/reinfer-def) survived the rehost but nothing drove it, and the
record-shapes/protocol-methods registries were empty stubs.

- records.ss: populate record-shapes (ctor key -> fields/tags/type, resolving
  nested record field tags) and protocol-methods (method var -> [proto method])
  registries at deftype/defprotocol load time; jolt.host accessors materialize
  them.
- passes/types.clj: wp-infer! runs a closed-world fixpoint joining call-site
  arg types into callee params; reinfer-def re-seeds each def at emit. Self-
  recursive calls and fn-level recur are collected so a recursive fn's params
  are constrained by its recursion, not just external callers — else a param
  the recursion widens (e.g. binary-trees check-tree, whose untagged child can
  be nil) would be unsoundly typed non-nil. A fn used in value position keeps
  :any params (callers unknown). Megamorphic sites join to :any.
- build.ss: analyze all app forms and run the fixpoint before per-form emit.
- run-wp.ss: gate (cross-fn propagation, escape soundness, self-recursion).

make test / shakesmoke green, 0 new divergences, selfhost holds.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 10:57:45 +00:00
Dmitri Sotnikov
32ef74b9b0
Persistent vector as a 32-way trie (#225)
The persistent vector was a flat Scheme vector with copy-on-write: every conj
copied the whole backing array, so building an n-element vector was O(n^2). On the
collections bench that's vec-sum building 7500 elements with 227MB of copies, 90%
of the bench's allocation.

Replace it with Clojure's PersistentVector — a 32-way trie plus a trailing tail
chunk. conj appends to the tail and, when it fills, path-copies it into the trie,
so conj is O(1) amortized and a linear build is O(n). nth/assoc/pop are
O(log32 n). make-pvec (build a trie from a flat vector) and pvec-v (materialize
back) stay as compatibility shims, so the ~14 callers that read the backing array
— all one-shot conversions in =, hash, seq, meta-copy, transients, the reader —
are untouched; only this file's internals change.

vec-sum 70ms/227MB -> 1ms/3MB; collections 10.4x -> 4.0x vs JVM, under the 5x
target. 5 new corpus rows plus boundary stress (level transitions at 32 and 1024,
pop-collapse, assoc at every index) cover the trie.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 06:32:18 +00:00
Dmitri Sotnikov
93be40f3fe
See through or/and in truthy-elision (#224)
A loop test like (or (>= i cap) (> ... 4.0)) desugars to
(let* [g (>= i cap)] (if (truthy? g) g (> ... 4.0))) and the whole thing was
wrapped in jolt-truthy? because returns-scheme-bool? only looked at :const and
:invoke nodes, not the let*/if an or/and expands to. The wrapper defeats Chez's
branch inlining on the hot loop edge.

Make returns-scheme-bool? recursive over :if (both branches bool), :let (body
bool, tracking which bound locals hold a Scheme boolean), and :local (in that
set). or/and over bool-returning ops then read as Scheme booleans and the outer
wrapper drops. Still sound: eliding only when the value is provably #t/#f — a
jolt-nil is a truthy record in Chez, so a false positive would be a real bug, and
the recursion only proves bool-ness through ops already known to return one.

No bench regression; the win lands on hinted float loops where the branch, not
boxed arithmetic, is the cost.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 06:11:35 +00:00
Dmitri Sotnikov
0a7e818700
Fixed-arity protocol dispatch shims (#223)
defprotocol emitted one variadic (fn [this & rest] (protocol-dispatch P m this
(list->cseq rest))) per method, so every protocol call — even a no-extra-arg one
like (area s) — consed a rest list, wrapped it in a cseq, var-deref'd
protocol-dispatch, and jolt-invoke'd it (consing again). On mono-dispatch that was
2.07GB of allocation, ~65% of the benchmark.

Emit one fixed-arity clause per declared arglist instead. The 1/2/3-param arities
call positional protocol-dispatch{1,2,3}, which resolve the impl (by record tag,
reify method, or host-tag extension — factored into protocol-resolve) and apply it
directly; no rest-list, no seq round-trip. The dispatchN entry points are in the
native-op table so the shim calls bind straight to the records.ss procedures
rather than var-deref. 4+ params fall back to the variadic protocol-dispatch.

mono-dispatch 1.5s/2.07GB -> 0.69s/280MB; dispatch 26x -> 12.2x, mono-dispatch
111x -> 51x vs JVM. 5 new corpus rows pin multi-arity methods, host-type args,
and protocol-method-as-value against JVM Clojure.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 05:57:42 +00:00
Dmitri Sotnikov
8bea1abe12
Native record representation + inline nil?/some? (#222)
Records were a jrec holding an alist of (kw . val) conses: ~113B/node, built
fresh per construction, field reads a list scan. Replace that with a shared
per-type descriptor (tag + field keywords + an eq?-keyed keyword->index table)
plus a flat per-instance value vector and an extension map for any non-field
keys assoc'd on (jolt-nil when there are none). Construction now allocates one
vector instead of a cons chain and a field read is an index lookup. binary-trees
construction allocation drops 2.085GB -> 1.19GB.

That alone barely moved binary-trees wall-time: profiling showed the read loop,
not allocation, dominates, and the read loop's own allocation came from (nil? l)
lowering to (jolt-invoke (var-deref "clojure.core" "nil?") l), which conses its
args every call. Add nil?/some? to the backend native-op table so they inline to
jolt-nil?/jolt-some? (and drop the truthy wrapper, like the other predicates).
check-tree's read loop goes from 1.476GB allocated to zero; binary-trees 18.9x
-> 9.7x vs JVM. The remaining gap is the field-read dispatch chain (jolt-c3mw).

Two JVM divergences fixed along the way, both certified:
- dissoc of a declared field downgrades a record to a plain map (was kept as a
  record); an extension key still drops cleanly.
- map->R keeps extension keys (was dropping anything outside the declared basis).

16 new corpus rows pin assoc/dissoc/count/keys/seq/=/hash/extension-field
behavior against JVM Clojure.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 05:42:24 +00:00
Dmitri Sotnikov
eacfa04e5b
Perf round 1: self-call, keyword interning, fast record field reads (#221)
* Make the benchmark harness build optimized binaries on Chez

bench/run.sh was Janet-era: it invoked a 'jolt' binary and set
JOLT_DIRECT_LINK/JOLT_WHOLE_PROGRAM, none of which exist on Chez, where
'joltc run -m' runs fully unoptimized (direct-link and inline default off). So
the suite was measuring jolt's unoptimized path.

run.sh now compiles each benchmark to an optimized AOT binary (joltc build
--direct-link --opt) and times it against JVM Clojure on the same portable
source, auto-detecting the Chez kernel dev files like build-smoke.sh. Adds
bench/deps.edn so joltc resolves the namespaces, NO_JVM to skip the reference.

mandelbrot.clj dropped its jolt.png require so the JVM reference can run it; the
picture demo moved to mandelbrot_png.clj (jolt-only). README scorecard refreshed
with current Chez numbers and the two-regime read (compute ~8-10x substrate floor;
dispatch/alloc ~120-330x architectural gaps the passes don't touch). Stale
'jolt -m' header lines point at bench/run.sh.

* Emit direct self-calls for named-fn self-recursion

A self-recursive call to a named fn compiled to (jolt-invoke fib ...) instead of
a direct (fib ...): emit-invoke handled a :local callee only when it was NOT a
known proc, so a :local that IS in *known-procs* (the letrec-bound self-name) fell
through to the :else jolt-invoke branch. Now a :local known proc emits a direct
Scheme call — no jolt-invoke, no per-call arg-list consing; case-lambda handles
arity.

fib 30: 63.3ms -> 4.7ms (faster than JVM Clojure's 7.1ms; was 9x slower). The win
is on every self-recursive non-loop fn, including the compiler's own. No semantic
change — selfhost holds, make test green, shakesmoke/buildsmoke byte-identical.

Re-mint (backend is seed). Corpus rows pin self-recursion across fixed/multi/
variadic arities.

* Intern no-ns keywords without per-call allocation

(keyword #f name) built a fresh combined-key string (string-append) on every
call just to do the intern-table lookup — ~80 bytes of garbage per (:kw x), map
literal, keyword arg, etc. A no-ns keyword now interns in a table keyed by the
name string directly, so a lookup of an already-interned keyword is one
hashtable-ref with no allocation. The ns table keeps the combined key; both share
the keyword-t khash (equal-hash of the combined key) so hash values are unchanged.

Small time win on its own (the field-read dispatch dominates hot record code —
see jolt-unx4) but removes per-call keyword allocation everywhere. Runtime .ss,
no re-mint; identity/=/hash unchanged, make test green.

* Fast record field reads: single eq? scan, skip the get-arm walk

(:field rec) / (get rec :field) lowers to (jolt-get rec kw), which walked the
get-arm list to reach the jrec arm, then did jrec-has? + jrec-lookup — TWO linear
scans, each comparing keys through the generic jolt=2 equality dispatcher. Field
keys are interned keywords, so:

- jrec-key=? compares a keyword query by eq? (jolt=2 only for non-keyword keys),
- jrec-ref does ONE scan (vs has?+lookup) and runs a deftype's ILookup valAt only
  when the field is genuinely absent (present-nil still returns nil, not default),
- jolt-get-dispatch checks jrec? first, skipping the get-arm walk for the hottest
  get target. jrec-lookup/jrec-has? (used by =, contains?, etc.) get the fast
  compare too.

binary-trees 135x->18.9x, dispatch 121x->26.4x, mono-dispatch 327x->108x vs JVM.
Runtime .ss (collections.ss + records.ss), no re-mint; make test + shakesmoke +
buildsmoke green, record get/assoc/keys/=/count semantics unchanged.

---------

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 05:00:28 +00:00
Dmitri Sotnikov
93ddf2c85a
Make the benchmark harness build optimized binaries on Chez (#220)
bench/run.sh was Janet-era: it invoked a 'jolt' binary and set
JOLT_DIRECT_LINK/JOLT_WHOLE_PROGRAM, none of which exist on Chez, where
'joltc run -m' runs fully unoptimized (direct-link and inline default off). So
the suite was measuring jolt's unoptimized path.

run.sh now compiles each benchmark to an optimized AOT binary (joltc build
--direct-link --opt) and times it against JVM Clojure on the same portable
source, auto-detecting the Chez kernel dev files like build-smoke.sh. Adds
bench/deps.edn so joltc resolves the namespaces, NO_JVM to skip the reference.

mandelbrot.clj dropped its jolt.png require so the JVM reference can run it; the
picture demo moved to mandelbrot_png.clj (jolt-only). README scorecard refreshed
with current Chez numbers and the two-regime read (compute ~8-10x substrate floor;
dispatch/alloc ~120-330x architectural gaps the passes don't touch). Stale
'jolt -m' header lines point at bench/run.sh.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 04:59:52 +00:00
Dmitri Sotnikov
f3084f8043
Collection fns: JVM-faithful return types + laziness (#219)
A type-aware audit (~190 collection expressions vs reference Clojure) found four
divergences the corpus missed — value-equality (= [0 1] '(0 1)) hides type and
laziness differences. Fixed, with type-predicate + over-infinite corpus rows that
pin them.

- partition-all [n coll] built vector chunks; JVM chunks are seqs. (The [n step
  coll] arity was already correct, as is the partition-all transducer, whose
  chunks are vectors in JVM too.) Now builds seq chunks.
- replace always returned a vector (mapv) and was eager; JVM is type-preserving —
  a vector maps to a vector, any other seqable to a lazy seq.
- sequence eagerly realized its source (into-xform), so (first (sequence (map inc)
  (range))) hung. Rewrote as a transformer iterator: pull one input at a time,
  buffer the step outputs, emit lazily, run the completion to flush a stateful
  xform. eduction builds on it (lazy, no longer an eager vector).
- mapcat and (apply concat coll-of-colls) hung over an infinite source because
  jolt-apply seq->lists the trailing arg and mapcat seq->lists the map result.
  Added lazy-concat-seq (lazily flatten a seq of colls); mapcat uses it directly,
  and apply special-cases concat (its result is lazy) to route through it.

Docs: a cross-cutting return-type + laziness contract in docs/spec/09-core-library;
SPEC.md notes that = masks type/laziness so they need predicate / over-infinite
rows. EBNF is reader syntax only — unaffected.

Seed change (partition-all/replace/eduction are clojure.core overlay) -> re-mint;
selfhost holds. make test + shakesmoke + buildsmoke green, 0 new divergences.

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 03:01:36 +00:00
Dmitri Sotnikov
8180c85393
Source locations: reader positions, error locations, native stack traces (#218)
* Reader records source line/column on list forms

The reader stamps 1-based :line/:column metadata on every list form (plus
:file when load-jolt-file is reading a file), and jolt.host/form-position
reads it back so the analyzer's :pos scaffold finally gets real data. A
left-to-right cursor counts newlines over the delta between successive forms,
so it stays O(n). Vector/map/set literals are untouched (their metadata is a
runtime value the analyzer would have to wrap in with-meta); empty () can't
carry meta. ^meta now merges onto the position keys instead of clobbering them.

Re-mint is byte-identical (the backend doesn't emit :pos), so this is a pure
scaffold for the error-location work that follows.

* Report source location on uncaught errors

Each top-level form records its source position (thread-local) before it
compiles+evals, and cli.ss jolt-report-uncaught appends 'at file:line:col'
when an error propagates out. Covers joltc -e, joltc run <file>, and
load-string — every interpreted path. Top-level granularity, one set per
form; deeper frames come from the Phase 2 frame walk.

Runtime .ss only, no re-mint.

* Clojure stack traces via source registry + native frame walk

A direct-link build emits (jolt-register-source! short-name ns name file line)
once per fn def — at definition time, so zero per-call cost. On an uncaught
error the reporter walks Chez's native continuation frames (jolt-throw captures
the live continuation via call/cc; host conditions carry their own
&continuation), maps each frame's procedure name through the registry, and
prints a Clojure backtrace 'ns/name (file:line)'. Wired into both the cli and a
built binary's launcher.

Frames are keyed by the short munged fn name Chez actually reports (emit-fn's
letrec self-binding), not jv$ns$name; a cross-namespace collision degrades to
the bare frame name rather than a wrong attribution. The analyzer carries the
original form's position through defn macroexpansion onto the def node.

Calling a non-fn now throws a catchable ClassCastException (via jolt-throw)
naming the operator, instead of a raw Chez error.

Caveats (documented in source-registry.ss): names map only in direct-link/AOT
closed-world builds — the open-world -e/repl/run path falls back to the
top-level location; and pervasive TCO erases tail-call frames, so a mapped
trace shows only the non-tail spine. JOLT_DEBUG_FRAMES dumps raw frame names.

Re-mint (analyzer + backend); prelude byte-identical (direct-link off during
mint). Corpus rows certified, build-smoke asserts the trace.

* Propagate source position through macroexpansion

hc-expand-1 now carries the macro call form's :line/:column onto the top of a
list expansion that has none of its own (merged under any meta the macro set),
so errors and stack traces in macro-generated code point at the call site —
Clojure parity. The analyze recursion re-expands inner macros, so each level's
top form picks it up, matching the reference compiler. (meta (macroexpand-1
'(when x y))) now reports the call-site line.

A direct-link fn defined through a user macro (build-app's defguarded) registers
with a real line, so build-smoke's trace assertion covers macro-defined fns.

Runtime .ss (host-contract.ss) — no re-mint; selfhost holds.

Phase 3's optional items are deferred: :line-in-ex-data has no clean consumer
(it would pollute ex-data, break = and printing, and positions already surface
via the trace + top-level location), and Chez source-object emission is a large
backend change the jv$-name registry already sidesteps.

* Review fixes: registration key, thread-locals, debug flag timing

- Register a fn under the name Chez actually reports for its frame, not the def
  name: a named fn literal whose name differs from the def (def foo (fn bar …))
  is framed as 'bar', and an anonymous fn def (def foo (fn …)) as jv$ns$foo.
  Both previously registered under the def name and so never appeared in traces.
- rdr-source-file / rdr-pos-cursor are thread parameters, so concurrent compiles
  (futures, core.async) don't clobber each other's file/line attribution.
- Read JOLT_DEBUG_FRAMES at call time: a built binary evaluates top-level forms
  at heap-build time, where a load-time getenv is always unset.

Re-mint (backend + reader); prelude byte-identical, selfhost holds.

---------

Co-authored-by: Yogthos <yogthos@gmail.com>
2026-06-26 02:14:34 +00:00
Dmitri Sotnikov
bdf436e242
Merge pull request #217 from jolt-lang/feat/bigdec-arithmetic
BigDecimal arithmetic (value-position + type-directed call-position)
2026-06-26 00:26:18 +00:00
Dmitri Sotnikov
838ff37207
Merge pull request #216 from jolt-lang/refactor/host-chez-java-folder
Group the JVM interop shims under host/chez/java/
2026-06-26 00:23:30 +00:00
Yogthos
09a9ad8c75 Add bigdec min/max (review follow-up)
Review found (< 1M 2M) worked but (min 1M 2M) threw — incoherent. Wire min/max
the same way as the other ops: value-position jolt-min/jolt-max shims (new in
seq.ss, added to core-value-procs) and call-position via bd-spec/bd-ops ->
jbd-min/jbd-max.

min/max return the original operand by value, not a coerced copy, matching
Clojure: (min 1M 2.0) -> 1M, (max 1M 2.0) -> 2.0, (min 1.50M 2M) -> 1.50M; a tie
keeps the second operand ((max 1.5M 1.50M) -> 1.50M). bigdec mixed with a flonum
in call position stays in the documented :any/contagion gap (value position
handles it). Re-mint; 6 more JVM-certified rows.
2026-06-25 20:22:26 -04:00
Yogthos
6fcc9fa8e6 BigDecimal call-position arithmetic via :bigdec type (Phase 2)
A direct (+ 1.5M 2.5M) emits a raw Chez + that rejects the bigdec record. Rather
than guard every arithmetic call site (measured 2-4x on unhinted fixnum loops),
let the analyzer dispatch where it can prove the type.

jolt.passes.numeric seeds a :bigdec kind from the M-literal and flows it through
let/loop/if like the existing :double/:long kinds; an arithmetic/comparison invoke
whose operands are all bigdec (integer literals allowed) gets :num-kind :bigdec.
The back end (bd-ops + emit-numeric) lowers those to the bigdec.ss engine
(jbd-add/-sub/-mul/-div, jbd-lt?/…, jbd-zero?/-pos?/-neg?, jbd-quot/-rem).

Zero cost on non-bigdec code: with no bigdec literals present the kind never
arises, so emission is byte-identical — the re-mint leaves prelude.ss unchanged,
only image.ss (the compiler) moves. Gaps (filed): a bigdec mixed with a flonum in
call position, and a bigdec the analyzer types :any, still hit the raw op and
throw; use value position or a literal-typed let.

Re-mint (numeric/backend are seed sources). 16 JVM-certified corpus rows.
2026-06-25 19:49:17 -04:00
Yogthos
bd7b75fb5d BigDecimal arithmetic: value-position + compare (Phase 1)
bigdec values existed but +,-,*,/ and compare threw — the header even said
"arithmetic contagion is not modelled". Add the scale-aware engine on the
{unscaled, scale} pair (jbd-add/-sub/-mul/-div + comparison helpers) following
java.math.BigDecimal's rules: add/sub align to the larger scale, multiply adds
scales, divide gives the exact quotient at minimal scale or throws
ArithmeticException on a non-terminating expansion. Clojure contagion: a bigdec
mixed with an integer stays bigdec, a flonum operand wins (result is a double).

Wire it into the value-position shims only — jolt-add/-sub/-mul/-div (what
(reduce + bigs)/(apply * bigs) lower to) and compare — so the inlined native hot
path is untouched. A call-position (+ 1.5M 2.5M) still reaches the raw Chez op;
that needs the analyzer's :bigdec type (next).

Runtime .ss only, no re-mint. 13 JVM-certified corpus rows.
2026-06-25 19:42:12 -04:00
Yogthos
ec9fde9e7e Group the JVM interop shims under host/chez/java/
The host/chez directory mixed jolt's own runtime (value model, seq, reader,
vars, ns, multimethods) with the shims that emulate the JVM: java.* / javax.*
classes, clojure.lang interfaces, and the host-class registry they hang off.
Move that JVM-emulation layer into host/chez/java/ so it reads as a distinct
unit instead of being interleaved with the platform runtime.

Moved (content unchanged): host-static, host-static-methods,
host-static-classes, host-class, dot-forms, records-interop, byte-buffer,
io, io-streams, inst-time, java-time, bigdec, natives-queue, natives-str,
natives-array, math, concurrency, async, ffi.

The load paths in rt.ss/cli.ss and the build.ss runtime manifest are updated
to point at java/; the build inliner follows the (load ...) strings, so the
AOT path needs no other change. All runtime shims, no seed source touched
(the three .clj edits are doc comments), so no re-mint.

Gate green: make test (selfhost fixpoint, certify 0-new, sci 211, infer),
shakesmoke (4 apps byte-identical).
2026-06-25 18:35:44 -04:00
Dmitri Sotnikov
5b77efa499
Merge pull request #215 from jolt-lang/cleanup/dedup-fresh-sym
Drop duplicate fresh-sym; clarify group-by-head vs parse-extend-impls
2026-06-25 21:38:23 +00:00
Yogthos
d77fd22bfe Drop the duplicate fresh-sym; clarify group-by-head vs parse-extend-impls
A post-conformance review (chiasmus) flagged fresh-sym defined byte-identically
in 00-syntax and 30-macros; 00-syntax loads first, so the second is redundant.
Also note why deftype uses group-by-head while extend-protocol uses
parse-extend-impls (the latter must treat a computed class type in head position).
No behavior change.
2026-06-25 17:35:18 -04:00
Dmitri Sotnikov
dcfe205a61
Merge pull request #214 from jolt-lang/fix/defn-docstring-assert-seqable
defn docstrings, assert throws AssertionError, Seqable covers collections
2026-06-25 21:26:41 +00:00
Yogthos
14ce46fb2a defn docstrings, assert throws AssertionError, Seqable covers collections
Conformance gaps surfaced re-running the library suites:

- defn now keeps a leading docstring as :doc metadata — it was dropped, so
  (:doc (meta #'f)) was always nil. Rides the def docstring slot.
- assert (and :pre/:post) throw a real AssertionError instead of an ex-info, so
  (catch AssertionError …) / (thrown? AssertionError …) match, with Clojure's
  "Assert failed: <msg>\n<form>" message.
- instance? clojure.lang.Seqable was conflated with ISeq, so a vector/map read
  as not-Seqable. Split them: Seqable covers every persistent collection, ISeq
  only seqs.
2026-06-25 17:23:24 -04:00
Dmitri Sotnikov
60e129a95c
Merge pull request #213 from jolt-lang/conformance/aws-api-host-shims
Host shims and protocol fixes shaken out by aws-api
2026-06-25 21:03:37 +00:00
Yogthos
829c251bca Host shims and protocol fixes shaken out by aws-api
Running cognitect aws-api's pure test namespaces (signing/shapes/protocols/
util/retry/endpoints) surfaced general gaps:

- extend-protocol/extend-type accept a computed class type, e.g.
  (Class/forName "[B") for the byte-array class — the byte-array idiom data.json
  and aws-api use. The macro grouping handled only symbol/nil heads (it crashed on
  a list type); type->name resolves a Class value via .getName; a byte-array
  dispatches on the "[B" host tag.
- java.nio.ByteBuffer over a jolt byte-array (wrap/allocate/get/put/array/
  remaining/position/limit/duplicate/flip), plus extend-protocol to it.
- java.util.Arrays (equals/copyOf/copyOfRange/fill) and java.util.Random
  (nextBytes/nextInt/…).
- java.net.URI/create and clojure.lang.RT/baseLoader statics.
- clojure.core.async/promise-chan (deliver-once, peek-don't-pop).
- a failed java.time parse throws DateTimeParseException (typed), so
  (catch DateTimeParseException …) matches it instead of leaking an untyped
  condition.

The XML side lives in the jolt-lang/xml library (libxml2 over jolt.ffi); ByteBuffer
stays in core as a generic java.nio primitive.

Gate: make test green (corpus +6 JVM-certified rows, 0 NEW divergence; unit
553/553; SCI 211).
2026-06-25 16:56:48 -04:00
Dmitri Sotnikov
05f29d1bcb
Merge pull request #212 from jolt-lang/conformance/core-memoize
Run core.memoize's test suite on jolt
2026-06-25 17:26:22 +00:00
Yogthos
d21ab77e7e 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.
2026-06-25 13:23:05 -04:00
Dmitri Sotnikov
3dde290f1a
Merge pull request #211 from jolt-lang/docs/host-interop-concurrency-refs
docs: host-interop for the new concurrency + reference shims
2026-06-25 15:46:26 +00:00
Yogthos
d06c7a0acc docs: host-interop — Thread/CountDownLatch, Soft/WeakReference + ReferenceQueue, ConcurrentHashMap, System/gc, Class/forName 2026-06-25 11:42:44 -04:00
Dmitri Sotnikov
ec792d28a0
Merge pull request #210 from jolt-lang/feat/gc-weak-references
Soft/WeakReference: real GC eviction via Chez weak pairs + guardians
2026-06-25 15:36:00 +00:00
Yogthos
80b2dfa9f9 Soft/WeakReference: real GC eviction via Chez weak pairs + guardians
Replace the strong-ref stub with genuine reclamation. The referent is held
through a weak-cons, so Chez's generational collector reclaims it once it is
otherwise unreachable (the pair's car becomes the bwp object, and .get returns
nil). A guardian registered on the referent makes the reference itself available
the instant its referent is collected, which ReferenceQueue.poll surfaces as
enqueued — the same hook clojure.core.cache's clear-soft-cache! drains.

Chez has no softer-than-weak reference, so a SoftReference clears on
unreachability rather than under memory pressure: a SoftCache evicts more eagerly
than the JVM's but is now real GC eviction, not an unbounded strong cache.
WeakReference gets the same (faithful) semantics. Added System/gc -> a full
collect so callers (and the queue) can force the cycle.

core.cache stays 1314/0/0 (its test values are immortal literals). Corpus row for
System/gc; make test + shakesmoke green.
2026-06-25 11:32:32 -04:00
Dmitri Sotnikov
e955b2072a
Merge pull request #209 from jolt-lang/fix/delay-exn-deftype-method-merge
core.cache: full conformance (delay/deftype/dispatch fixes + Thread/CountDownLatch/SoftReference)
2026-06-25 15:19:27 +00:00
Yogthos
774c6c0795 docs: list core.cache 2026-06-25 11:16:17 -04:00
Yogthos
9312ad0937 Thread/CountDownLatch + SoftReference/ConcurrentHashMap so core.cache fully passes
Closes the last clojure.core.cache gaps (now 1314/0/0, including the 1000-thread
cache-stampede):

- java.lang.Thread over Chez fork-thread (shared heap): (Thread. thunk) + start/
  join/run/isAlive, on a "user-thread" tag distinct from Thread/currentThread's
  interrupt shim. java.util.concurrent.CountDownLatch (count/mutex/condition).
- java.util.concurrent.ConcurrentHashMap = the mutable HashMap shim; get / count /
  contains? read it (clojure.core), which SoftCache uses on its backing map.
- java.lang.ref.SoftReference / ReferenceQueue: no JVM GC reference semantics, so
  the referent is held strongly (a SoftCache is unbounded rather than GC-evicting),
  but enqueue / poll work so clear-soft-cache! drains the queue.

JVM-certified corpus rows. make test + shakesmoke green.
2026-06-25 11:15:12 -04:00
Yogthos
5d0989a860 delay exception memoization, deftype cross-protocol method merge, more map-like dispatch
Further clojure.core.cache fixes (198 -> 257 of its assertions):

- delay: a throwing body re-ran on every force and never became realized?. Run it
  once like Clojure's Delay — cache the exception, mark realized, re-throw the same
  on each deref. Fixes value-fn memoization / cache-stampede protection.
- deftype/defrecord: a method name appearing in two protocols with different
  arities (data.priority-map's seq is in IPersistentMap [this] AND Sorted
  [this asc]) registered per-protocol and shadowed; merge clauses by name across
  all protocols into one multi-arity fn.
- empty?/peek/pop (IPersistentStack) dispatch through a deftype's methods; (= a-
  deftype other) uses its equiv method (so caches compare to their backing map);
  seq handles a host iterator (iterator-seq over .iterator).
- pop of an empty PersistentQueue returns it, like the JVM (was an error).

JVM-certified corpus rows. make test + shakesmoke green.
2026-06-25 10:57:31 -04:00
Dmitri Sotnikov
c445aaeaa2
Merge pull request #208 from jolt-lang/fix/destructure-or-prepost-deftype-dispatch
Destructuring :or, fn :pre/:post, deftype field access + map-like dispatch
2026-06-25 14:09:39 +00:00
Yogthos
b21b99b275 destructuring :or, fn :pre/:post, deftype field access + map-like dispatch
General fixes shaken out running clojure.core.cache (66 -> 198 of its assertions):

- Map destructuring applied an :or default only for :keys/:strs/:syms, not a
  direct {x :x} binding — so {x :x :or {x 9}} (and the & {…} kwargs form) ignored
  the default. Apply it for the direct binding too.
- fn didn't implement :pre/:post: a leading conditions map was evaluated as a body
  literal (so % was unbound and (.q %) blew up). Recognize it and assert pre
  before the body, bind % to the result, assert post, return %.
- (.q inst) on a deftype field with no matching method reads the field, like the
  JVM (was "No method q").
- A deftype implementing the clojure.lang collection interfaces now dispatches
  dissoc (without), contains? (containsKey), peek/pop (IPersistentStack), and
  keys/vals (via its Seqable seq) through its methods — they were field-only, so
  core.cache's caches and data.priority-map didn't behave as maps.

JVM-certified corpus rows for each. make test + shakesmoke green.
2026-06-25 10:06:33 -04:00
Dmitri Sotnikov
93b4d101a1
Merge pull request #207 from jolt-lang/fix/io-copy-htable-input-stream
io/copy: drain a byte-input-stream shim source
2026-06-25 13:04:21 +00:00
Yogthos
7952b1fe03 io/copy: drain a byte-input-stream shim source
input-bytes handled in-stream/bytevector/byte-array sources but not a host
byte-input-stream table (:jolt/input-stream — http-client's ByteArrayInputStream),
so io/copy fell through to rendering it as text (#[chez-htable …]) instead of its
bytes. Drain it like slurp does. Fixes http-client's response-body handling
(jolt-bjbi): its suite goes 100/16-fail -> 116/0, and the ring adapter's.
2026-06-25 09:01:02 -04:00
Dmitri Sotnikov
19b19fb83f
Merge pull request #204 from jolt-lang/feat/ring-defaults-host-interop
Host interop + deps fixes for ring-defaults on jolt
2026-06-25 10:40:46 +00:00
Yogthos
b2f671989d docs: list ring-defaults (via jolt-crypto) 2026-06-25 06:37:27 -04:00
Yogthos
65c8072ec8 io/copy: write to a byte-output-stream shim
io/copy handled file/stream/writer targets but not a host byte-output-stream
table (jolt-lang/http-client's ByteArrayOutputStream shim, :jolt/output-stream),
erroring 'don't know how to write to'. Dispatch through the shim's .write method,
byte-exact for a byte source — the JVM's io/copy writes to any OutputStream.
2026-06-25 06:29:57 -04:00
Yogthos
635cab0e49 host interop + deps fixes for running ring-defaults on jolt
Shaken out getting ring-defaults (and its ring-core/anti-forgery/session stack)
to load and serve static resources on jolt. All general fixes, all runtime:

- Class/forName throws a catchable ClassNotFoundException for a class jolt can't
  back (it returned a broken truthy value for any name, and crashed on use). Lets
  the common (try (Class/forName "optional.Dep") (catch ...)) probe libraries use
  to detect an absent dependency work — e.g. ring's joda-time check.
- deps: reconcile native libs (and source roots) in one step, deduped by library
  identity, instead of the ad-hoc distinct at each call site. An app pulling two
  libs that declare the same shared object (libcrypto via both jolt-crypto and
  http-client) now includes and loads it once.
- io: a File answers getProtocol ("file") / getFile so resource-serving
  middleware that expects io/resource to hand back a file: URL works; the
  classloader gains getResources (every source root holding the resource).
- clojure.string/replace accepts a char match/replacement, like the JVM.

JVM-certified corpus rows for the Class/forName and string/replace behavior.
2026-06-25 04:42:35 -04:00
Dmitri Sotnikov
16528e8637
Merge pull request #203 from jolt-lang/docs/libraries-conformance-directive
core.match: full support (regex + array patterns) + library-conformance directive
2026-06-25 04:50:41 +00:00
Yogthos
47b4971367 remove agent files 2026-06-25 00:47:23 -04:00
Yogthos
67e642bdfb core.match: regex + array patterns (full support); library-conformance directive
Finishes core.match — its full test suite (115/115) now passes, including the
two patterns the earlier work left out:

- Regex-literal patterns. A #"…" now reads as a regex VALUE (Clojure parity: the
  reader constructs the Pattern, so a macro receives a regex, not jolt's tagged
  form), and the analyzer compiles a regex value to the same :regex IR leaf via
  its source. emit-quoted handles a quoted regex; a regex value carries the
  java.util.regex.Pattern host tag so extend-protocol/instance? dispatch on it.
- Primitive-array patterns. A ^Type hint's :tag is now the SYMBOL (e.g. `ints`),
  matching the JVM, so core.match's array-tag lookup engages the array
  specialization (alength/aget). jolt's :tag consumers already tolerate a symbol
  (hc-cell-num-ret normalizes; tag->nkind/def-meta handle both).

Also: a library-conformance directive in CLAUDE.md, and the supported-libraries
list (docs + site) simplified to one-line entries — a listed library is assumed
to work fully, so no tallies or feature enumerations. core.match + transit-jolt
added to the list.

Seed change (reader/backend/30-macros) -> re-minted; the rest runtime. JVM-
certified corpus rows; the stale `symbol hint -> :tag` divergence is dropped from
the allowlist (jolt now matches the JVM). make test + shakesmoke green.
2026-06-25 00:46:10 -04:00
Yogthos
5737a39b7c docs: list core.match; add library-conformance directive to CLAUDE.md 2026-06-25 00:19:59 -04:00
Dmitri Sotnikov
d8683b0598
Merge pull request #202 from jolt-lang/feat/deftype-clojure-lang-interfaces
deftype/record: clojure.lang collection interfaces + protocol identity
2026-06-25 04:17:58 +00:00
Yogthos
f5455115a0 deftype/record: clojure.lang collection interfaces + protocol identity
Running clojure.core.match (a macro-heavy library that builds its compiler out
of deftypes implementing clojure.lang interfaces) shook out a cluster of general
gaps. Its own suite goes from not-loading to 111/115 assertions.

- deftype/defrecord implementing a clojure.lang collection interface now drives
  the core fns: Indexed -> nth, Counted -> count, Associative -> assoc, ILookup
  -> get/valAt (non-field keys only, so a method's own field bindings don't
  recurse), ISeq -> seq/first/rest, IPersistentCollection -> conj, IFn -> the
  value is callable. A jrec is still a map of fields by default; the interface
  method wins when declared.

- Multi-arity inline methods are grouped into one fn (a type with (nth [_ i]) and
  (nth [_ i x]) kept only the last before). Built as data, not a nested
  syntax-quote, so a `(= ~ocr ~l) method body keeps its unquotes.

- instance?/satisfies? recognize a protocol a type implements, including a MARKER
  protocol with no methods (core.match's IPseudoPattern) — deftype/defrecord now
  record protocol satisfaction even with zero methods. Added ILookup/Indexed/
  Counted to the instance? taxonomy for the built-in collections.

- Syntax-quote: a fully-qualified class name (clojure.lang.ILookup) stays bare
  instead of being namespace-qualified; (unquote x) is detected in a lazy seq
  (a macro that builds its template with map, e.g. deftype's rewrite-set).

- clojure.set union/intersection/difference are variadic (& sets) + union 0-arity.
- java map view methods: keySet/values/entrySet/size/isEmpty.
- deprecated java.util.Date getters (getYear/getMonth/...) + the multi-arg
  (Date. year-1900 month0 date hrs min) constructor.

Seed change (deftype/defrecord macros + clojure.set) -> re-minted; the rest are
runtime. 11 JVM-certified corpus rows; make test + shakesmoke green.
2026-06-25 00:14:19 -04:00
Dmitri Sotnikov
3cbfa8719c
Merge pull request #201 from jolt-lang/fix/edn-unknown-tag
edn: clean exception for an unknown reader tag
2026-06-25 03:13:35 +00:00
Yogthos
fb2749ac4c edn: clean exception for an unknown reader tag
clojure.edn's __read-tagged seam called (empty-pmap) — applying the empty-pmap
VALUE as a procedure — so an unknown tag (e.g. #object[...] from a JVM-printed
object, or any unregistered #foo) crashed the Chez VM with "attempt to apply
non-procedure" and surfaced a malformed condition (class :object, nil message)
instead of a catchable error.

Throw a clean ex-info naming the tag, matching the JVM's "No reader function
for tag <tag>". A reader port over edn (transit-jolt's read-conformance skip
path, aero, etc.) now catches a real exception instead of aborting.

clojure.core/read-string stays lenient (returns the tagged form) so clojure.edn
can apply :readers / :default before falling through to this throw.
2026-06-24 23:09:07 -04:00
Dmitri Sotnikov
9c48440a43
Merge pull request #200 from jolt-lang/feat/java-io-streams
java.io: full File API + byte/char streams over Chez ports
2026-06-25 02:17:02 +00:00
Yogthos
1853d827bd java.io: full File API + byte/char streams over Chez ports
Expand java.io so libraries that touch the filesystem work unchanged.

File: the full method surface — length, lastModified, can{Read,Write,Execute},
isHidden, list, mkdir(s), delete, createNewFile, renameTo, getParentFile,
get{Absolute,Canonical}File, compareTo/equals/hashCode — plus the statics
separator / pathSeparator / createTempFile / listRoots. A File now keeps the
path as given (new File("rel").getPath() is "rel", .isAbsolute false); a
relative path resolves against JOLT_PWD only when the filesystem is touched,
matching the JVM. slurp/spit and the dir helpers go through the same
resolution, fixing a spit-vs-slurp inconsistency.

Streams (host/chez/io-streams.ss) — each a jhost wrapping a Chez port, so
buffering, EOF and binary<->char transcoding come from Chez:
- FileInputStream / FileOutputStream / ByteArrayInputStream /
  ByteArrayOutputStream / BufferedInputStream / BufferedOutputStream
- FileReader / FileWriter / InputStreamReader / OutputStreamWriter /
  BufferedReader / BufferedWriter
Buffered* return the wrapped stream (Chez ports are already buffered).

clojure.java.io: input-stream/output-stream now yield real byte streams (were
aliased to the char reader/writer); added copy (byte-exact for byte sources),
make-parents, delete-file. with-open also closes file-writer/port-writer/
print-writer (a pre-existing gap).

All runtime shims, no re-mint. 15 JVM-certified corpus rows; make test +
shakesmoke green.
2026-06-24 22:12:46 -04:00
Dmitri Sotnikov
7bc4288e98
Merge pull request #199 from jolt-lang/feat/tick-dst-nano-data-readers
java.time DST + data readers: make tick pass fully
2026-06-25 01:33:41 +00:00
Yogthos
7b1ec9a1d3 java.time DST + data readers: make tick pass fully
Shaking out tick's api and alpha.interval suites (api 353->359, interval
0->103 passing) cleared a set of general gaps:

- Named-zone DST. Zones resolved to a fixed representative offset, so
  America/New_York in August read -05:00 not -04:00. Add US/EU DST rules
  (compact transition-date math) and make instant<->zoned, the zone rules'
  getOffset, and the zoned equality arm DST-aware.

- Nanosecond zoned/offset times. Instant is nanos but atZone/atOffset/
  toInstant/withZoneSameInstant and Instant/parse went through epoch-ms,
  truncating sub-ms. Route them through nanos.

- Locale month/day names. A formatter dropped its Locale; carry it and add
  French names so MMM under Locale/FRENCH renders "mai".

- Callable records. A defrecord implementing clojure.lang.IFn (tick's
  GeneralRelation) is now invokable: jolt-invoke dispatches to its inline
  invoke method. Also give collections the Iterable host tag so a protocol
  extended to Iterable matches vectors/seqs.

- Imported class short names. (:import [java.time ZonedDateTime]) then
  (. ZonedDateTime parse s) resolved to nil; an otherwise-unresolved bare
  Capitalized name that's a registered host class now resolves as a class.

- Data readers. A project's data_readers.{clj,cljc} is loaded into
  *data-readers* (reader namespaces required eagerly); registered #tag
  literals in source rewrite to (reader-fn 'form). clojure.core/read-string
  now applies #inst/#uuid/#"regex" and *data-readers* like Clojure.

- Duration/between accepts zoned/offset date-times.

All runtime shims, no re-mint. docs/libraries.md: tick full pass + aero.
2026-06-24 21:30:05 -04:00
Dmitri Sotnikov
8d7d03bfbc
Merge pull request #198 from jolt-lang/docs/libraries-spec-tick-json
libraries: add data.json, spec.alpha, tick
2026-06-25 00:41:52 +00:00
Yogthos
d75f06980f libraries: add data.json, spec.alpha, tick 2026-06-24 20:38:43 -04:00
Dmitri Sotnikov
462d53a28e
Merge pull request #197 from jolt-lang/spike/special-form-precedence
Make clojure.spec.alpha load and run
2026-06-25 00:36:13 +00:00
Dmitri Sotnikov
866b8c47d4
Merge pull request #196 from jolt-lang/spike/instant-nanos
java.time.Instant: nanosecond precision
2026-06-25 00:35:43 +00:00
Yogthos
7a343351d6 Make clojure.spec.alpha load and run
Four general gaps, shaken out by loading clojure.spec.alpha:

- Special forms were shadowable by a same-named macro. analyze-list
  macroexpanded before checking special forms, so a ns that redefs def/and/or
  (spec excludes them via :refer-clojure :exclude) made a bare def resolve to
  the macro instead of the special form, breaking every defn after. Now a head
  in the special-form set is never macroexpanded, matching the reference
  macroexpand1 isSpecial check.

- reify dropped all but the last arity of a multi-arity protocol method (spec
  reifies (specize* [s]) and (specize* [s _])). The macro keyed methods by name
  and overwrote; now it groups arities into one multi-arity fn.

- reify instances did not implement IObj: with-meta threw and (instance?
  clojure.lang.IObj r) was false. Every Clojure reify carries metadata. with-meta
  now copies the reify to a fresh identity (shared method table) and keys its
  meta; instance? IObj/IMeta is true for any reify. This was the registry bug —
  spec's with-name returned nil for specs, so get-spec missed.

- (set! (. Class field) val) was rejected. spec toggles
  clojure.lang.RT/checkSpecAsserts this way; the analyzer now lowers it to a
  jolt.host/set-static-field! call over a mutable-statics table, and a plain
  Class/field read consults that table.

Also: .name/.getName on a Namespace and .ns/.sym on a Var (spec's ns-qualify /
->sym). analyzer + reify are seed sources (re-minted). spec.alpha now does
valid?/conform/cat/keys/explain-str/check-asserts. tick.alpha.interval-test still
needs time-literals data readers (separate).
2026-06-24 19:46:22 -04:00
Yogthos
f417516148 java.time.Instant: nanosecond precision
The Instant jhost stored epoch-ms, so plusNanos/getNano rounded to the
millisecond and two instants a nanosecond apart compared =. Store epoch-nanos
instead: mk-instant still takes ms (scales to nanos) for the ms-based zone/Date
callers, mk-instant-nanos/inst-nanos own the nano arithmetic, and inst-ms floors
nanos back to ms. plus/minus/getNano/truncatedTo/compare/equals and the ISO
renderer all run on nanos; toString shows the fraction in 3/6/9-digit groups like
ISO_INSTANT. Fixes tick's interval coincidence test (shift end by one nano).
2026-06-24 19:10:58 -04:00
Dmitri Sotnikov
dcfc764b69
Merge pull request #195 from jolt-lang/spike/java-time-phase1
java.time on Chez: LocalDate..ZonedDateTime + formatters — runs tick (api_test 352/7)
2026-06-24 22:51:33 +00:00
Yogthos
a05eeefb08 java.time Phase 3: zones, offsets, ZonedDateTime, formatters — tick runs
ZoneOffset/ZoneId (SHORT_IDS, fixed-offset + UTC + system; named zones via a
fixed-offset table), ZonedDateTime/OffsetDateTime/OffsetTime, Clock (fixed/
system, with now [clock] arity), and DateTimeFormatter integration (ofPattern
+ ISO_* constants, .format/.parse over the rich java.time values via the
inst-time.ss pattern engine). systemDefault resolves to UTC to keep the
#inst atZone/toInstant round-trip machine-tz-independent.

tick.core + tick.protocols + tick.locale-en-us load; tick's api_test runs
31 tests / 352 pass / 7 fail / 0 error. The 7 are host gaps: named-zone DST
(no tzdb), French locale month names (no locale DB), nanosecond Instant.

General fixes surfaced by tick: :ns/keys map destructuring ({:tick/keys [..]})
in 00-syntax.clj (re-minted), and extend-protocol to java.time classes
(records.ss host-type-set). 12 corpus rows certified vs JVM. make test +
shakesmoke green, selfhost holds, 0 new divergences, data.json stays 138/139.
2026-06-24 18:45:46 -04:00
Yogthos
e3c14e656c java.time Phase 2: Duration/Period, enums, ChronoUnit/Field machinery
Duration (ISO PT.. toString, between, full arithmetic), Period (between with
borrow, P.. toString, normalized), full Month/DayOfWeek enums (named constants,
print as their name — fixes the Phase-1 raw-jhost print), Year, YearMonth
(2020-02 toString, leap, atDay/atEndOfMonth), ChronoUnit (between/getDuration)
and ChronoField. The temporal machinery on the Phase-1 types now works with
ChronoUnit/ChronoField: (.plus t n DAYS), (.until t1 t2 unit), (.get/.getLong
t field), (.with t field v), (.isSupported ..), (.truncatedTo ..).

Analyzer: (. Class method args) with a class target lowers to a static call
(Class/method args) instead of mis-dispatching as an instance call on the arg
— matches JVM; needed by cljc.java-time.year. Seed re-minted; selfhost holds.

The Phase-2 cljc.java-time namespaces load; tick.core advances to a Phase-3
zone gap. 10 corpus rows certified vs JVM. make test + shakesmoke green, 0 new
divergences, data.json stays 138/139.
2026-06-24 18:10:40 -04:00
Yogthos
c0561a8d14 java.time Phase 1: LocalDate/LocalTime/LocalDateTime/Instant
Core java.time value types as jolt host objects backed by the inst-time.ss
calendar engine (days-from-civil/civil-from-days/inst-fields/format-ms), in a
new host/chez/java-time.ss. tz-free reps: LocalDate=epoch-day,
LocalTime=nano-of-day, LocalDateTime=(epoch-day,nano-of-day); Instant reuses
the ms-based instant jhost (ms granularity; nano is a documented gap). Each
type registers statics (of/parse/now/MIN/MAX/...), instance methods
(plus/minus/with/get/isBefore/until/toString/...), =/hash, compare,
ISO-8601 print, instance?, and value-host-tags for protocol dispatch.

Reconciles the old ms-based local-date/local-dt stubs into the rich types
(LocalDateTime now prints ISO; .toLocalDate/.atZone paths preserved). The
four cljc.java-time namespaces (local-date/local-time/local-date-time/instant)
load. Deep temporal-field/unit machinery (range/get-long/with-field/until/
adjust-into) stubbed for Phase 2.

12 corpus rows certified vs JVM 1.12.5. make test + shakesmoke green, 0 new
divergences, data.json stays 138/139, selfhost holds.
2026-06-24 17:44:32 -04:00
Dmitri Sotnikov
e94ddb2ffe
Merge pull request #194 from jolt-lang/spike/datajson-final
data.json: Calendar/java.time, java.sql.Date class, JVM-faithful Class value (suite 138/139)
2026-06-24 20:49:57 +00:00
Yogthos
8c7b98e5f2 (class x) returns a JVM-faithful Class value
class / .getClass now return a Class value that renders like the JVM —
(str c)/.toString -> "class <name>", pr -> "<name>", .getName/.getSimpleName/
.getCanonicalName work — but stays = and hash equal to its name string, so
(= (class x) String), class-keyed maps, multimethod dispatch on class, and
instance? keep working against the bare class-name tokens. instance? unwraps
a Class passed as the type arg.

clojure.test/class-match? no longer assumes (class e) is a string (a jolt-ism;
on the JVM a Class isn't a string either) — reads the name via .getName.

Matches JVM Class.toString, which libraries surface in error messages
(clojure.data.json DJSON-54 expects "...of class java.net.URI"). data.json
suite 139/139 bar the one UTF-16 surrogate test (Unicode-scalar char model).

5 corpus rows certified vs JVM; make test + shakesmoke green, 0 new divergences.
2026-06-24 16:46:09 -04:00
Yogthos
9092b30f8b java.util.Calendar + java.time round-trip + java.sql.Date class
java.util.Calendar (a UTC calendar over epoch-ms): getInstance, the int
field constants, set/get/setTime/getTime/getTimeInMillis. java.time pieces
for a zoned round-trip: DateTimeFormatter/ISO_ZONED_DATE_TIME, formatter
.withZone/.parse, LocalDateTime/parse (with formatter), Instant/from,
.toLocalDate/.atStartOfDay. java.sql.Date is now a distinct class (its own
host value + dispatch tags) so a protocol extended to both java.util.Date
and java.sql.Date routes a sql.Date to its own impl. All UTC-consistent.

data.json print-sql-date + print-time-supports-format pass (suite 137/139).
2026-06-24 16:31:59 -04:00
Dmitri Sotnikov
7e10904e8c
Merge pull request #193 from jolt-lang/spike/pprint-port
Port real clojure.pprint (pretty-printer + cl-format); data.json pprint passes
2026-06-24 20:17:38 +00:00
157 changed files with 21215 additions and 6594 deletions

236
.github/workflows/release.yml vendored Normal file
View file

@ -0,0 +1,236 @@
name: release
# Build the self-contained joltc binary for each platform and attach it to the
# GitHub Release when a v* tag is pushed. The binary bundles the runtime,
# compiler, jolt-core + stdlib source, the Chez boots, and a launcher stub, so it
# runs AND compiles jolt apps with no Chez or cc on the user's machine (jolt-eaj).
#
# No Apple notarization, mirroring dirge: macOS users who download the tarball
# clear Gatekeeper quarantine once (`xattr -d com.apple.quarantine joltc`), or
# install via a Homebrew tap that de-quarantines on install.
on:
push:
tags:
- 'v*'
workflow_dispatch: {} # dry-run the build matrix without tagging
permissions:
contents: write # create/update the GitHub Release and upload assets
jobs:
build:
name: build ${{ matrix.target }}
runs-on: ${{ matrix.os }}
strategy:
fail-fast: false
matrix:
include:
- os: ubuntu-latest
target: x86_64-linux
shell: bash
# No x86_64-macos: GitHub is retiring the macos-13 Intel runner (jobs
# queue forever). Intel Macs build from source. macos-14 is arm64.
- os: macos-14
target: aarch64-macos
shell: bash
- os: windows-latest
target: x86_64-windows
shell: msys2 {0}
defaults:
run:
shell: ${{ matrix.shell }}
steps:
- uses: actions/checkout@v5
with:
submodules: recursive # vendor/irregex, used by the Chez regex shim
# --- Linux: build Chez from source. The apt chezscheme ships petite+scheme
# only, with no kernel dev files (libkernel.a, scheme.h), which build-joltc
# needs to cc-link. Same setup as .github/workflows/tests.yml. ---
- name: Install build dependencies (Linux)
if: runner.os == 'Linux'
run: |
sudo apt-get update
sudo apt-get install -y build-essential git liblz4-dev zlib1g-dev libncurses-dev uuid-dev
- name: Cache Chez Scheme (Linux)
if: runner.os == 'Linux'
id: cache-chez
uses: actions/cache@v4
with:
path: /opt/chez
key: chez-${{ runner.os }}-v10.4.1-x11off
- name: Build Chez Scheme from source (Linux)
if: runner.os == 'Linux' && steps.cache-chez.outputs.cache-hit != 'true'
run: |
git clone --depth 1 --branch v10.4.1 https://github.com/cisco/ChezScheme.git /tmp/chez-src
cd /tmp/chez-src
./configure --installprefix=/opt/chez --threads --disable-x11
make -j"$(nproc)"
sudo make install
sudo chown -R "$USER" /opt/chez
- name: Put chez on PATH (Linux)
if: runner.os == 'Linux'
run: |
# Installed as `scheme`; the build invokes `chez`. A wrapper that execs
# scheme keeps argv0 so Chez finds its boot files, and sits next to
# scheme so build.ss derives the csv dir (libkernel.a/scheme.h) from it.
printf '#!/bin/sh\nexec /opt/chez/bin/scheme "$@"\n' > /opt/chez/bin/chez
chmod +x /opt/chez/bin/chez
echo '/opt/chez/bin' >> "$GITHUB_PATH"
# --- macOS: Homebrew chezscheme ships `chez` plus the csv kernel dev files
# (libkernel.a, scheme.h, *.boot), which is all build-joltc needs. ---
- name: Install Chez Scheme (macOS)
if: runner.os == 'macOS'
run: brew install chezscheme lz4
# --- Windows: MSYS2/MinGW-w64 toolchain + Chez built from source (ta6nt).
# The whole job runs in the msys2 shell so cc/xxd/paths behave; the
# produced joltc.exe is a plain Windows binary (no MSYS runtime dep). ---
- name: Set up MSYS2 (Windows)
if: runner.os == 'Windows'
uses: msys2/setup-msys2@v2
with:
msystem: MINGW64
update: false
# inherit the runner PATH so GITHUB_PATH additions (the chez wrapper
# dir) are visible inside the msys2 shell
path-type: inherit
install: >-
git make vim unzip zip
mingw-w64-x86_64-gcc
mingw-w64-x86_64-lz4
mingw-w64-x86_64-zlib
mingw-w64-x86_64-ntldd
- name: Cache Chez Scheme (Windows)
if: runner.os == 'Windows'
id: cache-chez-win
uses: actions/cache@v4
with:
path: chez-install
key: chez-${{ runner.os }}-v10.4.1-mingw64
- name: Build Chez Scheme from source (Windows)
if: runner.os == 'Windows' && steps.cache-chez-win.outputs.cache-hit != 'true'
run: |
git clone --depth 1 --branch v10.4.1 https://github.com/cisco/ChezScheme.git /tmp/chez-src
cd /tmp/chez-src
./configure --threads
make -j"$(nproc)"
# `make install` drives the unix installsh through cmd and dies; the
# build tree has everything — assemble the layout by hand. Boot files
# sit next to scheme.exe (that's where the Windows kernel looks).
inst="$GITHUB_WORKSPACE/chez-install"
mkdir -p "$inst/bin" "$inst/csv"
cp ta6nt/bin/ta6nt/*.exe "$inst/bin/"
cp ta6nt/bin/ta6nt/*.dll "$inst/bin/" 2>/dev/null || true
cp ta6nt/boot/ta6nt/petite.boot ta6nt/boot/ta6nt/scheme.boot "$inst/bin/"
cp ta6nt/boot/ta6nt/petite.boot ta6nt/boot/ta6nt/scheme.boot "$inst/csv/"
cp ta6nt/boot/ta6nt/scheme.h "$inst/csv/"
cp ta6nt/boot/ta6nt/equates.h "$inst/csv/" 2>/dev/null || true
cp ta6nt/boot/ta6nt/libkernel.a "$inst/csv/" || { echo "libkernel.a not found:"; find ta6nt -name "*.a" -o -name "kernel*"; exit 1; }
- name: Put chez on PATH (Windows)
if: runner.os == 'Windows'
run: |
bindir="$GITHUB_WORKSPACE/chez-install/bin"
{ echo '#!/bin/sh'; echo "exec \"$bindir/scheme.exe\" \"\$@\""; } > "$bindir/chez"
chmod +x "$bindir/chez"
echo "$bindir" >> "$GITHUB_PATH"
echo "JOLT_CHEZ_CSV=$GITHUB_WORKSPACE/chez-install/csv" >> "$GITHUB_ENV"
# cc is the build's compiler name; alias it to mingw gcc
{ echo '#!/bin/sh'; echo 'exec gcc "$@"'; } > "$bindir/cc"
chmod +x "$bindir/cc"
- name: Show Chez version
run: chez --version
# build-joltc compiles in a fresh Chez and cc-links; the checked-in seed is
# the compiler image, so no selfhost re-mint (that byte-fixpoint is a
# dev-machine check — see jolt-8479). `make joltc-release`, not `make joltc`.
- name: Build joltc (release)
run: make joltc-release
env:
# Bake the release tag into the binary (build-joltc falls back to
# `git describe` when this is empty, e.g. a workflow_dispatch dry run).
JOLT_VERSION: ${{ startsWith(github.ref, 'refs/tags/') && github.ref_name || '' }}
- name: Inspect the binary (Windows)
if: runner.os == 'Windows'
run: |
set +e
ls -la target/release/
ntldd target/release/joltc.exe 2>&1 | head -20
./target/release/joltc.exe -e '(+ 1 2)'
echo "exit=$?"
# Sanity: the built binary runs (no Chez needed) and self-reports a value.
- name: Smoke the binary
run: |
out="$(./target/release/joltc -e '(reduce + (range 10))')"
test "$out" = "45" || { echo "joltc -e gave '$out', want 45"; exit 1; }
# The binary is a self-contained COMPILER: it must `build` an app with no
# jolt source on disk. Run from an isolated dir (nothing but the tiny app)
# so a build that reaches for host/chez/*.ss on the filesystem fails here,
# not on a user's machine.
- name: Smoke a self-contained build
run: |
joltc="$(pwd)/target/release/joltc"
work="$(mktemp -d)"
mkdir -p "$work/app/src/app"
printf '{:paths ["src"]}\n' > "$work/app/deps.edn"
printf '(ns app.core)\n(defn -main [& _] (println "built:" (reduce + (range 10))))\n' \
> "$work/app/src/app/core.clj"
( cd "$work/app" && "$joltc" build -m app.core -o app )
out="$("$work/app/app")"
test "$out" = "built: 45" || { echo "self-contained build ran '$out', want 'built: 45'"; exit 1; }
# A built binary must also run the DYNAMIC require path: a namespace not
# in the static ns graph compiles from the source roots at runtime, so the
# boot's top-level defines must be visible to the runtime compiler's eval
# (issue #290: this died with "variable var-deref is not bound").
- name: Smoke a runtime require in a built binary
run: |
joltc="$(pwd)/target/release/joltc"
work="$(mktemp -d)"
mkdir -p "$work/app/src/app"
printf '{:paths ["src"]}\n' > "$work/app/deps.edn"
printf '(ns app.extra)\n(defn greet [s] (str "Hello, " s "!"))\n' \
> "$work/app/src/app/extra.clj"
printf '(ns app.core)\n(defn -main [& _]\n (println ((requiring-resolve (quote app.extra/greet)) "runtime")))\n' \
> "$work/app/src/app/core.clj"
( cd "$work/app" && "$joltc" build -m app.core -o app )
out="$(cd "$work/app" && ./app)"
test "$out" = "Hello, runtime!" || { echo "runtime require ran '$out', want 'Hello, runtime!'"; exit 1; }
- name: Package
run: |
ver="${GITHUB_REF_NAME}"
name="joltc-${ver}-${{ matrix.target }}"
mkdir -p "dist/${name}"
cp README.md LICENSE "dist/${name}/"
if [ "${{ runner.os }}" = "Windows" ]; then
cp target/release/joltc.exe "dist/${name}/joltc.exe"
( cd dist && zip -r "${name}.zip" "${name}" && sha256sum "${name}.zip" > "${name}.zip.sha256" )
else
cp target/release/joltc "dist/${name}/joltc"
tar -C dist -czf "dist/${name}.tar.gz" "${name}"
( cd dist && shasum -a 256 "${name}.tar.gz" > "${name}.tar.gz.sha256" )
fi
ls -la dist
- name: Upload to the GitHub Release
if: startsWith(github.ref, 'refs/tags/')
uses: softprops/action-gh-release@v2
with:
files: |
dist/*.tar.gz
dist/*.tar.gz.sha256
dist/*.zip
dist/*.zip.sha256
fail_on_unmatched_files: false

View file

@ -56,7 +56,11 @@ jobs:
- name: Install JDK + Clojure (certify oracle)
run: |
sudo apt-get install -y default-jdk rlwrap
curl -L -O https://github.com/clojure/brew-install/releases/latest/download/linux-install.sh
# --retry + --fail so a transient CDN error retries instead of handing
# bash an HTML error page (a 2min timeout page flaked a run)
curl --fail --retry 5 --retry-delay 10 --retry-all-errors -L -O \
https://github.com/clojure/brew-install/releases/latest/download/linux-install.sh
head -1 linux-install.sh | grep -q '^#!' || { echo "installer download corrupt"; cat linux-install.sh | head -5; exit 1; }
sudo bash linux-install.sh
clojure --version

4
.gitignore vendored
View file

@ -1,4 +1,8 @@
AGENTS.md
.DS_Store
CLAUDE.md
build/
target/
.clj-kondo/
.dirge/
.claude/

3
.gitmodules vendored
View file

@ -4,3 +4,6 @@
[submodule "vendor/sci"]
path = vendor/sci
url = https://github.com/borkdude/sci.git
[submodule "vendor/clojure-test-suite"]
path = vendor/clojure-test-suite
url = https://github.com/jank-lang/clojure-test-suite.git

View file

@ -1,96 +0,0 @@
# Agent Instructions
This project uses **bd** (beads) for issue tracking. Run `bd prime` for full workflow context.
> **Architecture in one line:** Issues live in a local Dolt database
> (`.beads/dolt/`); cross-machine sync uses `bd dolt push/pull` (a
> git-compatible protocol), stored under `refs/dolt/data` on your git
> remote — separate from `refs/heads/*` where your code lives.
> `.beads/issues.jsonl` is a passive export, not the wire protocol.
>
> See [SYNC_CONCEPTS.md](https://github.com/gastownhall/beads/blob/main/docs/SYNC_CONCEPTS.md)
> for the one-screen overview and anti-patterns (don't treat JSONL as the
> source of truth; don't `bd import` during normal operation; don't
> reach for third-party Dolt hosting before trying the default).
## Quick Reference
```bash
bd ready # Find available work
bd show <id> # View issue details
bd update <id> --claim # Claim work atomically
bd close <id> # Complete work
bd dolt push # Push beads data to remote
```
## Non-Interactive Shell Commands
**ALWAYS use non-interactive flags** with file operations to avoid hanging on confirmation prompts.
Shell commands like `cp`, `mv`, and `rm` may be aliased to include `-i` (interactive) mode on some systems, causing the agent to hang indefinitely waiting for y/n input.
**Use these forms instead:**
```bash
# Force overwrite without prompting
cp -f source dest # NOT: cp source dest
mv -f source dest # NOT: mv source dest
rm -f file # NOT: rm file
# For recursive operations
rm -rf directory # NOT: rm -r directory
cp -rf source dest # NOT: cp -r source dest
```
**Other commands that may prompt:**
- `scp` - use `-o BatchMode=yes` for non-interactive
- `ssh` - use `-o BatchMode=yes` to fail instead of prompting
- `apt-get` - use `-y` flag
- `brew` - use `HOMEBREW_NO_AUTO_UPDATE=1` env var
<!-- BEGIN BEADS INTEGRATION v:1 profile:minimal hash:7510c1e2 -->
## Beads Issue Tracker
This project uses **bd (beads)** for issue tracking. Run `bd prime` to see full workflow context and commands.
### Quick Reference
```bash
bd ready # Find available work
bd show <id> # View issue details
bd update <id> --claim # Claim work
bd close <id> # Complete work
```
### Rules
- Use `bd` for ALL task tracking — do NOT use TodoWrite, TaskCreate, or markdown TODO lists
- Run `bd prime` for detailed command reference and session close protocol
- Use `bd remember` for persistent knowledge — do NOT use MEMORY.md files
**Architecture in one line:** issues live in a local Dolt DB; sync uses `refs/dolt/data` on your git remote; `.beads/issues.jsonl` is a passive export. See https://github.com/gastownhall/beads/blob/main/docs/SYNC_CONCEPTS.md for details and anti-patterns.
## Session Completion
**When ending a work session**, you MUST complete ALL steps below. Work is NOT complete until `git push` succeeds.
**MANDATORY WORKFLOW:**
1. **File issues for remaining work** - Create issues for anything that needs follow-up
2. **Run quality gates** (if code changed) - Tests, linters, builds
3. **Update issue status** - Close finished work, update in-progress items
4. **PUSH TO REMOTE** - This is MANDATORY:
```bash
git pull --rebase
git push
git status # MUST show "up to date with origin"
```
5. **Clean up** - Clear stashes, prune remote branches
6. **Verify** - All changes committed AND pushed
7. **Hand off** - Provide context for next session
**CRITICAL RULES:**
- Work is NOT complete until `git push` succeeds
- NEVER stop before pushing - that leaves work stranded locally
- NEVER say "ready to push when you are" - YOU must push
- If push fails, resolve and retry until it succeeds
<!-- END BEADS INTEGRATION -->

144
CLAUDE.md
View file

@ -1,144 +0,0 @@
# Project Instructions for AI Agents
This file provides instructions and context for AI coding agents working on this project.
<!-- BEGIN BEADS INTEGRATION v:1 profile:minimal hash:7510c1e2 -->
## Beads Issue Tracker
This project uses **bd (beads)** for issue tracking. Run `bd prime` to see full workflow context and commands.
### Quick Reference
```bash
bd ready # Find available work
bd show <id> # View issue details
bd update <id> --claim # Claim work
bd close <id> # Complete work
```
### Rules
- Use `bd` for ALL task tracking — do NOT use TodoWrite, TaskCreate, or markdown TODO lists
- Run `bd prime` for detailed command reference and session close protocol
- Use `bd remember` for persistent knowledge — do NOT use MEMORY.md files
**Architecture in one line:** issues live in a local Dolt DB; sync uses `refs/dolt/data` on your git remote; `.beads/issues.jsonl` is a passive export. See https://github.com/gastownhall/beads/blob/main/docs/SYNC_CONCEPTS.md for details and anti-patterns.
## Session Completion
**When ending a work session**, you MUST complete ALL steps below. Work is NOT complete until `git push` succeeds.
**MANDATORY WORKFLOW:**
1. **File issues for remaining work** - Create issues for anything that needs follow-up
2. **Run quality gates** (if code changed) - Tests, linters, builds
3. **Update issue status** - Close finished work, update in-progress items
4. **PUSH TO REMOTE** - This is MANDATORY:
```bash
git pull --rebase
git push
git status # MUST show "up to date with origin"
```
5. **Clean up** - Clear stashes, prune remote branches
6. **Verify** - All changes committed AND pushed
7. **Hand off** - Provide context for next session
**CRITICAL RULES:**
- Work is NOT complete until `git push` succeeds
- NEVER stop before pushing - that leaves work stranded locally
- NEVER say "ready to push when you are" - YOU must push
- If push fails, resolve and retry until it succeeds
<!-- END BEADS INTEGRATION -->
## Build & Test
No build step — `bin/joltc` runs off the checked-in seed (`host/chez/seed/`).
The gate is pure Chez (+ Clojure for the JVM oracle).
```bash
bin/joltc -e EXPR # run a Clojure expression on Chez
make test # FULL gate (self-host + corpus + unit + smoke + certify)
make corpus # conformance corpus vs the JVM-sourced spec (floor 2678)
make unit # host-specific unit cases (test/chez/unit.edn)
make selfhost # bootstrap fixpoint (rebuild == checked-in seed)
make certify # JVM oracle (skips if clojure absent)
chez --script host/chez/run-corpus.ss # the corpus gate directly; JOLT_CORPUS_LIMIT=N for a fast stride
make remint # re-mint the seed after a seed-source change
```
**Re-mint after changing a seed source.** The reader (`host/chez/reader.ss`), the
analyzer/IR/backend (`jolt-core/jolt/*.clj`), or the `clojure.core` overlay
(`jolt-core/clojure/core/*.clj`) are baked into the seed — change one and run
`make remint` (iterates `host/chez/bootstrap.ss` to a byte-fixpoint) or `make
selfhost` fails. Runtime-only `host/chez/*.ss` shims do NOT need a re-mint.
**Run the gate with a REAL exit code.** `make test > /tmp/gate.out 2>&1; echo
"EXIT: $?"` — the final `OK: all gates passed` line must be present. CI
(`.github/workflows/tests.yml`) runs `make test` on every push/PR.
## Architecture Overview
Clojure on Chez Scheme — the sole substrate. A small Chez runtime
(`host/chez/*.ss`: value model, persistent collections, seqs, vars/ns, host
interop) hosts a portable Clojure overlay (`jolt-core/`): the
reader/analyzer/IR/backend (`jolt-core/jolt/`) and `clojure.core` in
dependency-ordered tiers (`jolt-core/clojure/core/NN-*.clj`, loaded in order:
00-syntax, 00-kernel, 10-seq, 20-coll, 25-sorted, 30-macros, 40-lazy, 50-io).
The stdlib namespaces (`clojure.string`/`set`/`walk`/`edn`/`pprint`/…) are
portable Clojure under `stdlib/clojure/`.
`bin/joltc` (`host/chez/cli.ss`) loads the checked-in seed
(`host/chez/seed/{prelude,image}.ss`) + the spine and compiles+evals on Chez
(read → analyze → IR → emit → eval). `host/chez/bootstrap.ss` rebuilds that seed
from source on pure Chez; the build is a self-hosting fixpoint (a rebuild
reproduces the checked-in seed byte-for-byte — `make selfhost`). The correctness
oracle is the JVM-sourced conformance corpus (`test/chez/corpus.edn`,
`test/conformance/`).
Issue tracking and design notes live in beads (`bd prime`, `bd memories`).
## Conventions & Patterns
- **A tier may only use macros from tiers that load before it.** Compile mode
expands macros at tier LOAD, so an `if-let` (30-macros) inside a 20-coll fn
breaks compiled init even though it passes when expanded lazily. Same ordering
for expander-called fns (empty?/keys/vals live in 00-syntax).
- **Never read your own wrapper's fields with `get`** in attached-ops values
(sorted colls): `get` on the wrapper IS the dispatched lookup and recurses
forever. Use `jolt.host/ref-get`.
- **Map literals with `:jolt/type` as a key** parse as tagged reader forms —
don't tag overlay value maps in source.
- **The compiler is reached from the runtime by `var-deref` string lookup.** The
`.ss` runtime calls into the cross-compiled compiler with
`(var-deref "jolt.analyzer" "analyze")` etc., and the compiler resolves its own
unqualified `jolt.host/…` refs the same way against `host-contract.ss`. So a
public `defn` with no in-Clojure callers may still be a live entry point — don't
treat it as dead. Only a private `defn-` with no callers is safe to remove.
- **A native `clojure.core` fn is a `(def-var! "clojure.core" "name" …)`** in a
`host/chez/*.ss`; the rest of core is the overlay (`jolt-core/clojure/core/*.clj`).
A few natives are re-asserted in `post-prelude.ss` so they win over the overlay.
See [docs/MODULES.md](docs/MODULES.md) for where a given fn lives, and
[docs/seed-overlay-registry.md](docs/seed-overlay-registry.md) for the shadowing
rule. Start at [docs/MODULES.md](docs/MODULES.md) to find a feature's files.
- **Fix latent bugs to match Clojure** rather than preserving them, with a
regression case. Match the JVM (or provide a superset); the JVM-sourced corpus
is the contract.
- **Gate every change**: `make test` with a real exit code (self-host fixpoint,
corpus floor, unit, cli smoke, certify). Re-mint if a seed source changed.
## Writing style (comments, docstrings, docs)
Write like a human maintainer of a serious open-source project. Plain, terse,
factual. Document how the code works *now* — what it does and why it matters.
- No LLM tells: drop "Note that", "It's worth noting", "Importantly", "simply",
"essentially", "in order to", "under the hood", and marketing words
("comprehensive", "robust", "seamless", "leverage", "powerful").
- No historical exposition (how the code used to work, porting notes, "the prior
X"), no internal issue IDs (`jolt-xxxx`) or milestone tags ("Phase N") in
comments or docstrings. The git history and beads hold that.
- Keep genuine semantic contrasts with JVM Clojure — those document real,
user-visible behavior.
- Don't restate the code; explain the non-obvious. Match the surrounding file's
comment density and tone.

367
LICENSE
View file

@ -1,143 +1,179 @@
Eclipse Public License - v 1.0
Eclipse Public License - v 2.0
THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE
PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF
THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT.
THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE
PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION
OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT.
1. DEFINITIONS
"Contribution" means:
a) in the case of the initial Contributor, the initial code and
documentation distributed under this Agreement, and
a) in the case of the initial Contributor, the initial content
Distributed under this Agreement, and
b) in the case of each subsequent Contributor:
b) in the case of each subsequent Contributor:
i) changes to the Program, and
ii) additions to the Program;
where such changes and/or additions to the Program originate from
and are Distributed by that particular Contributor. A Contribution
"originates" from a Contributor if it was added to the Program by
such Contributor itself or anyone acting on such Contributor's behalf.
Contributions do not include changes or additions to the Program that
are not Modified Works.
i) changes to the Program, and
ii) additions to the Program;
where such changes and/or additions to the Program originate from and
are distributed by that particular Contributor. A Contribution
'originates' from a Contributor if it was added to the Program by such
Contributor itself or anyone acting on such Contributor's behalf.
Contributions do not include additions to the Program which: (i) are
separate modules of software distributed in conjunction with the Program
under their own license agreement, and (ii) are not derivative works of
the Program.
"Contributor" means any person or entity that distributes the Program.
"Contributor" means any person or entity that Distributes the Program.
"Licensed Patents" mean patent claims licensable by a Contributor which
are necessarily infringed by the use or sale of its Contribution alone
or when combined with the Program.
"Program" means the Contributions distributed in accordance with this
"Program" means the Contributions Distributed in accordance with this
Agreement.
"Recipient" means anyone who receives the Program under this Agreement,
including all Contributors.
"Recipient" means anyone who receives the Program under this Agreement
or any Secondary License (as applicable), including Contributors.
"Derivative Works" shall mean any work, whether in Source Code or other
form, that is based on (or derived from) the Program and for which the
editorial revisions, annotations, elaborations, or other modifications
represent, as a whole, an original work of authorship.
"Modified Works" shall mean any work in Source Code or other form that
results from an addition to, deletion from, or modification of the
contents of the Program, including, for purposes of clarity any new file
in Source Code form that contains any contents of the Program. Modified
Works shall not include works that contain only declarations,
interfaces, types, classes, structures, or files of the Program solely
in each case in order to link to, bind by name, or subclass the Program
or Modified Works thereof.
"Distribute" means the acts of a) distributing or b) making available
in any manner that enables the transfer of a copy.
"Source Code" means the form of a Program preferred for making
modifications, including but not limited to software source code,
documentation source, and configuration files.
"Secondary License" means either the GNU General Public License,
Version 2.0, or any later versions of that license, including any
exceptions or additional permissions as identified by the initial
Contributor.
2. GRANT OF RIGHTS
a) Subject to the terms of this Agreement, each Contributor hereby
grants Recipient a non-exclusive, worldwide, royalty-free copyright
license to reproduce, prepare derivative works of, publicly display,
publicly perform, distribute and sublicense the Contribution of such
Contributor, if any, and such derivative works, in source code and
object code form.
a) Subject to the terms of this Agreement, each Contributor hereby
grants Recipient a non-exclusive, worldwide, royalty-free copyright
license to reproduce, prepare Derivative Works of, publicly display,
publicly perform, Distribute and sublicense the Contribution of such
Contributor, if any, and such Derivative Works.
b) Subject to the terms of this Agreement, each Contributor hereby
grants Recipient a non-exclusive, worldwide, royalty-free patent license
under Licensed Patents to make, use, sell, offer to sell, import and
otherwise transfer the Contribution of such Contributor, if any, in
source code and object code form. This patent license shall apply to the
combination of the Contribution and the Program if, at the time the
Contribution is added by the Contributor, such addition of the
Contribution causes such combination to be covered by the Licensed
Patents. The patent license shall not apply to any other combinations
which include the Contribution. No hardware per se is licensed
hereunder.
b) Subject to the terms of this Agreement, each Contributor hereby
grants Recipient a non-exclusive, worldwide, royalty-free patent
license under Licensed Patents to make, use, sell, offer to sell,
import and otherwise transfer the Contribution of such Contributor,
if any, in Source Code or other form. This patent license shall
apply to the combination of the Contribution and the Program if, at
the time the Contribution is added by the Contributor, such addition
of the Contribution causes such combination to be covered by the
Licensed Patents. The patent license shall not apply to any other
combinations which include the Contribution. No hardware per se is
licensed hereunder.
c) Recipient understands that although each Contributor grants the
licenses to its Contributions set forth herein, no assurances are
provided by any Contributor that the Program does not infringe the
patent or other intellectual property rights of any other entity. Each
Contributor disclaims any liability to Recipient for claims brought by
any other entity based on infringement of intellectual property rights
or otherwise. As a condition to exercising the rights and licenses
granted hereunder, each Recipient hereby assumes sole responsibility to
secure any other intellectual property rights needed, if any. For
example, if a third party patent license is required to allow Recipient
to distribute the Program, it is Recipient's responsibility to acquire
that license before distributing the Program.
c) Recipient understands that although each Contributor grants the
licenses to its Contributions set forth herein, no assurances are
provided by any Contributor that the Program does not infringe the
patent or other intellectual property rights of any other entity.
Each Contributor disclaims any liability to Recipient for claims
brought by any other entity based on infringement of intellectual
property rights or otherwise. As a condition to exercising the
rights and licenses granted hereunder, each Recipient hereby
assumes sole responsibility to secure any other intellectual
property rights needed, if any. For example, if a third party
patent license is required to allow Recipient to Distribute the
Program, it is Recipient's responsibility to acquire that license
before distributing the Program.
d) Each Contributor represents that to its knowledge it has sufficient
copyright rights in its Contribution, if any, to grant the copyright
license set forth in this Agreement.
d) Each Contributor represents that to its knowledge it has
sufficient copyright rights in its Contribution, if any, to grant
the copyright license set forth in this Agreement.
e) Notwithstanding the terms of any Secondary License, no
Contributor makes additional grants to any Recipient (other than
those set forth in this Agreement) as a result of such Recipient's
receipt of the Program under the terms of a Secondary License
(if permitted under the terms of Section 3).
3. REQUIREMENTS
A Contributor may choose to distribute the Program in object code form
under its own license agreement, provided that:
3.1 If a Contributor Distributes the Program in any form, then:
a) it complies with the terms and conditions of this Agreement; and
a) the Program must also be made available as Source Code, in
accordance with section 3.2, and the Contributor must accompany
the Program with a statement that the Source Code for the Program
is available under this Agreement, and informs Recipients how to
obtain it in a reasonable manner on or through a medium customarily
used for software exchange; and
b) its license agreement:
b) the Contributor may Distribute the Program under a license
different than this Agreement, provided that such license:
i) effectively disclaims on behalf of all other Contributors all
warranties and conditions, express and implied, including
warranties or conditions of title and non-infringement, and
implied warranties or conditions of merchantability and fitness
for a particular purpose;
i) effectively disclaims on behalf of all Contributors all warranties
and conditions, express and implied, including warranties or conditions
of title and non-infringement, and implied warranties or conditions of
merchantability and fitness for a particular purpose;
ii) effectively excludes on behalf of all other Contributors all
liability for damages, including direct, indirect, special,
incidental and consequential damages, such as lost profits;
ii) effectively excludes on behalf of all Contributors all liability for
damages, including direct, indirect, special, incidental and
consequential damages, such as lost profits;
iii) does not attempt to limit or alter the recipients' rights
in the Source Code under section 3.2; and
iii) states that any provisions which differ from this Agreement are
offered by that Contributor alone and not by any other party; and
iv) requires any subsequent distribution of the Program by any
party to be under a license that satisfies the requirements
of this section 3.
iv) states that source code for the Program is available from such
Contributor, and informs licensees how to obtain it in a reasonable
manner on or through a medium customarily used for software exchange.
3.2 When the Program is Distributed as Source Code:
When the Program is made available in source code form:
a) it must be made available under this Agreement, or if the
Program (i) is combined with other material in a separate file or
files made available under a Secondary License, and (ii) the initial
Contributor attached to the Source Code the notice described in
Exhibit A of this Agreement, then the Program may be made available
under the terms of such Secondary Licenses, and
a) it must be made available under this Agreement; and
b) a copy of this Agreement must be included with each copy of
the Program.
b) a copy of this Agreement must be included with each copy of the
Program.
Contributors may not remove or alter any copyright notices contained
within the Program.
Each Contributor must identify itself as the originator of its
Contribution, if any, in a manner that reasonably allows subsequent
Recipients to identify the originator of the Contribution.
3.3 Contributors may not remove or alter any copyright, patent,
trademark, attribution notices, disclaimers of warranty, or limitations
of liability ("notices") contained within the Program from any copy of
the Program which they Distribute, provided that Contributors may add
their own appropriate notices.
4. COMMERCIAL DISTRIBUTION
Commercial distributors of software may accept certain responsibilities
with respect to end users, business partners and the like. While this
license is intended to facilitate the commercial use of the Program, the
Contributor who includes the Program in a commercial product offering
should do so in a manner which does not create potential liability for
other Contributors. Therefore, if a Contributor includes the Program in
a commercial product offering, such Contributor ("Commercial
Contributor") hereby agrees to defend and indemnify every other
Contributor ("Indemnified Contributor") against any losses, damages and
costs (collectively "Losses") arising from claims, lawsuits and other
legal actions brought by a third party against the Indemnified
license is intended to facilitate the commercial use of the Program,
the Contributor who includes the Program in a commercial product
offering should do so in a manner which does not create potential
liability for other Contributors. Therefore, if a Contributor includes
the Program in a commercial product offering, such Contributor
("Commercial Contributor") hereby agrees to defend and indemnify every
other Contributor ("Indemnified Contributor") against any losses,
damages and costs (collectively "Losses") arising from claims, lawsuits
and other legal actions brought by a third party against the Indemnified
Contributor to the extent caused by the acts or omissions of such
Commercial Contributor in connection with its distribution of the
Program in a commercial product offering. The obligations in this
section do not apply to any claims or Losses relating to any actual or
alleged intellectual property infringement. In order to qualify, an
Indemnified Contributor must: a) promptly notify the Commercial
Contributor in writing of such claim, and b) allow the Commercial
Contributor to control, and cooperate with the Commercial Contributor
in, the defense and any related settlement negotiations. The Indemnified
Contributor may participate in any such claim at its own expense.
Commercial Contributor in connection with its distribution of the Program
in a commercial product offering. The obligations in this section do not
apply to any claims or Losses relating to any actual or alleged
intellectual property infringement. In order to qualify, an Indemnified
Contributor must: a) promptly notify the Commercial Contributor in
writing of such claim, and b) allow the Commercial Contributor to control,
and cooperate with the Commercial Contributor in, the defense and any
related settlement negotiations. The Indemnified Contributor may
participate in any such claim at its own expense.
For example, a Contributor might include the Program in a commercial
product offering, Product X. That Contributor is then a Commercial
@ -145,80 +181,97 @@ Contributor. If that Commercial Contributor then makes performance
claims, or offers warranties related to Product X, those performance
claims and warranties are such Commercial Contributor's responsibility
alone. Under this section, the Commercial Contributor would have to
defend claims against the other Contributors related to those
performance claims and warranties, and if a court requires any other
Contributor to pay any damages as a result, the Commercial Contributor
must pay those damages.
defend claims against the other Contributors related to those performance
claims and warranties, and if a court requires any other Contributor to
pay any damages as a result, the Commercial Contributor must pay
those damages.
5. NO WARRANTY
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED
ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND,
EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES
OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR
A PARTICULAR PURPOSE. Each Recipient is solely responsible for
determining the appropriateness of using and distributing the Program
and assumes all risks associated with its exercise of rights under this
Agreement, including but not limited to the risks and costs of program
errors, compliance with applicable laws, damage to or loss of data,
programs or equipment, and unavailability or interruption of operations.
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT
PERMITTED BY APPLICABLE LAW, THE PROGRAM IS PROVIDED ON AN "AS IS"
BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR
IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF
TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR
PURPOSE. Each Recipient is solely responsible for determining the
appropriateness of using and distributing the Program and assumes all
risks associated with its exercise of rights under this Agreement,
including but not limited to the risks and costs of program errors,
compliance with applicable laws, damage to or loss of data, programs
or equipment, and unavailability or interruption of operations.
6. DISCLAIMER OF LIABILITY
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR
ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING
WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR
DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED
HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT
PERMITTED BY APPLICABLE LAW, NEITHER RECIPIENT NOR ANY CONTRIBUTORS
SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION LOST
PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE
EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.
7. GENERAL
If any provision of this Agreement is invalid or unenforceable under
applicable law, it shall not affect the validity or enforceability of
the remainder of the terms of this Agreement, and without further action
by the parties hereto, such provision shall be reformed to the minimum
extent necessary to make such provision valid and enforceable.
the remainder of the terms of this Agreement, and without further
action by the parties hereto, such provision shall be reformed to the
minimum extent necessary to make such provision valid and enforceable.
If Recipient institutes patent litigation against any entity (including
a cross-claim or counterclaim in a lawsuit) alleging that the Program
itself (excluding combinations of the Program with other software or
hardware) infringes such Recipient's patent(s), then such Recipient's
If Recipient institutes patent litigation against any entity
(including a cross-claim or counterclaim in a lawsuit) alleging that the
Program itself (excluding combinations of the Program with other software
or hardware) infringes such Recipient's patent(s), then such Recipient's
rights granted under Section 2(b) shall terminate as of the date such
litigation is filed.
All Recipient's rights under this Agreement shall terminate if it fails
to comply with any of the material terms or conditions of this Agreement
and does not cure such failure in a reasonable period of time after
becoming aware of such noncompliance. If all Recipient's rights under
this Agreement terminate, Recipient agrees to cease use and distribution
of the Program as soon as reasonably practicable. However, Recipient's
obligations under this Agreement and any licenses granted by Recipient
relating to the Program shall continue and survive.
All Recipient's rights under this Agreement shall terminate if it
fails to comply with any of the material terms or conditions of this
Agreement and does not cure such failure in a reasonable period of
time after becoming aware of such noncompliance. If all Recipient's
rights under this Agreement terminate, Recipient agrees to cease use
and distribution of the Program as soon as reasonably practicable.
However, Recipient's obligations under this Agreement and any licenses
granted by Recipient relating to the Program shall continue and survive.
Everyone is permitted to copy and distribute copies of this Agreement,
but in order to avoid inconsistency the Agreement is copyrighted and may
only be modified in the following manner. The Agreement Steward reserves
the right to publish new versions (including revisions) of this
Agreement from time to time. No one other than the Agreement Steward has
the right to modify this Agreement. The Eclipse Foundation is the
initial Agreement Steward. The Eclipse Foundation may assign the
but in order to avoid inconsistency the Agreement is copyrighted and
may only be modified in the following manner. The Agreement Steward
reserves the right to publish new versions (including revisions) of
this Agreement from time to time. No one other than the Agreement
Steward has the right to modify this Agreement. The Eclipse Foundation
is the initial Agreement Steward. The Eclipse Foundation may assign the
responsibility to serve as the Agreement Steward to a suitable separate
entity. Each new version of the Agreement will be given a distinguishing
version number. The Program (including Contributions) may always be
distributed subject to the version of the Agreement under which it was
received. In addition, after a new version of the Agreement is
published, Contributor may elect to distribute the Program (including
its Contributions) under the new version. Except as expressly stated in
Sections 2(a) and 2(b) above, Recipient receives no rights or licenses
to the intellectual property of any Contributor under this Agreement,
whether expressly, by implication, estoppel or otherwise. All rights in
the Program not expressly granted under this Agreement are reserved.
Distributed subject to the version of the Agreement under which it was
received. In addition, after a new version of the Agreement is published,
Contributor may elect to Distribute the Program (including its
Contributions) under the new version.
This Agreement is governed by the laws of the State of New York and the
intellectual property laws of the United States of America. No party to
this Agreement will bring a legal action under this Agreement more than
one year after the cause of action arose. Each party waives its rights
to a jury trial in any resulting litigation.
Except as expressly stated in Sections 2(a) and 2(b) above, Recipient
receives no rights or licenses to the intellectual property of any
Contributor under this Agreement, whether expressly, by implication,
estoppel or otherwise. All rights in the Program not expressly granted
under this Agreement are reserved. Nothing in this Agreement is intended
to be enforceable by any entity that is not a Contributor or Recipient.
No third-party beneficiary rights are created under this Agreement.
Exhibit A - Form of Secondary Licenses Notice
"This Source Code may also be made available under the following
Secondary Licenses when the conditions for such availability set forth
in the Eclipse Public License, v. 2.0 are satisfied: {name license(s),
version(s), and exceptions or additional permissions here}."
Simply including a copy of this Agreement, including this Exhibit A
is not sufficient to license the Source Code under Secondary Licenses.
If it is not possible or desirable to put the notice in a particular
file, then You may include the notice in a location (such as a LICENSE
file in a relevant directory) where a recipient would be likely to
look for such a notice.
You may add additional accurate notices of copyright ownership.

View file

@ -4,18 +4,23 @@
# build step. `make test` is the full gate. `make remint` rebuilds the seed after a
# source change.
.PHONY: test ci values corpus unit smoke buildsmoke selfhost sci certify ffi transient infer directlink numeric inline shakesmoke remint
.PHONY: test ci values corpus unit smoke buildsmoke staticnativesmoke selfhost sci cts certify ffi transient infer wp devirt fieldread numwp fieldnum protoret narrow directlink numeric inline shakesmoke remint joltc joltc-release joltc-debug joltcsmoke submodules
# Every target needs the vendored submodules; fail with the fix, not a load error.
submodules:
@test -f vendor/irregex/irregex.scm || { \
echo "vendor submodules missing; run: git submodule update --init --recursive"; exit 1; }
# Full gate (dev machine). Includes the self-host byte-fixpoint, which only holds
# on the same Chez that minted the seed.
test: selfhost ci
test: submodules selfhost ci
@echo "OK: all gates passed"
# CI gate: behavior only. The checked-in seed is a minted artifact (like a
# lockfile) — it RUNS correctly on any Chez, but `selfhost` rebuilds it and a
# different Chez version may emit byte-different (gensym/order) output, so the
# byte-fixpoint is a dev-machine check, not a CI one (jolt-8479).
ci: values corpus unit smoke buildsmoke sci ffi transient infer directlink numeric inline certify
ci: submodules values corpus unit smoke buildsmoke staticnativesmoke sci cts ffi transient infer wp devirt fieldread numwp fieldnum protoret narrow directlink numeric inline certify
@echo "OK: CI gates passed"
# Self-host fixpoint: bootstrap.ss rebuild == checked-in seed.
@ -42,10 +47,38 @@ smoke:
buildsmoke:
@sh host/chez/build-smoke.sh
# `jolt build` cc-links a :jolt/native :static archive into the binary (the
# default), and --dynamic keeps the runtime load-shared-object path.
staticnativesmoke:
@sh host/chez/static-native-smoke.sh
# Build joltc as a self-contained native binary into target/<profile>/joltc. The
# binary bundles the runtime, compiler, jolt-core + stdlib source, the Chez boots,
# and a launcher stub, so it runs AND compiles jolt apps with no Chez or cc on the
# machine. Built on a dev/CI host that HAS Chez + cc. release = optimize-level 3,
# no inspector info, compressed; debug = optimize-level 0 + inspector + debug info.
joltc-release:
@chez --script host/chez/build-joltc.ss release target/release/joltc
joltc-debug:
@chez --script host/chez/build-joltc.ss debug target/debug/joltc
# Re-mint the seed first so the embedded compiler image is current, then both builds.
joltc: selfhost joltc-release joltc-debug
@echo "OK: target/release/joltc and target/debug/joltc built"
# Self-build smoke: the distributed joltc compiles an app with Chez + cc removed.
joltcsmoke:
@sh host/chez/joltc-selfbuild-smoke.sh
# SCI conformance: load borkdude/sci's source through joltc (floor-gated).
sci:
@chez --script host/chez/run-sci.ss
# clojure-test-suite conformance: run the vendored jank-lang/clojure-test-suite
# per-namespace under joltc, gated on the per-namespace baseline
# (test/chez/cts-known-failures.txt).
cts:
@bash host/chez/cts.sh
# FFI: bind native functions (typed foreign-procedure), memory, and that a
# :blocking call is collect-safe (a parked thread doesn't pin the collector).
ffi:
@ -61,6 +94,49 @@ transient:
infer:
@chez --script host/chez/run-infer.ss
# Whole-program param-type fixpoint: record types flowing across fn boundaries
# (a callee's param picks up its callers' ctor return types), the foundation the
# bare-index field reads + protocol devirtualization build on.
wp:
@chez --script host/chez/run-wp.ss
# Protocol-call devirtualization: a monomorphic call resolves its impl by the
# inferred record tag (find-protocol-method) instead of routing through the
# protocol var; the result must match ordinary dispatch.
devirt:
@chez --script host/chez/run-devirt.ss
# Native record field reads: a keyword lookup on a statically-known record reads
# the field by its declared slot (jrec-field-at) instead of jolt-get; the value
# must match, and a non-field key / default-arg form keeps the generic path.
fieldread:
@chez --script host/chez/run-fieldread.ss
# Hintless whole-program double inference: a fn whose every call site passes a
# flonum has its param typed :double by the closed-world fixpoint and unboxed to
# fl-ops with no ^double hint; an integer caller leaves it generic, an escaped fn
# keeps :any.
numwp:
@chez --script host/chez/run-numwp.ss
# Double record fields: a ^double-tagged field reads back as a flonum (coerced at
# construction and set!), so hintless arithmetic over those fields unboxes to fl-ops;
# an untagged field stays generic.
fieldnum:
@chez --script host/chez/run-fieldnum.ss
# Protocol-method return inference: a method whose impls all return the same record
# type has a monomorphic return, so a (method recv ..) call types as that record and
# a field read off the result bare-indexes; a disagreeing impl keeps the generic path.
protoret:
@chez --script host/chez/run-protoret.ss
# Nilable record types + flow-sensitive narrowing: a record-or-nil types as a nilable
# record (some?/nil? don't fold, so a runtime guard stays); inside (if (some? x) ..)
# the then-branch narrows x to non-nil, so its field reads bare-index and unbox.
narrow:
@chez --script host/chez/run-narrow.ss
# Direct-linking emission: a closed-world build binds top-level app defs to jv$
# Scheme bindings and routes app->app calls/refs to them, skipping var-deref +
# jolt-invoke; ^:dynamic/^:redef and nested defs opt out.

View file

@ -7,6 +7,31 @@ Jolt reads Clojure source, analyzes it to a host-neutral IR, emits Scheme, and
runs it on Chez. The compiler is self-hosted: it is written in Clojure
(`jolt-core/`) and compiles itself. It ships a Clojure-compatible standard library.
## Install
Grab the self-contained `joltc` binary (Linux/macOS/Windows) — it bundles the
runtime, compiler, and standard library, so there is nothing else to install.
Download the binary archive for your platform from the
[releases page](https://github.com/jolt-lang/jolt/releases) (`joltc-<ver>-<platform>.tar.gz`,
or the `.zip` on Windows). The "Source code" archives GitHub attaches to every
release are not binaries — see [Build](#build) before using one.
With Homebrew:
```bash
brew install jolt-lang/jolt/jolt
```
Or with the install script (installs to `/usr/local/bin` by default; `--dir <dir>`
and `--version <v>` override that):
```bash
curl -sL https://raw.githubusercontent.com/jolt-lang/jolt/main/install | bash
```
Then `joltc -e '(+ 1 2)'`. To run from source instead (needs Chez), see
[Build](#build).
## Requirements
Only [Chez Scheme](https://cisco.github.io/ChezScheme/) (the gate invokes it as
@ -24,6 +49,18 @@ cd jolt
bin/joltc -e '(+ 1 2)' # => 3
```
The `--recurse-submodules` matters: jolt vendors its regex engine and test
suites as git submodules. In a checkout that's missing them (a plain
`git clone`, or after pulling a commit that adds one), fetch them with:
```bash
git submodule update --init --recursive
```
Note that GitHub's auto-generated "Source code (zip/tar.gz)" archives on the
releases page do **not** contain submodules, so they can't run or build —
clone the repo instead (or grab a prebuilt binary from the same page).
After changing a compiler source — the reader (`host/chez/reader.ss`), the
analyzer/IR/backend (`jolt-core/jolt/*.clj`), or the `clojure.core` overlay
(`jolt-core/clojure/core/*.clj`) — re-mint the seed:
@ -45,6 +82,32 @@ $ bin/joltc -e '(/ 1 2)'
1/2
```
## REPL and editor integration
```bash
bin/joltc repl # a line REPL with the project's deps loaded
bin/joltc --nrepl-server [port] # an nREPL server (default 7888) for editors
```
Both resolve the `deps.edn` in the current directory first, so the project's
source roots and native libraries are loaded — `(require '[my.ns])` works live.
`--nrepl-server` writes a `.nrepl-port` file in the project dir, so CIDER / Calva / Cursive
auto-detect the port; override it with the argument or `JOLT_NREPL_PORT`.
The server runs in dev mode — calls deref their var, so redefining a function
takes effect on the next call without restarting the process. The built-in
handler speaks `clone`/`describe`/`eval`/`load-file`/`close`; heavier ops
(sessions, interruptible eval, completion) are added as nREPL middleware listed
in `deps.edn` under `:nrepl/middleware`.
```clojure
;; from your editor, against the running process:
(require '[myapp.core :as app])
(app/start!) ; bring the app up
;; edit a handler, re-evaluate the defn — the running app sees it, no restart
(app/stop!)
```
## Compile a binary
`bin/joltc build` ahead-of-time compiles a project into a single self-contained
@ -80,6 +143,24 @@ compiler. They come with a from-source Chez install; a distro `chezscheme`
package ships only the runtime, so `build` won't link a binary there.
RFC 0007 (`docs/rfc/`) covers the design and the three-mode model.
## Standalone joltc binary
`make` builds joltc itself into a single self-contained native binary — the
runtime, compiler, `jolt-core`/`stdlib` source, and the Chez boots are baked in,
so the result runs and `build`s jolt apps on a machine with neither Chez nor a C
compiler. Build it on a host that *does* have both.
```bash
make joltc-release # => target/release/joltc (optimize-level 3, compressed)
make joltc-debug # => target/debug/joltc (optimize-level 0, inspector + debug info)
make joltc # re-mint the seed first, then both
```
`make joltc` re-mints the seed so the embedded compiler image is current before
linking; use `joltc-release`/`joltc-debug` directly to skip that when the seed is
already minted. Like `build`, both require Chez's kernel development files
(`libkernel.a`, `scheme.h`) and a C compiler.
## Architecture
A small Chez runtime (`host/chez/*.ss`: value model, persistent collections, seqs,
@ -150,4 +231,4 @@ whose expected values are sourced from reference JVM Clojure. See
## License
[Eclipse Public License 1.0](https://opensource.org/licenses/EPL-1.0)
[Eclipse Public License 2.0](https://www.eclipse.org/legal/epl-2.0/)

1
bench/.gitignore vendored Normal file
View file

@ -0,0 +1 @@
.cpcache/

View file

@ -34,34 +34,87 @@ control with record state), k-nucleotide proper.
## Holistic scorecard
`JVM=1 bench/run.sh` runs each benchmark on jolt **and** JVM Clojure and prints
the jolt/JVM ratio — the absolute-reference scorecard. As of
the broadening (2026-06-16), ratios cluster by axis:
`bench/run.sh` compiles each benchmark to an **optimized AOT binary** (`joltc build
--direct-link --opt`) and times it against JVM Clojure running the same portable
source — the jolt/JVM scorecard. jolt's optimizing passes fire only in a build;
`joltc run -m` is unoptimized, so the harness always builds.
- **pure compute** (`mandelbrot`) is the floor, ~15× — native arith
already gets jolt closest to the JVM.
- **collections** ~28×, **fib** ~37×.
- **dispatch** ~75× (megamorphic), and `mono-dispatch` is *worse* (~110×): the
JVM inline-caches a runtime-monomorphic call site to near-free, while jolt does
a full registry dispatch regardless (devirt only fires on *statically* proven
receivers, which `reduce` over a vector doesn't give). This is the signal for
the call-site inline cache.
- **allocation** (`binary-trees`) is the widest gap — but also the most inflated
by host memory pressure, so read it as "alloc is the worst axis," not a precise
multiple. Numbers are machine-specific; regenerate with `JVM=1 bench/run.sh`.
Indicative ratios (M-series, single isolated run — numbers are machine-specific,
regenerate locally), ascending:
| benchmark | ratio | axis |
|---|---|---|
| `fib` | ~0.6× | call + integer arith |
| `collections` | ~3.5× | persistent map/vector churn |
| `mandelbrot` | ~7.5× | pure float compute |
| `binary-trees` | ~10× | escaping short-lived records (allocation/GC) |
| `dispatch` | ~12× | megamorphic protocol dispatch |
| `mono-dispatch` | ~15× | monomorphic protocol dispatch |
- **Compute (~0.67.5×)** is the substrate floor: Chez is a native-compiling AOT
Scheme, not a profiling JIT. With native arith + direct-linking + inlining jolt
is at parity here — `fib` runs *faster* than JVM Clojure (no JIT warmup over a
short run), `collections` is within ~3.5×, and `mandelbrot` (~7.5×) is the
pure-tight-loop float ceiling that only native codegen moves further.
- **Dispatch & allocation (~1015×)** are the remaining architectural gaps, though
the type-proving / native-record / bare-field-read work has collapsed them by an
order of magnitude (`binary-trees` ~140×→~10×, `mono-dispatch` ~330×→~15×). On a
*statically proven* monomorphic receiver — which whole-program inference now gives
for a record iterated out of a vector — devirt resolves the impl and a per-site
inline cache holds it (resolved once, not per call), so `mono-dispatch` is no
longer worse than megamorphic. The remaining lever is `dispatch`: a *megamorphic*
site has no static type, so it pays a full protocol-registry lookup every call
where the JVM uses a polymorphic inline cache — a runtime (receiver-type-keyed)
cache is the missing piece. `binary-trees`
nodes escape into the tree, so scalar-replace can't remove them — residual GC
pressure.
## 64-bit integer arithmetic & generators (test.check)
The AOT suite above is float-compute / dispatch / allocation bound; none of it
exercises **64-bit integer arithmetic**, which Chez can't hold in a fixnum
(61-bit), so genuine 64-bit values are heap bignums. The SplitMix PRNG behind
`clojure.test.check` is the worst case — every `rand-long` is ~8 bignum ops. These
were measured in **run mode** (`joltc run`, where per-site var-cell caching is on;
the AOT build keeps it off) against JVM Clojure on the same portable source. The
first two rows are isolating microbenchmarks; the rest are real test.check
generators.
| workload | jolt | JVM | ratio | bound by |
|---|---|---|---|---|
| SplitMix `mix-64` (×100k) | 45ms | 14ms | ~3.2× | 64-bit integer arithmetic |
| deftype alloc + protocol dispatch (×100k) | 41ms | 5ms | ~8× | open-world dispatch |
| raw `split` + `rand-long` (×20k) | 74ms | 6ms | ~12× | bignum 64-bit + dispatch |
| `gen/large-integer` (×2k) | 108ms | 23ms | ~4.7× | arithmetic + rose-tree machinery |
| `(gen/vector gen/large-integer)` (×500) | 1289ms | 88ms | ~14.6× | element gen + gen machinery |
Two no-C codegen levers collapsed the **arithmetic** half: emitting `bit-and`/
`bit-or`/`bit-xor`/`bit-not` as inlined Chez `bitwise-*` primitives (they had gone
through a var-deref'd variadic overlay), and caching the resolved var cell per
reference site (a name lookup was ~45ns/access). Together they took `mix-64` from
~18× → ~3.2× JVM and the raw PRNG from ~30× → ~12×, and the generators ~1.6× each.
The residual gap is **machinery, not arithmetic**: the open-world generator
deftype/protocol dispatch + rose-tree allocation (~810×) can't be devirtualized
without static types, and the raw 64-bit ops bottom out at the Chez bignum floor
(~20× a native long, substrate-inherent). A native SplitMix C/FFI shim would give
the PRNG ~27× but is the only path that needs C.
## Running
```sh
bench/run.sh # whole-program optimization on (default)
JOLT_WHOLE_PROGRAM=0 bench/run.sh # WP off, to measure what WP buys
bench/run.sh binary-trees 16 # one benchmark, custom size
bench/run.sh # full suite + JVM scorecard
bench/run.sh fib # one benchmark, default size
bench/run.sh fib 32 # one benchmark, custom size
NO_JVM=1 bench/run.sh # jolt only (skip the JVM reference)
```
Needs Chez's kernel dev files (`libkernel.a` + `scheme.h`) and `cc` for the build,
like `jolt build`; set `JOLT_CHEZ_CSV` to override the detected csv dir.
## A/B against a change
To measure a pass, run the suite on `main`, then on the branch, back to back
(same machine, quiet) — the same protocol used for the ray tracer. Each
benchmark prints `runs: [...]` and `mean: N ms`; compare
the means. A pass is worth landing when it moves a benchmark whose axis it
(same machine, quiet). Each benchmark prints `runs: [...]` and `mean: N ms`;
compare the means. A pass is worth landing when it moves a benchmark whose axis it
targets, even if the ray tracer stays flat.

View file

@ -4,8 +4,7 @@
;; targets and the ray tracer never exercises (~7% alloc).
;;
;; Portable Clojure: runs on jolt and JVM Clojure for cross-impl comparison.
;; jolt -m binary-trees 14 (JOLT_DIRECT_LINK=1 JOLT_WHOLE_PROGRAM=1)
;; clojure -M -m binary-trees 14
;; bench/run.sh binary-trees 14
(ns binary-trees)
(defrecord Node [left right])

View file

@ -5,7 +5,7 @@
;; records, no collections in the hot loop) doesn't touch.
;;
;; Portable Clojure (jolt + JVM Clojure).
;; jolt -m collections 200000 (JOLT_DIRECT_LINK=1 JOLT_WHOLE_PROGRAM=1)
;; bench/run.sh collections 200000
(ns collections)
;; map churn: accumulate a frequency map over a stream of keys, then sum it back

1
bench/deps.edn Normal file
View file

@ -0,0 +1 @@
{:paths ["."]}

View file

@ -6,7 +6,7 @@
;; float-math cost (devirt measured FLAT there).
;;
;; Portable Clojure (jolt + JVM Clojure).
;; jolt -m dispatch 20000 (JOLT_DIRECT_LINK=1 JOLT_WHOLE_PROGRAM=1)
;; bench/run.sh dispatch 20000
(ns dispatch)
(defprotocol Shape

View file

@ -4,7 +4,7 @@
;; single-call-site / small-fn inlining and self-call direct-linking.
;;
;; Portable Clojure (jolt + JVM Clojure).
;; jolt -m fib 32 (JOLT_DIRECT_LINK=1 JOLT_WHOLE_PROGRAM=1)
;; bench/run.sh fib 32
(ns fib)
(defn fib [n]

View file

@ -5,10 +5,10 @@
;; on (where devirt/alloc passes measured flat), so it tracks native-arith codegen
;; and loop quality directly.
;;
;; Portable Clojure (jolt + JVM Clojure).
;; jolt -m mandelbrot 1000 (JOLT_DIRECT_LINK=1 JOLT_WHOLE_PROGRAM=1)
(ns mandelbrot
(:require [jolt.png :as png]))
;; Portable Clojure (jolt + JVM Clojure). The jolt.png picture demo lives in
;; mandelbrot_png.clj so this file stays portable for the JVM reference run.
;; bench/run.sh mandelbrot 1000
(ns mandelbrot)
(defn count-point [cr ci cap]
(loop [i 0 zr 0.0 zi 0.0]
@ -32,35 +32,6 @@
(recur (inc y) (+ acc row)))
acc))))
;; --- PNG demo (jolt.png) --------------------------------------------------
;; Render a real picture of the set, reusing count-point as the kernel. `render`
;; is a separate -main subcommand so the numeric-arg bench path is untouched.
(defn- color
"Escape-iteration count -> RGB. In-set points (n>=cap) are black; faster
escapes run through a warm gradient."
[n cap]
(if (>= n cap)
[0 0 0]
(let [t (/ (double n) cap)]
[(int (* 255 (min 1.0 (* 3.0 t))))
(int (* 255 (min 1.0 (max 0.0 (* 3.0 (- t 0.33))))))
(int (* 255 (min 1.0 (max 0.0 (* 3.0 (- t 0.66))))))])))
(defn render!
"Render a size×size view of the Mandelbrot set to a PNG at path."
[path size]
(let [w size h size cap 1000
img (png/image w h)]
(doseq [py (range h)]
(doseq [px (range w)]
(let [cr (- (* 3.5 (/ (double px) w)) 2.5) ; real ∈ [-2.5, 1.0]
ci (- (* 2.8 (/ (double py) h)) 1.4) ; imag ∈ [-1.4, 1.4]
[r g b] (color (count-point cr ci cap) cap)]
(png/put! img r g b))))
(png/write img w h path)
(println "wrote" path (str w "×" h ", cap " cap))))
(defn- run-bench [args]
(let [n (if (seq args) (Integer/parseInt (first args)) 1000)]
(dotimes [_ 2] (run (quot n 2))) ; warmup
@ -78,7 +49,4 @@
(println "mean:" (/ (Math/round (* mean 10.0)) 10.0) "ms"))))
(defn -main [& args]
(if (= (first args) "render")
(render! (or (second args) "mandelbrot.png")
(if (nth args 2 nil) (Integer/parseInt (nth args 2)) 600))
(run-bench args)))
(run-bench args))

36
bench/mandelbrot_png.clj Normal file
View file

@ -0,0 +1,36 @@
;; mandelbrot picture demo — renders a real image of the set to a PNG via
;; jolt.png (FFI), reusing mandelbrot/count-point as the kernel. jolt-only (the
;; benchmark in mandelbrot.clj stays portable for the JVM reference).
;; joltc run -m mandelbrot-png [path] [size]
(ns mandelbrot-png
(:require [mandelbrot :as m]
[jolt.png :as png]))
(defn- color
"Escape-iteration count -> RGB. In-set points (n>=cap) are black; faster
escapes run through a warm gradient."
[n cap]
(if (>= n cap)
[0 0 0]
(let [t (/ (double n) cap)]
[(int (* 255 (min 1.0 (* 3.0 t))))
(int (* 255 (min 1.0 (max 0.0 (* 3.0 (- t 0.33))))))
(int (* 255 (min 1.0 (max 0.0 (* 3.0 (- t 0.66))))))])))
(defn render!
"Render a size×size view of the Mandelbrot set to a PNG at path."
[path size]
(let [w size h size cap 1000
img (png/image w h)]
(doseq [py (range h)]
(doseq [px (range w)]
(let [cr (- (* 3.5 (/ (double px) w)) 2.5) ; real ∈ [-2.5, 1.0]
ci (- (* 2.8 (/ (double py) h)) 1.4) ; imag ∈ [-1.4, 1.4]
[r g b] (color (m/count-point cr ci cap) cap)]
(png/put! img r g b))))
(png/write img w h path)
(println "wrote" path (str w "×" h ", cap " cap))))
(defn -main [& args]
(render! (or (first args) "mandelbrot.png")
(if (second args) (Integer/parseInt (second args)) 600)))

View file

@ -5,7 +5,7 @@
;; monomorphic dispatch gets to a direct call. Same per-call work as `dispatch`.
;;
;; Portable Clojure (jolt + JVM Clojure).
;; jolt -m mono-dispatch 20000 (JOLT_DIRECT_LINK=1 JOLT_WHOLE_PROGRAM=1)
;; bench/run.sh mono-dispatch 20000
(ns mono-dispatch)
(defprotocol Shape

View file

@ -1,48 +1,70 @@
#!/bin/sh
# Run the jolt benchmark suite and print mean ms per benchmark.
# Run the jolt benchmark suite against JVM Clojure and print a jolt/JVM scorecard.
#
# Each benchmark isolates an axis the ray tracer (float-compute-bound) doesn't
# capture — see README.md. Run back-to-back against `main` to measure a pass's
# impact.
# jolt's optimizing passes (direct-linking, inlining, scalar-replace, whole-program
# inference) fire only in an AOT BUILD — `joltc run -m` is unoptimized — so each
# benchmark is compiled to an optimized standalone binary and timed. JVM Clojure
# runs the same portable source for the absolute reference. Each benchmark prints
# `runs: [...]` and `mean: N ms`; the table shows the means and the jolt/JVM ratio.
#
# bench/run.sh # default sizes, whole-program optimization on
# JOLT_WHOLE_PROGRAM=0 bench/run.sh # compare with WP off
# bench/run.sh binary-trees # one benchmark
# bench/run.sh # full suite + JVM scorecard
# bench/run.sh fib # one benchmark, default size
# bench/run.sh fib 32 # one benchmark, custom size
# NO_JVM=1 bench/run.sh # jolt only (skip the JVM reference)
#
# Needs `jolt` on PATH (build with `jpm build`; export PATH="$PWD/build:$PATH").
# Building needs Chez's kernel dev files (libkernel.a + scheme.h) and a C compiler,
# the same as `jolt build`; set JOLT_CHEZ_CSV to override the detected csv dir.
set -e
cd "$(dirname "$0")"
root="$(cd .. && pwd)"
joltc="$root/bin/joltc"
export JOLT_PWD="$PWD"
export JOLT_DIRECT_LINK="${JOLT_DIRECT_LINK:-1}"
export JOLT_WHOLE_PROGRAM="${JOLT_WHOLE_PROGRAM:-1}"
export JOLT_APP_PATHS="$PWD"
export JOLT_PATH="$PWD"
# Locate Chez's kernel dev files for the optimized build (as build-smoke.sh does).
csv="$JOLT_CHEZ_CSV"
if [ -z "$csv" ]; then
chez_bin="$(command -v chez || command -v scheme || command -v petite || true)"
if [ -n "$chez_bin" ]; then
base="$(cd "$(dirname "$chez_bin")/.." 2>/dev/null && pwd)"
for d in "$base"/lib/csv*/*/; do
[ -f "${d}libkernel.a" ] && csv="${d%/}" && break
done
fi
fi
if [ -z "$csv" ] || [ ! -f "$csv/libkernel.a" ] || [ ! -f "$csv/scheme.h" ] || ! command -v cc >/dev/null 2>&1; then
echo "error: the optimized build needs Chez kernel dev files (libkernel.a + scheme.h) and cc." >&2
echo " set JOLT_CHEZ_CSV to the csv dir, e.g. \$(brew --prefix chezscheme)/lib/csv*/<machine>." >&2
exit 1
fi
export JOLT_CHEZ_CSV="$csv"
# name:default-arg (arg sized to run in a few seconds each). Axes: allocation
# (binary-trees), megamorphic vs monomorphic dispatch, persistent-collection
# churn (collections — now O(log n) via the HAMT, so sized up), pure
# float compute (mandelbrot), call+arith recursion (fib).
BENCHES="binary-trees:14 dispatch:2000 mono-dispatch:2000 collections:30000 mandelbrot:200 fib:30"
bindir="$(mktemp -d)"
trap 'rm -rf "$bindir"' EXIT
# name:default-arg, each sized to run in a few seconds. Axes: see README.md.
BENCHES="fib:30 mandelbrot:200 collections:30000 mono-dispatch:2000 dispatch:2000 binary-trees:14"
# JVM=1 also runs each bench on JVM Clojure and prints a jolt/JVM ratio — the
# holistic absolute-reference scorecard for the optimization work.
run_one() {
ns="${1%%:*}"; arg="${2:-${1##*:}}"
jmean=$(jolt -m "$ns" "$arg" 2>&1 | awk '/^mean:/{print $2}')
if [ -n "$JVM" ]; then
vmean=$(clojure -Sdeps '{:paths ["."]}' -M -m "$ns" "$arg" 2>&1 | awk '/^mean:/{print $2}')
ratio=$(awk "BEGIN{ if ($vmean+0>0) printf \"%.1f\", ($jmean+0)/($vmean+0); else printf \"-\" }")
printf '%-16s jolt %9s ms jvm %8s ms %sx\n' "$ns" "${jmean:--}" "${vmean:--}" "$ratio"
if ! "$joltc" build -m "$ns" -o "$bindir/$ns" --direct-link --opt >/dev/null 2>&1; then
printf '%-16s jolt build FAILED\n' "$ns"; return
fi
jmean=$("$bindir/$ns" "$arg" 2>/dev/null | awk '/^mean:/{print $2}')
if [ -z "$NO_JVM" ]; then
vmean=$(clojure -Sdeps '{:paths ["."]}' -M -m "$ns" "$arg" 2>/dev/null | awk '/^mean:/{print $2}')
ratio=$(awk "BEGIN{ if (\"$vmean\"+0>0 && \"$jmean\"+0>0) printf \"%.1fx\", (\"$jmean\"+0)/(\"$vmean\"+0); else printf \"-\" }")
printf '%-16s jolt %9s ms jvm %8s ms %s\n' "$ns" "${jmean:--}" "${vmean:--}" "$ratio"
else
printf '%-16s %9s ms\n' "$ns" "${jmean:--}"
printf '%-16s jolt %9s ms\n' "$ns" "${jmean:--}"
fi
}
if [ -n "$1" ]; then
for spec in $BENCHES; do
[ "${spec%%:*}" = "$1" ] && run_one "$spec" "$2"
done
spec=""
for s in $BENCHES; do [ "${s%%:*}" = "$1" ] && spec="$s"; done
[ -n "$spec" ] || { echo "unknown benchmark: $1 (have: ${BENCHES})" >&2; exit 1; }
run_one "$spec" "$2"
else
echo "jolt benchmark suite (WP=$JOLT_WHOLE_PROGRAM${JVM:+, vs JVM Clojure})"
echo "jolt benchmark suite — optimized AOT binaries${NO_JVM:+ }${NO_JVM:-, vs JVM Clojure}"
for spec in $BENCHES; do run_one "$spec"; done
fi

View file

@ -13,7 +13,29 @@
# the user's original cwd (the project dir, where deps.edn lives) is passed in
# JOLT_PWD.
root="$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd)"
JOLT_PWD="${JOLT_PWD:-$PWD}"
export JOLT_PWD
export JOLT_PWD="${JOLT_PWD:-$PWD}"
# Identify the Chez Scheme executable
while read -r CHEZ
do
if [ `which ${CHEZ}` ]
then
break;
fi
done <<EOF
chez
chezscheme
EOF
# If we failed to find one, whinge and exit.
if [ ! `which ${CHEZ}` ]
then
echo "No valid Chez Scheme executable found: please install Chez Scheme."
exit 1
fi
# Version for --version / banners: git describe of this checkout, else "dev".
export JOLT_VERSION="${JOLT_VERSION:-$(git -C "$root" describe --tags --always --dirty 2>/dev/null || echo dev)}"
cd "$root" || exit 1
exec chez --script host/chez/cli.ss "$@"
exec ${CHEZ} --script host/chez/cli.ss "$@"

View file

@ -57,14 +57,14 @@ dependencies, and prepends the resolved source directories to the source roots
for the run. The CLI commands (`jolt.deps` + `jolt.main`):
```bash
bin/joltc run -m NS [args] # resolve deps.edn, load NS, call its -main
bin/joltc run FILE # resolve deps.edn, load a Clojure file
bin/joltc -M:alias [args] # run the alias's :main-opts
bin/joltc -A:alias [args] # add the alias's paths/deps, then run the rest
bin/joltc repl # start a line REPL (project deps + native libs loaded)
bin/joltc nrepl [port] # start an nREPL server (default 7888) for editors
bin/joltc path # print the resolved source roots (':'-joined)
bin/joltc <task> # run a deps.edn :tasks entry
bin/joltc run -m NS [args] # resolve deps.edn, load NS, call its -main
bin/joltc run FILE # resolve deps.edn, load a Clojure file
bin/joltc -M:alias [args] # run the alias's :main-opts
bin/joltc -A:alias [args] # add the alias's paths/deps, then run the rest
bin/joltc repl # start a line REPL (project deps + native libs loaded)
bin/joltc --nrepl-server [port] # start an nREPL server (default 7888) for editors
bin/joltc path # print the resolved source roots (':'-joined)
bin/joltc <task> # run a deps.edn :tasks entry
```
Example `deps.edn`:

View file

@ -19,6 +19,36 @@ reflection and no class hierarchy. `(class x)` returns the JVM class name for th
scalar/collection types Clojure programs compare against (`"java.lang.Long"`,
`"java.lang.String"`, and so on).
## Source layering: JVM-specific code lives in the java layer
Keep anything JVM-specific in `host/chez/java/`. The rest of the runtime stays
JVM-free, and the compiler in `jolt-core/` is JVM-free by construction.
- `host/chez/java/` holds the JVM model: the `java.*` mirrors, the class tokens
and class hierarchy, `(class x)`/`(type x)`/`instance?`, exception classes, the
interop dispatch for `.method`/`Class/static`/`(Class.)`. If a value or name
only means something because the JVM has it, it belongs here.
- The rest of `host/chez/` is the host-neutral runtime — the value model
(`values.ss`, `collections.ss`, `seq.ss`), reader, vars, multimethods, meta. It
speaks jolt's own taxonomy (`:string`, `:vector`, `:jolt/inst`), never JVM class
names.
- `jolt-core/` (the Clojure compiler + `clojure.core` overlay) emits and reasons
in that taxonomy only. The JVM mapping happens *after*, in the java layer.
The worked example is `type`. The core layer (`natives-meta.ss`) computes the
keyword taxonomy and binds it as `__type-tag` — that's what `print-method` and the
reader dispatch on, with no JVM in scope. The java layer (`java/host-class.ss`)
then rebinds the public `clojure.core/type` to Clojure's `(or (:type meta) (class
x))`, mapping `:jolt/inst` → `java.util.Date` and so on, right next to `(class
…)`. So the compiler keeps emitting `:jolt/inst`; the java layer remaps it.
When you add interop behaviour, prefer registering it through the generic hooks a
java-layer file already uses — `register-class-arm!` for `(class x)`,
`register-instance-check-arm!` for `instance?`, `register-eq-arm!` for value
equality — rather than threading a JVM concept back into a host-neutral file. A
new `java.*` shim is a new file under `host/chez/java/` loaded from `rt.ss`, not a
branch added to `collections.ss` or `seq.ss`.
## What's shimmed
This is the surface today, not the whole JVM. Methods not listed generally
@ -39,12 +69,28 @@ aren't implemented; a few are accepted but no-ops (noted inline).
`.doubleValue` `.floatValue` `.byteValue` `.shortValue` `.toString`
`.hashCode` (integer projections wrap modulo their width, as on the JVM).
- **`java.lang.System`** — `currentTimeMillis` `nanoTime` `exit` `getProperty`
`setProperty` `clearProperty` `getProperties` `getenv`.
- **`java.lang.Thread`** — `sleep` (real), `yield`/`interrupted` (no-ops),
`currentThread`.
`setProperty` `clearProperty` `getProperties` `getenv` `gc` (a full Chez
collection — clears weak references and fires their queues).
- **`java.lang.Thread`** — real OS threads over Chez `fork-thread`, sharing the
one heap (a captured atom/var is shared): `(Thread. thunk)` + `start` / `join` /
`run` / `isAlive`; plus `sleep` (real), `yield`/`interrupted`/`interrupt`
(no-ops), `currentThread`.
- **`java.util.concurrent.CountDownLatch`** — `(CountDownLatch. n)` + `countDown`
/ `await` / `getCount`, a real counting barrier (mutex + condition).
- **`java.lang.ref.SoftReference` / `WeakReference` + `ReferenceQueue`** — genuine
GC reclamation: the referent is held through a Chez weak pair, so the collector
reclaims it once unreachable (`.get` then returns nil) and a guardian enqueues
the reference on its `ReferenceQueue` (`poll`). Chez has no reference softer than
weak, so a `SoftReference` clears on unreachability, not memory pressure — eager,
but real eviction (core.cache's SoftCache).
- **`java.lang.Object`** — `(Object.)` as a fresh-identity sentinel; `.toString`
`.hashCode` `.equals` `.getClass` work on any value.
- **`java.lang.Class`** — `forName`.
- **`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). 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
@ -64,18 +110,37 @@ aren't implemented; a few are accepted but no-ops (noted inline).
- **`java.util.ArrayList`** — `add` `get` `set` `size` `isEmpty` `remove` `clear`
`contains` `toArray` `iterator`.
- **`java.util.HashMap`** — `put` `get` `getOrDefault` `containsKey`
`containsValue` `size` `isEmpty` `remove` `clear` `putAll` `keySet` `values`
`entrySet`.
- **`java.util.HashMap`** / **`java.util.concurrent.ConcurrentHashMap`** — `put`
`get` `getOrDefault` `containsKey` `containsValue` `size` `isEmpty` `remove`
`clear` `putAll` `keySet` `values` `entrySet`; `clojure.core`'s `get` / `count` /
`contains?` also read them. (One shared heap, so the plain mutable map serves the
concurrent one.)
### I/O
- **`java.io.File`** — `(File. path)` / `(File. parent child)`; `getPath`
`getName` `getAbsolutePath` `getCanonicalPath` `toURI` `toURL` `exists`
`isDirectory` `isFile` `listFiles` `getParent`.
- **`java.io.StringReader` / `StringWriter` / `PushbackReader`** — the
`read`/`readLine`/`mark`/`reset`/`unread`/`write`/`append`/`toString` surface
the reader and `with-out-str` rely on.
- **`java.io.File`** — `(File. path)` / `(File. parent child)`. A File keeps the
path as given (`(.getPath (File. "rel"))` is `"rel"`, `.isAbsolute` false); a
relative path resolves against `JOLT_PWD` only when the filesystem is touched.
Methods: `getPath` `getName` `getParent` `getParentFile` `getAbsolutePath`
`getAbsoluteFile` `getCanonicalPath` `getCanonicalFile` `toURI` `toURL`
`exists` `isDirectory` `isFile` `isAbsolute` `isHidden` `length` `lastModified`
`canRead` `canWrite` `canExecute` `list` `listFiles` `mkdir` `mkdirs` `delete`
`createNewFile` `renameTo` `compareTo` `equals` `hashCode`. Statics:
`File/separator` `File/separatorChar` `File/pathSeparator` `File/createTempFile`
`File/listRoots`.
- **Byte streams**`FileInputStream` / `FileOutputStream` (over a path/File,
`append` arg), `ByteArrayInputStream` / `ByteArrayOutputStream`
(`toByteArray`/`toString`/`size`/`reset`), `BufferedInputStream` /
`BufferedOutputStream`. `read`/`read(byte[])`, `write(int)`/`write(byte[])`,
`flush`, `close`. Each is a Chez binary port underneath.
- **Char streams**`FileReader` / `InputStreamReader` (read a byte stream as
UTF-8), `FileWriter` / `OutputStreamWriter`, `BufferedReader` (`readLine`,
`lines`) / `BufferedWriter` (`newLine`), `StringReader` / `StringWriter` /
`PushbackReader`.
- **`clojure.java.io`** — `file` `as-file` `reader` `writer` `input-stream`
`output-stream` `copy` (byte-exact for byte sources) `make-parents`
`delete-file` `resource` `as-url`. `slurp`/`spit`/`line-seq`/`with-open` work
over all of the above.
- **`java.lang.ClassLoader`** — `getSystemClassLoader`, `.getResource`,
`.getResourceAsStream` (resolved against the source roots).
@ -106,8 +171,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
@ -170,6 +240,32 @@ register checks without clobbering each other. This is the mechanism jolt's
HTTP client library uses to emulate `java.net.URL` and `HttpURLConnection` so
`clj-http-lite` runs unchanged.
`__register-instance-check!` answers one `(instance? Foo x)` question. When a
class belongs to a *hierarchy* — a custom exception that should be caught as an
`IOException`, or a value that should match `(instance? SomeInterface x)` across
its whole supertype chain and dispatch a protocol extended to any of those
supertypes — declare its direct supers once with `jolt.host/register-class-supers!`
instead. `instance?`, `isa?`, `supers`/`ancestors`, and `extend-protocol`
dispatch all derive from the one declaration (supers are given by canonical name;
transitivity is computed):
```clojure
;; a library's exception type that catch/instance? should treat as an IOException
(jolt.host/register-class-supers! "com.acme.RetryExhaustedException"
["java.io.IOException"])
(throw (jolt.host/throwable "com.acme.RetryExhaustedException" "gave up"))
;; (catch java.io.IOException e …) now matches it; (instance? java.lang.Exception e) is true
```
deftype/defrecord classes join the same graph automatically at definition: a
record's ancestry carries the record interfaces (`clojure.lang.IRecord`,
`IPersistentMap`, `Associative`, …), a bare deftype carries
`clojure.lang.IType`, and every protocol the type implements inline appears as
an implemented interface — so `(ancestors MyRecord)`, `(isa? MyRecord
clojure.lang.IPersistentMap)`, and hierarchy relationships `derive`d on a
class's supers all answer like the JVM.
Extending a *built-in* class instead (adding a method to core's `String` shim,
say) means editing the relevant `host/chez/*.ss` file and running `make remint`
— see [building-and-deps.md](building-and-deps.md).

View file

@ -1,55 +1,80 @@
# Clojure libraries known to work with Jolt
Libraries confirmed to load and pass their conformance checks on Jolt
(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)).
Libraries confirmed to load and pass their conformance checks on Jolt. A library
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).
* [config](https://github.com/yogthos/config)
* [Selmer](https://github.com/yogthos/Selmer)
* [medley](https://github.com/weavejester/medley)
* [cuerdas](https://github.com/funcool/cuerdas)
* [aero](https://github.com/juxt/aero) — EDN configuration with tag literals
(`#ref`/`#env`/`#or`/`#profile`/`#long`/…)
* [config](https://github.com/yogthos/config) — environment configuration
* [Selmer](https://github.com/yogthos/Selmer) — Django-style templates
* [medley](https://github.com/weavejester/medley) — collection utilities
* [cuerdas](https://github.com/funcool/cuerdas) — string manipulation
* [ring-core](https://github.com/ring-clojure/ring) — via `:deps/root "ring-core"`,
on the [ring-app example](https://github.com/jolt-lang/examples/tree/main/ring-app)'s
spork/http adapter
* [ring-codec](https://github.com/ring-clojure/ring-codec)
on the ring-app example
* [ring-codec](https://github.com/ring-clojure/ring-codec) — URL/form encoding
* [ring-defaults](https://github.com/ring-clojure/ring-defaults) — the standard
middleware stack (params, static resources + content-type, session, security
headers); its session/CSRF crypto comes from
[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 in Clojure by
[jolt-lang/router](https://github.com/jolt-lang/router). Load with
`JOLT_FEATURES` including `clj`.
`reitit.Trie` Java class is mirrored by
[jolt-lang/router](https://github.com/jolt-lang/router).
* [integrant](https://github.com/weavejester/integrant) — data-driven system
configuration; `ig/init`/`ig/halt!` build and tear down a component graph wired
with `#ig/ref`, on the ring-app example. Loads unmodified with its
configuration (`#ig/ref`), with its
[dependency](https://github.com/weavejester/dependency) and
[meta-merge](https://github.com/weavejester/meta-merge) deps.
* [honeysql](https://github.com/seancorfield/honeysql) — full formatter + helpers
(select/insert/update/delete/joins/:inline), loaded unmodified from git
* [clojure.jdbc](https://github.com/yogthos/clojure.jdbc) — as [jolt-lang/db](https://github.com/jolt-lang/db)'s
`jdbc.core`, over the built-in SQLite access (libsqlite3 via Chez's FFI)
* [next.jdbc](https://github.com/seancorfield/next-jdbc) — a compatibility layer in
[jolt-lang/db](https://github.com/jolt-lang/db) (`next.jdbc`, `next.jdbc.sql`,
`next.jdbc.prepare`, `next.jdbc.transaction`) over `jdbc.core`, for libraries
that target the next.jdbc API
* [tools.logging](https://github.com/clojure/tools.logging) — the real
`clojure.tools.logging` source runs verbatim. jolt provides a native
`clojure.tools.logging.impl` backend (a stderr `LoggerFactory` — the library's
designed extension point, where slf4j/log4j/jul adapters normally plug in) plus
the host shims it needs (`agent`/`send-off`, `clojure.lang.LockingTransaction`,
a `clojure.pprint` subset, `clojure.string/trim-newline`). The level macros,
`logf`/`logp`, `spy`, and `enabled?` all work; output goes to stderr.
* [migratus](https://github.com/yogthos/migratus) — database migrations; loads
unmodified and runs filesystem SQL/EDN migrations against SQLite through the
next.jdbc layer above. `migrate`/`rollback` round-trip end to end.
[meta-merge](https://github.com/weavejester/meta-merge) deps
* [honeysql](https://github.com/seancorfield/honeysql) — SQL formatter and helpers
* [clojure.jdbc](https://github.com/yogthos/clojure.jdbc) — via
[jolt-lang/db](https://github.com/jolt-lang/db)'s `jdbc.core`, over the built-in
SQLite access (libsqlite3 via Chez's FFI)
* [tools.logging](https://github.com/clojure/tools.logging) — runs verbatim over a
native `clojure.tools.logging.impl` stderr backend
* [migratus](https://github.com/yogthos/migratus) — database migrations over
[jolt-lang/db](https://github.com/jolt-lang/db)
* [malli](https://github.com/metosin/malli) — data schema validation, on the
[malli-app example](https://github.com/jolt-lang/examples/tree/main/malli-app).
`m/validate` and `m/explain` work across the vocabulary (predicates, `:int`/
`:string`/`:keyword`, `:map` incl. nested + optional, `:vector`, `:tuple`,
`:enum`, `:maybe`, `:and`/`:or`, `:re`, bounded int/string). Load with
`JOLT_FEATURES` including `clj` (malli's `.cljc` keys class-schemas off the
`:clj` reader-conditional branches).
malli-app example.
* [markdown-clj](https://github.com/yogthos/markdown-clj) — Markdown → HTML, on the
[markdown-app example](https://github.com/jolt-lang/examples/tree/main/markdown-app).
Renders headings, emphasis, inline code, links, lists, tables, strikethrough.
markdown-app example
* [hiccup](https://github.com/weavejester/hiccup) — HTML from Clojure data, on the
[hiccup-app example](https://github.com/jolt-lang/examples/tree/main/hiccup-app).
Element tags, attribute maps, nested elements, and `for` comprehensions; its
`html` macro pre-compiles the markup (a good compiler stress test).
hiccup-app example
* [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.
* [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).
* [core.memoize](https://github.com/clojure/core.memoize) — function memoization
over [core.cache](https://github.com/clojure/core.cache).
* [core.async](https://github.com/clojure/core.async) — CSP channels and `go` blocks
(`<!`/`>!`/`alts!`, `pipeline`, `mult`/`mix`/`pub`/`sub`) on real OS threads.
* [core.logic](https://github.com/clojure/core.logic) — relational logic programming
(unification, `run`/`fresh`/`conde`, finite domains).
* [math.combinatorics](https://github.com/clojure/math.combinatorics) — permutations,
combinations, subsets, selections, cartesian products, partitions.
* [core.contracts](https://github.com/clojure/core.contracts) — programming by
contract (`contract`/`with-constraints`/`provide`), over
[core.unify](https://github.com/clojure/core.unify).
* [data.zip](https://github.com/clojure/data.zip) — zipper navigation, including
`clojure.data.zip.xml`; XML parsing via [jolt-lang/xml](https://github.com/jolt-lang/xml)
(which now ships `clojure.xml/parse`).
* [data.csv](https://github.com/clojure/data.csv) — reading and writing CSV.
* [data.codec](https://github.com/clojure/data.codec) — base64 encode/decode over
byte arrays.
* [data.priority-map](https://github.com/clojure/data.priority-map) — priority
maps (incl. keyfn / custom comparator), with `subseq`/`rsubseq`.
* [tools.macro](https://github.com/clojure/tools.macro) — local macros
(`macrolet`/`symbol-macrolet`), `mexpand`/`mexpand-all`.
* [algo.monads](https://github.com/clojure/algo.monads) — monad macros and
monads (maybe/seq/state/writer/reader/…), over
[tools.macro](https://github.com/clojure/tools.macro).
* [test.check](https://github.com/clojure/test.check) — property-based testing
(generators, `quick-check`, shrinking).
* [tools.reader](https://github.com/clojure/tools.reader) — a Clojure reader in
Clojure (edn + full reader, indexing/pushback reader types).
* [rewrite-clj](https://github.com/clj-commons/rewrite-clj) — parse/rewrite Clojure
source while preserving whitespace and comments (nodes + zipper), over
[tools.reader](https://github.com/clojure/tools.reader).
* [tick](https://github.com/juxt/tick) — date/time over Jolt's `java.time`;
`#time/…` literals via `time-literals`.
* [transit-jolt](https://github.com/jolt-lang/transit-jolt) — Transit (JSON) read/write

View file

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

View file

@ -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.
@ -224,3 +225,31 @@ reader functions are the deliberate exception, S20). Forms read identically
whether or not they will be evaluated; `read-string` of any printable value
`v` followed by evaluation yields a value equal to `v` for the
self-evaluating types (§4 print/read round-trip contract).
## Strict tokens and edn mode
The reader rejects what the reference rejects (corpus `edn / strictness`,
`reader / strict tokens`):
- A token that starts like a number but doesn't parse as one is
NumberFormatException, never a symbol: `1a`, `08` (a leading zero demands
octal digits; `042` is 34), `0x2g`, `2r2`. A ratio's parts are plain digit
runs (`1/-1` is invalid); a zero denominator is ArithmeticException.
- Empty ns/name parts are invalid tokens: `:`, `::`, `foo/`, `/foo`, `:/foo`.
`/` (division), `ns//` and `:/` (a name of exactly `/`) are valid.
- Map literals with duplicate keys and set literals with duplicate elements
throw IllegalArgumentException at read.
- An unsupported string escape (`"\q"`) and an octal escape past `\377`
(string or `\o` char) throw. A stray close delimiter at top level is
"Unmatched delimiter". `\r` terminates a line comment like `\n`.
- `#inst` validates its calendar fields progressively (month 112, day valid
for the month including leap years, hour < 24, minute < 60); `#uuid`
demands canonical 8-4-4-4-12 hex.
clojure.edn adds on top of that (`__read-form-edn` seam): auto-resolved
keywords (`::k`) are invalid (no resolution context), each `#_` discarded
form is validated through the same `:readers`/`:default` pipeline (an
unreadable tagged element throws even when discarded), `M` literals
construct BigDecimals, lists satisfy `list?`, and end-of-input honors the
`:eof` option — an opts map without `:eof` makes EOF an error, while the
no-opts arity returns nil.

View file

@ -10,6 +10,40 @@ them (e.g. vector `nth` is "effectively constant time" — SHOULD-level).
---
## Collection return types & laziness (cross-cutting)
Two contracts hold across the sequence library and are not restated per entry.
**Return-type fidelity.** A function returns the same *kind* of collection the
reference does — value equality is not enough, since `(= [0 1] '(0 1))`.
- Sequence transformations return **seqs** (lazy unless noted): `map`, `filter`,
`remove`, `keep`, `mapcat`, `take`/`drop` and their `-while` forms, `partition`,
`partition-all`, `partition-by`, `interpose`, `dedupe`, `distinct`, `concat`,
`reductions`, `cons`, `rest`, `sequence`. The *elements* of `partition` /
`partition-all` / `partition-by` are themselves seqs, not vectors.
- The vector variants return **vectors**: `mapv`, `filterv`, `vec`, `subvec`,
`partitionv`, `partitionv-all`, `splitv-at`. `split-at` / `split-with` return a
2-vector `[take drop]`. A transducer applied eagerly (`into []`, the
`partition-all` transducer's chunks) yields vectors.
- Type-preserving functions return the input's type: `replace` over a vector is a
vector, over any other seqable a (lazy) seq; `empty`/`into (empty coll)` keep the
collection kind; `set`/`into #{}` return sets; `into {}`/`select-keys`/`zipmap`/
`frequencies`/`group-by`/`merge` return maps (`group-by` values are vectors).
**Laziness.** The lazy sequence functions — including `sequence`, `eduction`, and
`mapcat` — MUST consume their source incrementally and so terminate on an infinite
or unbounded source when only a prefix is demanded: `(first (sequence (map inc)
(range)))` and `(take n (mapcat f (range)))` return without realizing the whole
source. `(apply concat coll-of-colls)` is likewise lazy in its argument seq. The
eager consumers (`reduce`, `into`, `count`, `vec`, `doall`) realize the demanded
portion fully.
These are exercised by the `seq / lazy over infinite` and the per-fn type-predicate
rows in the conformance corpus.
---
### first — since 1.0
```
@ -162,6 +196,164 @@ cases; clojure-test-suite `core_test/parse_uuid.cljc`,
---
### clojure.template/apply-template, clojure.test/are — since 1.1
```
(apply-template argv expr values)
(are argv expr & args)
```
**Semantics**
- S1. `apply-template` MUST replace every occurrence of each `argv` symbol
in `expr` with its corresponding value by structural walk (postwalk symbol
substitution), not by lexical binding. Occurrences inside `quote` and at
any nesting depth substitute: `(apply-template '[x] '(f 'x) '[if])`
`(f 'if)`.
- S2. `do-template` MUST partition `args` by `(count argv)` and expand to a
`do` of one substituted `expr` per group.
- S3. `clojure.test/are` MUST expand through `do-template` with `expr`
wrapped in `is`. Consequently `(are [x] (special-symbol? 'x) if def)`
asserts `(special-symbol? 'if)` and `(special-symbol? 'def)` — a
let-binding implementation is non-conforming (the quoted symbol would not
substitute).
**Errors**
- X1. `are` MUST throw at macroexpansion when `(count args)` is not a
positive multiple of a non-empty `(count argv)` (empty/empty is allowed).
- X2. `apply-template` MUST throw when `argv` is not a vector of symbols.
**Conformance**
S1S3 → `test/chez/clojure-test.clj` (are with quoted template var);
clojure-test-suite `core_test/special_symbol_qmark.cljc` and every
`are`-based suite namespace.
---
### make-hierarchy, derive, underive, isa?, parents, ancestors, descendants — since 1.0
```
(make-hierarchy)
(derive tag parent) (derive h tag parent)
(underive tag parent) (underive h tag parent)
(isa? child parent) (isa? h child parent)
(parents tag) (ancestors tag) (descendants tag) ; + (f h tag) forms
```
**Semantics**
- S1. A hierarchy is a pure value `{:parents {tag #{...}} :ancestors {...}
:descendants {...}}`; the 3-arity forms are pure, the shorter arities read and
mutate the global hierarchy.
- S2. `isa?` is true when `(= child parent)`, when the host type system says
parent is assignable from child (both classes), when the relationship was
`derive`d — including a relationship derived on one of a class child's
supers — or component-wise for equal-length vectors.
- S3. Class tags answer through the host type hierarchy: `(parents c)` includes
the class's direct supers (`bases` — a concrete class's chain roots at
`java.lang.Object`, an interface's does not); `(ancestors c)` is the
transitive set plus anything `derive`d on the class or its supers. A
deftype/defrecord class's ancestry includes its implemented protocol
interfaces and, for records, the record interfaces
(`clojure.lang.IRecord`/`IPersistentMap`/`Associative`/…; `clojure.lang.IType`
for a bare deftype).
- S4. `derive` returns the updated hierarchy (3-arity) or nil (2-arity);
deriving a relationship that already holds transitively, or one that would
create a cycle, throws.
**Errors**
- X1. `derive` asserts its argument shapes: parent must be a namespaced Named
value; tag must be a class or a Named value (namespaced in the 2-arity
global form); `(derive h tag tag)` fails the `not=` assert. AssertionError.
- X2. `underive`/`derive` with a non-hierarchy `h` throw at the parents
lookup (the map is called as a function, like the reference).
- X3. `(descendants h SomeClass)` throws UnsupportedOperationException
("Can't get descendants of classes") — Java type inheritance is not
enumerable downward.
**Conformance**
S1S4, X1X3 → corpus `hierarchy / *` rows; clojure-test-suite
`core_test/{derive,underive,isa_…,parents,ancestors,descendants}.cljc`
(all fully passing).
---
### atom, add-watch, remove-watch, set-validator!, get-validator — since 1.0
```
(atom x & {:keys [meta validator]})
(add-watch iref key f) (remove-watch iref key)
(set-validator! iref f) (get-validator iref)
```
**Semantics**
- S1. Watches, validators, and reference metadata are one contract (the JVM's
ARef/IRef) shared by atoms, vars, and agents. `add-watch`/`remove-watch`
return the reference; re-adding a key replaces that watch in place.
- S2. A watch is called `(f key ref old new)` after a state change: atom
swap!/reset!/compare-and-set!, var ROOT changes (`def` on a watched var,
`var-set` outside a thread binding, `alter-var-root` — a thread-binding set
does not notify), and each agent action's state change.
- S3. A validator gates every state change and, via the `:validator` ctor
option, the initial value — an invalid initial value never constructs the
reference.
- S4. The `:meta` ctor option attaches reference metadata (`meta` reads it,
`alter-meta!`/`reset-meta!` update it); nil is allowed.
**Errors**
- X1. A rejected value (validator returns logical false or the ctor option
fails on the initial value) throws IllegalStateException "Invalid reference
state".
- X2. A non-map `:meta` ctor option throws ClassCastException.
**Conformance**
S1S4, X1X2 → corpus `iref / *` rows; clojure-test-suite
`core_test/{atom,add-watch,remove-watch}.cljc` (the remaining baselined error
in the watch namespaces is their STM `ref` section — refs are out of scope,
`stm-refs` in `coverage.md`).
---
### clojure.string coercion, some-fn, ifn? — since 1.2/1.3
```
(clojure.string/upper-case s) … (some-fn p & ps) (ifn? x)
```
**Semantics**
- S1. The clojure.string case fns and searches (`upper-case`, `lower-case`,
`capitalize`, `starts-with?`, `ends-with?`, `includes?`, `index-of`,
`replace`) take any Object `s` through its `toString`, like the reference's
`^CharSequence`+`.toString` signatures: `(upper-case :kw)` is `":KW"`,
`(capitalize 1)` is `"1"`. nil throws (method call on null); a nil `substr`
throws.
- S2. `some-fn` follows the reference arities: at least one predicate
(`(some-fn)` is an arity error) and the returned fn chains with `or`, so a
no-match result is the last predicate's own falsy value (`false` stays
`false`).
- S3. `ifn?` covers fns, keywords, symbols, maps, sets, vectors, vars,
multimethods, promises (invoking a promise delivers it), and a
deftype/defrecord implementing `clojure.lang.IFn`'s `invoke`.
- S4. A `defmulti`/`defmethod` deferred inside a fn body interns/resolves in
the namespace it was WRITTEN in (the macros bake their expansion ns), not
whatever namespace is current when it runs.
**Conformance**
S1S4 → corpus `string / toString coercion`, `core / some-fn`, `core / ifn?`,
`multimethods / deferred definition`; clojure-test-suite string/some-fn/
ifn-qmark/boolean-qmark/reduce namespaces (all fully passing).
---
## Authoring notes
- Source examples from the ClojureDocs export (`clojuredocs-export.edn`,

View file

@ -1,21 +1,21 @@
# Appendix A — Coverage Dashboard (generated)
Generated 2026-06-22 by `tools/spec_coverage.py` — do not edit by hand.
Generated 2026-06-26 by `tools/spec_coverage.py` — do not edit by hand.
Surface: **694** clojure.core vars (ClojureDocs export; 648 with
community examples). jolt interns 574 of them.
community examples). jolt interns 594 of them.
| Status | Count | Meaning |
|---|---|---|
| implemented+tested | 568 | in jolt and exercised by spec/conformance |
| implemented-untested | 6 | in jolt, no direct test — spec entries will add them |
| implemented+tested | 590 | in jolt and exercised by spec/conformance |
| implemented-untested | 4 | in jolt, no direct test — spec entries will add them |
| resolvable-not-interned | 0 | works in code but invisible to ns introspection (conformance finding) |
| missing-portable | 6 | portable semantics, jolt lacks it — implementation gap |
| missing-portable | 0 | portable semantics, jolt lacks it — implementation gap |
| special-form | 16 | specified in §3, not a library var |
| dynamic-var | 24 | classification needed: portable default vs host-dependent |
| dynamic-var | 11 | classification needed: portable default vs host-dependent |
| agents-taps | 16 | out of scope pending concurrency design note |
| stm-refs | 11 | out of scope pending concurrency design note |
| jvm-specific | 47 | catalogued, not specified |
| jvm-specific | 46 | catalogued, not specified |
Classifications are initial and mechanical — reclassifying is an ordinary
spec change. A var is *Verified* only when its §9 entry exists and carries no
@ -27,35 +27,35 @@ UNVERIFIED field; that column will be added as entries land.
|---|---|---|
| `*` | implemented+tested | ✓ |
| `*'` | implemented+tested | ✓ |
| `*1` | missing-portable | ✓ |
| `*2` | missing-portable | ✓ |
| `*3` | missing-portable | ✓ |
| `*1` | implemented+tested | ✓ |
| `*2` | implemented+tested | ✓ |
| `*3` | implemented+tested | ✓ |
| `*agent*` | dynamic-var | ✓ |
| `*allow-unresolved-vars*` | dynamic-var | ✓ |
| `*assert*` | implemented+tested | ✓ |
| `*clojure-version*` | implemented+tested | ✓ |
| `*command-line-args*` | dynamic-var | ✓ |
| `*compile-files*` | dynamic-var | ✓ |
| `*command-line-args*` | implemented-untested | ✓ |
| `*compile-files*` | implemented+tested | ✓ |
| `*compile-path*` | dynamic-var | ✓ |
| `*compiler-options*` | dynamic-var | ✓ |
| `*data-readers*` | dynamic-var | ✓ |
| `*default-data-reader-fn*` | dynamic-var | ✓ |
| `*e` | missing-portable | ✓ |
| `*err*` | implemented-untested | ✓ |
| `*file*` | dynamic-var | ✓ |
| `*flush-on-newline*` | dynamic-var | |
| `*data-readers*` | implemented+tested | ✓ |
| `*default-data-reader-fn*` | implemented+tested | ✓ |
| `*e` | implemented+tested | ✓ |
| `*err*` | implemented+tested | ✓ |
| `*file*` | implemented-untested | ✓ |
| `*flush-on-newline*` | implemented+tested | |
| `*fn-loader*` | dynamic-var | |
| `*in*` | implemented+tested | |
| `*math-context*` | dynamic-var | |
| `*math-context*` | implemented+tested | |
| `*ns*` | implemented+tested | ✓ |
| `*out*` | implemented-untested | ✓ |
| `*print-dup*` | dynamic-var | ✓ |
| `*print-length*` | dynamic-var | ✓ |
| `*print-level*` | dynamic-var | ✓ |
| `*print-meta*` | dynamic-var | ✓ |
| `*print-namespace-maps*` | dynamic-var | ✓ |
| `*out*` | implemented+tested | ✓ |
| `*print-dup*` | implemented+tested | ✓ |
| `*print-length*` | implemented+tested | ✓ |
| `*print-level*` | implemented+tested | ✓ |
| `*print-meta*` | implemented+tested | ✓ |
| `*print-namespace-maps*` | implemented-untested | ✓ |
| `*print-readably*` | implemented+tested | ✓ |
| `*read-eval*` | dynamic-var | ✓ |
| `*read-eval*` | implemented+tested | ✓ |
| `*reader-resolver*` | dynamic-var | |
| `*repl*` | dynamic-var | |
| `*source-path*` | dynamic-var | ✓ |
@ -63,7 +63,7 @@ UNVERIFIED field; that column will be added as entries land.
| `*unchecked-math*` | implemented+tested | ✓ |
| `*use-context-classloader*` | dynamic-var | ✓ |
| `*verbose-defrecords*` | dynamic-var | |
| `*warn-on-reflection*` | implemented-untested | ✓ |
| `*warn-on-reflection*` | implemented+tested | ✓ |
| `+` | implemented+tested | ✓ |
| `+'` | implemented+tested | ✓ |
| `-` | implemented+tested | ✓ |
@ -131,7 +131,7 @@ UNVERIFIED field; that column will be added as entries land.
| `assoc-in` | implemented+tested | ✓ |
| `associative?` | implemented+tested | ✓ |
| `atom` | implemented+tested | ✓ |
| `await` | implemented-untested | ✓ |
| `await` | implemented+tested | ✓ |
| `await-for` | agents-taps | ✓ |
| `await1` | agents-taps | |
| `bases` | jvm-specific | ✓ |
@ -218,7 +218,7 @@ UNVERIFIED field; that column will be added as entries land.
| `declare` | implemented+tested | ✓ |
| `dedupe` | implemented+tested | ✓ |
| `def` | special-form | ✓ |
| `default-data-readers` | jvm-specific | ✓ |
| `default-data-readers` | implemented+tested | ✓ |
| `definline` | jvm-specific | |
| `definterface` | implemented+tested | ✓ |
| `defmacro` | special-form | ✓ |
@ -375,7 +375,7 @@ UNVERIFIED field; that column will be added as entries land.
| `lazy-cat` | implemented+tested | ✓ |
| `lazy-seq` | implemented+tested | ✓ |
| `let` | implemented+tested | ✓ |
| `letfn` | missing-portable | ✓ |
| `letfn` | implemented+tested | ✓ |
| `line-seq` | implemented+tested | ✓ |
| `list` | implemented+tested | ✓ |
| `list*` | implemented+tested | ✓ |
@ -512,7 +512,7 @@ UNVERIFIED field; that column will be added as entries land.
| `rational?` | implemented+tested | ✓ |
| `rationalize` | implemented+tested | ✓ |
| `re-find` | implemented+tested | ✓ |
| `re-groups` | missing-portable | ✓ |
| `re-groups` | implemented+tested | ✓ |
| `re-matcher` | implemented+tested | ✓ |
| `re-matches` | implemented+tested | ✓ |
| `re-pattern` | implemented+tested | ✓ |
@ -558,7 +558,7 @@ UNVERIFIED field; that column will be added as entries land.
| `reset-vals!` | implemented+tested | ✓ |
| `resolve` | implemented+tested | ✓ |
| `rest` | implemented+tested | ✓ |
| `restart-agent` | implemented-untested | ✓ |
| `restart-agent` | implemented+tested | ✓ |
| `resultset-seq` | jvm-specific | ✓ |
| `reverse` | implemented+tested | ✓ |
| `reversible?` | implemented+tested | ✓ |

View file

@ -72,11 +72,41 @@ bindings resolve. Each entry is a map — `{:name "sqlite3" :darwin
the running process's own symbols, e.g. libc sockets, no external file). A
project inherits its dependencies' `:jolt/native`.
### Static vs dynamic linking
When you `joltc build`, a native lib is **statically linked** into the binary by
default if the spec carries a `:static` archive — so the executable calls the C
code with no shared object present at runtime. Add `:static` alongside the runtime
candidates:
```clojure
{:name "sqlite3"
:static {:archive "/opt/homebrew/lib/libsqlite3.a"} ; or {:lib "sqlite3" :libdir "/usr/lib"}
:darwin ["libsqlite3.0.dylib"] ; still used by `run`/`repl` and by --dynamic
:linux ["libsqlite3.so.0"]}
```
`:static {:archive PATH}` force-loads the whole `.a` and is the reliable
cross-platform form. `:static {:lib NAME :libdir DIR}` links `-lNAME` (with a
`-Bstatic` preference on Linux); on macOS, which has no `-Bstatic`, prefer the
archive form. A spec with no `:static` (or a build passed `--dynamic`, or
`:jolt/build {:dynamic-natives true}`) keeps the old behavior — the shared object
is loaded at startup via `load-shared-object`.
Static linking needs a C compiler (`cc`) on `PATH` at build time (plus the C libs
the Chez kernel links — lz4, zlib, ncurses). The distributed `joltc` bundles the
Chez kernel, so it re-links the launcher stub with the archive baked in — no
external Chez, just `cc`. Without a `cc`, a `:static` lib fails with a message
pointing you to install one or pass `--dynamic`. Keep a `:darwin`/`:linux`
candidate on any `:static` spec so `run`/`repl` (which have no static binary) can
still load it.
## Standalone binaries
`joltc build -m NS` compiles the app and every library into one executable (the
runtime + compiler are baked in). It loads the resolved `:jolt/native` libs at
startup, so an FFI app — sockets, SQLite — runs with no jolt or Chez on the path.
runtime + compiler are baked in). Resolved `:jolt/native` libs are statically
linked in (or loaded at startup — see [Native libraries](#native-libraries)), so
an FFI app — sockets, SQLite — runs with no jolt or Chez on the path.
Output goes under the project's `target/`, cargo-style: `target/release/<project>`
by default and with `--opt`, `target/debug/<project>` with `--dev` (the
@ -152,6 +182,30 @@ a root, transitively.
- Source only; compiled `.class` files in a git dep are ignored.
- git `:git/sha` must be a full SHA (`git fetch` can't resolve a short one).
## Stack traces
An uncaught error prints the message, the top-level source location, and — when
frames are available — a `trace:` backtrace. In an AOT `jolt build --direct-link`
binary the frames map to `ns/name (file:line)`; on the runtime eval path they are
the surviving fn names. Tail-call optimization erases tail-called frames, so the
default trace shows only the non-tail spine.
A fuller **tail-frame history** recovers the frames TCO erases: each compiled fn
records itself on entry into a bounded ring-of-rings buffer, so the trace shows
TCO-elided frames (including the immediate error site) while a tight tail loop
stays bounded and its non-tail caller context is preserved.
It is **on by default in REPL-driven development** — a `repl` or nREPL session
turns it on, so an error in code you evaluate or reload shows a tail-frame trace
with no setup. Because the recording is baked in at compile time, only code
compiled while a session is live is traced; reload a namespace to trace code that
was already loaded (e.g. an app's initial `-M:run` load before its nREPL started).
Elsewhere it is off (a small per-call cost, and never emitted into a `jolt build`
binary). Override with the environment: `JOLT_TRACE=1` forces it on for a whole
run — including a plain `-M:run`, so the app's own load is traced — and
`JOLT_TRACE=0` forces it off, even in a REPL/nREPL session.
## Conformance
The known-working libraries (see [libraries.md](libraries.md)) and the

Binary file not shown.

View file

@ -23,21 +23,38 @@
(fields (mutable val) (mutable watches) (mutable validator) lock)
(nongenerative jolt-atom-v3))
;; (atom init) / (atom init :validator f :meta m): scan the trailing keyword opts
;; for :validator (the only one with runtime behaviour; :meta is accepted/ignored).
;; a rejected reference value is IllegalStateException, like ARef.validate.
(define (jolt-iref-state-throw)
(jolt-throw (jolt-host-throwable "java.lang.IllegalStateException" "Invalid reference state")))
;; (atom init :meta m :validator f) — the ARef ctor contract: the validator runs
;; against the initial value (an invalid init never constructs), :meta must be a
;; map (anything else is the JVM's IPersistentMap cast failure).
(define (jolt-atom-new v . opts)
(let loop ((o opts) (validator jolt-nil))
(let loop ((o opts) (validator jolt-nil) (m #f))
(cond
((or (null? o) (null? (cdr o))) (make-jolt-atom v '() validator (make-mutex)))
((or (null? o) (null? (cdr o)))
(let ((a (make-jolt-atom v '() validator (make-mutex))))
(jolt-atom-validate a v)
(when (and m (not (jolt-nil? m)))
(unless (jolt-map? m)
(jolt-throw (jolt-host-throwable
"java.lang.ClassCastException"
(string-append "class " (jolt-class-name m)
" cannot be cast to class clojure.lang.IPersistentMap"))))
(hashtable-set! meta-table a m))
a))
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "validator"))
(loop (cddr o) (cadr o)))
(else (loop (cddr o) validator)))))
(loop (cddr o) (cadr o) m))
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "meta"))
(loop (cddr o) validator (cadr o)))
(else (loop (cddr o) validator m)))))
;; validate a candidate value: a non-nil validator that returns falsey rejects.
(define (jolt-atom-validate a v)
(let ((vf (jolt-atom-validator a)))
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf v)))
(error #f "Invalid reference state"))))
(jolt-iref-state-throw))))
;; notify each watch (k ref old new), in insertion order (alist is reverse-built,
;; so walk it reversed to match add order).
@ -106,27 +123,87 @@
(jolt-atom-notify a old v)
(jolt-vector old v)))
;; --- watches / validators ---------------------------------------------------
;; --- watches / validators: the IRef seam --------------------------------------
;; On the JVM these are the ARef contract shared by atom/var/agent/ref. The atom
;; keeps its record slots (the hot swap!/reset! path); every OTHER watchable
;; reference type registers a predicate here and stores its watches/validator in
;; identity-keyed side tables. A ref type makes itself notify by calling
;; iref-notify at its mutation points (vars do at root set).
(define iref-arms '())
(define (register-iref-arm! pred) (set! iref-arms (cons pred iref-arms)))
(define (iref? r)
(let loop ((as iref-arms))
(cond ((null? as) #f) (((car as) r) #t) (else (loop (cdr as))))))
(define iref-watch-tbl (make-weak-eq-hashtable))
(define iref-validator-tbl (make-weak-eq-hashtable))
(define (iref-notify r old new)
(for-each (lambda (kv) (jolt-invoke (cdr kv) (car kv) r old new))
(reverse (hashtable-ref iref-watch-tbl r '()))))
(define (iref-validate r v)
(let ((vf (hashtable-ref iref-validator-tbl r jolt-nil)))
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf v)))
(jolt-iref-state-throw))))
;; add-watch interns (key . fn) (replacing any existing key, keeping order);
;; remove-watch drops it; both return the atom. set-validator! installs a
;; remove-watch drops it; both return the reference. set-validator! installs a
;; validator and validates the CURRENT value immediately (Clojure throws if it's
;; already invalid); get-validator reads the slot.
(define (jolt-watch-add alist key f)
(cons (cons key f) (remp (lambda (kv) (jolt=2 (car kv) key)) alist)))
(define (jolt-add-watch a key f)
(jolt-atom-watches-set! a
(cons (cons key f)
(remp (lambda (kv) (jolt=2 (car kv) key)) (jolt-atom-watches a))))
a)
(cond
((jolt-atom? a)
(jolt-atom-watches-set! a (jolt-watch-add (jolt-atom-watches a) key f))
a)
((iref? a)
(hashtable-set! iref-watch-tbl a (jolt-watch-add (hashtable-ref iref-watch-tbl a '()) key f))
a)
(else (error #f "add-watch: not a watchable reference" a))))
(define (jolt-remove-watch a key)
(jolt-atom-watches-set! a
(remp (lambda (kv) (jolt=2 (car kv) key)) (jolt-atom-watches a)))
a)
(cond
((jolt-atom? a)
(jolt-atom-watches-set! a
(remp (lambda (kv) (jolt=2 (car kv) key)) (jolt-atom-watches a)))
a)
((iref? a)
(hashtable-set! iref-watch-tbl a
(remp (lambda (kv) (jolt=2 (car kv) key)) (hashtable-ref iref-watch-tbl a '())))
a)
(else (error #f "remove-watch: not a watchable reference" a))))
(define (jolt-set-validator! a f)
(let ((vf (if (jolt-nil? f) jolt-nil f)))
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf (jolt-atom-val a))))
(error #f "Invalid reference state"))
(jolt-atom-validator-set! a vf)
(cond
((jolt-atom? a)
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf (jolt-atom-val a))))
(jolt-iref-state-throw))
(jolt-atom-validator-set! a vf))
((iref? a)
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf (jolt-deref a))))
(jolt-iref-state-throw))
(hashtable-set! iref-validator-tbl a vf))
(else (error #f "set-validator!: not a reference" a)))
jolt-nil))
(define (jolt-get-validator a) (jolt-atom-validator a))
(define (jolt-get-validator a)
(cond ((jolt-atom? a) (jolt-atom-validator a))
((iref? a) (hashtable-ref iref-validator-tbl a jolt-nil))
(else jolt-nil)))
;; vars are watchable IRefs: a root change (def / var-set on the root /
;; alter-var-root) validates and notifies like Var.bindRoot. The def-var! wrap
;; pays two weak-table probes per def and only does IRef work on a watched var.
(register-iref-arm! var-cell?)
(define def-var!-pre-iref def-var!)
(set! def-var!
(lambda (ns name v)
(let ((c (jolt-var ns name)))
(if (or (pair? (hashtable-ref iref-watch-tbl c '()))
(not (jolt-nil? (hashtable-ref iref-validator-tbl c jolt-nil))))
(let ((old (var-cell-root c)))
(iref-validate c v)
(let ((r (def-var!-pre-iref ns name v)))
(iref-notify c old v)
r))
(def-var!-pre-iref ns name v)))))
(def-var! "clojure.core" "atom" jolt-atom-new)
(def-var! "clojure.core" "deref" jolt-deref)

View file

@ -1,74 +0,0 @@
;; BigDecimal. A jbigdec is {unscaled, scale} over Chez arbitrary-precision exact
;; integers; its value is unscaled * 10^-scale (1.5M = {15,1}, 1.00M = {100,2},
;; 3M = {3,0}). M-suffix literals read to a :bigdec form that the back end lowers
;; to jolt-bigdec-from-string; bigdec coerces a number/string. Equality is by
;; value (1.0M = 1.00M), str drops the M, pr keeps it, class is
;; java.math.BigDecimal. Arithmetic contagion is not modelled.
(define-record-type jbigdec (fields unscaled scale) (nongenerative chez-jbigdec-v1))
(define (bd-index-char s ch)
(let loop ((i 0))
(cond ((>= i (string-length s)) #f)
((char=? (string-ref s i) ch) i)
(else (loop (+ i 1))))))
;; "1.50" -> {150,2}; "3" -> {3,0}; "-0.0" -> {0,1}; ".5" -> {5,1}.
(define (jolt-bigdec-from-string s)
(let* ((neg (and (> (string-length s) 0) (char=? (string-ref s 0) #\-)))
(sgn (and (> (string-length s) 0) (or neg (char=? (string-ref s 0) #\+))))
(s1 (if sgn (substring s 1 (string-length s)) s))
(sign (if neg -1 1))
(dot (bd-index-char s1 #\.)))
(if dot
(let* ((intp (substring s1 0 dot))
(fracp (substring s1 (+ dot 1) (string-length s1)))
(digs (string-append intp fracp))
(unscaled (if (= 0 (string-length digs)) 0 (string->number digs))))
(make-jbigdec (* sign unscaled) (string-length fracp)))
(make-jbigdec (* sign (string->number s1)) 0))))
;; bigdec coercion: a bigdec is itself; an exact integer keeps scale 0; a string
;; or any other number routes through its decimal text.
(define (jolt-bigdec x)
(cond
((jbigdec? x) x)
((and (number? x) (exact? x) (integer? x)) (make-jbigdec x 0))
((string? x) (jolt-bigdec-from-string x))
((number? x) (jolt-bigdec-from-string (jolt-num->string x)))
(else (error #f "bigdec: cannot coerce" x))))
;; value equality: unscaled_a * 10^scale_b == unscaled_b * 10^scale_a.
(define (jbigdec=? a b)
(= (* (jbigdec-unscaled a) (expt 10 (jbigdec-scale b)))
(* (jbigdec-unscaled b) (expt 10 (jbigdec-scale a)))))
;; render the decimal text (no M): insert the point `scale` digits from the right.
(define (jbigdec->string bd)
(let* ((u (jbigdec-unscaled bd)) (sc (jbigdec-scale bd))
(neg (< u 0)) (digs (number->string (abs u))))
(string-append
(if neg "-" "")
(if (<= sc 0)
digs
(let* ((padded (if (<= (string-length digs) sc)
(string-append (make-string (- (+ sc 1) (string-length digs)) #\0) digs)
digs))
(pl (string-length padded)))
(string-append (substring padded 0 (- pl sc)) "." (substring padded (- pl sc) pl)))))))
;; --- wire into the value model ----------------------------------------------
(def-var! "clojure.core" "bigdec" jolt-bigdec)
;; equality: a bigdec equals only another bigdec, by value (matching (= 3M 3) = false).
(register-eq-arm! (lambda (a b) (or (jbigdec? a) (jbigdec? b)))
(lambda (a b) (and (jbigdec? a) (jbigdec? b) (jbigdec=? a b))))
;; str drops the M; pr/pr-str keep it.
(register-str-render! jbigdec? jbigdec->string)
(register-pr-arm! jbigdec? (lambda (x) (string-append (jbigdec->string x) "M")))
;; class / decimal?
(register-class-arm! jbigdec? (lambda (x) "java.math.BigDecimal"))
(set! jolt-decimal? (lambda (x) (jbigdec? x)))
(def-var! "clojure.core" "decimal?" jolt-decimal?)

264
host/chez/build-joltc.ss Normal file
View file

@ -0,0 +1,264 @@
;; build-joltc.ss — build joltc itself as a self-contained native binary (jolt-eaj).
;;
;; chez --script host/chez/build-joltc.ss <profile> <out-path>
;; profile: "release" | "debug" out-path: e.g. target/release/joltc
;;
;; Runs on a dev/CI machine that HAS Chez + cc. Produces a binary that needs
;; NEITHER: it bakes the full runtime + compiler image + all jolt-core/stdlib
;; source + the Chez petite/scheme boots + a prebuilt launcher stub into one
;; cc-linked executable, so the resulting joltc can run AND `build` jolt apps on
;; its own. joltc itself is cc-linked (not appended) so its signature stays clean
;; for Homebrew/codesign, like dirge's binaries; only the apps it later builds use
;; the appended-stub path (host/chez/build.ss build-self-contained).
;;
;; Pipeline:
;; 0. cc-compile host/chez/stub/launcher.c against the Chez kernel.
;; 1. emit flat.ss = runtime + compiler image (cli.ss load order) + inlined
;; build.ss + every jolt-core/stdlib file as a baked string literal + the
;; joltc launcher.
;; 2. in-process compile-file + make-boot-file (profile Chez settings), error
;; restored around the call (the runtime shadows it; regex.ss/%chez-error).
;; 3. xxd the joltc boot + petite/scheme boots + stub into C arrays, generate
;; main.c, cc-link -> out-path. The launcher reads the petite/scheme/stub
;; arrays via FFI on `build` (jolt-materialize-bundles!).
(import (chezscheme))
(load "host/chez/rt.ss")
(set-chez-ns! "clojure.core")
(load "host/chez/seed/prelude.ss")
(load "host/chez/post-prelude.ss")
(set-chez-ns! "user")
(load "host/chez/host-contract.ss")
(load "host/chez/seed/image.ss")
(load "host/chez/compile-eval.ss")
(load "host/chez/png.ss")
(load "host/chez/loader.ss")
(load "host/chez/java/ffi.ss")
(set-source-roots! (list "jolt-core" "stdlib"))
(load "host/chez/build.ss") ; bld-* helpers, ei-* (emit-image), dce
(define jb-args (cdr (command-line)))
(define jb-profile (if (pair? jb-args) (car jb-args) "release"))
(define jb-out (if (and (pair? jb-args) (pair? (cdr jb-args))) (cadr jb-args)
(string-append "target/" jb-profile "/joltc")))
(define jb-release? (string=? jb-profile "release"))
(unless (or jb-release? (string=? jb-profile "debug"))
(error 'build-joltc "profile must be \"release\" or \"debug\"" jb-profile))
;; Version baked into the binary's saved heap. Prefer $JOLT_VERSION (CI sets it to
;; the release tag); else derive it from git in this checkout; else "dev".
(define jb-version
(let ((env (getenv "JOLT_VERSION")))
(if (and env (> (string-length env) 0))
env
(let ((s (bld-sh-capture "git describe --tags --always --dirty 2>/dev/null")))
(if (> (string-length s) 0) s "dev")))))
(define jb-build (string-append jb-out ".build"))
(bld-check-toolchain)
(bld-system (string-append "mkdir -p '" (path-parent jb-out) "' '" jb-build "'"))
;; --- 0. compile the launcher stub -------------------------------------------
(define jb-stub (string-append jb-build "/launcher"))
(display "build-joltc: compiling launcher stub\n")
(bld-system (string-append
"cc -O2 -I'" bld-csv-dir "' 'host/chez/stub/launcher.c' '"
bld-csv-dir "/libkernel.a' -o '" jb-stub "' " (bld-link-libs)))
;; --- 1. emit flat.ss --------------------------------------------------------
(define jb-flat-ss (string-append jb-build "/flat.ss"))
(define (str-suffix? s suf)
(let ((n (string-length s)) (m (string-length suf)))
(and (>= n m) (string=? (substring s (- n m) n) suf))))
;; Bake every jolt-core/stdlib source file as an in-heap string literal keyed by
;; its root-relative path ("jolt/main.clj", "clojure/string.clj") — exactly what
;; resolve-on-roots probes. Literals (not read-file-string at startup) because
;; flat.ss top-level forms run at every startup, with no source on disk.
(define (jb-emit-source-embeds out)
(for-each
(lambda (root)
(for-each
(lambda (rp)
(let ((rel (car rp)) (abs (cdr rp)))
(when (or (str-suffix? rel ".clj") (str-suffix? rel ".cljc"))
(put-string out (string-append
"(register-embedded-resource! " (ei-str-lit rel) " "
(ei-str-lit (read-file-string abs)) ")\n")))))
(bld-walk-files root "" '())))
(list "jolt-core" "stdlib")))
;; Embed every runtime .ss the build inlines into an app (the transitive closure of
;; the manifest's loads: rt.ss + all it loads, the seed, compile-eval, loader, ffi,
;; png, vendored irregex). Keyed by the exact path the (load "…") forms use, so
;; build.ss's bld-source-string reads them from the binary with no jolt source on
;; disk. Traversal mirrors bld-emit-runtime/bld-inline-line via the same
;; bld-file-lines + bld-load-path, so the embedded set is exactly what build reads.
(define (jb-collect-load-paths)
(let ((seen (make-hashtable string-hash string=?)) (order '()))
(define (walk path)
(when (and path (not (hashtable-ref seen path #f)))
(hashtable-set! seen path #t)
(set! order (cons path order))
(for-each (lambda (l) (walk (bld-load-path l))) (bld-file-lines path))))
(for-each (lambda (entry) (when (string? entry) (walk (bld-load-path entry))))
bld-runtime-manifest)
(for-each (lambda (kv) (walk (bld-load-path (cdr kv)))) bld-tagged-loads)
(reverse order)))
(define (jb-emit-runtime-embeds out)
(for-each
(lambda (path)
(put-string out (string-append
"(register-embedded-resource! " (ei-str-lit path) " "
(ei-str-lit (read-file-string path)) ")\n")))
(jb-collect-load-paths)))
;; The launcher (Chez scheme-start): replicates host/chez/cli.ss but reads argv
;; from the scheme-start lambda and has no repo root to cd into (all source is
;; embedded; JOLT_PWD defaults to cwd via io/jolt.main). build.ss is already
;; inlined, so `build` dispatches straight to jolt.host/build-binary after the
;; bundled boots/stub are materialized from the binary's own C arrays.
(define (jb-emit-launcher out)
(put-string out "
;; Materialize the bundled Chez boots + launcher stub (cc-linked into this binary
;; as C arrays) into the embedded-bytes store, so build-self-contained can spill
;; them. Done lazily on `build` only.
(define (jolt-materialize-bundles!)
(load-shared-object #f)
(let ((memcpy (foreign-procedure \"memcpy\" (u8* uptr uptr) void*)))
(for-each
(lambda (spec)
(let* ((len (foreign-ref 'unsigned-int (foreign-entry (caddr spec)) 0))
(bv (make-bytevector len)))
(memcpy bv (foreign-entry (cadr spec)) len)
(register-embedded-bytes! (car spec) bv)))
'((\"csv/petite.boot\" \"jolt_petite_boot\" \"jolt_petite_boot_len\")
(\"csv/scheme.boot\" \"jolt_scheme_boot\" \"jolt_scheme_boot_len\")
(\"stub/launcher\" \"jolt_stub\" \"jolt_stub_len\")
(\"csv/scheme.h\" \"jolt_scheme_h\" \"jolt_scheme_h_len\")
(\"csv/libkernel.a\" \"jolt_libkernel_a\" \"jolt_libkernel_a_len\")
(\"stub/launcher.c\" \"jolt_launcher_c\" \"jolt_launcher_c_len\")))))
(suppress-greeting #t)
(scheme-start
(lambda args
(set-source-roots! (list \"jolt-core\" \"stdlib\"))
;; JOLT_TRACE at RUNTIME (the env is unset at heap-build), before any app ns
;; compiles, so a `-M:run` traces the app's own code.
(jolt-trace-init-from-env!)
(guard (v (#t (jolt-report-throwable v (current-error-port)) (exit 1)))
(cond
((and (= (length args) 2) (string=? (car args) \"-e\"))
(let ((result (jolt-final-str
(jolt-compile-eval (string-append \"(do \" (cadr args) \")\") \"user\"))))
(unless (string=? result \"\") (display result) (newline))))
(else
(when (and (pair? args) (string=? (car args) \"build\"))
(jolt-materialize-bundles!))
(load-namespace \"jolt.main\")
(apply jolt-invoke (var-deref \"jolt.main\" \"-main\") args))))
(exit 0)))
"))
(display "build-joltc: emitting flat source\n")
(let ((out (open-output-file jb-flat-ss 'replace)))
;; full runtime + compiler image: keep the compiler (joltc evals at runtime).
(bld-emit-runtime out #f #f)
(put-string out "\n;; === build driver (inlined for self-contained `jolt build`) ===\n")
(bld-inline-line "(load \"host/chez/build.ss\")" out 0)
(put-string out "\n;; === embedded runtime source (self-contained `build` reads these) ===\n")
(jb-emit-runtime-embeds out)
(put-string out "\n;; === embedded jolt-core + stdlib source ===\n")
(jb-emit-source-embeds out)
;; Bake the version into the saved heap (runs at heap-build; loader.ss defined
;; jolt-baked-version above, so this set! resolves).
(put-string out (string-append "\n;; === baked version ===\n(set! jolt-baked-version "
(ei-str-lit jb-version) ")\n"))
(put-string out "\n;; === joltc launcher ===\n")
(jb-emit-launcher out)
(close-port out))
;; --- 2. compile + boot in a FRESH Chez (profile Chez settings) --------------
;; joltc is a compiler/REPL: it evals jolt-compiled Scheme at runtime, which must
;; resolve the runtime's top-level procedures (var-deref, jolt-inc, …) through the
;; boot's interaction-environment. compile-file's top-level defines are visible
;; there only when compiled in the REAL interaction-environment, and `error` (and
;; other primitives the inlined runtime references before redefining) bind to the
;; kernel primitive only when compiled against a clean chezscheme env. A fresh
;; Chez process gives both at once — exactly the legacy build-with-cc pass. The
;; in-process compile in build.ss/build-self-contained is for the distributed
;; joltc building (non-eval) apps, where no Chez is available.
(define jb-flat-so (string-append jb-build "/flat.so"))
(define jb-boot (string-append jb-build "/joltc.boot"))
(define jb-bool (lambda (b) (if b "#t" "#f")))
(display (string-append "build-joltc: compiling (" jb-profile " profile)\n"))
(let ((cs (string-append jb-build "/compile.ss")))
(let ((p (open-output-file cs 'replace)))
(put-string p
(string-append
"(import (chezscheme))\n"
"(optimize-level " (if jb-release? "3" "0") ")\n"
"(generate-inspector-information " (jb-bool (not jb-release?)) ")\n"
"(generate-procedure-source-information " (jb-bool (not jb-release?)) ")\n"
"(debug-on-exception " (jb-bool (not jb-release?)) ")\n"
"(fasl-compressed " (jb-bool jb-release?) ")\n"
"(compile-file " (ei-str-lit jb-flat-ss) " " (ei-str-lit jb-flat-so) ")\n"
"(make-boot-file " (ei-str-lit jb-boot) " '()\n "
(ei-str-lit (string-append bld-csv-dir "/petite.boot")) "\n "
(ei-str-lit (string-append bld-csv-dir "/scheme.boot")) "\n "
(ei-str-lit jb-flat-so) ")\n"))
(close-port p))
(bld-system (string-append bld-chez " --script '" cs "'")))
;; --- 3. embed boots/stub as C arrays + cc-link ------------------------------
;; xxd a file into header H and rename its symbol to NAME / NAME_len.
(define (jb-c-array file h name)
(bld-system (string-append "xxd -i '" file "' > '" h "'"))
(bld-system (string-append
"sed -i.bak -E 's/unsigned char [A-Za-z0-9_]+\\[\\]/unsigned char " name "[]/; "
"s/unsigned int [A-Za-z0-9_]+_len/unsigned int " name "_len/' '" h "'")))
(display "build-joltc: embedding boots + stub, linking\n")
(jb-c-array jb-boot (string-append jb-build "/boot_data.h") "jolt_boot")
(jb-c-array (string-append bld-csv-dir "/petite.boot") (string-append jb-build "/petite_data.h") "jolt_petite_boot")
(jb-c-array (string-append bld-csv-dir "/scheme.boot") (string-append jb-build "/scheme_data.h") "jolt_scheme_boot")
(jb-c-array jb-stub (string-append jb-build "/stub_data.h") "jolt_stub")
;; Also bundle the Chez kernel (libkernel.a + scheme.h) and the launcher source,
;; so a `build` with :static native libs can re-link a custom stub with those
;; archives baked in — the appended-stub path can't add object code to a prebuilt
;; stub, so it relinks (build.ss bld-relink-stub). Needs the system cc at build.
(jb-c-array (string-append bld-csv-dir "/scheme.h") (string-append jb-build "/schemeh_data.h") "jolt_scheme_h")
(jb-c-array (string-append bld-csv-dir "/libkernel.a") (string-append jb-build "/libkernel_data.h") "jolt_libkernel_a")
(jb-c-array "host/chez/stub/launcher.c" (string-append jb-build "/launcherc_data.h") "jolt_launcher_c")
(define jb-main-c (string-append jb-build "/main.c"))
(let ((mc (open-output-file jb-main-c 'replace)))
(put-string mc
(string-append
"#include \"scheme.h\"\n"
"#include \"boot_data.h\"\n"
"#include \"petite_data.h\"\n"
"#include \"scheme_data.h\"\n"
"#include \"stub_data.h\"\n"
"#include \"schemeh_data.h\"\n"
"#include \"libkernel_data.h\"\n"
"#include \"launcherc_data.h\"\n"
"int main(int argc, char *argv[]) {\n"
" Sscheme_init(0);\n"
" Sregister_boot_file_bytes(\"jolt\", jolt_boot, jolt_boot_len);\n"
" Sbuild_heap(0, 0);\n"
" int status = Sscheme_start(argc, (const char **)argv);\n"
" Sscheme_deinit();\n return status;\n}\n"))
(close-port mc))
;; -rdynamic puts the embedded jolt_* boot/stub symbols in the dynamic symbol
;; table so `build` can foreign-entry them to spill the bundled Chez boots. On
;; Linux dlsym can't see executable symbols otherwise (macOS exports them anyway).
(bld-system (string-append
;; the embedded jolt_* arrays must be foreign-entry-visible at runtime:
;; -rdynamic on ELF; on Windows an exe needs an export table (GetProcAddress).
"cc -O2 " (if bld-nt? "-Wl,--export-all-symbols " "-rdynamic ") "-I'" bld-csv-dir "' -I'" jb-build "' '" jb-main-c "' '"
bld-csv-dir "/libkernel.a' -o '" jb-out "' " (bld-link-libs)))
(display (string-append "build-joltc: wrote " jb-out "\n"))

View file

@ -81,6 +81,41 @@ fi
if ! grep -q '(jv\$app.util\$shout' "$out.build/flat.ss"; then
echo " FAIL: --direct-link did not emit a direct app->app call"; exit 1
fi
# A direct-link build registers fn sources, so an uncaught throw prints a Clojure
# stack trace mapping each native frame back to ns/name (file:line).
if ! grep -q 'jolt-register-source!' "$out.build/flat.ss"; then
echo " FAIL: --direct-link did not emit source registrations"; exit 1
fi
boom_err="$(cd / && "$out" --boom 2>&1 >/dev/null)"
for frame in 'app.util/deep-boom' 'app.util/mid-boom' 'app.core/-main'; do
if ! printf '%s' "$boom_err" | grep -q "$frame"; then
echo " FAIL: stack trace missing frame $frame"
echo "--- got ----"; echo "$boom_err"
exit 1
fi
done
# A built binary runs -main with *ns* = user, like clojure.main — so a runtime
# resolve of an aliased symbol is nil (the alias lives in the entry ns, not user),
# matching the JVM and interpreted joltc rather than the entry ns's alias table. A
# separate app: `resolve` defeats tree-shaking, so keep it out of the shake test's
# app above.
nsp="$(dirname "$out")/nsparity"
mkdir -p "$nsp/src/nsp"
printf '{:paths ["src"]}\n' > "$nsp/deps.edn"
printf '(ns nsp.lib)\n(defn thing [] 1)\n' > "$nsp/src/nsp/lib.clj"
printf '(ns nsp.main (:require [nsp.lib :as l]))\n(defn -main [& _]\n (println "ns:" (str *ns*))\n (println "resolve:" (pr-str (resolve (quote l/thing))))\n (println "ns-resolve:" (pr-str (ns-resolve (quote nsp.lib) (quote thing)))))\n' > "$nsp/src/nsp/main.clj"
nspout="$(dirname "$out")/nsparity-bin"
if ! JOLT_PWD="$nsp" bin/joltc build -m nsp.main -o "$nspout" >/dev/null 2>&1; then
echo " FAIL: jolt build of the ns-parity app exited non-zero"; exit 1
fi
nsp_out="$(cd / && "$nspout" 2>&1)"
if ! printf '%s' "$nsp_out" | grep -q 'ns: user' \
|| ! printf '%s' "$nsp_out" | grep -q '^resolve: nil' \
|| ! printf '%s' "$nsp_out" | grep -q "ns-resolve: #'nsp.lib/thing"; then
echo " FAIL: built binary -main ns parity — want 'ns: user', 'resolve: nil', ns-resolve found"
echo "--- got ----"; echo "$nsp_out"
exit 1
fi
# Tree-shaking (opt-in): same result, and an unreachable def (the `twice` macro,
# expanded at AOT and never called at runtime) is dropped.
if ! JOLT_PWD="$app" bin/joltc build -m app.core -o "$out" --tree-shake >/dev/null 2>&1; then
@ -103,4 +138,33 @@ fi
if grep -q 'def-var! "clojure.core" "group-by"' "$out.build/flat.ss"; then
echo " FAIL: --tree-shake kept an unreachable clojure.core fn (group-by)"; exit 1
fi
echo "build smoke: passed (release + optimized + direct-link + tree-shake + compiler+core shake)"
# A registered data reader that returns a CODE form must be compiled into the
# binary (the emit path applies it too, not just the interpreted loader): the
# datareader-app's #code literal builds to 42, not the literal list.
drapp="$root/test/chez/datareader-app"
drout="$(dirname "$out")/dr-bin"
if ! JOLT_PWD="$drapp" bin/joltc build -m drtest.main -o "$drout" >/dev/null 2>&1; then
echo " FAIL: jolt build of a data-reader app exited non-zero"; exit 1
fi
got_dr="$(cd / && "$drout" 2>&1 | tail -1)"
if [ "$got_dr" != "42" ]; then
echo " FAIL: built #code data reader — want 42, got \`$got_dr\`"; exit 1
fi
# A script namespace with no -main (just top-level side effects) must build and
# run its top-level forms, then exit cleanly — not crash calling a nil -main.
nomain="$(dirname "$out")/nomain"
mkdir -p "$nomain/src"
printf '{:paths ["src"]}\n' > "$nomain/deps.edn"
printf '(ns script)\n(println "no-main script ran")\n' > "$nomain/src/script.clj"
nmout="$(dirname "$out")/nomain-bin"
if ! JOLT_PWD="$nomain" bin/joltc build -m script -o "$nmout" >/dev/null 2>&1; then
echo " FAIL: jolt build of a no-main script exited non-zero"; exit 1
fi
got_nm="$(cd / && "$nmout" 2>&1)"; rc_nm=$?
if [ "$got_nm" != "no-main script ran" ] || [ "$rc_nm" != "0" ]; then
echo " FAIL: no-main script binary — want 'no-main script ran' rc 0, got \`$got_nm\` rc $rc_nm"
exit 1
fi
echo "build smoke: passed (release + optimized + direct-link + tree-shake + compiler+core shake + data-reader + no-main)"

View file

@ -23,7 +23,7 @@
;; --- shell helpers ----------------------------------------------------------
;; Run a command, return its stdout as one trimmed string ("" on no output).
(define (bld-sh-capture cmd)
(let* ((p (process cmd)) (in (car p)))
(let* ((p (process (bld-sh-wrap cmd))) (in (car p)))
(let loop ((acc '()))
(let ((l (get-line in)))
(if (eof-object? l)
@ -37,10 +37,16 @@
(loop (cons l acc)))))))
(define (bld-system cmd)
(let ((rc (system cmd)))
(let ((rc (system (bld-sh-wrap cmd))))
(unless (zero? rc)
(error 'jolt-build (string-append "command failed (" (number->string rc) "): " cmd)))))
;; mkdir -p without a subprocess (the self-contained build shells out to nothing).
(define (bld-mkdir-p dir)
(unless (or (string=? dir "") (string=? dir "/") (string=? dir ".") (file-exists? dir))
(bld-mkdir-p (path-parent dir))
(guard (e (#t #f)) (mkdir dir))))
(define (bld-contains? s sub)
(let ((ns (string-length s)) (nsub (string-length sub)))
(let loop ((i 0))
@ -51,6 +57,24 @@
;; --- toolchain discovery ----------------------------------------------------
(define bld-machine (symbol->string (machine-type)))
(define bld-osx? (bld-contains? bld-machine "osx"))
(define bld-nt? (bld-contains? bld-machine "nt"))
;; Chez's system/process run through cmd.exe on Windows; every build command
;; here is written for sh (MSYS2 provides it). On nt, spill the command to a
;; script and run `sh <file>` — workspace paths carry no spaces, and the
;; script file sidesteps cmd's quoting entirely. Identity elsewhere.
(define bld-shell-counter 0)
(define (bld-sh-wrap cmd)
(if bld-nt?
(let* ((tmp (or (getenv "TEMP") (getenv "TMP") "."))
(f (begin (set! bld-shell-counter (+ bld-shell-counter 1))
(string-append tmp "\\jolt-sh-"
(number->string bld-shell-counter) ".sh"))))
(let ((p (open-output-file f 'replace)))
(put-string p cmd)
(close-port p))
(string-append "sh " f))
cmd))
;; The Chez executable, for the isolated compile pass (see build-binary step 4).
(define bld-chez
@ -74,6 +98,9 @@
(cand (string-append bindir "/../lib/csv" bld-version "/" bld-machine)))
cand))))
(define (bld-have-cc?)
(> (string-length (bld-sh-capture "command -v cc")) 0))
(define (bld-check-toolchain)
(for-each
(lambda (f)
@ -85,14 +112,21 @@
;; Link flags. macOS Homebrew layout for the kernel's lz4/zlib/ncurses deps.
(define (bld-link-libs)
(if bld-osx?
(let ((lz4 (bld-sh-capture "brew --prefix lz4 2>/dev/null")))
(string-append
(if (> (string-length lz4) 0) (string-append "-L" lz4 "/lib ") "")
"-llz4 -lz -lncurses -framework Foundation -liconv -lm"))
;; Linux: the Chez kernel pulls in compression (lz4/z), the expression
;; editor (ncurses + terminfo), threads, dlopen, libuuid, and clock_gettime.
"-llz4 -lz -lncurses -ltinfo -ldl -lm -lpthread -luuid -lrt"))
(cond
(bld-osx?
(let ((lz4 (bld-sh-capture "brew --prefix lz4 2>/dev/null")))
(string-append
(if (> (string-length lz4) 0) (string-append "-L" lz4 "/lib ") "")
"-llz4 -lz -lncurses -framework Foundation -liconv -lm")))
;; Windows (ta6nt, MinGW-w64 under MSYS2): the Chez kernel pulls in
;; compression, winsock, COM/UUID, and the registry.
(bld-nt?
;; -static: a single-file exe (no libwinpthread/libgcc/lz4 DLL deps) —
;; required for a distributable binary and for TLS init consistency.
"-static -llz4 -lz -lws2_32 -lrpcrt4 -lole32 -luuid -ladvapi32 -luser32 -lshell32 -lm")
;; Linux: the Chez kernel pulls in compression (lz4/z), the expression
;; editor (ncurses + terminfo), threads, dlopen, libuuid, and clock_gettime.
(else "-llz4 -lz -lncurses -ltinfo -ldl -lm -lpthread -luuid -lrt")))
;; --- runtime manifest (mirrors host/chez/cli.ss's load order) ---------------
;; A line is either literal Scheme text to inline, or a tag whose emission the build
@ -111,7 +145,7 @@
'compile-eval
"(load \"host/chez/png.ss\")"
"(load \"host/chez/loader.ss\")"
"(load \"host/chez/ffi.ss\")"
"(load \"host/chez/java/ffi.ss\")"
"(set-source-roots! (list \"jolt-core\" \"stdlib\"))"))
(define bld-tagged-loads
@ -132,12 +166,23 @@
(q2 (let scan ((i (+ q1 1))) (if (char=? (string-ref s i) #\") i (scan (+ i 1))))))
(substring s (+ q1 1) q2)))))
(define (bld-file-lines path)
(call-with-input-file path
(lambda (p)
(let loop ((acc '()))
(let ((l (get-line p)))
(if (eof-object? l) (reverse acc) (loop (cons l acc))))))))
;; runtime source for PATH: from the binary's embedded store if present (a
;; self-contained joltc building an app, with no jolt checkout on disk), else read
;; from disk (running from a source checkout). build-joltc embeds every runtime
;; .ss the manifest inlines, so `build` never touches the filesystem for them.
(define (bld-source-string path)
(let ((emb (hashtable-ref embedded-resources path #f)))
(if (string? emb) emb (read-file-string path))))
(define (bld-string-lines s)
(let ((n (string-length s)))
(let loop ((i 0) (start 0) (acc '()))
(cond ((>= i n) (reverse (if (> i start) (cons (substring s start i) acc) acc)))
((char=? (string-ref s i) #\newline)
(loop (+ i 1) (+ i 1) (cons (substring s start i) acc)))
(else (loop (+ i 1) start acc))))))
(define (bld-file-lines path) (bld-string-lines (bld-source-string path)))
;; Emit one line to OUT, recursively inlining a `(load ...)` of a repo file.
(define (bld-inline-line line out depth)
@ -170,6 +215,38 @@
;; The loop itself is emit-image's ei-emit-ns* (optimize? #t, guard? #f).
(define (bld-emit-ns ns-name src) (ei-emit-ns* ns-name src #t #f))
;; --- whole-program inference pre-pass ---------------------------------------
;; Analyze every app form (all namespaces, deps-first) to IR and run the
;; closed-world param-type fixpoint, so each fn's param types pick up the record
;; types its callers pass. The per-ns emit below then bare-indexes field reads and
;; devirtualizes protocol calls at those sites (the back end reads the resulting
;; :hint/:devirt annotations). Optimized builds only; registries come from the
;; runtime tables populated as the app loaded.
(define jolt-wp-infer! (var-deref "jolt.passes.types" "wp-infer!"))
(define jolt-wp-set-record-shapes! (var-deref "jolt.passes.types" "set-record-shapes!"))
(define jolt-wp-set-proto-methods! (var-deref "jolt.passes.types" "set-protocol-methods!"))
(define jolt-wp-host-record-shapes (var-deref "jolt.host" "record-shapes"))
(define jolt-wp-host-proto-methods (var-deref "jolt.host" "protocol-methods"))
(define (bld-wp-infer! ordered)
(jolt-wp-set-record-shapes! (jolt-wp-host-record-shapes #f))
(jolt-wp-set-proto-methods! (jolt-wp-host-proto-methods #f))
(let ((nodes '()))
(for-each
(lambda (nf)
(set-chez-ns! (car nf))
(let ((src (ldr-read-source (cdr nf))))
(parameterize ((rdr-source-file (cdr nf)))
(for-each
(lambda (f)
(ce-scan-requires! f (car nf))
(unless (or (ei-ns-form? f) (ce-macro-form? f))
(guard (e (#t #f))
(set! nodes (cons (jolt-ce-analyze (make-analyze-ctx (car nf)) f) nodes)))))
(ei-read-all src)))))
ordered)
(jolt-wp-infer! (apply jolt-vector (reverse nodes)))))
;; Strings emitted before each app ns's forms, replaying what the source loader
;; does per file: (1) set chez-current-ns so runtime ns-sensitive setup forms
;; (defmulti/defmethod resolve their target var through it) land in the right ns;
@ -233,21 +310,24 @@
(define (bld-strs x) (map jolt-str-render-one (seq->list x)))
;; Emit native-library loads. `natives` is the encoded jolt seq jolt.main/
;; encode-natives produced: each entry is ["process"] | ["req" cand…] | ["opt" cand…].
;; `which` selects 'required (process + req) or 'optional. Required + process loads
;; are emitted before the app forms (the app's defcfn foreign-procedures resolve
;; their symbols at top-level eval during startup, so the libs must be loaded
;; first); a load-shared-object failure there is fatal — correct for a required
;; lib. Optional loads run in the scheme-start launcher, where guard catches a
;; missing lib (an optional lib's namespace is only present when the app requires
;; it, so its foreign-procedures aren't among the baked top-level forms).
;; encode-natives produced: each entry is ["process"] | ["static" form…] |
;; ["req" cand…] | ["opt" cand…]. `which` selects 'required (process + static +
;; req) or 'optional. Required loads are emitted before the app forms (the app's
;; defcfn foreign-procedures resolve their symbols at top-level eval during
;; startup, so the libs must be loaded first); a load-shared-object failure there
;; is fatal — correct for a required lib. A "static" lib is cc-linked into the
;; binary (see bld-native-link-flags), so its symbols are already in the process:
;; it loads them the same way a "process" lib does. Optional loads run in the
;; scheme-start launcher, where guard catches a missing lib (an optional lib's
;; namespace is only present when the app requires it, so its foreign-procedures
;; aren't among the baked top-level forms).
(define (bld-emit-natives out natives which)
(for-each
(lambda (entry)
(let* ((parts (bld-strs entry)) (kind (car parts)) (cands (cdr parts))
(cand-lits (fold-left (lambda (s c) (string-append s (ei-str-lit c) " ")) "" cands)))
(cond
((and (eq? which 'required) (string=? kind "process"))
((and (eq? which 'required) (or (string=? kind "process") (string=? kind "static")))
(put-string out "(jolt-build-load-native '() #f #t)\n"))
((and (eq? which 'required) (string=? kind "req"))
(put-string out (string-append "(jolt-build-load-native (list " cand-lits ") #f #f)\n")))
@ -255,6 +335,66 @@
(put-string out (string-append "(jolt-build-load-native (list " cand-lits ") #t #f)\n"))))))
(seq->list natives)))
;; The cc link fragment for the "static" natives: each archive must be FORCE-loaded
;; (the linker would otherwise drop an archive member main.c never references) and,
;; on Linux, the executable's symbols exported into the dynamic table so the
;; startup (load-shared-object #f) + foreign-procedure can resolve them (-rdynamic,
;; added by build-with-cc when this fragment is non-empty). Returns "" when no lib
;; is statically linked. Entry forms: ["static" "archive" path] | ["static" "lib"
;; name libdir].
(define (bld-native-link-flags natives)
(fold-left
(lambda (acc entry)
(let ((parts (bld-strs entry)))
(if (string=? (car parts) "static")
(string-append acc " " (bld-one-static-link (cdr parts)))
acc)))
"" (seq->list natives)))
;; A statically-linked native is only in the OUTPUT binary, but build step 1
;; evaluates the app's `foreign-procedure` forms in THIS process (to register its
;; macros/vars), and Chez resolves a foreign entry eagerly. So make the archive's
;; symbols resolvable here: build a throwaway shared object from it (force-loading
;; every member) and load it. The output binary still cc-links the static archive;
;; this temp .so is build-time only. Only the "archive" form is preloaded — the
;; "lib" form names a system library the OS loader already finds by soname.
(define (bld-preload-static-natives! natives builddir)
(let ((n 0))
(for-each
(lambda (entry)
(let ((parts (bld-strs entry)))
(when (and (string=? (car parts) "static") (string=? (cadr parts) "archive"))
(let* ((archive (caddr parts))
(so (string-append builddir "/native-" (number->string n)
(if bld-osx? ".dylib" ".so"))))
(set! n (+ n 1))
(bld-system
(if bld-osx?
(string-append "cc -dynamiclib -undefined dynamic_lookup -Wl,-all_load '"
archive "' -o '" so "'")
(string-append "cc -shared -Wl,--whole-archive '" archive
"' -Wl,--no-whole-archive -Wl,--unresolved-symbols=ignore-all -o '" so "'")))
(load-shared-object so)))))
(seq->list natives))))
(define (bld-one-static-link form)
(let ((kind (car form)))
(cond
((string=? kind "archive")
(let ((path (cadr form)))
(if bld-osx?
(string-append "-Wl,-force_load," path)
(string-append "-Wl,--whole-archive " path " -Wl,--no-whole-archive"))))
((string=? kind "lib")
(let* ((lib (cadr form)) (dir (caddr form))
(L (if (> (string-length dir) 0) (string-append "-L" dir " ") "")))
;; -Bstatic forces the .a over a .so of the same -l name (GNU ld). macOS's
;; ld64 has no -Bstatic; there an :archive path is the reliable form.
(if bld-osx?
(string-append L "-l" lib)
(string-append L "-Wl,-Bstatic -l" lib " -Wl,-Bdynamic"))))
(else ""))))
;; Walk an embed root recursively; return (resource-name . abspath) pairs, where
;; resource-name is the "/"-joined path under the root (what io/resource is asked for).
(define (bld-walk-files root rel acc)
@ -296,8 +436,31 @@
;; direct-link?: opt-in closed-world direct-linking (app->app calls bind directly,
;; no runtime redefinition). Off by default in every mode — release stays
;; dynamically linked.
(define (bld-suffix? s suf)
(let ((n (string-length s)) (m (string-length suf)))
(and (>= n m) (string=? (substring s (- n m) n) suf))))
(define (build-binary entry-ns out-path mode natives embed-dirs ext-roots direct-link? tree-shake?)
(bld-check-toolchain)
;; Windows executables carry .exe; normalize here so the append-payload and
;; cc paths agree and the shell can run the result.
(let ((out-path (if (and bld-nt? (not (bld-suffix? out-path ".exe")))
(string-append out-path ".exe")
out-path)))
;; The self-contained path (jolt-embedded-bytes "stub/launcher") needs no csv
;; kernel files, no Chez, no cc — only the legacy cc path does.
(unless (jolt-embedded-bytes "stub/launcher") (bld-check-toolchain))
(when (> (string-length (bld-native-link-flags natives)) 0)
;; :static natives are cc-linked into the binary, so a C compiler must be on
;; PATH — the self-contained joltc bundles the Chez kernel (libkernel.a +
;; scheme.h) and relinks a custom stub (see build-self-contained), but still
;; needs the system cc for that link. Fail early (before the app's foreign-
;; procedure forms eval below) with an actionable message.
(unless (bld-have-cc?)
(error 'jolt-build
"static native linking needs a C compiler (cc) on PATH; install one, or pass --dynamic to load the library at runtime."))
;; Preload static archives' symbols into this process so step 1's foreign-
;; procedure evals resolve; the .build dir must exist first.
(bld-mkdir-p (string-append out-path ".build"))
(bld-preload-static-natives! natives (string-append out-path ".build")))
;; 1. record app namespaces in dependency order as they finish loading.
(let ((app-order '()))
(set-ns-loaded-hook!
@ -326,8 +489,15 @@
(set-optimize! (string=? mode "optimized"))
(when direct-link?
((var-deref "jolt.backend-scheme" "set-direct-link!") #t)
((var-deref "jolt.backend-scheme" "direct-link-reset!"))))
((var-deref "jolt.backend-scheme" "direct-link-reset!")))
;; whole-program param-type fixpoint before per-form emit
(when (string=? mode "optimized") (bld-wp-infer! ordered)))
(lambda ()
;; A #tag data-reader literal must compile in the binary the same as
;; it loads interpreted — apply the reader rewrite to each emitted
;; form too (no-op unless the app registered data readers).
(parameterize ((ei-emit-form-hook
(lambda (form) (if data-readers-active (ldr-apply-readers form) form))))
(if tree-shake?
(dce-shake
(dce-blob-records "host/chez/seed/prelude.ss")
@ -336,21 +506,23 @@
;; ns-prelude forms (always kept, no fqn/refs) set the
;; ns + register aliases before this ns's forms; dce
;; keeps original order.
(let ((src (read-file-string (cdr nf))))
(append
(map (lambda (s) (dce-rec #t #f '() s))
(bld-ns-prelude (car nf) src))
(ei-emit-ns-records (car nf) src))))
(let ((src (ldr-read-source (cdr nf))))
(parameterize ((rdr-source-file (cdr nf)))
(append
(map (lambda (s) (dce-rec #t #f '() s))
(bld-ns-prelude (car nf) src))
(ei-emit-ns-records (car nf) src)))))
ordered))
(string-append entry-ns "/-main"))
(values #f
(apply append
(map (lambda (nf)
(let ((src (read-file-string (cdr nf))))
(append (bld-ns-prelude (car nf) src)
(bld-emit-ns (car nf) src))))
(let ((src (ldr-read-source (cdr nf))))
(parameterize ((rdr-source-file (cdr nf)))
(append (bld-ns-prelude (car nf) src)
(bld-emit-ns (car nf) src)))))
ordered))
#f)))
#f))))
(lambda ()
(set-optimize! #f)
((var-deref "jolt.backend-scheme" "set-direct-link!") #f)))))
@ -361,7 +533,7 @@
(boot (string-append builddir "/jolt.boot"))
(boot-h (string-append builddir "/boot_data.h"))
(main-c (string-append builddir "/main.c")))
(bld-system (string-append "mkdir -p '" builddir "'"))
(bld-mkdir-p builddir)
;; 3. flat source = runtime + app + launcher.
(let ((out (open-output-file flat-ss 'replace)))
(bld-emit-runtime out drop-compiler? core-strs)
@ -399,47 +571,176 @@
"))\n"
" (list \"jolt-core\" \"stdlib\"))))\n"))
(put-string out (string-append
" (let ((mainv (var-deref " (ei-str-lit entry-ns) " \"-main\")))\n"
" (apply jolt-invoke mainv args))\n"
;; Call -main only if the entry namespace defines one;
;; a script ns (top-level side effects, no -main) has
;; already run its forms at heap build, so invoking a nil
;; -main would crash ("nil cannot be cast to IFn") — just
;; exit cleanly instead.
" (let ((maincell (var-cell-lookup " (ei-str-lit entry-ns) " \"-main\")))\n"
;; render an uncaught throw (+ Clojure backtrace) instead
;; of Chez's opaque dump, then exit non-zero.
" (guard (v (#t (jolt-report-throwable v (current-error-port)) (exit 1)))\n"
;; Loading the app left the current ns at the entry ns; reset
;; it to `user` before -main, matching clojure.main (*ns* is
;; `user` when a `-m` -main runs, so a runtime resolve of an
;; aliased symbol behaves the same as on the JVM / interpreted
;; joltc, not off the entry ns's alias table).
" (set-chez-ns! \"user\")\n"
" (when (and maincell (var-cell-defined? maincell))\n"
" (apply jolt-invoke (var-cell-root maincell) args))))\n"
" (exit 0)))\n"))
(close-port out))
;; 4. compile -> boot -> embed -> link.
;; compile-file/make-boot-file run in a FRESH Chez, not this process: the
;; loaded runtime shadows `error` (regex.ss, for irregex), which would
;; otherwise bake a broken `error` reference into the boot.
(display (string-append "jolt build: compiling " entry-ns " (" mode " mode)\n"))
(let ((cs (string-append builddir "/compile.ss")))
(let ((p (open-output-file cs 'replace)))
(put-string p
(string-append
"(import (chezscheme))\n"
"(compile-file " (ei-str-lit flat-ss) " " (ei-str-lit flat-so) ")\n"
"(make-boot-file " (ei-str-lit boot) " '()\n "
(ei-str-lit (string-append bld-csv-dir "/petite.boot")) "\n "
(ei-str-lit (string-append bld-csv-dir "/scheme.boot")) "\n "
(ei-str-lit flat-so) ")\n"))
(close-port p))
(bld-system (string-append bld-chez " --script '" cs "'")))
(bld-system (string-append "xxd -i '" boot "' > '" boot-h "'"))
;; The xxd symbol is derived from the path; normalize to jolt_boot.
(bld-system (string-append
"sed -i.bak -E 's/unsigned char [A-Za-z0-9_]+\\[\\]/unsigned char jolt_boot[]/; "
"s/unsigned int [A-Za-z0-9_]+_len/unsigned int jolt_boot_len/' '" boot-h "'"))
(let ((mc (open-output-file main-c 'replace)))
(put-string mc
(string-append
"#include \"scheme.h\"\n#include \"boot_data.h\"\n"
"int main(int argc, char *argv[]) {\n"
" Sscheme_init(0);\n"
" Sregister_boot_file_bytes(\"jolt\", jolt_boot, jolt_boot_len);\n"
" Sbuild_heap(0, 0);\n"
" int status = Sscheme_start(argc, (const char **)argv);\n"
" Sscheme_deinit();\n return status;\n}\n"))
(close-port mc))
(bld-system (string-append
"cc -O2 -I'" bld-csv-dir "' '" main-c "' '" bld-csv-dir "/libkernel.a' "
"-o '" out-path "' " (bld-link-libs)))
(display (string-append "jolt build: wrote " out-path "\n")))))))
;; 4. compile -> boot -> link. Two paths, chosen by whether this process
;; carries the bundled Chez boots + launcher stub:
;; - SELF-CONTAINED (the distributed joltc, jolt-eaj): compile-file +
;; make-boot-file run IN PROCESS (the compiler is resident — joltc is
;; built from scheme.boot), then the boot is appended to a copy of the
;; embedded stub. No external Chez, no cc.
;; - LEGACY (dev bin/joltc): spawn a fresh Chez for compile-file/
;; make-boot-file, then xxd the boot into a C array and cc-link against
;; libkernel.a. Kept so `make buildsmoke` still exercises the cc path.
(if (jolt-embedded-bytes "stub/launcher")
(build-self-contained entry-ns out-path mode builddir flat-ss flat-so boot
(bld-native-link-flags natives))
(build-with-cc entry-ns out-path mode builddir flat-ss flat-so boot boot-h main-c
(bld-native-link-flags natives)))))))))
;; --- self-contained link (in-process compile + append the boot to the stub) ---
;; compile-file runs against the DEFAULT interaction environment, so the boot's
;; top-level defines land in the real symbol cells — the runtime compiler's
;; eval'd code must resolve them (var-deref, jolt-invoke, the jolt-n* macros)
;; when the built binary dynamically requires a namespace. Compiling in a clean
;; copy-environment instead orphans every define in locations eval can't see,
;; and the binary dies with "variable var-deref is not bound" the moment a
;; runtime require compiles source.
;;
;; The default env has a wrinkle the legacy fresh-Chez path doesn't: THIS
;; process's cells hold jolt's redefinitions of some kernel names (`error`,
;; regex.ss), so references to them compile as cell reads — and a read that
;; runs before the redefining form would find the fresh binary's cell unbound.
;; The prologue closes that: it first binds each redefined kernel name's cell
;; to its kernel value, making the boot's earliest reads identical to the
;; legacy path's primitive references.
;; every top-level (define nm …)/(define (nm …) …) name in the flat file that
;; shadows a scheme-environment VARIABLE (syntax names don't eval; skip them).
(define (bld-kernel-prologue flat-ss)
(let ((seen (make-eq-hashtable))
(kenv (scheme-environment))
(names '()))
(let ((ip (open-input-file flat-ss)))
(let loop ()
(let ((f (read ip)))
(unless (eof-object? f)
(when (and (pair? f) (eq? (car f) 'define) (pair? (cdr f)))
(let* ((h (cadr f))
(nm (if (pair? h) (car h) h)))
(when (and (symbol? nm)
(not (hashtable-ref seen nm #f))
(guard (e (#t #f)) (begin (eval nm kenv) #t)))
(hashtable-set! seen nm #t)
(set! names (cons nm names)))))
(loop))))
(close-port ip))
(apply string-append
(map (lambda (nm)
(let ((s (symbol->string nm)))
(string-append "(define " s " (eval '" s " (scheme-environment)))\n")))
(reverse names)))))
;; prepend the prologue to the flat file in place.
(define (bld-prepend-prologue! flat-ss)
(let ((prologue (bld-kernel-prologue flat-ss))
(body (read-file-string flat-ss)))
(let ((out (open-output-file flat-ss 'replace)))
(put-string out ";; kernel-name cells pre-bound so early reads match the kernel primitives\n")
(put-string out prologue)
(put-string out body)
(close-port out))))
(define (build-self-contained entry-ns out-path mode builddir flat-ss flat-so boot native-link)
(let ((petite (string-append builddir "/petite.boot"))
(scheme (string-append builddir "/scheme.boot")))
(jolt-spill-embedded! "csv/petite.boot" petite)
(jolt-spill-embedded! "csv/scheme.boot" scheme)
(display (string-append "jolt build: compiling " entry-ns " (" mode " mode, self-contained)\n"))
(bld-prepend-prologue! flat-ss)
(compile-file flat-ss flat-so)
(make-boot-file boot '() petite scheme flat-so)
;; The stub is the native launcher the boot is appended to. With no :static
;; natives it's the prebuilt one bundled in joltc (no cc needed); with :static
;; natives it's re-linked here from the bundled kernel + launcher source so the
;; archives are baked in and their symbols resolve in the running binary.
(if (> (string-length native-link) 0)
(bld-relink-stub builddir native-link out-path)
(jolt-spill-embedded! "stub/launcher" out-path))
;; link: stub bytes ++ boot ++ frame, then make it executable.
(jolt-append-payload! out-path (read-file-bytes boot))
(jolt-chmod-755 out-path)
(display (string-append "jolt build: wrote " out-path "\n"))
(when bld-osx?
(display (string-append
"jolt build: note — on macOS this binary is unsigned; to share it,\n"
" `xattr -d com.apple.quarantine " out-path "` on the target, or sign it.\n")))))
;; Re-link the launcher stub with the app's static native archives baked in, to
;; OUT-PATH. The self-contained joltc bundles the Chez kernel (libkernel.a),
;; header, and launcher source; spill them and drive the system cc — the same link
;; build-joltc.ss ran once at joltc-build time, plus the force-load archive flags
;; (native-link) and, on Linux, -rdynamic so the baked-in symbols stay dlsym-
;; visible for (load-shared-object #f) + foreign-procedure at startup.
(define (bld-relink-stub builddir native-link out-path)
(let ((h (string-append builddir "/scheme.h"))
(lk (string-append builddir "/libkernel.a"))
(lc (string-append builddir "/launcher.c")))
(jolt-spill-embedded! "csv/scheme.h" h)
(jolt-spill-embedded! "csv/libkernel.a" lk)
(jolt-spill-embedded! "stub/launcher.c" lc)
(display "jolt build: relinking launcher stub with static native libraries\n")
(bld-system (string-append
"cc -O2 " (if bld-osx? "" "-rdynamic ")
"-I'" builddir "' '" lc "' '" lk "' -o '" out-path "' "
(bld-link-libs) native-link))))
;; --- legacy cc link (dev bin/joltc): fresh Chez compile + xxd + cc ------------
(define (build-with-cc entry-ns out-path mode builddir flat-ss flat-so boot boot-h main-c native-link)
(display (string-append "jolt build: compiling " entry-ns " (" mode " mode)\n"))
(let ((cs (string-append builddir "/compile.ss")))
(let ((p (open-output-file cs 'replace)))
(put-string p
(string-append
"(import (chezscheme))\n"
"(compile-file " (ei-str-lit flat-ss) " " (ei-str-lit flat-so) ")\n"
"(make-boot-file " (ei-str-lit boot) " '()\n "
(ei-str-lit (string-append bld-csv-dir "/petite.boot")) "\n "
(ei-str-lit (string-append bld-csv-dir "/scheme.boot")) "\n "
(ei-str-lit flat-so) ")\n"))
(close-port p))
(bld-system (string-append bld-chez " --script '" cs "'")))
(bld-system (string-append "xxd -i '" boot "' > '" boot-h "'"))
;; The xxd symbol is derived from the path; normalize to jolt_boot.
(bld-system (string-append
"sed -i.bak -E 's/unsigned char [A-Za-z0-9_]+\\[\\]/unsigned char jolt_boot[]/; "
"s/unsigned int [A-Za-z0-9_]+_len/unsigned int jolt_boot_len/' '" boot-h "'"))
(let ((mc (open-output-file main-c 'replace)))
(put-string mc
(string-append
"#include \"scheme.h\"\n#include \"boot_data.h\"\n"
"int main(int argc, char *argv[]) {\n"
" Sscheme_init(0);\n"
" Sregister_boot_file_bytes(\"jolt\", jolt_boot, jolt_boot_len);\n"
" Sbuild_heap(0, 0);\n"
" int status = Sscheme_start(argc, (const char **)argv);\n"
" Sscheme_deinit();\n return status;\n}\n"))
(close-port mc))
;; -rdynamic (Linux) exports the executable's symbols into the dynamic table so
;; a statically-linked native lib's symbols resolve via (load-shared-object #f)
;; at startup. macOS keeps unstripped executable symbols dlsym-visible already.
(bld-system (string-append
"cc -O2 " (if (and (not bld-osx?) (> (string-length native-link) 0)) "-rdynamic " "")
"-I'" bld-csv-dir "' '" main-c "' '" bld-csv-dir "/libkernel.a' "
"-o '" out-path "' " (bld-link-libs) native-link))
(display (string-append "jolt build: wrote " out-path "\n")))
(def-var! "jolt.host" "build-binary"
(lambda (entry out mode natives embed-dirs ext-roots direct-link? tree-shake?)

View file

@ -11,6 +11,26 @@
(define cli-args (cdr (command-line))) ; drop the script name
;; Fail early and actionably when the vendored submodules aren't checked out —
;; a plain `git clone` or GitHub's auto-generated "Source code" release archive
;; lacks them, and the raw failure ("load failed for vendor/irregex/irregex.scm")
;; doesn't say how to fix it. (The self-contained joltc binary embeds these and
;; never runs this file.)
(unless (file-exists? "vendor/irregex/irregex.scm")
(display "jolt: vendor submodules are missing (vendor/irregex).
" (current-error-port))
(display "GitHub's 'Source code' release archives don't include submodules.
" (current-error-port))
(display "Clone the repo instead:
" (current-error-port))
(display " git clone --recurse-submodules https://github.com/jolt-lang/jolt.git
" (current-error-port))
(display "or, in an existing checkout:
" (current-error-port))
(display " git submodule update --init --recursive
" (current-error-port))
(exit 1))
(load "host/chez/rt.ss")
(set-chez-ns! "clojure.core")
(load "host/chez/seed/prelude.ss")
@ -24,7 +44,7 @@
;; jolt.ffi host primitives (memory / library loading) load AFTER the loader's
;; baked-ns snapshot, so a library's (require '[jolt.ffi]) still loads jolt.ffi's
;; Clojure side (the foreign-fn / defcfn macros, stdlib/jolt/ffi.clj).
(load "host/chez/ffi.ss") ; jolt.ffi (FFI: a library binds native code)
(load "host/chez/java/ffi.ss") ; jolt.ffi (FFI: a library binds native code)
;; jolt.main + jolt.deps live under jolt-core; keep them (and stdlib) on the
;; roots so the CLI's own namespaces — and any jolt.* an app pulls in — resolve.
@ -32,29 +52,23 @@
(set-source-roots! (list "jolt-core" "stdlib"))
;; Render an uncaught jolt throw (any value, not just a Chez condition) to stderr
;; and exit non-zero, instead of Chez's opaque "non-condition value" dump. An
;; ex-info shows its message + ex-data; anything else is pr-str'd.
(define (jolt-report-uncaught v)
(let ((port (current-error-port)))
(if (and (jolt=2 (jolt-get v jolt-kw-ex-type jolt-nil) jolt-kw-ex-info))
(begin
(display "Unhandled exception: " port)
(display (jolt-str-render-one (jolt-get v jolt-kw-message jolt-nil)) port)
(newline port)
(let ((data (jolt-get v jolt-kw-data jolt-nil)))
(unless (jolt-nil? data)
(display " ex-data: " port) (display (jolt-pr-str data) port) (newline port)))
(let ((cause (jolt-get v jolt-kw-cause jolt-nil)))
(when (condition? cause)
(display " cause: " port)
(display (with-output-to-string (lambda () (display-condition cause))) port)
(newline port))))
(begin
(display "Unhandled exception: " port)
(display (if (condition? v) (with-output-to-string (lambda () (display-condition v))) (jolt-pr-str v)) port)
(newline port)))
;; and exit non-zero, instead of Chez's opaque "non-condition value" dump. The
;; message/ex-data/cause + a mapped Clojure backtrace come from the shared
;; renderer (source-registry.ss); the cli adds the top-level source location.
(define (jolt-report-uncaught raw)
(let ((v (jolt-unwrap-throw raw))
(port (current-error-port)))
(jolt-render-throwable v port)
;; The top-level form that was evaluating when this propagated (file:line:col).
(let ((loc (jolt-current-source-string)))
(when loc (display " at " port) (display loc port) (newline port)))
(let ((bt (jolt-backtrace-string v)))
(when bt (display " trace:\n" port) (display bt port)))
(exit 1)))
;; JOLT_TRACE opt-in, at runtime (before any app ns compiles) so the app is traced.
(jolt-trace-init-from-env!)
(guard (v (#t (jolt-report-uncaught v)))
(cond
;; -e EXPR — evaluate one expression and print it (blank for nil). Wrapped in

View file

@ -32,45 +32,161 @@
out))
;; ============================================================================
;; persistent vector — copy-on-write over a Scheme vector
;; persistent vector — 32-way trie + tail (Clojure's PersistentVector)
;; ============================================================================
;; A pvec carries an `ent` flag: #t marks a MAP ENTRY (the [k v] pair seq'd out
;; of a map). A map entry equals its [k v] vector and walks like one (nth/count/
;; seq/=/hash/print all read only `v`), but is NOT `vector?` and IS `map-entry?`
;; — matching Clojure's MapEntry. The flag defaults #f, so every
;; existing `(make-pvec v)` builds a plain vector; modifying an entry (conj/assoc)
;; likewise yields a plain vector.
(define-record-type pvec
(fields v ent)
(protocol (lambda (new) (case-lambda ((v) (new v #f)) ((v e) (new v e)))))
(nongenerative chez-pvec-v1))
(define empty-pvec (make-pvec (vector)))
(define (jolt-vector . xs) (make-pvec (list->vector xs)))
(define (make-map-entry k v) (make-pvec (vector k v) #t))
(define (jolt-map-entry? x) (and (pvec? x) (pvec-ent x) #t))
(define (pvec-count p) (vector-length (pvec-v p)))
;; cnt elements live in a trie of 32-wide nodes (root, height = shift bits) plus a
;; trailing `tail` chunk of 1..32. conj appends to the tail and, when it fills,
;; pushes it into the trie by path-copy — so conj is O(1) amortized and a linear
;; build is O(n), not the O(n^2) of a flat copy-on-write array. nth/assoc/pop are
;; O(log32 n). Trie nodes are Scheme vectors holding only their live children
;; (grown left-to-right), so a node's length is its child count.
;;
;; `ent` #t marks a MAP ENTRY (the [k v] pair seq'd out of a map). An entry has 2
;; elements (all in the tail), equals its [k v] vector and walks like one, and is
;; both vector? (Clojure's MapEntry implements IPersistentVector) and map-entry?.
;; Modifying an entry (conj/assoc/pop) yields a plain vector (ent #f).
;;
;; make-pvec and pvec-v keep the old flat-vector API: make-pvec builds a trie from
;; a Scheme vector (every existing caller still passes one) and pvec-v materializes
;; it back, so only this file's internals change.
(define pv-bits 5)
(define pv-width 32)
(define pv-mask 31)
(define pv-empty-node (vector))
(define-record-type (pvec mk-pvec pvec?)
(fields cnt shift root tail ent) (nongenerative chez-pvec-v2))
;; trailing helpers over Scheme vectors used by the trie
(define (vec-snoc v x) ; copy v with x appended
(let* ((n (vector-length v)) (out (make-vector (fx+ n 1))))
(let loop ((i 0)) (when (fx<? i n) (vector-set! out i (vector-ref v i)) (loop (fx+ i 1))))
(vector-set! out n x) out))
(define (vec-drop-last v) (vec-copy-range v 0 (fx- (vector-length v) 1)))
(define (vec-take v n) (vec-copy-range v 0 n))
(define (vec-set-or-snoc v i x) ; replace index i, or append when i = length
(let ((n (vector-length v))) (if (fx<? i n) (vec-set v i x) (vec-snoc v x))))
(define (pv-tailoff cnt)
(if (fx<? cnt pv-width) 0 (fxsll (fxsra (fx- cnt 1) pv-bits) pv-bits)))
;; the 32-chunk Scheme vector holding index i (the tail or a trie leaf)
(define (pv-chunk-for p i)
(if (fx>=? i (pv-tailoff (pvec-cnt p)))
(pvec-tail p)
(let loop ((node (pvec-root p)) (level (pvec-shift p)))
(if (fx>? level 0)
(loop (vector-ref node (fxand (fxsra i level) pv-mask)) (fx- level pv-bits))
node))))
;; jolt models every number as a double, so vector indices arrive as flonums —
;; coerce an integer-valued index to a Scheme fixnum before bounds math.
(define (->idx i) (if (fixnum? i) i (if (flonum? i) (exact (floor i)) i)))
(define (pvec-count p) (pvec-cnt p))
(define (pvec-nth-d p i d)
(let ((v (pvec-v p)) (i (->idx i)))
(if (and (fixnum? i) (fx>=? i 0) (fx<? i (vector-length v))) (vector-ref v i) d)))
(let ((i (->idx i)))
(if (and (fixnum? i) (fx>=? i 0) (fx<? i (pvec-cnt p)))
(vector-ref (pv-chunk-for p i) (fxand i pv-mask))
d)))
;; new-path: wrap a node in single-child nodes up `level` bits.
(define (pv-new-path level node)
(if (fx=? level 0) node (vector (pv-new-path (fx- level pv-bits) node))))
;; push a full tail chunk into the trie under `parent` at `level`.
(define (pv-push-tail cnt level parent tail-node)
(let ((subidx (fxand (fxsra (fx- cnt 1) level) pv-mask)))
(if (fx=? level pv-bits)
(vec-set-or-snoc parent subidx tail-node)
(let ((child (and (fx<? subidx (vector-length parent)) (vector-ref parent subidx))))
(vec-set-or-snoc parent subidx
(if child (pv-push-tail cnt (fx- level pv-bits) child tail-node)
(pv-new-path (fx- level pv-bits) tail-node)))))))
(define (pvec-conj p x)
(let* ((v (pvec-v p)) (n (vector-length v)) (out (make-vector (fx+ n 1))))
(let loop ((i 0)) (when (fx<? i n) (vector-set! out i (vector-ref v i)) (loop (fx+ i 1))))
(vector-set! out n x)
(make-pvec out)))
(let ((cnt (pvec-cnt p)) (shift (pvec-shift p)))
(if (fx<? (fx- cnt (pv-tailoff cnt)) pv-width)
;; room in the tail
(mk-pvec (fx+ cnt 1) shift (pvec-root p) (vec-snoc (pvec-tail p) x) #f)
;; tail full: push it into the trie, start a fresh tail
(let ((tail-node (pvec-tail p)))
(if (fx>? (fxsra cnt pv-bits) (fxsll 1 shift))
;; root overflow: grow the trie a level
(mk-pvec (fx+ cnt 1) (fx+ shift pv-bits)
(vector (pvec-root p) (pv-new-path shift tail-node))
(vector x) #f)
(mk-pvec (fx+ cnt 1) shift
(pv-push-tail cnt shift (pvec-root p) tail-node)
(vector x) #f))))))
(define (pv-assoc-trie level node i x)
(if (fx=? level 0)
(vec-set node (fxand i pv-mask) x)
(let ((subidx (fxand (fxsra i level) pv-mask)))
(vec-set node subidx (pv-assoc-trie (fx- level pv-bits) (vector-ref node subidx) i x)))))
(define (pvec-assoc p i x) ; i in [0,count]; =count appends
(let* ((v (pvec-v p)) (n (vector-length v)) (i (->idx i)))
(cond ((and (fx>=? i 0) (fx<? i n)) (make-pvec (vec-set v i x)))
((fx=? i n) (pvec-conj p x))
(else (error 'assoc "vector index out of bounds")))))
(let ((i (->idx i)) (cnt (pvec-cnt p)))
(cond
((fx=? i cnt) (pvec-conj p x))
((and (fx>=? i 0) (fx<? i cnt))
(if (fx>=? i (pv-tailoff cnt))
(mk-pvec cnt (pvec-shift p) (pvec-root p)
(vec-set (pvec-tail p) (fxand i pv-mask) x) #f)
(mk-pvec cnt (pvec-shift p)
(pv-assoc-trie (pvec-shift p) (pvec-root p) i x) (pvec-tail p) #f)))
(else (jolt-throw (jolt-host-throwable "java.lang.IndexOutOfBoundsException" "vector index out of bounds"))))))
(define (pvec-peek p)
(let ((n (pvec-count p))) (if (fx=? n 0) jolt-nil (vector-ref (pvec-v p) (fx- n 1)))))
(let ((n (pvec-cnt p))) (if (fx=? n 0) jolt-nil (pvec-nth-d p (fx- n 1) jolt-nil))))
;; pop the last trie chunk back into the tail; #f means the subtree emptied.
(define (pv-pop-tail cnt level node)
(let ((subidx (fxand (fxsra (fx- cnt 2) level) pv-mask)))
(cond
((fx>? level pv-bits)
(let ((newchild (pv-pop-tail cnt (fx- level pv-bits) (vector-ref node subidx))))
(cond ((and (not newchild) (fx=? subidx 0)) #f)
(newchild (vec-set node subidx newchild))
(else (vec-take node subidx)))))
((fx=? subidx 0) #f)
(else (vec-take node subidx)))))
(define (pvec-pop p)
(let ((n (pvec-count p)))
(if (fx=? n 0) (error 'pop "can't pop empty vector")
(make-pvec (vec-copy-range (pvec-v p) 0 (fx- n 1))))))
(let ((cnt (pvec-cnt p)) (shift (pvec-shift p)))
(cond
((fx=? cnt 0) (error 'pop "can't pop empty vector"))
((fx=? cnt 1) empty-pvec)
((fx>? (fx- cnt (pv-tailoff cnt)) 1)
(mk-pvec (fx- cnt 1) shift (pvec-root p) (vec-drop-last (pvec-tail p)) #f))
(else
(let* ((new-tail (pv-chunk-for p (fx- cnt 2)))
(popped (pv-pop-tail cnt shift (pvec-root p)))
(new-root (or popped pv-empty-node)))
(if (and (fx>? shift pv-bits) (fx<? (vector-length new-root) 2))
(mk-pvec (fx- cnt 1) (fx- shift pv-bits)
(if (fx=? 0 (vector-length new-root)) pv-empty-node (vector-ref new-root 0))
new-tail #f)
(mk-pvec (fx- cnt 1) shift new-root new-tail #f)))))))
(define empty-pvec (mk-pvec 0 pv-bits pv-empty-node (vector) #f))
;; build a trie pvec from a flat Scheme vector (the public constructor).
(define make-pvec
(case-lambda
((v) (make-pvec v #f))
((v ent)
(let ((n (vector-length v)))
(if (fx<=? n pv-width)
(mk-pvec n pv-bits pv-empty-node v ent) ; fits in the tail
(let loop ((p empty-pvec) (i 0))
(if (fx=? i n) p (loop (pvec-conj p (vector-ref v i)) (fx+ i 1)))))))))
;; materialize the trie back to a flat Scheme vector (compatibility for callers
;; that read the backing array — all one-shot conversions, not hot loops).
(define (pvec-v p)
(let* ((cnt (pvec-cnt p)) (out (make-vector cnt)))
(let loop ((i 0))
(if (fx<? i cnt)
(let* ((chunk (pv-chunk-for p i)) (clen (vector-length chunk)))
(let cloop ((j 0) (k i))
(if (and (fx<? j clen) (fx<? k cnt))
(begin (vector-set! out k (vector-ref chunk j)) (cloop (fx+ j 1) (fx+ k 1)))
(loop k))))
out))))
(define (jolt-vector . xs) (make-pvec (list->vector xs)))
(define (make-map-entry k v) (make-pvec (vector k v) #t))
(define (jolt-map-entry? x) (and (pvec? x) (pvec-ent x) #t))
;; ============================================================================
;; bitmap HAMT — keys hashed by jolt-hash, leaves compared by jolt=
@ -171,26 +287,109 @@
;; ============================================================================
;; persistent map / set over the HAMT
;; ============================================================================
(define-record-type pmap (fields root cnt) (nongenerative chez-pmap-v1))
(define empty-pmap (make-pmap empty-hnode 0))
;; A small map keeps its keys in INSERTION order (Clojure's PersistentArrayMap),
;; converting to hash order past a threshold (PersistentHashMap). The HAMT root
;; always backs the values; `order` is the auxiliary insertion-order key list when
;; the map is in array mode, or #f once it has grown into hash mode. Equality and
;; hashing fold over the entries order-independently, so this only affects
;; iteration order (seq/keys/vals/print), matching the JVM.
(define-record-type pmap (fields root cnt order) (nongenerative chez-pmap-v2))
(define empty-pmap (make-pmap empty-hnode 0 '())) ; {} = empty array map
(define empty-pmap-hash (make-pmap empty-hnode 0 #f)) ; hash-order backing (sets)
(define pmap-absent (list 'absent)) ; unique missing-key sentinel
;; PersistentArrayMap threshold: assoc of a new key promotes to hash mode once the
;; map already holds 8 entries (array.length >= 16 in the reference). Clojure 1.13
;; raised the limit to 64 for maps whose keys are ALL keywords (the common
;; keyword-map case); mixed-key maps still cap at 8.
(define array-map-limit 8)
(define array-map-limit-kw 64)
(define (all-keywords? ks)
(or (null? ks) (and (keyword? (car ks)) (all-keywords? (cdr ks)))))
;; Should a map of `cnt` entries with insertion order `ord` stay in array mode
;; when key `k` is added? Under 8 always; a keyword-only map (existing keys + the
;; new key all keywords) grows to 64; otherwise it caps at 8.
(define (pmap-array-keep? cnt ord k)
(cond ((fx<? cnt array-map-limit) #t)
((fx>=? cnt array-map-limit-kw) #f)
((and (keyword? k) (all-keywords? ord)) #t)
(else #f)))
(define (append-key ord k) (append ord (list k)))
(define (remove-key ord k) (let loop ((o ord)) (cond ((null? o) '()) ((jolt= (car o) k) (cdr o)) (else (cons (car o) (loop (cdr o)))))))
;; growth rule (PersistentArrayMap.assoc): a new key appends to the order while in
;; array mode under the limit; otherwise the result is hash-ordered. Replacing an
;; existing key (or assoc onto an already-hash map) keeps the current order.
(define (pmap-assoc m k v)
(let* ((added (box #f)) (r (node-assoc (pmap-root m) 0 (key-hash k) k v added))
(cnt (pmap-cnt m)) (ord (pmap-order m)))
(if (unbox added)
(if (and ord (pmap-array-keep? cnt ord k))
(make-pmap r (fx+ cnt 1) (append-key ord k))
(make-pmap r (fx+ cnt 1) #f))
(make-pmap r cnt ord))))
;; force-ordered / force-hash inserts for rebuilding a map whose final mode is
;; already decided (array-map ctor, transient persistent!).
(define (pmap-put-ordered m k v)
(let* ((added (box #f)) (r (node-assoc (pmap-root m) 0 (key-hash k) k v added)))
(make-pmap r (if (unbox added) (fx+ (pmap-cnt m) 1) (pmap-cnt m)))))
(if (unbox added)
(make-pmap r (fx+ (pmap-cnt m) 1) (append-key (or (pmap-order m) '()) k))
(make-pmap r (pmap-cnt m) (pmap-order m)))))
(define (pmap-put-hash m k v)
(let* ((added (box #f)) (r (node-assoc (pmap-root m) 0 (key-hash k) k v added)))
(make-pmap r (if (unbox added) (fx+ (pmap-cnt m) 1) (pmap-cnt m)) #f)))
(define (pmap->hash m) (if (pmap-order m) (make-pmap (pmap-root m) (pmap-cnt m) #f) m))
(define (pmap-dissoc m k)
(let* ((removed (box #f)) (r (node-dissoc (pmap-root m) 0 (key-hash k) k removed)))
(make-pmap r (if (unbox removed) (fx- (pmap-cnt m) 1) (pmap-cnt m)))))
(let* ((removed (box #f)) (r (node-dissoc (pmap-root m) 0 (key-hash k) k removed))
(ord (pmap-order m)))
(if (unbox removed)
(make-pmap r (fx- (pmap-cnt m) 1) (if ord (remove-key ord k) #f))
m)))
(define (pmap-get m k default) (node-get (pmap-root m) 0 (key-hash k) k default))
(define (pmap-contains? m k) (not (eq? pmap-absent (node-get (pmap-root m) 0 (key-hash k) k pmap-absent))))
(define (pmap-fold m proc acc) (node-fold (pmap-root m) proc acc))
;; The universal fold idiom across the runtime is `(pmap-fold m (lambda (k v a)
;; (cons ... a)) '())`, which accumulates in REVERSE visitation order. So that this
;; reconstructs the map's INSERTION order, pmap-fold visits an array-mode map's keys
;; in reverse insertion order; a hash-mode map visits HAMT order (its iteration
;; order is unspecified, so reverse-of-HAMT is equivalent and matches prior
;; behaviour). Use pmap-fold-fwd when building a value directly in iteration order.
(define (pmap-fold m proc acc)
(let ((ord (pmap-order m)))
(if ord
(fold-right (lambda (k a) (proc k (pmap-get m k jolt-nil) a)) acc ord) ; visits last->first
(node-fold (pmap-root m) proc acc))))
;; visit entries in iteration (insertion) order — for code that builds a new map /
;; ordered value directly rather than via cons-accumulation.
(define (pmap-fold-fwd m proc acc)
(let ((ord (pmap-order m)))
(if ord
(let loop ((ks ord) (a acc))
(if (null? ks) a (loop (cdr ks) (proc (car ks) (pmap-get m (car ks) jolt-nil) a))))
(node-fold (pmap-root m) proc acc))))
;; map LITERAL ({...}): array map up to 8 entries (64 if keyword-only, per 1.13),
;; hash map beyond (RT.map).
(define (jolt-hash-map . kvs)
(let loop ((m empty-pmap) (kvs kvs))
(cond ((null? kvs) m)
(cond ((null? kvs)
(let ((cnt (pmap-cnt m)) (ord (pmap-order m)))
(if (fx>? cnt (if (all-keywords? ord) array-map-limit-kw array-map-limit))
(pmap->hash m) m)))
((null? (cdr kvs)) (error 'hash-map "odd number of map literal entries"))
(else (loop (pmap-assoc m (car kvs) (cadr kvs)) (cddr kvs))))))
(else (loop (pmap-put-ordered m (car kvs) (cadr kvs)) (cddr kvs))))))
;; array-map ctor: insertion-ordered regardless of size (createAsIfByAssoc).
(define (jolt-array-map-build kvs)
(let loop ((m empty-pmap) (kvs kvs))
(cond ((null? kvs) m)
((null? (cdr kvs)) (error 'array-map "odd number of map entries"))
(else (loop (pmap-put-ordered m (car kvs) (cadr kvs)) (cddr kvs))))))
;; hash-map ctor: hash order (PersistentHashMap).
(define (jolt-hash-map-build kvs)
(let loop ((m empty-pmap-hash) (kvs kvs))
(cond ((null? kvs) m)
((null? (cdr kvs)) (error 'hash-map "odd number of map entries"))
(else (loop (pmap-put-hash m (car kvs) (cadr kvs)) (cddr kvs))))))
(define-record-type pset (fields m) (nongenerative chez-pset-v1))
(define empty-pset (make-pset empty-pmap))
(define empty-pset (make-pset empty-pmap-hash)) ; sets are hash-ordered
(define (pset-conj s e) (if (pmap-contains? (pset-m s) e) s (make-pset (pmap-assoc (pset-m s) e e))))
(define (pset-disj s e) (make-pset (pmap-dissoc (pset-m s) e)))
(define (pset-contains? s e) (pmap-contains? (pset-m s) e))
@ -211,19 +410,22 @@
((empty-list-t? coll) (cseq-list x jolt-nil))
((pmap? coll)
(cond ((jolt-nil? x) coll) ; (conj m nil) = m
((pmap? x) (pmap-fold x (lambda (k v m) (pmap-assoc m k v)) coll)) ; merge
((pmap? x) (pmap-fold-fwd x (lambda (k v m) (pmap-assoc m k v)) coll)) ; merge in x's order
((and (pvec? x) (fx=? 2 (pvec-count x)))
(pmap-assoc coll (pvec-nth-d x 0 jolt-nil) (pvec-nth-d x 1 jolt-nil)))
(else (error 'conj "conj on a map expects a [k v] pair or a map"))))
((rec-coll-method coll "cons") => (lambda (m) (jolt-invoke m coll x)))
(else (error 'conj "unsupported collection"))))
;; (conj) -> []; (conj nil a b ...) builds a list (conj prepending -> (b a)).
(define (jolt-conj . args)
(if (null? args)
(jolt-vector)
(let ((coll (car args)) (xs (cdr args)))
(if (jolt-nil? coll)
(fold-left jolt-conj1 jolt-empty-list xs)
(meta-carry coll (fold-left jolt-conj1 coll xs))))))
(cond
;; 1-arity returns the coll untouched — (conj nil) is nil
((null? xs) coll)
((jolt-nil? coll) (fold-left jolt-conj1 jolt-empty-list xs))
(else (meta-carry coll (fold-left jolt-conj1 coll xs)))))))
;; A host shim registers a type's get via register-get-arm! (handler: (coll k d) ->
;; value) instead of set!-wrapping jolt-get — disjoint coll types, checked before the
@ -238,32 +440,53 @@
((string? coll) (let ((i (->idx k)))
(if (and (fixnum? i) (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i) d)))
(else d)))
;; jrec? / jrec-ref live in records.ss (loaded later); these are forward references
;; resolved at call time. A record field read is the hottest get, so check it first
;; and skip the get-arm walk.
(define (jolt-get-dispatch coll k d)
(let loop ((as jolt-get-arms))
(cond ((null? as) (jolt-get-base coll k d))
(((caar as) coll) ((cdar as) coll k d))
(else (loop (cdr as))))))
(if (jrec? coll)
(jrec-ref coll k d)
(let loop ((as jolt-get-arms))
(cond ((null? as) (jolt-get-base coll k d))
(((caar as) coll) ((cdar as) coll k d))
(else (loop (cdr as)))))))
(define jolt-get
(case-lambda
((coll k) (jolt-get-dispatch coll k jolt-nil))
((coll k d) (jolt-get-dispatch coll k d))))
;; A deftype implementing a clojure.lang collection interface (Indexed/Counted/
;; Associative/ILookup/ISeq/IPersistentCollection) carries the interface method
;; as an inline impl; the core collection fns fall back to it. find-method-any-
;; protocol / jolt-invoke load later — resolved at call time.
(define (rec-coll-method coll name)
(and (jrec? coll) (find-method-any-protocol (jrec-tag coll) name)))
(define (jolt-nth-nil-idx! i)
(when (jolt-nil? i)
(jolt-throw (jolt-host-throwable "java.lang.NullPointerException" "nth index"))))
(define jolt-nth
(case-lambda
((coll i)
(jolt-nth-nil-idx! i)
(let ((i (->idx i)))
(cond ((pvec? coll) (let ((v (pvec-v coll)))
(cond ((jolt-nil? coll) jolt-nil) ; RT.nth(nil, i) is nil at any index
((pvec? coll) (let ((v (pvec-v coll)))
(if (and (fx>=? i 0) (fx<? i (vector-length v))) (vector-ref v i)
(error 'nth "index out of bounds"))))
(jolt-throw (jolt-host-throwable "java.lang.IndexOutOfBoundsException" "index out of bounds")))))
((string? coll) (if (and (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i)
(error 'nth "index out of bounds")))
(jolt-throw (jolt-host-throwable "java.lang.IndexOutOfBoundsException" "index out of bounds"))))
((or (cseq? coll) (empty-list-t? coll)) (seq-nth coll i #f jolt-nil))
((rec-coll-method coll "nth") => (lambda (m) (jolt-invoke m coll i)))
(else (error 'nth "unsupported collection")))))
((coll i d)
(jolt-nth-nil-idx! i)
(let ((i (->idx i)))
(cond ((pvec? coll) (pvec-nth-d coll i d))
(cond ((jolt-nil? coll) d) ; RT.nth(nil, i, notFound) is notFound
((pvec? coll) (pvec-nth-d coll i d))
((string? coll) (if (and (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i) d))
((or (cseq? coll) (empty-list-t? coll)) (seq-nth coll i #t d))
((rec-coll-method coll "nth") => (lambda (m) (jolt-invoke m coll i d)))
(else d))))))
;; a count is an exact integer (JVM parity: count returns a long). jolt= is
@ -279,12 +502,14 @@
((empty-list-t? coll) 0)
((cseq? coll) (let loop ((s coll) (n 0)) ; walk (forces a finite seq)
(if (jolt-nil? s) n (loop (jolt-seq (seq-more s)) (fx+ n 1)))))
((rec-coll-method coll "count") => (lambda (m) (jolt-invoke m coll)))
(else (error 'count "uncountable")))))
(define (jolt-assoc1 coll k v)
(cond ((pmap? coll) (pmap-assoc coll k v))
((pvec? coll) (pvec-assoc coll k v))
((jolt-nil? coll) (pmap-assoc empty-pmap k v))
((rec-coll-method coll "assoc") => (lambda (m) (jolt-invoke m coll k v)))
(else (error 'assoc "unsupported collection"))))
(define (jolt-assoc coll . kvs)
(meta-carry coll
@ -303,6 +528,21 @@
((pset? coll) (pset-contains? coll k))
((pvec? coll) (let ((k (->idx k))) (and (fixnum? k) (fx>=? k 0) (fx<? k (pvec-count coll)))))
((jolt-nil? coll) #f)
;; a string supports contains? by INDEX only (RT.contains: CharSequence +
;; Number key); any other key — or any unsupported type — is the JVM's
;; IllegalArgumentException.
((string? coll)
(if (and (number? k) (exact? k) (integer? k))
(and (>= k 0) (< k (string-length coll)))
(jolt-throw (jolt-host-throwable
"java.lang.IllegalArgumentException"
"contains? not supported on type: java.lang.String"))))
((or (cseq? coll) (empty-list-t? coll) (number? coll) (boolean? coll)
(keyword? coll) (jolt-symbol? coll) (char? coll))
(jolt-throw (jolt-host-throwable
"java.lang.IllegalArgumentException"
(string-append "contains? not supported on type: "
(guard (e (#t "?")) (jolt-class-name coll))))))
(else #f)))
(define (jolt-empty? coll)
@ -315,15 +555,25 @@
((cseq? coll) #f) ; a cseq is non-empty by construction
(else (error 'empty? "unsupported collection"))))
(define (jolt-stack-throw coll)
(jolt-throw (jolt-host-throwable
"java.lang.ClassCastException"
(string-append "class " (guard (e (#t "?")) (jolt-class-name coll))
" cannot be cast to class clojure.lang.IPersistentStack"))))
(define (jolt-peek coll)
(cond ((pvec? coll) (pvec-peek coll))
((or (cseq? coll) (empty-list-t? coll)) (jolt-first coll)) ; list peek = first
((jolt-nil? coll) jolt-nil) (else (error 'peek "unsupported collection"))))
;; list peek = first; a non-list seq (range, a rest chain) is not an
;; IPersistentStack on the JVM
((and (cseq? coll) (cseq-list? coll)) (jolt-first coll))
((empty-list-t? coll) (jolt-first coll))
((jolt-nil? coll) jolt-nil)
(else (jolt-stack-throw coll))))
(define (jolt-pop coll)
(cond ((pvec? coll) (meta-carry coll (pvec-pop coll)))
((cseq? coll) (meta-carry coll (jolt-rest coll))) ; list pop = rest
(cond ((jolt-nil? coll) jolt-nil) ; RT.pop(nil) is nil
((pvec? coll) (meta-carry coll (pvec-pop coll)))
((and (cseq? coll) (cseq-list? coll)) (meta-carry coll (jolt-rest coll)))
((empty-list-t? coll) (error 'pop "can't pop empty list"))
(else (error 'pop "unsupported collection"))))
(else (jolt-stack-throw coll))))
;; ============================================================================
;; equality / hash hooks called from values.ss (jolt=2 / jolt-hash)

View file

@ -20,12 +20,138 @@
;; whose data conversion would turn those into real sets.
(define jolt-ce-read jolt-read-form-raw)
;; --- current source location ------------------------------------------------
;; The position of the top-level form currently compiling/evaluating, so an
;; uncaught error can report where it came from (cli.ss jolt-report-uncaught).
;; Thread-local: a future/agent worker tracks its own form. Holds #f or a
;; {:line :column :file?} position map (jolt.host/form-position's shape).
;; Top-level granularity — one set per top-level form, nothing per call.
(define jolt-current-source (make-thread-parameter #f))
;; clojure.lang.Compiler/LINE and /COLUMN — derefable cells (Vars on the JVM)
;; holding the line/column of the form being compiled. Macros read @Compiler/LINE
;; as a fallback when &form carries no position (jolt's reader stamps :line on list
;; forms, so this is rarely hit). Updated per top-level form, like *current-source*.
(define compiler-line-cell (jolt-atom-new 0))
(define compiler-column-cell (jolt-atom-new 0))
;; clojure.lang.Compiler/specials — the JVM's special-form table (sym -> parser).
;; tools.macro reads (keys Compiler/specials) to know which heads NOT to expand.
;; Only the keys matter here; values are #t. The set matches Clojure 1.2/1.3.
(define compiler-specials
(let ((unq '("def" "loop*" "recur" "if" "case*" "let*" "letfn*" "do" "fn*"
"quote" "var" "." "set!" "try" "monitor-enter" "monitor-exit"
"throw" "new" "&" "catch" "finally" "reify*" "deftype*")))
(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 "demunge" compiler-demunge))))
(register-class-statics! "Compiler" members)
(register-class-statics! "clojure.lang.Compiler" members))
(define (jolt-enter-form! form)
(let ((p (hc-form-position form)))
(when (pmap? p)
(jolt-current-source p)
(let ((line (jolt-get p hc-kw-line jolt-nil)) (col (jolt-get p hc-kw-column jolt-nil)))
(jolt-atom-val-set! compiler-line-cell (if (jolt-nil? line) 0 line))
(jolt-atom-val-set! compiler-column-cell (if (jolt-nil? col) 0 col))))))
;; "file:line:col" / "line:col" for the current form, or #f when none is set.
(define (jolt-current-source-string)
(let ((p (jolt-current-source)))
(and (pmap? p)
(let ((line (jolt-get p hc-kw-line jolt-nil))
(col (jolt-get p hc-kw-column jolt-nil))
(file (jolt-get p hc-kw-file jolt-nil)))
(string-append
(if (jolt-nil? file) "" (string-append file ":"))
(if (jolt-nil? line) "?" (number->string line)) ":"
(if (jolt-nil? col) "?" (number->string col)))))))
;; The spine ALWAYS runs with the full clojure.core prelude loaded, so a clojure.*
;; ref must lower to var-deref (resolved from the prelude), not trip the emitter's
;; "unsupported stdlib fn (no core on Chez yet)" out-of-subset guard — that guard
;; is only for the bare -e subset with no prelude. Turn prelude mode on once, here,
;; so every analyze->emit on this spine sees the full core.
((var-deref "jolt.backend-scheme" "set-prelude-mode!") #t)
;; Cache resolved var cells per reference site in runtime-compiled code (the big
;; win for libraries / REPL code). emit-image.ss turns this back off so the seed
;; mint and AOT build stay byte-deterministic. Guarded: the flag is absent in an
;; older seed during the first re-mint pass.
(let ((scv (var-deref "jolt.backend-scheme" "set-var-cache!")))
(when (procedure? scv) (scv #t)))
;; JOLT_TRACE is a falsey value (case-insensitive) — the single predicate both the
;; dev-mode enable and the whole-run enable consult, so "off" never accidentally
;; means "on". An empty / unset value is NOT falsey here — it carries no signal, so
;; dev mode still traces and a whole run still doesn't.
(define (jolt-trace-env-off? e)
(and (string? e)
(let ((s (string-downcase e)))
(or (string=? s "0") (string=? s "false") (string=? s "no")
(string=? s "off") (string=? s "n")))))
;; Tail-frame history. Turning it on makes the emitter add a per-fn history push to
;; every fn compiled AFTERWARD, and allocates this thread's ring. Suppressed when
;; JOLT_TRACE is a falsey value, so JOLT_TRACE=0 / off / no disables it in dev mode.
(define (jolt-enable-trace!)
(unless (jolt-trace-env-off? (getenv "JOLT_TRACE"))
(let ((stf (var-deref "jolt.backend-scheme" "set-trace-frames!")))
(when (procedure? stf) (stf #t)))
(jolt-trace-enable!)))
;; Exposed so the REPL / nREPL entrypoints (jolt.main, jolt.nrepl) can turn tracing
;; on for REPL-driven development without the user setting JOLT_TRACE. Because the
;; push is baked in at compile time, only code compiled after this call is traced —
;; which is exactly the code you eval / reload in a live session.
(def-var! "jolt.host" "enable-trace!" jolt-enable-trace!)
;; Explicit opt-in for a whole run (JOLT_TRACE=1): turn tracing on BEFORE any app
;; namespace is compiled, so a plain `-M:run` traces the app's own code too. Called
;; from the runtime entrypoints (cli.ss, and the built joltc launcher) — NOT at load
;; time: a built joltc runs top-level forms at heap-build time, where JOLT_TRACE is
;; always unset, so a load-time check would never see the user's runtime env. Only an
;; affirmative value (set, non-empty, not falsey) forces it on.
(define (jolt-trace-init-from-env!)
(let ((e (getenv "JOLT_TRACE")))
(when (and e (fx>? (string-length e) 0) (not (jolt-trace-env-off? e)))
(jolt-enable-trace!))))
;; (with-meta sym m) -> sym, else x — an (ns ^:no-doc name …) yields the name with
;; reader metadata as a with-meta form; strip it to read the bare ns symbol.
(define (ce-unwrap-meta x)
(if (and (cseq? x) (cseq-list? x))
(let ((items (seq->list x)))
(if (and (pair? items) (symbol-t? (car items))
(string=? (symbol-t-name (car items)) "with-meta") (pair? (cdr items)))
(cadr items) x))
x))
;; (quote X) -> X, else x — unwraps a quoted require spec.
(define (ce-unquote x)
@ -51,14 +177,22 @@
;; (require spec...) / (use spec...) — specs are quoted
((and hn (or (string=? hn "require") (string=? hn "use")))
(for-each (lambda (a) (chez-register-spec! ns (ce-unquote a))) (cdr items)))
;; (ns name (:require [a :as x]) ...) — clause specs are literal
;; (ns name (:require [a :as x]) ...) — clause specs are literal. Register
;; the aliases under NAME (the ns being defined), not the passed `ns`:
;; when a file is loaded its ns form compiles while (chez-current-ns) is
;; still the requiring ns, so using `ns` would leak the loaded ns's
;; aliases into its requirer and clobber a same-named alias there
;; (rewrite-clj.zip.base's [node.protocols :as node] over the caller's node).
((and hn (string=? hn "ns"))
(for-each (lambda (clause)
(when (and (cseq? clause) (cseq-list? clause))
(let ((cl (seq->list clause)))
(when (ce-clause-require? cl)
(for-each (lambda (spec) (chez-register-spec! ns spec)) (cdr cl))))))
(if (pair? (cdr items)) (cddr items) '())))
(let ((ns-name (if (and (pair? (cdr items)) (symbol-t? (ce-unwrap-meta (cadr items))))
(symbol-t-name (ce-unwrap-meta (cadr items)))
ns)))
(for-each (lambda (clause)
(when (and (cseq? clause) (cseq-list? clause))
(let ((cl (seq->list clause)))
(when (ce-clause-require? cl)
(for-each (lambda (spec) (chez-register-spec! ns-name spec)) (cdr cl))))))
(if (pair? (cdr items)) (cddr items) '()))))
(else (for-each (lambda (x) (ce-scan-requires! x ns)) items))))))))
;; Already-read FORM -> Scheme source string (analyze -> emit on Chez).
@ -109,7 +243,13 @@
;; A top-level (do ...) is UNROLLED — each subform compiled+eval'd in turn, like
;; Clojure's top-level do — so a runtime defmacro/def in an earlier subform is
;; visible (macro flag set, var interned) before a later subform is analyzed.
;; a non-form VALUE (a function object, a BigDecimal, a reference type)
;; self-evaluates, like eval on the JVM.
(define (jolt-compile-eval-form form ns)
(if (or (procedure? form) (jbigdec? form) (jolt-atom? form) (jolt-multifn? form))
form
(jolt-compile-eval-form* form ns)))
(define (jolt-compile-eval-form* form ns)
(cond
;; thread the current ns: an earlier subform may switch it (ns/in-ns call
;; set-chez-ns!), and the next subform must be ANALYZED in that ns so its defs
@ -124,6 +264,12 @@
;; of the expander fn + (mark-macro! …) so subsequent forms expand it. One
;; macro-expansion path (no separate spine interception).
(else
;; record this form's source location first, so a compile- or run-time error
;; in it reports the right place.
(jolt-enter-form! form)
;; drop tail-frame history from earlier top-level forms, so an error's trace
;; shows only this form's own call history (a no-op unless JOLT_TRACE is on).
(jolt-trace-reset!)
(eval (read (open-input-string (jolt-analyze-emit-form form ns)))
(interaction-environment)))))

View file

@ -1,324 +0,0 @@
;; concurrency.ss — real OS-thread futures + promises for the Chez host.
;;
;; SHARED-HEAP semantics, like JVM Clojure: a future body runs on a native thread
;; (fork-thread) over the SAME heap, so a captured atom is shared and the body's
;; mutations are visible to the parent. deref blocks on a mutex+condition latch.
;;
;; future / future-call / future-cancel / future? / future-done? / future-cancelled?
;; promise / deliver, and the deref extension for both, are bound here (some
;; re-asserted in post-prelude.ss over the overlay's versions).
;;
;; pmap / pcalls / pvalues live in the clojure.core overlay (40-lazy) expressed
;; over `future`, so they light up for free once future-call exists.
;;
;; Loaded near the end of rt.ss — after atoms.ss (jolt-deref, the atom lock) and
;; dyn-binding.ss (the thread-local binding stack we convey into the worker).
;; Requires a threaded Chez build (fork-thread / make-mutex / make-condition).
;; --- time helpers -----------------------------------------------------------
;; A relative duration / absolute deadline from a millisecond count (a jolt number).
(define (ms->duration ms)
(let* ((ms* (exact (floor ms)))
(secs (quotient ms* 1000))
(nanos (* (remainder ms* 1000) 1000000)))
(make-time 'time-duration nanos secs)))
(define (ms->deadline ms) (add-duration (current-time 'time-utc) (ms->duration ms)))
;; --- futures ----------------------------------------------------------------
;; A future is a mutable cell guarded by `mu`; workers/derefs coordinate on `cv`.
;; done? — result (or cancellation) is final; derefs may proceed
;; cancelled? — future-cancel won before the body finished
;; ok? — payload is a value (else payload is a raised condition/value)
;; payload — the result value, or the captured throw
(define-record-type jolt-future
(fields (mutable done?) (mutable cancelled?) (mutable ok?) (mutable payload) mu cv)
(nongenerative jolt-future-v1))
;; (future-call thunk): spawn a thread running (thunk). The dynamic bindings in
;; effect now are conveyed into the worker (Chez inherits thread-parameters at
;; fork; we also install an explicit snapshot for certainty). The result — value
;; or thrown condition — is latched and broadcast; a cancel that already finalized
;; the future makes the late result a no-op.
(define (jolt-future-call thunk)
(let ((f (make-jolt-future #f #f #f jolt-nil (make-mutex) (make-condition)))
(snap (dyn-binding-stack)))
(fork-thread
(lambda ()
(dyn-binding-stack snap)
(let ((r (guard (e (#t (cons #f e))) (cons #t (jolt-invoke thunk)))))
(with-mutex (jolt-future-mu f)
(unless (jolt-future-done? f) ; not already cancelled
(jolt-future-ok?-set! f (car r))
(jolt-future-payload-set! f (cdr r))
(jolt-future-done?-set! f #t))
(condition-broadcast (jolt-future-cv f))))))
f))
;; Final value of a settled future (called OUTSIDE the lock): re-raise a captured
;; throw, signal a cancellation, else the value.
(define (jolt-future-finish f)
(cond
((jolt-future-cancelled? f)
(jolt-throw (jolt-ex-info "Future cancelled" (jolt-hash-map))))
((jolt-future-ok? f) (jolt-future-payload f))
(else (raise (jolt-future-payload f)))))
(define (jolt-future-deref f)
(with-mutex (jolt-future-mu f)
(let loop ()
(unless (jolt-future-done? f)
(condition-wait (jolt-future-cv f) (jolt-future-mu f))
(loop))))
(jolt-future-finish f))
;; (deref f timeout-ms timeout-val): wait up to timeout-ms; return timeout-val if
;; it has not settled by the absolute deadline.
(define (jolt-future-deref-timed f ms timeout-val)
(let* ((deadline (ms->deadline ms))
(settled (with-mutex (jolt-future-mu f)
(let loop ()
(cond ((jolt-future-done? f) #t)
((condition-wait (jolt-future-cv f) (jolt-future-mu f) deadline)
(loop)) ; woken — recheck
(else (jolt-future-done? f))))))) ; timed out: final check
(if settled (jolt-future-finish f) timeout-val)))
;; future-cancel: the running thread can't be interrupted, but the future object
;; reflects the cancellation — if not already settled, mark it cancelled+done so
;; derefs raise and the predicates flip. Returns true iff this call cancelled it.
(define (jolt-future-cancel f)
(let ((cancelled (with-mutex (jolt-future-mu f)
(if (jolt-future-done? f)
#f
(begin (jolt-future-cancelled?-set! f #t)
(jolt-future-done?-set! f #t)
(condition-broadcast (jolt-future-cv f))
#t)))))
cancelled))
(define (jolt-native-future-done? x)
(if (jolt-future? x) (jolt-future-done? x)
(jolt-throw (jolt-ex-info "future-done? requires a future" (jolt-hash-map)))))
(define (jolt-native-future-cancelled? x)
(and (jolt-future? x) (jolt-future-cancelled? x)))
;; --- promises ---------------------------------------------------------------
;; A blocking promise (like the JVM): deref parks until deliver, then caches the
;; value. deliver wins once; later delivers return nil.
(define-record-type jolt-promise
(fields (mutable delivered?) (mutable value) mu cv)
(nongenerative jolt-promise-v1))
(define (jolt-promise-new) (make-jolt-promise #f jolt-nil (make-mutex) (make-condition)))
(define (jolt-deliver p v)
(if (jolt-promise? p)
(let ((won (with-mutex (jolt-promise-mu p)
(if (jolt-promise-delivered? p)
#f
(begin (jolt-promise-value-set! p v)
(jolt-promise-delivered?-set! p #t)
(condition-broadcast (jolt-promise-cv p))
#t)))))
(if won p jolt-nil))
(jolt-throw (jolt-ex-info "deliver requires a promise" (jolt-hash-map)))))
(define (jolt-promise-deref p)
(with-mutex (jolt-promise-mu p)
(let loop ()
(unless (jolt-promise-delivered? p)
(condition-wait (jolt-promise-cv p) (jolt-promise-mu p))
(loop))))
(jolt-promise-value p))
(define (jolt-promise-deref-timed p ms timeout-val)
(let* ((deadline (ms->deadline ms))
(got (with-mutex (jolt-promise-mu p)
(let loop ()
(cond ((jolt-promise-delivered? p) #t)
((condition-wait (jolt-promise-cv p) (jolt-promise-mu p) deadline)
(loop))
(else (jolt-promise-delivered? p)))))))
(if got (jolt-promise-value p) timeout-val)))
;; --- agents (async, per-agent serialized dispatch) --------------------------
;; JVM semantics: send/send-off enqueue an action and a single worker thread
;; applies them to the state IN ORDER; deref reads the
;; (possibly not-yet-updated) state without blocking; await blocks until the queue
;; drains. An action error is captured (agent-error) and stops the queue.
(define-record-type jolt-agent
(fields (mutable state) (mutable err) (mutable validator)
(mutable queue) (mutable running?) mu cv)
(nongenerative jolt-agent-v1))
;; (agent state) / (agent state :validator f :error-mode m :meta x): only :validator
;; has runtime behaviour here; other opts are accepted/ignored.
(define (jolt-agent-new state . opts)
(let loop ((o opts) (validator jolt-nil))
(cond
((or (null? o) (null? (cdr o)))
(make-jolt-agent state jolt-nil validator (vector '() '()) #f (make-mutex) (make-condition)))
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "validator"))
(loop (cddr o) (cadr o)))
(else (loop (cddr o) validator)))))
;; The action queue is an amortized-O(1) FIFO held as a mutable #(out in): `out` is
;; the front, `in` holds sends reversed onto it (an append-to-a-list send was O(n)).
;; All three helpers run under the agent mutex.
(define (jagent-q-empty? a)
(let ((q (jolt-agent-queue a))) (and (null? (vector-ref q 0)) (null? (vector-ref q 1)))))
(define (jagent-q-push! a entry)
(let ((q (jolt-agent-queue a))) (vector-set! q 1 (cons entry (vector-ref q 1)))))
(define (jagent-q-pop! a)
(let ((q (jolt-agent-queue a)))
(when (null? (vector-ref q 0))
(vector-set! q 0 (reverse (vector-ref q 1))) (vector-set! q 1 '()))
(let ((out (vector-ref q 0))) (vector-set! q 0 (cdr out)) (car out))))
;; Drain the queue, applying each action (f state arg*) outside the lock (an action
;; may send/deref the same agent). A validator rejection or a thrown action puts the
;; agent in an error state and halts the queue (JVM :fail mode).
(define (jolt-agent-worker a)
(let loop ()
(let ((act (with-mutex (jolt-agent-mu a)
(if (or (not (jolt-nil? (jolt-agent-err a))) (jagent-q-empty? a))
(begin (jolt-agent-running?-set! a #f)
(condition-broadcast (jolt-agent-cv a)) #f)
(jagent-q-pop! a)))))
(when act
(guard (e (#t (with-mutex (jolt-agent-mu a)
(jolt-agent-err-set! a e)
(condition-broadcast (jolt-agent-cv a)))))
(let ((nv (apply jolt-invoke (car act) (jolt-agent-state a) (cdr act))))
(let ((vf (jolt-agent-validator a)))
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf nv)))
(error #f "Invalid reference state")))
(jolt-agent-state-set! a nv)))
(loop)))))
;; send / send-off: enqueue the action, start the worker if idle. (jolt treats them
;; identically — one serialized worker per agent — which is observably a superset of
;; the JVM's fixed/cached pool split.)
(define (jolt-agent-send a f . args)
(with-mutex (jolt-agent-mu a)
(jagent-q-push! a (cons f args))
(unless (jolt-agent-running? a)
(jolt-agent-running?-set! a #t)
(fork-thread (lambda () (jolt-agent-worker a)))))
a)
;; (await & agents): block until each agent's queue has drained.
(define (jolt-agent-await . agents)
(for-each
(lambda (a)
(with-mutex (jolt-agent-mu a)
(let loop ()
(when (or (jolt-agent-running? a) (not (jagent-q-empty? a)))
(condition-wait (jolt-agent-cv a) (jolt-agent-mu a)) (loop)))))
agents)
jolt-nil)
(define (jolt-agent-error a) (jolt-agent-err a))
(define (jolt-agent-restart a new-state . _opts)
(jolt-agent-err-set! a jolt-nil)
(jolt-agent-state-set! a new-state)
a)
;; --- delay (lazy once-forced computation) -----------------------------------
;; (delay body) -> (make-delay (fn [] body)) (overlay macro); force/deref run the
;; thunk once under a lock and cache the value (JVM delays are thread-safe). force
;; (overlay) is (if (delay? x) (deref x) x), so it works once delay?/deref do.
(define-record-type jolt-delay (fields thunk (mutable realized?) (mutable value) mu)
(nongenerative jolt-delay-v1))
(define (jolt-make-delay thunk) (make-jolt-delay thunk #f jolt-nil (make-mutex)))
(define (jolt-delay-force d)
(with-mutex (jolt-delay-mu d)
(unless (jolt-delay-realized? d)
(jolt-delay-value-set! d (jolt-invoke (jolt-delay-thunk d)))
(jolt-delay-realized?-set! d #t)))
(jolt-delay-value d))
;; --- deref extension --------------------------------------------------------
;; Chain the fully-built jolt-deref (atoms/vars/volatiles/reduced) with futures,
;; promises, agents, and delays; accept the timed (deref ref ms val) arity for the
;; blocking ref types.
(define %pre-conc-deref jolt-deref)
(set! jolt-deref
(lambda (x . opts)
(cond
((jolt-future? x)
(if (null? opts) (jolt-future-deref x)
(jolt-future-deref-timed x (car opts) (cadr opts))))
((jolt-promise? x)
(if (null? opts) (jolt-promise-deref x)
(jolt-promise-deref-timed x (car opts) (cadr opts))))
((jolt-agent? x) (jolt-agent-state x))
((jolt-delay? x) (jolt-delay-force x))
(else (apply %pre-conc-deref x opts)))))
;; realized? for a future/promise/delay. Wrapped over the overlay version in
;; post-prelude.ss.
(define (jolt-conc-realized? x)
(cond ((jolt-future? x) (jolt-future-done? x))
((jolt-promise? x) (jolt-promise-delivered? x))
((jolt-delay? x) (jolt-delay-realized? x))
(else #f)))
;; --- bind into clojure.core -------------------------------------------------
(def-var! "clojure.core" "future-call" jolt-future-call)
(def-var! "clojure.core" "future-cancel" jolt-future-cancel)
(def-var! "clojure.core" "future?" jolt-future?)
(def-var! "clojure.core" "future-done?" jolt-native-future-done?)
(def-var! "clojure.core" "future-cancelled?" jolt-native-future-cancelled?)
(def-var! "clojure.core" "promise" jolt-promise-new)
(def-var! "clojure.core" "deliver" jolt-deliver)
(def-var! "clojure.core" "agent" jolt-agent-new)
(def-var! "clojure.core" "agent?" jolt-agent?)
(def-var! "clojure.core" "send" jolt-agent-send)
(def-var! "clojure.core" "send-off" jolt-agent-send)
(def-var! "clojure.core" "await" jolt-agent-await)
(def-var! "clojure.core" "agent-error" jolt-agent-error)
(def-var! "clojure.core" "restart-agent" jolt-agent-restart)
(def-var! "clojure.core" "make-delay" jolt-make-delay)
(def-var! "clojure.core" "delay?" jolt-delay?)
(def-var! "clojure.core" "deref" jolt-deref)
;; --- 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
;; running computation, even a tight Scheme loop, can be aborted from another
;; thread. An interrupt TOKEN is a shared box; run-interruptible arms a periodic
;; timer in the eval thread whose handler escapes (via call/cc) when the token is
;; set; interrupt! sets the token from any thread. The aborted eval throws a jolt
;; ex-info {:jolt/interrupted true}, so the thread is REUSED, not abandoned.
;;
;; Caveat: a thread blocked in a __collect_safe foreign call (socket recv/accept,
;; sleep) only sees the interrupt when it returns to Scheme — like the JVM not
;; killing native code.
(define interrupt-check-ticks 100000) ; ~poll interval; responsive + low overhead
(define interrupt-sentinel (cons 'jolt 'interrupted))
(define jolt-kw-interrupted (keyword "jolt" "interrupted"))
(define (jolt-make-interrupt) (box #f))
(define (jolt-interrupt! token) (when (box? token) (set-box! token #t)) jolt-nil)
(define (jolt-interrupted? token) (and (box? token) (unbox token) #t))
(define (jolt-run-interruptible token thunk)
(let ((prev-handler (timer-interrupt-handler)))
(let ((r (call/cc
(lambda (k)
(timer-interrupt-handler
(lambda ()
(if (and (box? token) (unbox token))
(k interrupt-sentinel)
(begin (set-timer interrupt-check-ticks) (void)))))
(set-timer interrupt-check-ticks)
(let ((v (thunk))) (set-timer 0) v)))))
;; restore the prior timer state regardless of outcome.
(set-timer 0)
(timer-interrupt-handler prev-handler)
(if (eq? r interrupt-sentinel)
(jolt-throw (jolt-ex-info "Evaluation interrupted" (jolt-hash-map jolt-kw-interrupted #t)))
r))))
(def-var! "jolt.host" "make-interrupt" jolt-make-interrupt)
(def-var! "jolt.host" "interrupt!" jolt-interrupt!)
(def-var! "jolt.host" "interrupted?" jolt-interrupted?)
(def-var! "jolt.host" "run-interruptible" jolt-run-interruptible)

View file

@ -27,17 +27,48 @@
((and (flonum? v) (fl= v +inf.0)) "Infinity")
((and (flonum? v) (fl= v -inf.0)) "-Infinity")
((and (flonum? v) (not (fl= v v))) "NaN")
;; a symbol stringifies to its name (JVM Symbol.toString returns the interned
;; name), so (str sym) of a no-ns symbol is the SAME string object the symbol
;; holds — code that compares those by identity (core.logic's non-unique lvar
;; equality) depends on it.
((symbol-t? v)
(let ((ns (symbol-t-ns v)))
(if (or (not ns) (jolt-nil? ns))
(symbol-t-name v)
(string-append ns "/" (symbol-t-name v)))))
(else
(let loop ((rs str-render-registry))
(cond
((null? rs) (jolt-pr-str v))
(((caar rs) v) ((cdar rs) v))
(else (loop (cdr rs))))))))
;; print/println render non-readably: a nested string is raw. jolt-str-render-one
;; is exactly that (collections fall through to jolt-pr-str). The print family
;; uses this seam, NOT the str fn — which renders readably (below). A top-level nil
;; prints "nil" (str renders it ""), so the seam special-cases it.
(define (jolt-print-one v) (if (jolt-nil? v) "nil" (jolt-str-render-one v)))
(def-var! "clojure.core" "__print1" jolt-print-one)
;; str: a top-level string/scalar renders as jolt-str-render-one (raw string,
;; "Infinity"…), but a COLLECTION renders as its readable form — nested strings
;; are QUOTED ((str ["x"]) => "[\"x\"]"), matching the JVM (a collection's
;; toString is readable). jolt-pr-readable resolves at call time.
(define (jolt-str-one v)
(if (or (pvec? v) (pmap? v) (pset? v) (cseq? v) (empty-list-t? v) (jolt-lazyseq? v))
(jolt-pr-readable v)
(jolt-str-render-one v)))
(define (jolt-str . xs)
(let loop ((xs xs) (acc '()))
(if (null? xs)
(apply string-append (reverse acc))
(loop (cdr xs) (cons (jolt-str-render-one (car xs)) acc)))))
(cond
((null? xs) "")
;; single arg returns its rendering directly (no string-append copy), so
;; (str sym) hands back the symbol's own name string — JVM (str x) is
;; x.toString(), and core.logic's non-unique lvar equality compares those by
;; identity.
((null? (cdr xs)) (jolt-str-one (car xs)))
(else (let loop ((xs xs) (acc '()))
(if (null? xs)
(apply string-append (reverse acc))
(loop (cdr xs) (cons (jolt-str-one (car xs)) acc)))))))
;; jolt indices are flonums; substring etc. need exact ints.
(define (jolt->idx n) (exact (truncate n)))
@ -86,23 +117,31 @@
(let ((a (car args)))
(cond
((jolt-symbol? a) a)
;; (symbol "ns/name") splits the namespace at the LAST "/" (JVM
;; Symbol.intern), so (namespace (symbol "foo/bar")) => "foo". A lone "/"
;; or a leading slash has no namespace. The no-ns sentinel is #f — matches
;; emit's quoted-symbol lowering (jolt-symbol #f "x"), so (= 'x (symbol
;; "x")) holds (jolt= compares ns with strict equal?).
;; (symbol "ns/name") splits the namespace at the FIRST "/" (JVM
;; Symbol.intern), so (namespace (symbol "foo/bar/baz")) => "foo" with
;; name "bar/baz". A lone "/" or a leading slash has no namespace. The
;; no-ns sentinel is #f — matches emit's quoted-symbol lowering
;; (jolt-symbol #f "x"), so (= 'x (symbol "x")) holds (jolt= compares
;; ns with strict equal?).
((string? a)
(let ((slen (string-length a)))
(if (string=? a "/")
(jolt-symbol #f "/")
(let loop ((i (- slen 1)))
(cond ((<= i 0) (jolt-symbol #f a))
(let loop ((i 1))
(cond ((>= i slen) (jolt-symbol #f a))
((char=? (string-ref a i) #\/)
(jolt-symbol (substring a 0 i) (substring a (+ i 1) slen)))
(else (loop (- i 1))))))))
(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)))))
((= (length args) 2) (jolt-symbol (car args) (cadr args)))
;; (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=
;; compares ns with strict equal?, so a jolt-nil ns would differ from #f.
((= (length args) 2)
(let ((ns (car args)))
(jolt-symbol (if (jolt-nil? ns) #f ns) (cadr args))))
(else (error #f "symbol: wrong arity"))))
;; gensym: per-process counter.
@ -117,7 +156,12 @@
;; int/long: truncate toward zero to an EXACT integer (= JVM long). char -> code
;; point (exact). double: always a flonum (= JVM double).
(define (jolt-int x) (if (char? x) (char->integer x) (exact (truncate x))))
(define (jolt-double x) (if (char? x) (exact->inexact (char->integer x)) (exact->inexact x)))
;; a numeric type outside Chez's tower converts through this hook (bigdec).
(define (jolt-double-slow x) (jolt-num-cast-throw x))
(define (jolt-double x)
(cond ((char? x) (exact->inexact (char->integer x)))
((number? x) (exact->inexact x))
(else (jolt-double-slow x))))
;; compare: 3-way, returns an EXACT integer (= JVM compare -> int).
(define (jolt-cmp3 x y) (cond ((< x y) -1) ((> x y) 1) (else 0)))
@ -134,7 +178,11 @@
((jolt-nil? b) 1)
((and (number? a) (number? b)) (jolt-cmp3 a b))
((and (string? a) (string? b)) (jolt-strcmp a b))
((and (keyword? a) (keyword? b)) (jolt-strcmp (jolt-kw->string a) (jolt-kw->string b)))
;; keywords order like symbols: a nil namespace sorts before any namespace,
;; then by namespace, then by name (Keyword.compareTo -> Symbol.compareTo)
((and (keyword? a) (keyword? b))
(let ((r (jolt-strcmp (or (keyword-t-ns a) "") (or (keyword-t-ns b) ""))))
(if (= r 0) (jolt-strcmp (keyword-t-name a) (keyword-t-name b)) r)))
((and (jolt-symbol? a) (jolt-symbol? b))
(let ((r (jolt-strcmp (jolt-sym-ns-string a) (jolt-sym-ns-string b))))
(if (= r 0) (jolt-strcmp (symbol-t-name a) (symbol-t-name b)) r)))
@ -157,16 +205,84 @@
(def-var! "clojure.core" "keyword" jolt-keyword)
(def-var! "clojure.core" "symbol" jolt-symbol-new)
(def-var! "clojure.core" "gensym" jolt-gensym)
(def-var! "clojure.core" "int" jolt-int)
;; char: coerce a code point (jolt's all-flonum number) to a Chez char; pass a
;; char through. Inverse of int on chars. The cross-compiled emitter's
;; chez-str-lit needs it for printable-ASCII escaping.
(define (jolt-char x) (if (char? x) x (integer->char (exact (round x)))))
;; --- checked narrow casts (RT.byteCast/shortCast/intCast/longCast/charCast) --
;; One helper carries the JVM ranges: truncate toward zero, then range-check.
;; NaN casts to 0 (Java (long)NaN); an out-of-range value (including a float
;; infinity) is IllegalArgumentException "Value out of range for <type>: x".
;; A non-numeric operand is the usual ClassCastException. Numeric types outside
;; Chez's tower truncate through a hook the shim extends (BigDecimal).
(define (jolt-cast-range-throw name x)
(jolt-throw (jolt-host-throwable
"java.lang.IllegalArgumentException"
(string-append "Value out of range for " name ": " (jolt-str x)))))
(define (jolt-cast-truncate-slow x) (jolt-num-cast-throw x))
(define (jolt-checked-cast name lo hi x)
(let ((n (cond ((char? x) (char->integer x))
((and (number? x) (exact? x)) (truncate x))
;; a double range-checks ITSELF (before truncation): (byte
;; 127.000001) throws, (byte 1.1) is 1; NaN casts to 0; an
;; infinity always fails the compare.
((flonum? x) (cond ((nan? x) 0)
((or (< x lo) (> x hi)) (+ hi 1))
(else (exact (truncate x)))))
(else (jolt-cast-truncate-slow x)))))
(if (and (>= n lo) (<= n hi)) n (jolt-cast-range-throw name x))))
(define (jolt-byte-cast x) (jolt-checked-cast "byte" -128 127 x))
(define (jolt-short-cast x) (jolt-checked-cast "short" -32768 32767 x))
(define (jolt-int-cast x) (jolt-checked-cast "int" -2147483648 2147483647 x))
(define (jolt-long-cast x) (jolt-checked-cast "long" -9223372036854775808 9223372036854775807 x))
(def-var! "clojure.core" "int" jolt-int-cast)
(def-var! "clojure.core" "long" jolt-long-cast)
(def-var! "clojure.core" "byte" jolt-byte-cast)
(def-var! "clojure.core" "short" jolt-short-cast)
;; char: pass a char through; a code point must be in [0, 0xFFFF] (charCast).
(define (jolt-char x)
(if (char? x) x (integer->char (jolt-checked-cast "char" 0 65535 x))))
(def-var! "clojure.core" "char" jolt-char)
;; long: same truncation as int in jolt's all-flonum model (seed core-long =
;; math/trunc; char -> code point). Distinct cell so (long ...) resolves.
(def-var! "clojure.core" "long" jolt-int)
;; unchecked-long: truncate + wrap to 64 bits (RT.uncheckedLongCast — a float
;; infinity saturates, NaN is 0). unchecked-int wraps and sign-folds to 32.
(define (jolt-cast-saturate n lo hi) (cond ((< n lo) lo) ((> n hi) hi) (else n)))
(define (jolt-unchecked-long x)
(cond ((char? x) (char->integer x))
;; an exact integer wraps (long narrowing); a double SATURATES (Java's
;; double->long conversion clamps at the bounds, NaN is 0).
((and (number? x) (exact? x)) (jolt-wrap64 (truncate x)))
((flonum? x) (if (nan? x) 0
(jolt-cast-saturate (if (infinite? x) (if (> x 0.0) unc-2^63 (- unc-2^63)) (exact (truncate x)))
-9223372036854775808 9223372036854775807)))
(else (jolt-wrap64 (jolt-cast-truncate-slow x)))))
(define (jolt-unchecked-int x)
(if (flonum? x)
;; double->int clamps like Java
(if (nan? x) 0
(jolt-cast-saturate (if (infinite? x) (if (> x 0.0) #x80000000 (- #x80000000)) (exact (truncate x)))
-2147483648 2147483647))
(let ((i (bitwise-and (jolt-unchecked-long x) #xffffffff)))
(if (>= i #x80000000) (- i #x100000000) i))))
(def-var! "clojure.core" "unchecked-long" jolt-unchecked-long)
(def-var! "clojure.core" "unchecked-int" jolt-unchecked-int)
(def-var! "clojure.core" "double" jolt-double)
;; float: Chez has no single-float type, so float coerces to a flonum like double.
(def-var! "clojure.core" "float" jolt-double)
;; float: Chez has no single-float type, so the value stays a flonum — but the
;; cast range-checks against Float/MAX_VALUE like RT.floatCast (an infinity is
;; out of range; NaN passes).
(define fl-float-max 3.4028234663852886e38)
(define (jolt-float x)
(let ((d (jolt-double x)))
(if (and (flonum? d) (not (nan? d))
(or (< d (- fl-float-max)) (> d fl-float-max)))
(jolt-cast-range-throw "float" x)
d)))
(def-var! "clojure.core" "float" jolt-float)
;; numerator/denominator: jolt ratios are Chez exact rationals; a non-ratio is
;; the JVM's Ratio cast failure.
(define (jolt-ratio-part name f)
(lambda (x)
(if (and (number? x) (exact? x) (rational? x) (not (integer? x)))
(f x)
(jolt-throw (jolt-host-throwable
"java.lang.ClassCastException"
(string-append "class " (guard (e (#t "?")) (jolt-class-name x))
" cannot be cast to class clojure.lang.Ratio"))))))
(def-var! "clojure.core" "numerator" (jolt-ratio-part "numerator" numerator))
(def-var! "clojure.core" "denominator" (jolt-ratio-part "denominator" denominator))
(def-var! "clojure.core" "compare" jolt-compare)

120
host/chez/cts.sh Executable file
View file

@ -0,0 +1,120 @@
#!/bin/bash
# clojure-test-suite gate: run the vendored jank-lang/clojure-test-suite
# (vendor/clojure-test-suite) against joltc, one process per test namespace (a
# hang or crash is contained), and compare per-namespace fail/error counts
# against the checked-in baseline test/chez/cts-known-failures.txt.
#
# The comparison is exact, like certify's allowlist: a namespace doing WORSE
# than the baseline fails the gate (regression), and one doing BETTER also
# fails (stale baseline — update the file in the same change that improved it).
#
# JOLT_CTS_JOBS=N parallel workers (default 4)
# JOLT_CTS_TIMEOUT=SECS per-namespace timeout (default 120)
# JOLT_CTS_WRITE_BASELINE=1 regenerate the baseline file instead of gating
# JOLT_CTS_NS=ns1,ns2 run only these namespaces, verbose, no gating
set -u
root="$(CDPATH= cd -- "$(dirname -- "$0")/../.." && pwd)"
cd "$root"
suite="vendor/clojure-test-suite/test"
baseline="test/chez/cts-known-failures.txt"
app="$root/test/chez/cts-app"
jobs="${JOLT_CTS_JOBS:-4}"
tmo="${JOLT_CTS_TIMEOUT:-120}"
if [ ! -d "$suite/clojure" ]; then
echo "cts: skipped (git submodule update --init vendor/clojure-test-suite)"
exit 0
fi
work="$(mktemp -d)"
trap 'rm -rf "$work"' EXIT
# test namespaces from the .cljc files (portability is a helper, not a test ns)
find "$suite" -name '*.cljc' | sed "s|^$suite/||;s|\.cljc$||;s|/|.|g;s|_|-|g" \
| grep -v '\.portability$' | sort > "$work/nses"
if [ -n "${JOLT_CTS_NS:-}" ]; then
echo "${JOLT_CTS_NS}" | tr ',' '\n' > "$work/nses"
fi
# round-robin the namespaces over N sequential workers; each worker appends
# "ns pass fail error" lines (HUNG/CRASH in the pass column) to its own file.
awk -v j="$jobs" '{print > ("'"$work"'/chunk." (NR % j))}' "$work/nses"
run_chunk() {
chunk="$1"; out="$2"
while IFS= read -r ns; do
res=$(JOLT_PWD="$app" perl -e "alarm $tmo; exec @ARGV" -- "$root/bin/joltc" -M:cts "$ns" 2>&1 </dev/null)
rc=$?
line=$(echo "$res" | grep '^CTS-RESULT' | head -1)
if [ -n "$line" ]; then
echo "$line" | awk '{print $2, $3, $4, $5}' >> "$out"
if [ -n "${JOLT_CTS_NS:-}" ]; then
echo "$res" | grep -E 'FAIL:|ERROR:|LOAD:' | sed 's/^/ /' >> "$out"
fi
elif [ $rc -ge 128 ]; then
echo "$ns HUNG 0 0" >> "$out"
else
echo "$ns CRASH 0 0" >> "$out"
fi
done < "$chunk"
}
for c in "$work"/chunk.*; do
run_chunk "$c" "$c.res" &
done
wait
cat "$work"/chunk.*.res 2>/dev/null | sort > "$work/results"
if [ -n "${JOLT_CTS_NS:-}" ]; then
cat "$work/results"
exit 0
fi
summary=$(awk '$2!="HUNG" && $2!="CRASH" {p+=$2; f+=$3; e+=$4; c++}
$2=="HUNG" {h++} $2=="CRASH" {x++}
END {printf "%d namespaces: pass %d, fail %d, error %d, hung %d, crash %d",
c+h+x, p, f, e, h, x}' "$work/results")
if [ "${JOLT_CTS_WRITE_BASELINE:-0}" = "1" ]; then
{
echo "# clojure-test-suite known failures: <namespace> <fail> <error>"
echo "# The gate fails on any per-namespace change, worse OR better; regenerate"
echo "# with: JOLT_CTS_WRITE_BASELINE=1 host/chez/cts.sh"
awk '$2=="HUNG" || $2=="CRASH" {print $1, $2, $2; next}
$3 != 0 || $4 != 0 {print $1, $3, $4}' "$work/results"
} > "$baseline"
echo "cts: $summary"
echo "cts: baseline written to $baseline ($(grep -cv '^#' "$baseline") namespaces)"
exit 0
fi
if [ ! -f "$baseline" ]; then
echo "cts: FAIL — no baseline; run JOLT_CTS_WRITE_BASELINE=1 host/chez/cts.sh"
exit 1
fi
status=0
while read -r ns p f e; do
case "$p" in HUNG|CRASH) f="$p"; e="$p" ;; esac
bl=$(grep -v '^#' "$baseline" | awk -v n="$ns" '$1==n {print $2, $3; exit}')
if [ -n "$bl" ]; then bf="${bl%% *}"; be="${bl##* }"; else bf=0; be=0; fi
if [ "$f" = "$bf" ] && [ "$e" = "$be" ]; then
continue
elif [ "$f" = "HUNG" ] || [ "$f" = "CRASH" ] \
|| { [ "$bf" != "HUNG" ] && [ "$bf" != "CRASH" ] \
&& { [ "$f" -gt "$bf" ] || [ "$e" -gt "$be" ]; }; }; then
echo "cts: NEW regression in $ns — fail $f error $e (baseline $bf $be)"
status=1
else
echo "cts: STALE baseline for $ns — now fail $f error $e (baseline $bf $be); update $baseline"
status=1
fi
done < "$work/results"
# a baseline entry whose namespace no longer reports is stale too
while read -r ns bf be; do
grep -q "^$ns " "$work/results" || { echo "cts: STALE baseline entry $ns (namespace gone)"; status=1; }
done < <(grep -v '^#' "$baseline")
echo "cts: $summary"
if [ $status -eq 0 ]; then echo "cts: passed (matches baseline)"; else echo "cts: FAILED"; fi
exit $status

View file

@ -90,7 +90,10 @@
;; str re-serializes the read form (compiled identically; comments/whitespace are
;; irrelevant).
(define (dce-blob-records path)
(call-with-input-file path
;; bld-source-string (build.ss) reads the embedded copy when running from a
;; self-contained joltc, else the file on disk — so tree-shake works with no
;; jolt checkout present. Forward ref: build.ss loads after this file.
(call-with-port (open-input-string (bld-source-string path))
(lambda (p)
(let loop ((acc '()))
(let ((form (read p)))

View file

@ -77,14 +77,23 @@
(let ((p (dyn-find-binding v)))
(if p
(begin (set-cdr! p val) val)
(begin (var-cell-root-set! v val) (var-cell-defined?-set! v #t) val)))
;; a ROOT change is Var.bindRoot: validate, set, notify watches
;; (a thread-binding set does not notify, like the JVM).
(let ((old (var-cell-root v)))
(iref-validate v val)
(var-cell-root-set! v val) (var-cell-defined?-set! v #t)
(iref-notify v old val)
val)))
(error #f "var-set: not a var" v)))
;; alter-var-root: atomically apply f to the current root plus args.
(define (jolt-alter-var-root v f . args)
(let ((new (apply jolt-invoke f (var-cell-root v) args)))
(let* ((old (var-cell-root v))
(new (apply jolt-invoke f old args)))
(iref-validate v new)
(var-cell-root-set! v new)
(var-cell-defined?-set! v #t)
(iref-notify v old new)
new))
;; __local-var: a fresh free-standing var cell (not interned). with-local-vars
@ -117,6 +126,16 @@
((eq? cell star-ns-cell) (intern-ns! (chez-current-ns)))
(else (var-cell-root cell)))))))
;; var-deref's read on an ALREADY-RESOLVED cell — what compiled code emits when it
;; caches the cell at a reference site. Binding stack first, then *ns* thread-local,
;; else the raw root. Lenient on an unbound root (returns the sentinel), matching
;; var-deref — NOT the strict jolt-var-get, which throws "Unbound var".
(define (var-cell-deref cell)
(let ((bv (dyn-binding-value cell)))
(cond ((not (eq? bv dyn-no-binding)) bv)
((eq? cell star-ns-cell) (intern-ns! (chez-current-ns)))
(else (var-cell-root cell)))))
;; jolt-var-get (vars.ss): the var-get fn + deref/@ on a cell. Stack first, then
;; the original (which errors on an unbound root, matching Clojure).
(define %dyn-var-get jolt-var-get)

View file

@ -28,3 +28,43 @@
;; *print-meta* — when true, pr prints metadata with a ^ prefix; default false.
(def-var! "clojure.core" "*print-meta*" #f)
;; *print-length* / *print-level* — collection print limits, honored by both
;; printers (rt.ss jolt-pr-str + printing.ss jolt-pr-readable). nil = unlimited
;; (the default); a number truncates elements / collapses depth to "#".
;; *print-length* limits a lazy/infinite seq before realizing it.
(def-var! "clojure.core" "*print-length*" jolt-nil)
(def-var! "clojure.core" "*print-level*" jolt-nil)
;; *default-data-reader-fn* — a (fn [tag value]) the reader consults for an
;; unregistered #tag before raising; nil = no default handler.
(def-var! "clojure.core" "*default-data-reader-fn*" jolt-nil)
;; Portable clojure.core dynamic vars whose DEFAULT already matches jolt's
;; behaviour, so exposing them is sound (resolve/binding work, reads return the
;; right value) — not a silent divergence.
;;
;; *read-eval* — gates #=() read-eval. jolt's reader has no #=, so it reads true
;; (no eval-on-read happens regardless); a lib can (binding [*read-eval* false] …).
(def-var! "clojure.core" "*read-eval*" #t)
;; *print-dup* — gates print-dup (a multimethod that exists); default false.
(def-var! "clojure.core" "*print-dup*" #f)
;; *print-namespace-maps* — jolt never prints the #:ns{…} map shorthand, so the
;; var reads false (accurate); settable for code that toggles it.
(def-var! "clojure.core" "*print-namespace-maps*" #f)
;; *flush-on-newline* — jolt flushes line output; default true.
(def-var! "clojure.core" "*flush-on-newline*" #t)
;; *compile-files* — jolt has no separate compile phase that emits .class files.
(def-var! "clojure.core" "*compile-files*" #f)
;; *math-context* — BigDecimal rounding context; nil = unlimited, jolt's default.
(def-var! "clojure.core" "*math-context*" jolt-nil)
;; *command-line-args* — the args after the script/-main; nil outside a -m run.
(def-var! "clojure.core" "*command-line-args*" jolt-nil)
;; *file* — the source file being loaded; "NO_SOURCE_PATH" when none, like the JVM.
(def-var! "clojure.core" "*file*" "NO_SOURCE_PATH")
;; REPL result/exception history. Bound by the REPL after each evaluation; nil
;; outside a REPL, which is what reading them returns here.
(def-var! "clojure.core" "*1" jolt-nil)
(def-var! "clojure.core" "*2" jolt-nil)
(def-var! "clojure.core" "*3" jolt-nil)
(def-var! "clojure.core" "*e" jolt-nil)

View file

@ -41,6 +41,15 @@
;; top-level entry: in direct-link mode it binds jv$<fqn> for a top-level def; off
;; that mode (the minter, runtime eval) it is exactly emit, so output is unchanged.
(define jolt-ce-emit-top (var-deref "jolt.backend-scheme" "emit-top-form"))
;; Seed mint and AOT build must stay byte-deterministic, so emit the image with var
;; cell-caching OFF (compile-eval.ss turned it on for runtime eval; this file loads
;; after it). Guarded for the first re-mint pass off an older seed.
(let ((scv (var-deref "jolt.backend-scheme" "set-var-cache!")))
(when (procedure? scv) (scv #f)))
;; Tail-frame tracing off for the mint + `jolt build`: the seed must stay a
;; byte-fixpoint, and a built app should carry no per-call trace overhead.
(let ((stf (var-deref "jolt.backend-scheme" "set-trace-frames!")))
(when (procedure? stf) (stf #f)))
(define (ei-compile-form ctx f optimize?)
(let ((ir (jolt-ce-analyze ctx f)))
(jolt-ce-emit-top (if optimize? (jolt-ce-run-passes ir ctx) ir))))
@ -58,15 +67,23 @@
;; the seed minter (ei-emit-ns: optimize? #f, guard? #t — tolerant, skips a form
;; that fails to emit) and `jolt build` (bld-emit-ns: optimize? #t, guard? #f —
;; strict, a failing form errors the build).
;; A per-form transform applied to each read form before emit — the build sets it
;; to the data-reader rewrite (loader.ss ldr-apply-readers) so a registered #tag
;; literal compiles in a `jolt build` the same as it does in an interpreted load.
;; #f (the default, and during the seed mint where loader.ss isn't loaded) is no
;; transform, so emit-image.ss carries no loader dependency.
(define ei-emit-form-hook (make-parameter #f))
(define (ei-emit-ns* ns-name src optimize? guard?)
;; set the ns before reading so ::kw auto-resolves against this ns (the runtime
;; loader reads form-by-form after the ns form sets it; the cross-compile reads
;; all forms up front, so set it here).
(set-chez-ns! ns-name)
(let loop ((forms (ei-read-all src)) (acc '()))
(let ((hook (ei-emit-form-hook)))
(let loop ((forms (ei-read-all src)) (acc '()))
(if (null? forms)
(reverse acc)
(let ((f (car forms)))
(let ((f (let ((f0 (car forms))) (if hook (hook f0) f0))))
(ce-scan-requires! f ns-name)
(cond
((ei-ns-form? f) (loop (cdr forms) acc))
@ -84,7 +101,7 @@
(ei-compile-form (make-analyze-ctx ns-name) f optimize?))))
(loop (cdr forms)
(if (and guard? (not scm)) acc
(cons (if guard? (string-append "(guard (e (#t #f))\n " scm ")") scm) acc))))))))))
(cons (if guard? (string-append "(guard (e (#t #f))\n " scm ")") scm) acc)))))))))))
(define (ei-emit-ns ns-name src) (ei-emit-ns* ns-name src #f #t))

View file

@ -46,7 +46,9 @@
;; ANY non-empty seq is a list form for analysis (a macro/eval form built via
;; concat/map/cons is a lazy cseq with list?=#f, but evaluating it still means
;; calling its head) — not just reader-built lists.
(define (hc-list? x) (or (empty-list-t? x) (cseq? x)))
;; a lazy seq is a list form too: a macro that builds its expansion with map/for
;; (now a LazySeq, not an eager cseq) and splices it must still analyze.
(define (hc-list? x) (or (empty-list-t? x) (cseq? x) (jolt-lazyseq? x)))
(define (hc-vec? x) (pvec? x))
(define (hc-map? x) (and (pmap? x) (jolt-nil? (jolt-get x hc-kw-jolt-type))))
;; A set form is the reader's tagged map {:jolt/type :jolt/set :value <pvec>} OR a
@ -64,7 +66,7 @@
(and (pmap? x)
(eq? (jolt-get x hc-kw-jolt-type) hc-kw-jolt-tagged)
(eq? (jolt-get x hc-kw-tag) tag)))
(define (hc-regex? x) (hc-tagged-of x hc-kw-regex))
(define (hc-regex? x) (regex-t? x)) ; #"..." reads as a regex VALUE now
(define (hc-inst? x) (hc-tagged-of x hc-kw-inst))
(define (hc-uuid? x) (hc-tagged-of x hc-kw-uuid))
(define (hc-bigdec? x) (hc-tagged-of x hc-kw-bigdec))
@ -74,6 +76,17 @@
;; reconstruct it by name at the call site.
(define (hc-ns-value? x) (jns? x))
(define (hc-ns-value-name x) (jns-name x))
;; a live Var value spliced into a form (a macro that does `(~v …)` with v a
;; resolved var) — the analyzer turns it into a :the-var reference by ns+name.
(define (hc-var-value? x) (var-cell? x))
(define (hc-var-value-ns x) (var-cell-ns x))
(define (hc-var-value-name x) (var-cell-name x))
;; *unchecked-math* read at compile time: when truthy (a file's (set!
;; *unchecked-math* …)), the analyzer rewrites +/-/*/inc/dec to their wrapping
;; unchecked-* forms for the rest of that file, like the JVM.
(define (hc-unchecked-math?)
(jolt-truthy? (guard (e (#t #f)) (var-deref "clojure.core" "*unchecked-math*"))))
;; --- form accessors ---------------------------------------------------------
(define (hc-char-code x) (char->integer x)) ; native Chez char -> codepoint
@ -95,7 +108,7 @@
;; list items -> jolt vector (pvec); the analyzer mapv's over the result.
(define (hc-elements x)
(cond ((empty-list-t? x) empty-pvec)
((cseq? x) (make-pvec (list->vector (seq->list x))))
((or (cseq? x) (jolt-lazyseq? x)) (make-pvec (list->vector (seq->list x))))
(else empty-pvec)))
(define (hc-vec-items x) x) ; already a pvec
(define (hc-set-items x)
@ -115,12 +128,26 @@
(seq->list (jolt-seq (jolt-keys x))))) (acc '()))
(if (null? ks) (apply jolt-vector (reverse acc))
(loop (cdr ks) (cons (jolt-vector (car ks) (jolt-get x (car ks))) acc)))))))
(define (hc-regex-source x) (jolt-get x hc-kw-form))
(define (hc-regex-source x) (regex-t-source x))
(define (hc-inst-source x) (jolt-get x hc-kw-form))
(define (hc-uuid-source x) (jolt-get x hc-kw-form))
;; The Chez reader does not record source offsets yet.
(define (hc-form-position x) jolt-nil)
;; Source position for a list form: the reader stamps :line/:column (+ :file when
;; compiling a file) into the form's metadata. Return a clean {:line :column
;; :file?} map, or nil for a synthetic/macro-built form that carries none.
(define hc-kw-line (keyword #f "line"))
(define hc-kw-column (keyword #f "column"))
(define hc-kw-file (keyword #f "file"))
(define (hc-form-position x)
(let ((m (jolt-meta x)))
(if (and (pmap? m) (not (jolt-nil? (jolt-get m hc-kw-line))))
(let ((line (jolt-get m hc-kw-line))
(col (jolt-get m hc-kw-column))
(file (jolt-get m hc-kw-file)))
(if (jolt-nil? file)
(jolt-hash-map hc-kw-line line hc-kw-column col)
(jolt-hash-map hc-kw-line line hc-kw-column col hc-kw-file file)))
jolt-nil)))
;; --- special forms ----------------------------------------------------------
;; Mirrors host_iface special-names + interop-head? — forms the analyzer marks
@ -157,7 +184,12 @@
;; a qualified ns may be a require :as alias (s/split -> clojure.string/split)
(let ((target (or (chez-resolve-alias (chez-actx-cns ctx) qualified) qualified)))
(var-cell-lookup target nm))
(or (var-cell-lookup (chez-actx-cns ctx) nm)
(or (let ((c (var-cell-lookup (chez-actx-cns ctx) nm)))
;; an undefined forward-intern must not shadow a real referred
;; or clojure.core var — e.g. the compiler ns referencing `set`,
;; which late-binds (interns `jolt.backend-scheme/set` undefined)
;; and would otherwise hide clojure.core/set on the mint fixpoint.
(and c (var-cell-defined? c) c))
;; a :refer'd name resolves to its source ns
(let ((ref (chez-resolve-refer (chez-actx-cns ctx) nm)))
(and ref (var-cell-lookup ref nm)))
@ -170,12 +202,54 @@
;; of the list), and the analyzer re-analyzes the returned form.
(define (hc-macro? ctx sym)
(macro-var? (hc-resolve-cell ctx sym)))
(define (hc-expand-1 ctx form)
;; Clojure parity: a macro expansion inherits the call form's source position, so
;; errors/traces in macro-generated code point at the macro call site. Carry it
;; onto the top of a LIST expansion (code) that has none of its own — merged under
;; any meta the macro set, leaving collection literals (runtime data) alone. The
;; recursion through analyze re-expands inner macros, so each level's top form
;; picks up the position the same way (as the reference compiler does).
(define (hc-propagate-pos src dst)
(if (and (cseq? dst) (cseq-list? dst))
(let ((sp (hc-form-position src))
(dm (jolt-meta dst)))
(if (and (pmap? sp)
(or (jolt-nil? dm) (jolt-nil? (jolt-get dm hc-kw-line))))
(jolt-with-meta dst
(if (pmap? dm)
(pmap-fold-fwd sp (lambda (k v acc) (jolt-assoc1 acc k v)) dm)
sp))
dst))
dst))
;; A set literal reads as the tagged set-form {:jolt/type :jolt/set :value [...]}
;; for the analyzer, but a macro must see a real set value (Clojure parity, so
;; (set? arg) / seq / conj work — hiccup's compiler does this). Convert a set-form
;; argument to a set; elements stay as read (a deeply-nested set literal inside
;; another form is rarer and left for the analyzer).
(define (hc-macro-arg x)
(if (rdr-set-form? x)
(let ((items (jolt-get x rdr-kw-value)))
(let loop ((i 0) (s empty-pset))
(if (fx>=? i (pvec-count items)) s
(loop (fx+ i 1) (pset-conj s (pvec-nth-d items i jolt-nil))))))
x))
;; &form and &env are bound (as dynamic vars) around the expander call, so a
;; macro body can read the call form / lexical env without changing the calling
;; convention. The analyzer passes amp-env (the in-scope locals); macroexpand-1
;; has none, so it defaults to {}.
(define hc-amp-form-cell (declare-var! "clojure.core" "&form"))
(define hc-amp-env-cell (declare-var! "clojure.core" "&env"))
(define (hc-expand-1 ctx form . maybe-env)
(let* ((items (seq->list form))
(head (car items))
(args (cdr items))
(expander (var-cell-root (hc-resolve-cell ctx head))))
(apply jolt-invoke expander args)))
(args (map hc-macro-arg (cdr items)))
(expander (var-cell-root (hc-resolve-cell ctx head)))
(amp-env (if (pair? maybe-env) (car maybe-env) (jolt-hash-map))))
(dynamic-wind
(lambda () (jolt-push-thread-bindings
(jolt-hash-map hc-amp-form-cell form hc-amp-env-cell amp-env)))
(lambda () (hc-propagate-pos form (apply jolt-invoke expander args)))
(lambda () (jolt-pop-thread-bindings)))))
;; Classify a global (non-local) symbol reference against the var registry:
;; {:kind :var :ns NS :name NAME} — a defined var (compile ns / clojure.core)
@ -188,9 +262,10 @@
;; read from its meta. Lets jolt.passes.numeric type a call to it.
(define (hc-cell-num-ret cell)
(let ((m (and cell (hashtable-ref var-meta-table cell #f))))
(and m (let ((t (jolt-get m hc-kw-tag)))
(cond ((equal? t "double") hc-kw-double)
((equal? t "long") hc-kw-long)
(and m (let* ((t (jolt-get m hc-kw-tag)) ; ^double/^long is a symbol; ^"double" a string
(s (cond ((symbol-t? t) (symbol-t-name t)) ((string? t) t) (else #f))))
(cond ((equal? s "double") hc-kw-double)
((equal? s "long") hc-kw-long)
(else #f))))))
;; A slash-free dotted symbol whose final segment is Capitalized is a class
@ -215,9 +290,17 @@
hc-kw-name (var-cell-name cell)))
(nr (hc-cell-num-ret cell)))
(if nr (jolt-assoc base hc-kw-num-ret nr) base))
(if (hc-fq-class-name? nm)
(jolt-hash-map hc-kw-kind hc-kw-class hc-kw-name nm)
(jolt-hash-map hc-kw-kind hc-kw-unresolved hc-kw-name nm)))))
(cond
;; java.util.Map / clojure.lang.Named — a dotted class name.
((hc-fq-class-name? nm) (jolt-hash-map hc-kw-kind hc-kw-class hc-kw-name nm))
;; a bare Capitalized name that names a registered host class — an
;; imported short name (`(:import [java.time ZonedDateTime])` then
;; `(. ZonedDateTime parse s)`). Only when otherwise unresolved, so a
;; same-named var still wins.
((and (fx>? (string-length nm) 0) (char-upper-case? (string-ref nm 0))
(hashtable-ref class-statics-tbl nm #f))
(jolt-hash-map hc-kw-kind hc-kw-class hc-kw-name nm))
(else (jolt-hash-map hc-kw-kind hc-kw-unresolved hc-kw-name nm))))))
(define (hc-intern! ctx ns-name nm) (declare-var! ns-name nm) jolt-nil)
@ -240,10 +323,19 @@
(define (hc-sym nm) (jolt-symbol #f nm))
;; is `x` a non-empty list FORM whose head is the unqualified symbol `nm`?
;; Detect a (unquote …) / (unquote-splicing …) form in a syntax-quote template.
;; Any seq counts, not just a proper list: a macro that builds the template with
;; map/for (e.g. deftype's rewrite-set) yields a LAZY seq, and its ~unquotes must
;; still be recognized.
;; head symbol matches name nm, bare or clojure.core-qualified — the reader
;; produces clojure.core/unquote(-splicing) for ~/~@ (JVM parity), and this is
;; only used to spot those heads in syntax-quote templates.
(define (hc-head-is? x nm)
(and (cseq? x) (cseq-list? x)
(and (cseq? x)
(let ((h (seq-first x)))
(and (symbol-t? h) (jolt-nil? (hc-sym-ns h)) (string=? (symbol-t-name h) nm)))))
(and (symbol-t? h) (string=? (symbol-t-name h) nm)
(let ((ns (hc-sym-ns h)))
(or (jolt-nil? ns) (and (string? ns) (string=? ns "clojure.core"))))))))
(define (hc-second x) (seq-first (jolt-seq (seq-more x))))
(define (hc-sq-symbol ctx form gsmap)
@ -258,6 +350,20 @@
(hashtable-set! gsmap nm g) g)))
((hc-special-symbol? nm) form) ; special form: leave bare
((hc-interop-head? nm) form) ; interop (.method / Class. / .-field): bare
;; a fully-qualified class name (java.util.Map, clojure.lang.ILookup) is
;; a class token, not a var to namespace-qualify — leave it bare, as
;; Clojure's syntax-quote resolves it to the class.
((hc-fq-class-name? nm) form)
;; the compile ns's OWN def shadows clojure.core — a name the ns
;; excluded and redefined (e.g. core.logic's `==` after
;; (:refer-clojure :exclude [==])), or any ns-local redefinition.
;; Referred names live in a separate table, so this only hits a real
;; local intern, matching how the analyzer resolves the bare symbol.
((var-cell-lookup (chez-actx-cns ctx) nm) (jolt-symbol (chez-actx-cns ctx) nm))
;; a name the compile ns excluded from clojure.core (:refer-clojure
;; :exclude) is not clojure.core/nm even before the ns defines its own —
;; qualify to the compile ns, like Clojure (core.logic.fd's `==`).
((chez-core-excluded? (chez-actx-cns ctx) nm) (jolt-symbol (chez-actx-cns ctx) nm))
((var-cell-lookup "clojure.core" nm) (jolt-symbol "clojure.core" nm))
;; a name referred into the compile ns (:require :refer / :use :only)
;; qualifies to its SOURCE ns, not the compile ns — so a macro that
@ -311,9 +417,36 @@
(define (hc-syntax-quote-lower ctx inner)
(hc-sq-lower ctx inner (make-hashtable string-hash string=?)))
(define (hc-record-type? ctx name) #f)
(define (hc-record-ctor-key ctx name) jolt-nil)
(define (hc-record-shapes ctx) (jolt-hash-map))
;; a ^Type param hint: name is the tag (a symbol, sometimes a string). Resolve it
;; against the record registry (records.ss) so the inference seeds the param as
;; that record — the open-world / cross-ns path where no caller type is inferred.
(define (hc-record-tag-name name)
(cond ((symbol-t? name) (symbol-t-name name))
((string? name) name)
(else #f)))
(define (hc-record-type? ctx name)
(let ((nm (hc-record-tag-name name)))
(if (and nm (chez-find-ctor-key nm (chez-current-ns))) #t #f)))
(define (hc-record-ctor-key ctx name)
(let ((nm (hc-record-tag-name name)))
(or (and nm (chez-find-ctor-key nm (chez-current-ns))) jolt-nil)))
;; The fully-qualified deftype tag ("ns.Name") IFF `class` names a deftype DEFINED
;; in the ctx's compile ns — the analyzer qualifies a bare (Name. …) to it, so a
;; deftype doesn't shadow a same-named built-in host class in an unrelated ns
;; (rewrite-clj imports java.io.PushbackReader; tools.reader defines its own). Strict:
;; only this ns's own def (the preferred shape key) counts, not the global
;; simple-name fallback, so a ns that merely uses the built-in resolves nil.
(define (hc-deftype-ctor-class ctx class)
(let* ((nm (jolt-str-render-one class))
(cns (hc-current-ns ctx))
(key (string-append cns "/->" nm)))
(if (hashtable-ref chez-record-shapes-tbl key #f)
(string-append cns "." nm)
jolt-nil)))
;; record + protocol-method shapes for the inference, from the runtime registries
;; (records.ss) populated as deftype/defprotocol forms load.
(define (hc-record-shapes ctx) (chez-record-shapes-map))
(define (hc-protocol-methods ctx) (chez-protocol-methods-map))
;; Optimization gate. Off for ordinary runs (open world, redefinition); `jolt
;; build` flips it on during app emission for release/optimized modes (closed
;; world), turning on the inference + flatten + scalar-replace passes.
@ -361,6 +494,10 @@
(def-var! "jolt.host" "form-uuid?" hc-uuid?)
(def-var! "jolt.host" "form-ns-value?" hc-ns-value?)
(def-var! "jolt.host" "form-ns-value-name" hc-ns-value-name)
(def-var! "jolt.host" "form-var-value?" hc-var-value?)
(def-var! "jolt.host" "form-var-value-ns" hc-var-value-ns)
(def-var! "jolt.host" "form-var-value-name" hc-var-value-name)
(def-var! "jolt.host" "unchecked-math?" hc-unchecked-math?)
(def-var! "jolt.host" "form-bigdec?" hc-bigdec?)
(def-var! "jolt.host" "form-bigdec-source" hc-bigdec-source)
(def-var! "jolt.host" "form-elements" hc-elements)
@ -381,7 +518,9 @@
(def-var! "jolt.host" "form-syntax-quote-lower" hc-syntax-quote-lower)
(def-var! "jolt.host" "record-type?" hc-record-type?)
(def-var! "jolt.host" "record-ctor-key" hc-record-ctor-key)
(def-var! "jolt.host" "deftype-ctor-class" hc-deftype-ctor-class)
(def-var! "jolt.host" "record-shapes" hc-record-shapes)
(def-var! "jolt.host" "protocol-methods" hc-protocol-methods)
(def-var! "jolt.host" "inline-enabled?" hc-inline-enabled?)
(def-var! "jolt.host" "inline-ir" hc-inline-ir)
(def-var! "jolt.host" "stash-inline!" hc-stash-inline!))

View file

@ -113,7 +113,7 @@
(define %h-set? jolt-set?)
(set! jolt-set? (lambda (x) (or (htable-sorted-set? x) (%h-set? x))))
(def-var! "clojure.core" "set?" jolt-set?)
(def-var! "clojure.core" "coll?" (lambda (x) (or (htable-sorted? x) (jrec? x) (jolt-coll-pred? x))))
(def-var! "clojure.core" "coll?" (lambda (x) (or (htable-sorted? x) (jrec-collection? x) (jolt-coll-pred? x))))
;; --- equality / hash ---------------------------------------------------------
;; A sorted coll canonicalizes like its unordered counterpart:

View file

@ -1,17 +1,20 @@
;; async.ss — clojure.core.async on real OS threads for the Chez host.
;; async.ss — clojure.core.async channel primitives on real OS threads.
;;
;; A `go` block is an OS thread and a channel is a mutex+condition blocking
;; queue: <! / >! are the blocking <!! / >!! (they "park" by blocking the thread).
;; <! / >! work ANYWHERE — no CPS transform — because they are ordinary blocking
;; calls. Real parallelism, shared heap. Trade-off: one OS thread per go block
;; (fine for typical use, not for thousands of simultaneous go blocks).
;; A `go` block is an OS thread and a channel is a Chez mutex+condition blocking
;; queue: <! / >! are the blocking <!! / >!! (they "park" by blocking the thread),
;; and work ANYWHERE — no CPS transform, no go-only restriction. Real parallelism,
;; shared heap. This is a superset of the JVM model: it has no fixed go-block
;; thread pool, no MAX-QUEUE-SIZE on pending ops, and parking ops are legal outside
;; a go block. One OS thread per go block (fine for typical use).
;;
;; Channel: an unbuffered channel is a rendezvous (the putter blocks until its
;; value is taken); a buffered (chan n) put blocks only when full; dropping/sliding
;; buffers never block the putter. A transducer is applied on the put side.
;; buffers never block the putter. A transducer is applied on the put side; an
;; optional ex-handler catches a throw from the transducer step.
;;
;; The fns are def-var!'d into clojure.core.async; go/go-loop/thread are macros
;; (mark-macro!) expanding to go-spawn. Loaded after
;; This file provides the primitives; the higher-level dataflow API (mult, mix,
;; pub/sub, pipeline, map, merge, reduce, …) is a Clojure overlay over them.
;; go/go-loop/thread are macros (mark-macro!) expanding to go-spawn. Loaded after
;; concurrency.ss (reuses ms->duration). Requires a threaded Chez build.
;; --- buffers ----------------------------------------------------------------
@ -19,6 +22,8 @@
(define (jolt-async-buffer n) (make-async-buffer n 'fixed))
(define (jolt-async-dropping-buffer n) (make-async-buffer n 'dropping))
(define (jolt-async-sliding-buffer n) (make-async-buffer n 'sliding))
(define (jolt-async-unblocking-buffer? b)
(if (and (async-buffer? b) (memq (async-buffer-kind b) '(dropping sliding promise))) #t #f))
;; --- channels ---------------------------------------------------------------
;; items: an amortized-O(1) FIFO held as a mutable #(out in len) — `out` is the
@ -27,9 +32,12 @@
;; Each entry is (value . box); box is #f for a buffered value or a 1-slot vector
;; for an unbuffered rendezvous put (set #t when taken, waking the putter).
;; cap 0 + kind 'unbuffered = rendezvous; cap>0 with kind fixed/dropping/sliding.
;; takew counts threads parked in a blocking take (so a non-blocking offer! to an
;; unbuffered channel can tell a taker is waiting). xrf is the transducer reducing
;; fn (or #f); exh the ex-handler (or #f).
(define-record-type async-chan
(fields mu cv (mutable items) cap kind (mutable closed?) (mutable xrf))
(nongenerative async-chan-v1))
(fields mu cv (mutable items) cap kind (mutable closed?) (mutable xrf) (mutable takew) exh)
(nongenerative async-chan-v2))
(define (ac-qnew) (vector '() '() 0))
(define (ac-qlen ch) (vector-ref (async-chan-items ch) 2))
@ -73,17 +81,30 @@
((null? (cdr args)) (car args)) ; completion
(else (ac-buf-give! ch (cadr args)) (car args))))) ; step
(define (ac-make cap kind xrf) (make-async-chan (make-mutex) (make-condition) (ac-qnew) cap kind #f xrf))
;; run the transducer step (or completion) guarded by the channel's ex-handler:
;; if the xform throws and exh returns non-nil, that value is added to the buffer.
(define (ac-xrf-apply ch . v)
(let ((xrf (async-chan-xrf ch)) (exh (async-chan-exh ch)))
(guard (e (#t (if exh
(let ((else (jolt-invoke exh e)))
(unless (jolt-nil? else) (ac-buf-give! ch else))
(async-chan-xrf ch)) ; treat as non-reduced
(raise e))))
(apply jolt-invoke xrf ch v))))
;; (chan) | (chan n) | (chan buf) | (chan n|buf xform)
(define (ac-make cap kind xrf) (make-async-chan (make-mutex) (make-condition) (ac-qnew) cap kind #f xrf 0 #f))
(define (ac-make/exh cap kind exh) (make-async-chan (make-mutex) (make-condition) (ac-qnew) cap kind #f #f 0 exh))
;; (chan) | (chan n) | (chan buf) | (chan n|buf xform) | (chan n|buf xform exh)
(define (jolt-async-chan . args)
(let ((buf (if (pair? args) (car args) jolt-nil))
(xform (if (and (pair? args) (pair? (cdr args))) (cadr args) jolt-nil)))
(xform (if (and (pair? args) (pair? (cdr args))) (cadr args) jolt-nil))
(exh (if (and (pair? args) (pair? (cdr args)) (pair? (cddr args))) (caddr args) jolt-nil)))
(let-values (((cap kind)
(cond ((async-buffer? buf) (values (async-buffer-n buf) (async-buffer-kind buf)))
((and (number? buf) (> buf 0)) (values buf 'fixed))
(else (values 0 'unbuffered)))))
(let ((ch (ac-make cap kind #f)))
(let ((ch (ac-make/exh cap kind (if (jolt-nil? exh) #f exh))))
(unless (jolt-nil? xform)
(async-chan-xrf-set! ch (jolt-invoke xform (ac-make-add-rf ch))))
ch))))
@ -93,7 +114,7 @@
(define (ac-close! ch)
(unless (async-chan-closed? ch)
(async-chan-closed?-set! ch #t)
(when (async-chan-xrf ch) (guard (e (#t #f)) (jolt-invoke (async-chan-xrf ch) ch)))
(when (async-chan-xrf ch) (guard (e (#t #f)) (ac-xrf-apply ch)))
(condition-broadcast (async-chan-cv ch)))
jolt-nil)
(define (jolt-async-close! ch) (with-mutex (async-chan-mu ch) (ac-close! ch)))
@ -102,17 +123,22 @@
;; transducer the value is run through it (one put -> zero or more channel values);
;; a `reduced` result closes the channel.
(define (jolt-async-give ch v)
(when (jolt-nil? v) (jolt-throw (jolt-ex-info "Can't put nil on a channel" (jolt-hash-map))))
(when (jolt-nil? v) (jolt-throw (jolt-host-throwable "java.lang.IllegalArgumentException" "Can't put nil on a channel")))
(with-mutex (async-chan-mu ch)
(cond
((async-chan-closed? ch) #f)
((async-chan-xrf ch)
(let ((r (jolt-invoke (async-chan-xrf ch) ch v)))
(let ((r (ac-xrf-apply ch v)))
(when (jolt-reduced? r) (ac-close! ch))
#t))
(else
(case (async-chan-kind ch)
((dropping sliding) (ac-buf-give! ch v) #t)
;; a promise channel takes ONE value, delivered to every taker; further
;; puts are dropped. Never blocks.
((promise) (when (ac-qempty? ch)
(ac-qpush! ch (cons v #f)) (condition-broadcast (async-chan-cv ch)))
#t)
(else
(if (> (async-chan-cap ch) 0)
(let loop () ; buffered fixed: wait for room
@ -135,44 +161,75 @@
(condition-broadcast (async-chan-cv ch))
v))
;; peek the front value without removing it (promise channels keep their value).
(define (ac-peek ch)
(let ((q (async-chan-items ch)))
(ac-qfront! q)
(car (car (vector-ref q 0)))))
;; <! / <!! — take, blocking. Drains buffered values, then nil once closed + empty.
;; A promise channel PEEKS — its one value stays for every taker.
(define (jolt-async-take ch)
(with-mutex (async-chan-mu ch)
(let loop ()
(cond ((not (ac-qempty? ch)) (ac-take-head! ch))
(cond ((eq? (async-chan-kind ch) 'promise)
(cond ((not (ac-qempty? ch)) (ac-peek ch))
((async-chan-closed? ch) jolt-nil)
(else (ac-take-wait ch) (loop))))
((not (ac-qempty? ch)) (ac-take-head! ch))
((async-chan-closed? ch) jolt-nil)
(else (condition-wait (async-chan-cv ch) (async-chan-mu ch)) (loop))))))
(else (ac-take-wait ch) (loop))))))
;; non-blocking take for alts!: a value, jolt-nil (closed+empty), or ac-poll-empty.
;; park in a take, tracking the waiter count so a concurrent offer! to an
;; unbuffered channel can see that a taker is ready.
(define (ac-take-wait ch)
(async-chan-takew-set! ch (fx+ 1 (async-chan-takew ch)))
(condition-wait (async-chan-cv ch) (async-chan-mu ch))
(async-chan-takew-set! ch (fx- (async-chan-takew ch) 1)))
;; non-blocking take for alts!/poll!: a value, jolt-nil (closed+empty), or ac-poll-empty.
(define ac-poll-empty (list 'empty))
(define (ac-poll! ch)
(with-mutex (async-chan-mu ch)
(cond ((not (ac-qempty? ch)) (ac-take-head! ch))
(cond ((and (eq? (async-chan-kind ch) 'promise) (not (ac-qempty? ch))) (ac-peek ch))
((not (ac-qempty? ch)) (ac-take-head! ch))
((async-chan-closed? ch) jolt-nil)
(else ac-poll-empty))))
;; (alts! [ch ...]) — take from whichever channel is ready first; returns
;; [value channel] (value nil if that channel closed). Take-only: every port must
;; be a channel — put specs [ch val] and the :default option are not supported, so
;; reject them with a clear error instead of crashing inside ac-poll!.
;; Polls with a 1ms backoff — no cross-channel wait-set yet.
(define ac-1ms (make-time 'time-duration 1000000 0))
(define (jolt-async-alts chans)
(let ((cs (seq->list (jolt-seq chans))))
(for-each (lambda (c)
(unless (async-chan? c)
(jolt-throw (jolt-ex-info
"alts! supports channel ports only (put specs [ch val] and :default are not supported)"
(jolt-hash-map)))))
cs)
(let loop ()
(let try ((rest cs))
(if (null? rest)
(begin (sleep ac-1ms) (loop))
(let ((r (ac-poll! (car rest))))
(if (eq? r ac-poll-empty)
(try (cdr rest))
(jolt-vector r (car rest)))))))))
;; non-blocking give: 'ok (accepted), 'full (would block), or 'closed.
(define (ac-try-give! ch v)
(when (jolt-nil? v) (jolt-throw (jolt-host-throwable "java.lang.IllegalArgumentException" "Can't put nil on a channel")))
(with-mutex (async-chan-mu ch)
(cond
((async-chan-closed? ch) 'closed)
((async-chan-xrf ch) (let ((r (ac-xrf-apply ch v)))
(when (jolt-reduced? r) (ac-close! ch)) 'ok))
(else
(case (async-chan-kind ch)
((dropping sliding) (ac-buf-give! ch v) 'ok)
((promise) (when (ac-qempty? ch) (ac-qpush! ch (cons v #f))
(condition-broadcast (async-chan-cv ch))) 'ok)
(else
(cond
((> (async-chan-cap ch) 0)
(if (< (ac-qlen ch) (async-chan-cap ch))
(begin (ac-qpush! ch (cons v #f)) (condition-broadcast (async-chan-cv ch)) 'ok)
'full))
;; unbuffered: only immediate if a taker is parked to receive it.
((> (async-chan-takew ch) 0)
(let ((box (vector #f)))
(ac-qpush! ch (cons v box))
(condition-broadcast (async-chan-cv ch))
'ok))
(else 'full))))))))
;; offer! / poll! — never block. offer! returns #t/#f(closed) on completion, nil if
;; it would block; poll! returns a value, nil (closed+empty), or the ::none sentinel.
(define cca-none (keyword "clojure.core.async" "none"))
(define (jolt-async-offer! ch v)
(case (ac-try-give! ch v) ((ok) #t) ((closed) #f) (else jolt-nil)))
(define (jolt-async-poll! ch)
(let ((r (ac-poll! ch))) (if (eq? r ac-poll-empty) cca-none r)))
;; (timeout ms) — a channel that closes after ms milliseconds.
(define (jolt-async-timeout ms)
@ -180,17 +237,28 @@
(fork-thread (lambda () (sleep (ms->duration ms)) (jolt-async-close! w)))
w))
;; (put! ch v [cb]) / (take! ch cb) — async put/take on a thread, optional callback.
(define (jolt-async-put! ch v . cb)
(fork-thread (lambda ()
(let ((ok (jolt-async-give ch v)))
(when (and (pair? cb) (not (jolt-nil? (car cb)))) (jolt-invoke (car cb) ok)))))
jolt-nil)
(define (jolt-async-take! ch cb)
(fork-thread (lambda ()
(let ((v (jolt-async-take ch)))
(unless (jolt-nil? cb) (jolt-invoke cb v)))))
jolt-nil)
;; (put! ch v [cb [on-caller?]]) — async put, optional completion callback. If the
;; put completes immediately and on-caller? (default #t), the callback runs on the
;; calling thread; otherwise on another thread. Returns true unless already closed.
(define (jolt-async-put! ch v . rest)
(let* ((cb (if (pair? rest) (car rest) jolt-nil))
(on-caller? (if (and (pair? rest) (pair? (cdr rest))) (jolt-truthy? (cadr rest)) #t))
(call-cb (lambda (ok) (unless (jolt-nil? cb) (jolt-invoke cb ok)))))
(case (ac-try-give! ch v)
((ok) (if on-caller? (call-cb #t) (fork-thread (lambda () (call-cb #t)))) #t)
((closed) (if on-caller? (call-cb #f) (fork-thread (lambda () (call-cb #f)))) #f)
(else (fork-thread (lambda () (call-cb (jolt-async-give ch v)))) #t))))
;; (take! ch cb [on-caller?]) — async take. Same on-caller? rule as put!.
(define (jolt-async-take! ch cb . rest)
(let* ((on-caller? (if (pair? rest) (jolt-truthy? (car rest)) #t))
(call-cb (lambda (v) (unless (jolt-nil? cb) (jolt-invoke cb v))))
(r (ac-poll! ch)))
(cond
((eq? r ac-poll-empty) (fork-thread (lambda () (call-cb (jolt-async-take ch)))))
(on-caller? (call-cb r))
(else (fork-thread (lambda () (call-cb r)))))
jolt-nil))
;; (go-spawn thunk) — run thunk on a thread; return a buffered(1) channel that
;; conveys its value once then closes (a nil result just closes). Dynamic bindings
@ -224,18 +292,24 @@
;; --- install clojure.core.async ---------------------------------------------
(define (cca-def! name v) (def-var! "clojure.core.async" name v))
(cca-def! "chan" jolt-async-chan)
(cca-def! "promise-chan" (lambda args (ac-make 1 'promise #f)))
(cca-def! "chan?" async-chan?)
(cca-def! "buffer" jolt-async-buffer)
(cca-def! "dropping-buffer" jolt-async-dropping-buffer)
(cca-def! "sliding-buffer" jolt-async-sliding-buffer)
(cca-def! "__promise-buffer" (lambda () (make-async-buffer 1 'promise)))
(cca-def! "unblocking-buffer?" jolt-async-unblocking-buffer?)
(cca-def! "close!" jolt-async-close!)
(cca-def! "<!" jolt-async-take) (cca-def! "<!!" jolt-async-take)
(cca-def! ">!" jolt-async-give) (cca-def! ">!!" jolt-async-give)
(cca-def! "alts!" jolt-async-alts) (cca-def! "alts!!" jolt-async-alts)
(cca-def! "timeout" jolt-async-timeout)
(cca-def! "put!" jolt-async-put!)
(cca-def! "take!" jolt-async-take!)
(cca-def! "offer!" jolt-async-offer!)
(cca-def! "go-spawn" async-go-spawn)
;; non-blocking primitives the Clojure overlay's do-alts polls over.
(cca-def! "__poll!" jolt-async-poll!)
(cca-def! "__offer!" jolt-async-offer!)
(cca-def! "go" cca-go-macro) (mark-macro! "clojure.core.async" "go")
(cca-def! "go-loop" cca-go-loop-macro) (mark-macro! "clojure.core.async" "go-loop")
(cca-def! "thread" cca-thread-macro) (mark-macro! "clojure.core.async" "thread")

402
host/chez/java/bigdec.ss Normal file
View file

@ -0,0 +1,402 @@
;; BigDecimal. A jbigdec is {unscaled, scale} over Chez arbitrary-precision exact
;; integers; its value is unscaled * 10^-scale (1.5M = {15,1}, 1.00M = {100,2},
;; 3M = {3,0}). M-suffix literals read to a :bigdec form that the back end lowers
;; to jolt-bigdec-from-string; bigdec coerces a number/string. Equality is by
;; value (1.0M = 1.00M), str drops the M, pr keeps it, class is
;; java.math.BigDecimal.
;;
;; Arithmetic follows java.math.BigDecimal's scale rules: add/sub align to the
;; larger scale; multiply adds scales; divide gives the exact quotient at minimal
;; scale or throws ArithmeticException on a non-terminating expansion (a bound
;; *math-context* rounds instead). Clojure contagion: a bigdec mixed with an
;; integer or ratio stays a bigdec; a flonum operand wins (the result is a
;; double). jbd-add/-sub/-mul/-div, jbd-min/-max, the jbd-lt?/…/zero? helpers,
;; and jbd-quot/-rem are the shared engine. Two paths reach it, both leaving the
;; inlined fast path untouched:
;; - the seq.ss binary dispatch: every generic op (any position — (+ (bigdec x)
;; 1), (reduce + bigs), (quot 10.0 3M)) whose operand is outside Chez's tower
;; falls to the jolt-*-slow hooks extended below.
;; - static call position ((+ 1.5M 2.5M), (< a b), (zero? b)): jolt.passes.numeric
;; tags the invoke :num-kind :bigdec when every operand is statically a bigdec
;; (M literal or a let-bound copy, integer literals allowed), and the back end
;; lowers it directly to the jbd op.
(define-record-type jbigdec (fields unscaled scale) (nongenerative chez-jbigdec-v1))
(define (bd-index-char s ch)
(let loop ((i 0))
(cond ((>= i (string-length s)) #f)
((char=? (string-ref s i) ch) i)
(else (loop (+ i 1))))))
;; "1.50" -> {150,2}; "3" -> {3,0}; "-0.0" -> {0,1}; ".5" -> {5,1}.
(define (jolt-bigdec-from-string s)
(let* ((neg (and (> (string-length s) 0) (char=? (string-ref s 0) #\-)))
(sgn (and (> (string-length s) 0) (or neg (char=? (string-ref s 0) #\+))))
(s1 (if sgn (substring s 1 (string-length s)) s))
(sign (if neg -1 1))
(dot (bd-index-char s1 #\.)))
(if dot
(let* ((intp (substring s1 0 dot))
(fracp (substring s1 (+ dot 1) (string-length s1)))
(digs (string-append intp fracp))
(unscaled (if (= 0 (string-length digs)) 0 (string->number digs))))
(make-jbigdec (* sign unscaled) (string-length fracp)))
(make-jbigdec (* sign (string->number s1)) 0))))
;; bigdec coercion: a bigdec is itself; an exact integer keeps scale 0; a string
;; or any other number routes through its decimal text.
(define (jolt-bigdec x)
(cond
((jbigdec? x) x)
((and (number? x) (exact? x) (integer? x)) (make-jbigdec x 0))
((string? x) (jolt-bigdec-from-string x))
((number? x) (jolt-bigdec-from-string (jolt-num->string x)))
(else (error #f "bigdec: cannot coerce" x))))
;; value equality: unscaled_a * 10^scale_b == unscaled_b * 10^scale_a.
(define (jbigdec=? a b)
(= (* (jbigdec-unscaled a) (expt 10 (jbigdec-scale b)))
(* (jbigdec-unscaled b) (expt 10 (jbigdec-scale a)))))
;; render the decimal text (no M): insert the point `scale` digits from the right.
(define (jbigdec->string bd)
(let* ((u (jbigdec-unscaled bd)) (sc (jbigdec-scale bd))
(neg (< u 0)) (digs (number->string (abs u))))
(string-append
(if neg "-" "")
(if (<= sc 0)
digs
(let* ((padded (if (<= (string-length digs) sc)
(string-append (make-string (- (+ sc 1) (string-length digs)) #\0) digs)
digs))
(pl (string-length padded)))
(string-append (substring padded 0 (- pl sc)) "." (substring padded (- pl sc) pl)))))))
;; value as a Chez flonum (for double contagion: a flonum operand wins).
(define (jbigdec->flonum b)
(exact->inexact (/ (jbigdec-unscaled b) (expt 10 (jbigdec-scale b)))))
;; coerce an exact operand to a bigdec; pass a bigdec through. Used on the
;; non-flonum mixed path (bigdec + long -> bigdec). A Ratio converts like
;; Numbers.toBigDecimal — exact decimal expansion or throw on non-terminating.
(define (jbd-coerce x)
(cond ((jbigdec? x) x)
((and (number? x) (exact? x) (integer? x)) (make-jbigdec x 0))
((and (number? x) (exact? x) (rational? x)) (jbd-rational->bigdec x))
(else (error #f "bigdec arithmetic: cannot coerce operand" x))))
;; --- core arithmetic on the {unscaled, scale} pair --------------------------
;; align two bigdecs to a common scale, returning (unscaled-a unscaled-b scale).
(define (jbd-align a b)
(let ((sa (jbigdec-scale a)) (sb (jbigdec-scale b)))
(cond
((= sa sb) (values (jbigdec-unscaled a) (jbigdec-unscaled b) sa))
((> sa sb) (values (jbigdec-unscaled a)
(* (jbigdec-unscaled b) (expt 10 (- sa sb))) sa))
(else (values (* (jbigdec-unscaled a) (expt 10 (- sb sa)))
(jbigdec-unscaled b) sb)))))
(define (jbd2+ a b) (let-values (((ua ub s) (jbd-align a b))) (make-jbigdec (+ ua ub) s)))
(define (jbd2- a b) (let-values (((ua ub s) (jbd-align a b))) (make-jbigdec (- ua ub) s)))
(define (jbd2* a b) (make-jbigdec (* (jbigdec-unscaled a) (jbigdec-unscaled b))
(+ (jbigdec-scale a) (jbigdec-scale b))))
(define (jbd-negate a) (make-jbigdec (- (jbigdec-unscaled a)) (jbigdec-scale a)))
;; exact rational -> bigdec at minimal scale, or throw if non-terminating. den must
;; factor into 2s and 5s; scale = max(count2, count5).
(define (jbd-rational->bigdec r)
(let ((p (numerator r)) (q (denominator r)))
(let loop ((d q) (c2 0) (c5 0))
(cond
((= d 1) (let ((sc (max c2 c5)))
(make-jbigdec (* p (quotient (expt 10 sc) q)) sc)))
((= 0 (modulo d 2)) (loop (quotient d 2) (+ c2 1) c5))
((= 0 (modulo d 5)) (loop (quotient d 5) c2 (+ c5 1)))
(else (jolt-throw (jolt-host-throwable
"java.lang.ArithmeticException"
"Non-terminating decimal expansion; no exact representable decimal result.")))))))
;; floor(log10 |r|) for a nonzero exact rational.
(define (jbd-exp10 r)
(let ((n (abs (numerator r))) (d (denominator r)))
(if (>= n d)
(- (jbd-digits (quotient n d)) 1)
(let loop ((x (* n 10)) (e -1))
(if (>= x d) e (loop (* x 10) (- e 1)))))))
;; round an exact rational to `prec` significant digits (the MathContext divide).
(define (jbd-rational-prec r prec mode)
(if (= r 0)
(make-jbigdec 0 0)
(let* ((neg (< r 0)) (ar (abs r))
(s (- prec 1 (jbd-exp10 ar)))
(scaled (* ar (expt 10 s)))
(q (floor scaled)) (frac (- scaled q))
(q2 (if (jbd-round-inc? q frac 1 mode neg) (+ q 1) q))
(res (make-jbigdec (if neg (- q2) q2) s)))
;; a carry can add a digit (9.99 -> 10.0); re-normalizing drops an exact
;; trailing zero, never re-rounds.
(if (> (jbd-digits q2) prec) (jbd-round-prec res prec mode) res))))
(define (jbd2-div a b)
(when (= 0 (jbigdec-unscaled b))
(jolt-throw (jolt-host-throwable "java.lang.ArithmeticException" "Divide by zero")))
;; a/b = (ua * 10^sb) / (ub * 10^sa) as an exact rational. Unlimited context:
;; exact result at minimal scale or throw on a non-terminating expansion. A
;; bound *math-context* instead rounds to its precision.
(let ((r (/ (* (jbigdec-unscaled a) (expt 10 (jbigdec-scale b)))
(* (jbigdec-unscaled b) (expt 10 (jbigdec-scale a)))))
(mc (jbd-math-context)))
(if mc
(jbd-rational-prec r (jbd-mc-precision mc) (jbd-mc-mode mc))
(jbd-rational->bigdec r))))
;; integer-division semantics (quot/rem): truncate toward zero, scale 0.
(define (jbd-int-quot a b)
(when (= 0 (jbigdec-unscaled b))
(jolt-throw (jolt-host-throwable "java.lang.ArithmeticException" "Divide by zero")))
(let-values (((ua ub s) (jbd-align a b))) (make-jbigdec (quotient ua ub) 0)))
(define (jbd-int-rem a b)
(when (= 0 (jbigdec-unscaled b))
(jolt-throw (jolt-host-throwable "java.lang.ArithmeticException" "Divide by zero")))
(let-values (((ua ub s) (jbd-align a b)))
(make-jbigdec (remainder ua ub) (max (jbigdec-scale a) (jbigdec-scale b)))))
;; scale-independent ordering: compare unscaled values aligned to a common scale.
(define (jbd-compare2 a b)
(let-values (((ua ub s) (jbd-align a b))) (cond ((< ua ub) -1) ((> ua ub) 1) (else 0))))
;; --- *math-context* (with-precision) -----------------------------------------
;; with-precision binds clojure.core/*math-context* to {:precision N :rounding
;; MODE}; every exact bigdec result rounds through it (java.math.MathContext).
(define jbd-kw-precision (keyword #f "precision"))
(define jbd-kw-rounding (keyword #f "rounding"))
(define (jbd-math-context)
(let ((mc (var-deref "clojure.core" "*math-context*")))
(if (jolt-nil? mc) #f mc)))
(define (jbd-mc-precision mc) (jolt-get mc jbd-kw-precision))
(define (jbd-mc-mode mc)
(let ((r (jolt-get mc jbd-kw-rounding)))
(cond ((symbol-t? r) (symbol-t-name r))
((string? r) r)
(else "HALF_UP"))))
;; should |value| = q + r/div (0 <= r < div) round up in magnitude? neg is the
;; value's sign; r/div may be exact rationals (the division path).
(define (jbd-round-inc? q r div mode neg)
(cond ((= r 0) #f)
((string=? mode "UP") #t)
((string=? mode "DOWN") #f)
((string=? mode "CEILING") (not neg))
((string=? mode "FLOOR") neg)
((string=? mode "HALF_DOWN") (> (* 2 r) div))
((string=? mode "HALF_EVEN")
(let ((c (- (* 2 r) div)))
(cond ((> c 0) #t) ((< c 0) #f) (else (odd? q)))))
((string=? mode "UNNECESSARY")
(jolt-throw (jolt-host-throwable "java.lang.ArithmeticException" "Rounding necessary")))
(else (>= (* 2 r) div)))) ; HALF_UP, the MathContext default
(define (jbd-digits n) (string-length (number->string (abs n))))
;; round a bigdec to `prec` significant digits with `mode` (a RoundingMode name).
(define (jbd-round-prec bd prec mode)
(let ((u (jbigdec-unscaled bd)) (s (jbigdec-scale bd)))
(if (= u 0)
bd
(let ((digs (jbd-digits u)))
(if (<= digs prec)
bd
(let* ((drop (- digs prec)) (div (expt 10 drop))
(neg (< u 0)) (au (abs u))
(q (quotient au div)) (r (remainder au div))
(q2 (if (jbd-round-inc? q r div mode neg) (+ q 1) q))
(res (make-jbigdec (if neg (- q2) q2) (- s drop))))
;; a carry can add a digit back (99 -> 100 at precision 2)
(if (> (jbd-digits q2) prec) (jbd-round-prec res prec mode) res)))))))
(define (jbd-mc-round x)
(let ((mc (and (jbigdec? x) (jbd-math-context))))
(if mc (jbd-round-prec x (jbd-mc-precision mc) (jbd-mc-mode mc)) x)))
;; A binary op over operands that may mix bigdec / integer / flonum. flonum-op is
;; the native fallback for the double-contagion path; bd-op is the exact bigdec op
;; (its result rounds through a bound *math-context*).
(define (jbd-binop flonum-op bd-op a b)
(if (or (flonum? a) (flonum? b))
(flonum-op (if (jbigdec? a) (jbigdec->flonum a) a)
(if (jbigdec? b) (jbigdec->flonum b) b))
(jbd-mc-round (bd-op (jbd-coerce a) (jbd-coerce b)))))
;; --- variadic engine ops (Phase-2 emit targets + value-position folds) -------
(define (jbd-fold flonum-op bd-op init xs)
(let loop ((acc init) (rest xs))
(if (null? rest) acc (loop (jbd-binop flonum-op bd-op acc (car rest)) (cdr rest)))))
(define (jbd-add . xs)
(cond ((null? xs) (make-jbigdec 0 0))
((null? (cdr xs)) (car xs))
(else (jbd-fold + jbd2+ (car xs) (cdr xs)))))
(define (jbd-sub . xs)
(cond ((null? xs) (error #f "- needs at least 1 arg"))
((null? (cdr xs)) (if (jbigdec? (car xs)) (jbd-negate (car xs)) (- (car xs))))
(else (jbd-fold - jbd2- (car xs) (cdr xs)))))
(define (jbd-mul . xs)
(cond ((null? xs) (make-jbigdec 1 0))
((null? (cdr xs)) (car xs))
(else (jbd-fold * jbd2* (car xs) (cdr xs)))))
(define (jbd-div . xs)
(cond ((null? xs) (error #f "/ needs at least 1 arg"))
((null? (cdr xs)) (jbd-binop / jbd2-div (make-jbigdec 1 0) (car xs)))
(else (jbd-fold / jbd2-div (car xs) (cdr xs)))))
;; comparison / predicate helpers (Phase-2 emit targets). A flonum operand demotes
;; to the native comparison on the flonum values.
(define (jbd-cmp-num op flop a b)
(if (or (flonum? a) (flonum? b))
(flop (if (jbigdec? a) (jbigdec->flonum a) a) (if (jbigdec? b) (jbigdec->flonum b) b))
(op (jbd-compare2 (jbd-coerce a) (jbd-coerce b)) 0)))
(define (jbd-lt? a b) (jbd-cmp-num < < a b))
(define (jbd-gt? a b) (jbd-cmp-num > > a b))
(define (jbd-le? a b) (jbd-cmp-num <= <= a b))
(define (jbd-ge? a b) (jbd-cmp-num >= >= a b))
(define (jbd-zero? a) (= 0 (jbigdec-unscaled a)))
(define (jbd-pos? a) (> (jbigdec-unscaled a) 0))
(define (jbd-neg? a) (< (jbigdec-unscaled a) 0))
(define (jbd-quot a b) (jbd-int-quot (jbd-coerce a) (jbd-coerce b)))
(define (jbd-rem a b) (jbd-int-rem (jbd-coerce a) (jbd-coerce b)))
;; min/max compare by value but return the ORIGINAL operand (its type and scale
;; unchanged), matching java/Clojure: (min 1M 2.0) -> 1M, (max 1M 2.0) -> 2.0,
;; (min 1.50M 2M) -> 1.50M. Comparison handles a bigdec mixed with an int / flonum.
(define (jbd-value-compare a b)
(if (or (flonum? a) (flonum? b))
(let ((fa (if (jbigdec? a) (jbigdec->flonum a) a)) (fb (if (jbigdec? b) (jbigdec->flonum b) b)))
(cond ((< fa fb) -1) ((> fa fb) 1) (else 0)))
(jbd-compare2 (jbd-coerce a) (jbd-coerce b))))
;; strict comparison so a tie keeps the second operand, like Clojure's
;; (if (< x y) x y) / (if (> x y) x y): (max 1.5M 1.50M) -> 1.50M.
(define (jbd-min2 a b) (if (< (jbd-value-compare a b) 0) a b))
(define (jbd-max2 a b) (if (> (jbd-value-compare a b) 0) a b))
(define (jbd-min x . xs) (fold-left jbd-min2 x xs))
(define (jbd-max x . xs) (fold-left jbd-max2 x xs))
;; --- wire into the value model ----------------------------------------------
(def-var! "clojure.core" "bigdec" jolt-bigdec)
;; The seq.ss binary numeric dispatch (jolt-add2/… and the jolt-n* macros) routes
;; any op whose operand is outside Chez's tower to the *-slow hooks; extend each
;; with a bigdec arm. Every arithmetic position (call, value, higher-order)
;; funnels through these, so contagion and *math-context* rounding apply
;; uniformly. min/max need no arm: the generic jolt-min2 compares through
;; jolt-num-cmp-slow and returns the original operand.
(set! jolt-num-slow?
(let ((prev jolt-num-slow?)) (lambda (x) (or (jbigdec? x) (prev x)))))
(define (jbd-extend-hook prev bd-op)
(lambda (a b)
(if (or (jbigdec? a) (jbigdec? b)) (bd-op a b) (prev a b))))
(set! jolt-add-slow (jbd-extend-hook jolt-add-slow (lambda (a b) (jbd-binop + jbd2+ a b))))
(set! jolt-sub-slow (jbd-extend-hook jolt-sub-slow (lambda (a b) (jbd-binop - jbd2- a b))))
(set! jolt-mul-slow (jbd-extend-hook jolt-mul-slow (lambda (a b) (jbd-binop * jbd2* a b))))
(set! jolt-div-slow (jbd-extend-hook jolt-div-slow (lambda (a b) (jbd-binop / jbd2-div a b))))
(set! jolt-num-cmp-slow
(let ((prev jolt-num-cmp-slow))
(lambda (a b)
(if (and (or (jbigdec? a) (jbigdec? b)) (jbd-numberish? a) (jbd-numberish? b))
(jbd-value-compare a b)
(prev a b)))))
;; quot/rem/mod: a double operand demotes to the double path; exact operands use
;; the integer-division bigdec ops (mod = rem, floor-adjusted to the divisor's sign).
(define (jbd->num x) (if (jbigdec? x) (jbigdec->flonum x) x))
(set! jolt-quot-slow
(jbd-extend-hook jolt-quot-slow
(lambda (a b) (if (or (flonum? a) (flonum? b))
(jolt-quot (jbd->num a) (jbd->num b))
(jbd-int-quot (jbd-coerce a) (jbd-coerce b))))))
(set! jolt-rem-slow
(jbd-extend-hook jolt-rem-slow
(lambda (a b) (if (or (flonum? a) (flonum? b))
(jolt-rem (jbd->num a) (jbd->num b))
(jbd-int-rem (jbd-coerce a) (jbd-coerce b))))))
(set! jolt-mod-slow
(jbd-extend-hook jolt-mod-slow
(lambda (a b)
(if (or (flonum? a) (flonum? b))
(jolt-mod (jbd->num a) (jbd->num b))
(let* ((bb (jbd-coerce b))
(m (jbd-int-rem (jbd-coerce a) bb)))
(if (or (jbd-zero? m) (eq? (jbd-neg? m) (jbd-neg? bb))) m (jbd2+ m bb)))))))
;; unary shims: inc/dec and the sign predicates take a bigdec arm. set! updates
;; call-position references; the re-def-var! updates the var cell AND claims the
;; wrapped proc's class name before the prelude's inc'/dec' aliases are defined
;; ((type inc) stays clojure.core$inc — first def wins in the class registry).
(define jbd-one (make-jbigdec 1 0))
(set! jolt-inc (let ((prev jolt-inc)) (lambda (x) (if (jbigdec? x) (jbd-mc-round (jbd2+ x jbd-one)) (prev x)))))
(set! jolt-dec (let ((prev jolt-dec)) (lambda (x) (if (jbigdec? x) (jbd-mc-round (jbd2- x jbd-one)) (prev x)))))
(set! jolt-zero? (let ((prev jolt-zero?)) (lambda (x) (if (jbigdec? x) (jbd-zero? x) (prev x)))))
(set! jolt-pos? (let ((prev jolt-pos?)) (lambda (x) (if (jbigdec? x) (jbd-pos? x) (prev x)))))
(set! jolt-neg? (let ((prev jolt-neg?)) (lambda (x) (if (jbigdec? x) (jbd-neg? x) (prev x)))))
;; a BigDecimal IS a number (java.lang.Number): extend the number? native so the
;; predicate — and everything defined over it (num, =='s guard) — accepts it.
;; The compiled fast paths test Chez number? directly and are unaffected.
(set! jolt-number? (let ((prev jolt-number?)) (lambda (x) (if (jbigdec? x) #t (prev x)))))
(def-var! "clojure.core" "number?" jolt-number?)
(def-var! "clojure.core" "inc" jolt-inc)
(def-var! "clojure.core" "dec" jolt-dec)
(def-var! "clojure.core" "zero?" jolt-zero?)
(def-var! "clojure.core" "pos?" jolt-pos?)
(def-var! "clojure.core" "neg?" jolt-neg?)
;; rationalize: reference Clojure goes through BigDecimal.valueOf(double) — the
;; SHORTEST decimal print of the double, not its exact binary value — so
;; (rationalize 1.1) is 11/10. A bigdec is exact already; other exacts pass through.
(define (jolt-rationalize x)
(cond ((jbigdec? x) (/ (jbigdec-unscaled x) (expt 10 (jbigdec-scale x))))
((flonum? x)
(if (or (nan? x) (infinite? x))
(jolt-throw (jolt-host-throwable "java.lang.NumberFormatException"
(string-append "Invalid input: " (number->string x))))
(let ((bd (jolt-bigdec-from-string (jolt-num->string x))))
(/ (jbigdec-unscaled bd) (expt 10 (jbigdec-scale bd))))))
((number? x) x)
(else (jolt-num-cast-throw x))))
(def-var! "clojure.core" "rationalize" jolt-rationalize)
;; double/float of a bigdec is its flonum value.
(set! jolt-double-slow
(let ((prev jolt-double-slow))
(lambda (x) (if (jbigdec? x) (jbigdec->flonum x) (prev x)))))
;; narrow casts truncate a bigdec like Number.longValue.
(set! jolt-cast-truncate-slow
(let ((prev jolt-cast-truncate-slow))
(lambda (x)
(if (jbigdec? x)
(truncate (/ (jbigdec-unscaled x) (expt 10 (jbigdec-scale x))))
(prev x)))))
;; compare: add a bigdec arm (enables compare / sort / sorted collections). A
;; bigdec vs a plain number compares by value; bigdec vs bigdec is scale-independent.
(define jbd-prev-compare jolt-compare)
(define (jbd-numberish? x) (or (jbigdec? x) (number? x)))
(set! jolt-compare
(lambda (a b)
(if (and (or (jbigdec? a) (jbigdec? b)) (jbd-numberish? a) (jbd-numberish? b))
(if (or (flonum? a) (flonum? b))
(let ((fa (if (jbigdec? a) (jbigdec->flonum a) a))
(fb (if (jbigdec? b) (jbigdec->flonum b) b)))
(cond ((< fa fb) -1) ((> fa fb) 1) (else 0)))
(jbd-compare2 (jbd-coerce a) (jbd-coerce b)))
(jbd-prev-compare a b))))
(def-var! "clojure.core" "compare" jolt-compare)
;; equality: a bigdec equals only another bigdec, by value (matching (= 3M 3) = false).
(register-eq-arm! (lambda (a b) (or (jbigdec? a) (jbigdec? b)))
(lambda (a b) (and (jbigdec? a) (jbigdec? b) (jbigdec=? a b))))
;; str drops the M; pr/pr-str keep it.
(register-str-render! jbigdec? jbigdec->string)
(register-pr-arm! jbigdec? (lambda (x) (string-append (jbigdec->string x) "M")))
;; class / decimal?
(register-class-arm! jbigdec? (lambda (x) "java.math.BigDecimal"))
(set! jolt-decimal? (lambda (x) (jbigdec? x)))
(def-var! "clojure.core" "decimal?" jolt-decimal?)

View file

@ -0,0 +1,85 @@
;; byte-buffer.ss — java.nio.ByteBuffer over a jolt byte-array. A buffer is a
;; jhost tagged "byte-buffer" with mutable #(backing-array position limit); the
;; backing is a jolt byte-array (vector of 0..255). Covers the slice of the API
;; portable code reaches for — wrap / get(byte[]) / array / remaining / position /
;; limit / duplicate / flip / rewind — e.g. cognitect aws-api wrapping blob bytes.
(define (make-byte-buffer backing pos limit) (make-jhost "byte-buffer" (vector backing pos limit)))
(define (bb? x) (and (jhost? x) (string=? (jhost-tag x) "byte-buffer")))
(define (bb-backing b) (vector-ref (jhost-state b) 0))
(define (bb-pos b) (vector-ref (jhost-state b) 1))
(define (bb-limit b) (vector-ref (jhost-state b) 2))
(define (bb-pos! b n) (vector-set! (jhost-state b) 1 n))
(define (bb-limit! b n) (vector-set! (jhost-state b) 2 n))
(define (bb-capacity b) (vector-length (jolt-array-vec (bb-backing b))))
;; (ByteBuffer/wrap ba) | (ByteBuffer/wrap ba off len) | (ByteBuffer/allocate n)
(register-class-statics! "ByteBuffer"
(list
(cons "wrap" (lambda (ba . rest)
(let ((cap (vector-length (jolt-array-vec ba))))
(if (pair? rest)
(let ((off (jnum->exact (car rest))) (len (jnum->exact (cadr rest))))
(make-byte-buffer ba off (+ off len)))
(make-byte-buffer ba 0 cap)))))
(cons "allocate" (lambda (n)
(let ((cap (jnum->exact n)))
(make-byte-buffer (make-jolt-array (make-vector cap 0) 'byte) 0 cap))))
;; jolt has one heap; a direct buffer is just a buffer here.
(cons "allocateDirect" (lambda (n)
(let ((cap (jnum->exact n)))
(make-byte-buffer (make-jolt-array (make-vector cap 0) 'byte) 0 cap))))))
(register-host-methods! "byte-buffer"
(list
(cons "remaining" (lambda (self) (->num (- (bb-limit self) (bb-pos self)))))
(cons "hasRemaining" (lambda (self) (> (bb-limit self) (bb-pos self))))
;; position / limit are getters with no arg, setters (returning the buffer) with one
(cons "position" (lambda (self . a)
(if (pair? a) (begin (bb-pos! self (jnum->exact (car a))) self) (->num (bb-pos self)))))
(cons "limit" (lambda (self . a)
(if (pair? a) (begin (bb-limit! self (jnum->exact (car a))) self) (->num (bb-limit self)))))
(cons "capacity" (lambda (self) (->num (bb-capacity self))))
(cons "hasArray" (lambda (self) #t))
(cons "array" (lambda (self) (bb-backing self)))
(cons "duplicate" (lambda (self) (make-byte-buffer (bb-backing self) (bb-pos self) (bb-limit self))))
(cons "rewind" (lambda (self) (bb-pos! self 0) self))
(cons "flip" (lambda (self) (bb-limit! self (bb-pos self)) (bb-pos! self 0) self))
(cons "clear" (lambda (self) (bb-pos! self 0) (bb-limit! self (bb-capacity self)) self))
;; (.get dst) | (.get dst off len): bulk copy from position into a byte-array,
;; advancing position. Returns the buffer like the JVM.
;; (.put src): copy bytes into the buffer at position, advancing it. src is
;; another ByteBuffer (its remaining bytes), a byte-array, or a single byte.
(cons "put" (lambda (self src . rest)
(let ((dv (jolt-array-vec (bb-backing self))) (dp (bb-pos self)))
(cond
((bb? src)
(let* ((sv (jolt-array-vec (bb-backing src))) (sp (bb-pos src))
(n (- (bb-limit src) sp)))
(do ((i 0 (fx+ i 1))) ((fx=? i n))
(vector-set! dv (+ dp i) (vector-ref sv (+ sp i))))
(bb-pos! src (bb-limit src)) (bb-pos! self (+ dp n))))
((jolt-array? src)
(let* ((sv (jolt-array-vec src)) (n (vector-length sv)))
(do ((i 0 (fx+ i 1))) ((fx=? i n))
(vector-set! dv (+ dp i) (vector-ref sv i)))
(bb-pos! self (+ dp n))))
(else (vector-set! dv dp (jnum->exact src)) (bb-pos! self (+ dp 1))))
self)))
(cons "get" (lambda (self dst . rest)
(let* ((src (jolt-array-vec (bb-backing self)))
(dv (jolt-array-vec dst))
(off (if (pair? rest) (jnum->exact (car rest)) 0))
(len (if (and (pair? rest) (pair? (cdr rest))) (jnum->exact (cadr rest)) (vector-length dv)))
(p (bb-pos self)))
(do ((i 0 (+ i 1))) ((= i len))
(vector-set! dv (+ off i) (vector-ref src (+ p i))))
(bb-pos! self (+ p len))
self)))))
(register-class-arm! bb? (lambda (x) "java.nio.ByteBuffer"))
(register-instance-check-arm!
(lambda (type-sym val)
(if (and (symbol-t? type-sym) (bb? val)
(member (last-dot (symbol-t-name type-sym)) '("ByteBuffer")))
#t 'pass)))

View file

@ -0,0 +1,261 @@
;; class-hierarchy.ss — one JVM class/interface graph, the single source of truth
;; for every "what classes does this satisfy" question. value-host-tags (protocol
;; dispatch), instance?, isa?/supers/ancestors, and the exception hierarchy all
;; derive from the ONE table here instead of maintaining parallel hand-kept lists
;; that drift apart.
;;
;; The graph is keyed by canonical (FQN) class name -> its DIRECT super
;; interfaces/classes (also FQN). Transitivity is computed (jch-closure), so a row
;; lists only what a class directly extends/implements, matching the JVM source.
;;
;; It is OPEN: a library registers a class and its supers with
;; jolt.host/register-class-supers! (plus a class-arm in host-class.ss to map its
;; values to that class name), and every derived view picks the class up with no
;; core change. Loaded before records.ss so value-host-tags can derive from it.
;; canonical-name -> list of direct super canonical-names. Mutable + extensible.
(define jvm-class-parents (make-hashtable string-hash string=?))
;; closure cache, invalidated whenever the graph is extended.
(define jch-closure-cache (make-hashtable string-hash string=?))
(define jch-tags-cache (make-hashtable string-hash string=?))
;; Merge direct supers for a class (union with any already registered). Public so
;; libraries can graft their own classes onto the modeled hierarchy.
(define (jch-register-supers! name supers)
(let ((cur (hashtable-ref jvm-class-parents name '())))
(hashtable-set! jvm-class-parents name
(let add ((ss supers) (acc cur))
(cond ((null? ss) acc)
((member (car ss) acc) (add (cdr ss) acc))
(else (add (cdr ss) (append acc (list (car ss)))))))))
(hashtable-clear! jch-closure-cache)
(hashtable-clear! jch-tags-cache))
(define (jch-direct-supers name) (hashtable-ref jvm-class-parents name '()))
;; Replace a class's direct supers outright (defrecord re-declares the row its
;; deftype half registered). Same cache invalidation as a register.
(define (jch-set-supers! name supers)
(hashtable-set! jvm-class-parents name supers)
(hashtable-clear! jch-closure-cache)
(hashtable-clear! jch-tags-cache)
(set! jch-known-cache #f)
(set! jch-simple->fqn-cache #f))
;; transitive supers of NAME (canonical), excluding NAME and Object; Object is the
;; universal root supplied by callers. Breadth-first, deduped, stable order.
(define (jch-closure name)
(or (hashtable-ref jch-closure-cache name #f)
(let ((result
(let loop ((pending (jch-direct-supers name)) (seen '()))
(cond ((null? pending) (reverse seen))
((member (car pending) seen) (loop (cdr pending) seen))
(else (loop (append (jch-direct-supers (car pending)) (cdr pending))
(cons (car pending) seen)))))))
(hashtable-set! jch-closure-cache name result)
result)))
;; ns segment munging for a JVM-spelled class name: dashes become underscores
;; (clojure.core-test.x -> clojure.core_test.x).
(define (jch-munge-segments s)
(list->string (map (lambda (c) (if (char=? c #\-) #\_ c)) (string->list s))))
(define (jch-last-segment s)
(let loop ((i (- (string-length s) 1)))
(cond ((< i 0) s)
((char=? (string-ref s i) #\.) (substring s (+ i 1) (string-length s)))
((char=? (string-ref s i) #\$) (substring s (+ i 1) (string-length s)))
(else (loop (- i 1))))))
;; The protocol-dispatch / instance? tag list for a value of class NAME: the class
;; and its whole ancestry, each in BOTH canonical and simple spelling (extend-protocol
;; and instance? accept either "Associative" or "clojure.lang.Associative"), plus
;; "Object". Memoized — this is on the hot protocol-dispatch path.
(define (jch-tags name)
(or (hashtable-ref jch-tags-cache name #f)
(let* ((chain (cons name (jch-closure name)))
(result
(let build ((cs chain) (acc '()))
(if (null? cs)
(reverse (cons "Object" acc))
(let* ((fqn (car cs))
(simple (jch-last-segment fqn))
(acc1 (if (member fqn acc) acc (cons fqn acc)))
(acc2 (if (or (string=? simple fqn) (member simple acc1))
acc1 (cons simple acc1))))
(build (cdr cs) acc2))))))
(hashtable-set! jch-tags-cache name result)
result)))
;; Is WANTED (canonical or simple) the class CHILD (canonical) or one of its
;; ancestors? Object is every class's root. Matched by full name or last segment so
;; "IOException" and "java.io.IOException" both hit.
(define (jch-isa? child wanted)
(let ((wseg (jch-last-segment wanted)))
(or (string=? wanted "java.lang.Object") (string=? wanted "Object")
(let loop ((names (cons child (jch-closure child))))
(cond ((null? names) #f)
((or (string=? wanted (car names))
(string=? wseg (jch-last-segment (car names)))) #t)
(else (loop (cdr names))))))))
;; Does the graph model WANTED at all (as a class or as any class's ancestor)? Used
;; by instance? to decide between a definitive #f and 'pass (defer to other arms).
(define jch-known-cache #f)
(define (jch-known? wanted)
(when (not jch-known-cache)
(set! jch-known-cache (make-hashtable string-hash string=?))
(let-values (((keys vals) (hashtable-entries jvm-class-parents)))
(vector-for-each
(lambda (k supers)
(hashtable-set! jch-known-cache k #t)
(hashtable-set! jch-known-cache (jch-last-segment k) #t)
(for-each (lambda (s)
(hashtable-set! jch-known-cache s #t)
(hashtable-set! jch-known-cache (jch-last-segment s) #t))
supers))
keys vals)))
(or (hashtable-ref jch-known-cache wanted #f)
(hashtable-ref jch-known-cache (jch-last-segment wanted) #f)))
;; simple last-segment -> canonical FQN for a modeled class (first registered
;; wins). Lets a simple exception name (from chez-condition-exc-class) resolve to
;; its graph key so the exception hierarchy answers through the one graph.
(define jch-simple->fqn-cache #f)
(define (jch-fqn-of-simple name)
(when (not jch-simple->fqn-cache)
(set! jch-simple->fqn-cache (make-hashtable string-hash string=?))
(let-values (((keys vals) (hashtable-entries jvm-class-parents)))
(vector-for-each
(lambda (k supers)
(for-each (lambda (n)
(let ((seg (jch-last-segment n)))
(when (not (hashtable-ref jch-simple->fqn-cache seg #f))
(hashtable-set! jch-simple->fqn-cache seg n))))
(cons k supers)))
keys vals)))
(or (hashtable-ref jch-simple->fqn-cache name #f) name))
;; A register also invalidates the derived caches.
(define jch-register-supers!-inner jch-register-supers!)
(set! jch-register-supers!
(lambda (name supers)
(set! jch-known-cache #f)
(set! jch-simple->fqn-cache #f)
(jch-register-supers!-inner name supers)))
;; ---- interface marking ---------------------------------------------------------
;; The JVM distinguishes a concrete class (whose bases/supers chain roots at
;; Object) from an interface (whose don't). The graph marks the modeled
;; interfaces; anything unmarked is treated as a concrete class.
(define jch-interface-set (make-hashtable string-hash string=?))
(define (jch-mark-interface! name) (hashtable-set! jch-interface-set name #t))
(define (jch-interface? name) (hashtable-ref jch-interface-set name #f))
(for-each jch-mark-interface!
'("clojure.lang.Seqable" "clojure.lang.Sequential" "clojure.lang.Sorted"
"clojure.lang.Reversible" "clojure.lang.Indexed" "clojure.lang.Counted"
"clojure.lang.Named" "clojure.lang.Fn" "clojure.lang.IFn"
"clojure.lang.IPersistentCollection" "clojure.lang.ISeq"
"clojure.lang.Associative" "clojure.lang.ILookup"
"clojure.lang.IPersistentStack" "clojure.lang.IPersistentVector"
"clojure.lang.IPersistentMap" "clojure.lang.IPersistentSet"
"clojure.lang.IPersistentList" "clojure.lang.IObj" "clojure.lang.IMeta"
"clojure.lang.IDeref" "clojure.lang.IRecord" "clojure.lang.IType"
"clojure.lang.IHashEq" "clojure.lang.IEditableCollection"
"clojure.lang.IExceptionInfo" "clojure.lang.IReduceInit"
"java.util.List" "java.util.Set" "java.util.Collection" "java.util.Map"
"java.util.Iterator" "java.lang.Iterable" "java.lang.CharSequence"
"java.lang.Comparable" "java.lang.Runnable"
"java.util.concurrent.Callable" "java.io.Serializable"))
;; ---- seed the built-in graph: direct supers only, faithful to the JVM ---------
;; core clojure.lang interfaces
(jch-register-supers! "clojure.lang.IPersistentCollection" '("clojure.lang.Seqable"))
(jch-register-supers! "clojure.lang.ISeq" '("clojure.lang.IPersistentCollection"))
(jch-register-supers! "clojure.lang.Associative" '("clojure.lang.IPersistentCollection" "clojure.lang.ILookup"))
(jch-register-supers! "clojure.lang.IPersistentStack" '("clojure.lang.IPersistentCollection"))
(jch-register-supers! "clojure.lang.IPersistentVector" '("clojure.lang.Associative" "clojure.lang.Sequential"
"clojure.lang.IPersistentStack" "clojure.lang.Reversible"
"clojure.lang.Indexed"))
(jch-register-supers! "clojure.lang.IPersistentMap" '("java.lang.Iterable" "clojure.lang.Associative" "clojure.lang.Counted"))
(jch-register-supers! "clojure.lang.IPersistentSet" '("clojure.lang.IPersistentCollection" "clojure.lang.Counted"))
(jch-register-supers! "clojure.lang.IPersistentList" '("clojure.lang.Sequential" "clojure.lang.IPersistentStack"))
(jch-register-supers! "clojure.lang.IObj" '("clojure.lang.IMeta"))
(jch-register-supers! "clojure.lang.IFn" '("java.lang.Runnable" "java.util.concurrent.Callable"))
(jch-register-supers! "clojure.lang.Fn" '("clojure.lang.IFn"))
(jch-register-supers! "clojure.lang.AFn" '("clojure.lang.IFn"))
(jch-register-supers! "clojure.lang.AFunction" '("clojure.lang.AFn" "clojure.lang.Fn"))
;; java.util collection interfaces
(jch-register-supers! "java.util.List" '("java.util.Collection"))
(jch-register-supers! "java.util.Set" '("java.util.Collection"))
(jch-register-supers! "java.util.Collection" '("java.lang.Iterable"))
;; concrete collection classes
(jch-register-supers! "clojure.lang.APersistentVector" '("clojure.lang.IPersistentVector" "java.util.List"))
(jch-register-supers! "clojure.lang.PersistentVector" '("clojure.lang.APersistentVector" "clojure.lang.IObj"
"java.util.List" "java.lang.Comparable"))
(jch-register-supers! "clojure.lang.APersistentMap" '("clojure.lang.IPersistentMap" "java.util.Map"))
(jch-register-supers! "clojure.lang.PersistentArrayMap" '("clojure.lang.APersistentMap" "clojure.lang.IObj"))
(jch-register-supers! "clojure.lang.PersistentHashMap" '("clojure.lang.APersistentMap" "clojure.lang.IObj"))
(jch-register-supers! "clojure.lang.PersistentTreeMap" '("clojure.lang.APersistentMap" "clojure.lang.IObj" "clojure.lang.Sorted" "clojure.lang.Reversible"))
(jch-register-supers! "clojure.lang.APersistentSet" '("clojure.lang.IPersistentSet" "java.util.Set"))
(jch-register-supers! "clojure.lang.PersistentHashSet" '("clojure.lang.APersistentSet" "clojure.lang.IObj"))
(jch-register-supers! "clojure.lang.PersistentTreeSet" '("clojure.lang.APersistentSet" "clojure.lang.IObj" "clojure.lang.Sorted" "clojure.lang.Reversible"))
(jch-register-supers! "clojure.lang.ASeq" '("clojure.lang.ISeq" "clojure.lang.Sequential" "java.util.List"))
(jch-register-supers! "clojure.lang.PersistentList" '("clojure.lang.ASeq" "clojure.lang.IPersistentList" "clojure.lang.Counted"))
(jch-register-supers! "clojure.lang.PersistentList$EmptyList" '("clojure.lang.PersistentList"))
(jch-register-supers! "clojure.lang.LazySeq" '("clojure.lang.ISeq" "clojure.lang.Sequential" "java.util.List" "clojure.lang.IObj"))
(jch-register-supers! "clojure.lang.Cons" '("clojure.lang.ASeq"))
(jch-register-supers! "clojure.lang.PersistentQueue" '("clojure.lang.IPersistentList" "clojure.lang.IPersistentCollection" "java.util.Collection"))
;; scalars / named / callable
(jch-register-supers! "clojure.lang.Keyword" '("clojure.lang.IFn" "clojure.lang.Named" "java.lang.Comparable"))
(jch-register-supers! "clojure.lang.Symbol" '("clojure.lang.IObj" "clojure.lang.IFn" "clojure.lang.Named" "java.lang.Comparable"))
(jch-register-supers! "clojure.lang.Var" '("clojure.lang.IDeref" "clojure.lang.IFn"))
(jch-register-supers! "clojure.lang.Atom" '("clojure.lang.IDeref"))
(jch-register-supers! "clojure.lang.Ratio" '("java.lang.Number" "java.lang.Comparable"))
(jch-register-supers! "clojure.lang.BigInt" '("java.lang.Number"))
(jch-register-supers! "java.lang.String" '("java.lang.CharSequence" "java.lang.Comparable"))
(jch-register-supers! "java.lang.Long" '("java.lang.Number" "java.lang.Comparable"))
(jch-register-supers! "java.lang.Integer" '("java.lang.Number" "java.lang.Comparable"))
(jch-register-supers! "java.lang.Double" '("java.lang.Number" "java.lang.Comparable"))
(jch-register-supers! "java.lang.Float" '("java.lang.Number" "java.lang.Comparable"))
(jch-register-supers! "java.math.BigDecimal" '("java.lang.Number" "java.lang.Comparable"))
(jch-register-supers! "java.math.BigInteger" '("java.lang.Number" "java.lang.Comparable"))
(jch-register-supers! "java.lang.Boolean" '("java.lang.Comparable"))
(jch-register-supers! "java.lang.Character" '("java.lang.Comparable"))
(jch-register-supers! "java.util.UUID" '("java.lang.Comparable"))
;; exception hierarchy (folds in the former exception-parent table)
(jch-register-supers! "java.lang.Exception" '("java.lang.Throwable"))
(jch-register-supers! "java.lang.RuntimeException" '("java.lang.Exception"))
(jch-register-supers! "clojure.lang.ExceptionInfo" '("java.lang.RuntimeException" "clojure.lang.IExceptionInfo"))
(jch-register-supers! "java.lang.IllegalArgumentException" '("java.lang.RuntimeException"))
(jch-register-supers! "clojure.lang.ArityException" '("java.lang.IllegalArgumentException"))
(jch-register-supers! "java.lang.NumberFormatException" '("java.lang.IllegalArgumentException"))
(jch-register-supers! "java.lang.IllegalStateException" '("java.lang.RuntimeException"))
(jch-register-supers! "java.lang.UnsupportedOperationException" '("java.lang.RuntimeException"))
(jch-register-supers! "java.lang.ArithmeticException" '("java.lang.RuntimeException"))
(jch-register-supers! "java.lang.NullPointerException" '("java.lang.RuntimeException"))
(jch-register-supers! "java.lang.ClassCastException" '("java.lang.RuntimeException"))
(jch-register-supers! "java.lang.IndexOutOfBoundsException" '("java.lang.RuntimeException"))
(jch-register-supers! "java.util.ConcurrentModificationException" '("java.lang.RuntimeException"))
(jch-register-supers! "java.util.NoSuchElementException" '("java.lang.RuntimeException"))
(jch-register-supers! "java.io.UncheckedIOException" '("java.lang.RuntimeException"))
(jch-register-supers! "java.time.DateTimeException" '("java.lang.RuntimeException"))
(jch-register-supers! "java.time.format.DateTimeParseException" '("java.time.DateTimeException"))
(jch-register-supers! "java.lang.InterruptedException" '("java.lang.Exception"))
(jch-register-supers! "java.io.IOException" '("java.lang.Exception"))
(jch-register-supers! "java.io.InterruptedIOException" '("java.io.IOException"))
(jch-register-supers! "java.io.FileNotFoundException" '("java.io.IOException"))
(jch-register-supers! "java.io.UnsupportedEncodingException" '("java.io.IOException"))
(jch-register-supers! "java.net.UnknownHostException" '("java.io.IOException"))
(jch-register-supers! "java.net.SocketException" '("java.io.IOException"))
(jch-register-supers! "java.net.ConnectException" '("java.net.SocketException"))
(jch-register-supers! "java.net.SocketTimeoutException" '("java.io.InterruptedIOException"))
(jch-register-supers! "java.net.MalformedURLException" '("java.io.IOException"))
(jch-register-supers! "javax.net.ssl.SSLException" '("java.io.IOException"))
(jch-register-supers! "java.lang.Error" '("java.lang.Throwable"))
(jch-register-supers! "java.lang.AssertionError" '("java.lang.Error"))
;; Throwable's only super is Object (universal), so no row needed for it.
;; Public seam: libraries extend the modeled hierarchy.
(def-var! "jolt.host" "register-class-supers!"
(lambda (name supers) (jch-register-supers! name (seq->list supers)) jolt-nil))

View file

@ -0,0 +1,611 @@
;; concurrency.ss — real OS-thread futures + promises for the Chez host.
;;
;; SHARED-HEAP semantics, like JVM Clojure: a future body runs on a native thread
;; (fork-thread) over the SAME heap, so a captured atom is shared and the body's
;; mutations are visible to the parent. deref blocks on a mutex+condition latch.
;;
;; future / future-call / future-cancel / future? / future-done? / future-cancelled?
;; promise / deliver, and the deref extension for both, are bound here (some
;; re-asserted in post-prelude.ss over the overlay's versions).
;;
;; pmap / pcalls / pvalues live in the clojure.core overlay (40-lazy) expressed
;; over `future`, so they light up for free once future-call exists.
;;
;; Loaded near the end of rt.ss — after atoms.ss (jolt-deref, the atom lock) and
;; dyn-binding.ss (the thread-local binding stack we convey into the worker).
;; Requires a threaded Chez build (fork-thread / make-mutex / make-condition).
;; --- time helpers -----------------------------------------------------------
;; A relative duration / absolute deadline from a millisecond count (a jolt number).
(define (ms->duration ms)
(let* ((ms* (exact (floor ms)))
(secs (quotient ms* 1000))
(nanos (* (remainder ms* 1000) 1000000)))
(make-time 'time-duration nanos secs)))
(define (ms->deadline ms) (add-duration (current-time 'time-utc) (ms->duration ms)))
;; --- futures ----------------------------------------------------------------
;; A future is a mutable cell guarded by `mu`; workers/derefs coordinate on `cv`.
;; done? — result (or cancellation) is final; derefs may proceed
;; cancelled? — future-cancel won before the body finished
;; ok? — payload is a value (else payload is a raised condition/value)
;; payload — the result value, or the captured throw
(define-record-type jolt-future
(fields (mutable done?) (mutable cancelled?) (mutable ok?) (mutable payload) mu cv)
(nongenerative jolt-future-v1))
;; (future-call thunk): spawn a thread running (thunk). The dynamic bindings in
;; effect now are conveyed into the worker (Chez inherits thread-parameters at
;; fork; we also install an explicit snapshot for certainty). The result — value
;; or thrown condition — is latched and broadcast; a cancel that already finalized
;; the future makes the late result a no-op.
(define (jolt-future-call thunk)
(let ((f (make-jolt-future #f #f #f jolt-nil (make-mutex) (make-condition)))
(snap (dyn-binding-stack)))
(fork-thread
(lambda ()
(dyn-binding-stack snap)
(let ((r (guard (e (#t (cons #f e))) (cons #t (jolt-invoke thunk)))))
(with-mutex (jolt-future-mu f)
(unless (jolt-future-done? f) ; not already cancelled
(jolt-future-ok?-set! f (car r))
(jolt-future-payload-set! f (cdr r))
(jolt-future-done?-set! f #t))
(condition-broadcast (jolt-future-cv f))))))
f))
;; Final value of a settled future (called OUTSIDE the lock): re-raise a captured
;; throw, signal a cancellation, else the value.
(define (jolt-future-finish f)
(cond
((jolt-future-cancelled? f)
(jolt-throw (jolt-ex-info "Future cancelled" (jolt-hash-map))))
((jolt-future-ok? f) (jolt-future-payload f))
(else (raise (jolt-future-payload f)))))
(define (jolt-future-deref f)
(with-mutex (jolt-future-mu f)
(let loop ()
(unless (jolt-future-done? f)
(condition-wait (jolt-future-cv f) (jolt-future-mu f))
(loop))))
(jolt-future-finish f))
;; (deref f timeout-ms timeout-val): wait up to timeout-ms; return timeout-val if
;; it has not settled by the absolute deadline.
(define (jolt-future-deref-timed f ms timeout-val)
(let* ((deadline (ms->deadline ms))
(settled (with-mutex (jolt-future-mu f)
(let loop ()
(cond ((jolt-future-done? f) #t)
((condition-wait (jolt-future-cv f) (jolt-future-mu f) deadline)
(loop)) ; woken — recheck
(else (jolt-future-done? f))))))) ; timed out: final check
(if settled (jolt-future-finish f) timeout-val)))
;; future-cancel: the running thread can't be interrupted, but the future object
;; reflects the cancellation — if not already settled, mark it cancelled+done so
;; derefs raise and the predicates flip. Returns true iff this call cancelled it.
(define (jolt-future-cancel f)
(let ((cancelled (with-mutex (jolt-future-mu f)
(if (jolt-future-done? f)
#f
(begin (jolt-future-cancelled?-set! f #t)
(jolt-future-done?-set! f #t)
(condition-broadcast (jolt-future-cv f))
#t)))))
cancelled))
(define (jolt-native-future-done? x)
(if (jolt-future? x) (jolt-future-done? x)
(jolt-throw (jolt-ex-info "future-done? requires a future" (jolt-hash-map)))))
(define (jolt-native-future-cancelled? x)
(and (jolt-future? x) (jolt-future-cancelled? x)))
;; --- promises ---------------------------------------------------------------
;; A blocking promise (like the JVM): deref parks until deliver, then caches the
;; value. deliver wins once; later delivers return nil.
(define-record-type jolt-promise
(fields (mutable delivered?) (mutable value) mu cv)
(nongenerative jolt-promise-v1))
(define (jolt-promise-new) (make-jolt-promise #f jolt-nil (make-mutex) (make-condition)))
(define (jolt-deliver p v)
(if (jolt-promise? p)
(let ((won (with-mutex (jolt-promise-mu p)
(if (jolt-promise-delivered? p)
#f
(begin (jolt-promise-value-set! p v)
(jolt-promise-delivered?-set! p #t)
(condition-broadcast (jolt-promise-cv p))
#t)))))
(if won p jolt-nil))
(jolt-throw (jolt-ex-info "deliver requires a promise" (jolt-hash-map)))))
(define (jolt-promise-deref p)
(with-mutex (jolt-promise-mu p)
(let loop ()
(unless (jolt-promise-delivered? p)
(condition-wait (jolt-promise-cv p) (jolt-promise-mu p))
(loop))))
(jolt-promise-value p))
(define (jolt-promise-deref-timed p ms timeout-val)
(let* ((deadline (ms->deadline ms))
(got (with-mutex (jolt-promise-mu p)
(let loop ()
(cond ((jolt-promise-delivered? p) #t)
((condition-wait (jolt-promise-cv p) (jolt-promise-mu p) deadline)
(loop))
(else (jolt-promise-delivered? p)))))))
(if got (jolt-promise-value p) timeout-val)))
;; --- agents (async, per-agent serialized dispatch) --------------------------
;; JVM semantics: send/send-off enqueue an action and a single worker thread
;; applies them to the state IN ORDER; deref reads the
;; (possibly not-yet-updated) state without blocking; await blocks until the queue
;; drains. An action error is captured (agent-error) and stops the queue.
(define-record-type jolt-agent
(fields (mutable state) (mutable err) (mutable validator)
(mutable queue) (mutable running?) mu cv)
(nongenerative jolt-agent-v1))
;; (agent state :meta m :validator f :error-mode e): the ARef ctor contract like
;; atom's — the validator runs against the initial state, :meta must be a map.
;; :error-mode is accepted/ignored (jolt agents are always :fail).
(define (jolt-agent-new state . opts)
(let loop ((o opts) (validator jolt-nil) (m #f))
(cond
((or (null? o) (null? (cdr o)))
(let ((a (make-jolt-agent state jolt-nil validator (vector '() '()) #f (make-mutex) (make-condition))))
(when (and (not (jolt-nil? validator)) (jolt-not (jolt-invoke validator state)))
(jolt-iref-state-throw))
(when (and m (not (jolt-nil? m)))
(unless (jolt-map? m)
(jolt-throw (jolt-host-throwable
"java.lang.ClassCastException"
(string-append "class " (jolt-class-name m)
" cannot be cast to class clojure.lang.IPersistentMap"))))
(hashtable-set! meta-table a m))
a))
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "validator"))
(loop (cddr o) (cadr o) m))
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "meta"))
(loop (cddr o) validator (cadr o)))
(else (loop (cddr o) validator m)))))
;; agents are watchable IRefs; the worker notifies on each state change.
(register-iref-arm! jolt-agent?)
;; The action queue is an amortized-O(1) FIFO held as a mutable #(out in): `out` is
;; the front, `in` holds sends reversed onto it (an append-to-a-list send was O(n)).
;; All three helpers run under the agent mutex.
(define (jagent-q-empty? a)
(let ((q (jolt-agent-queue a))) (and (null? (vector-ref q 0)) (null? (vector-ref q 1)))))
(define (jagent-q-push! a entry)
(let ((q (jolt-agent-queue a))) (vector-set! q 1 (cons entry (vector-ref q 1)))))
(define (jagent-q-pop! a)
(let ((q (jolt-agent-queue a)))
(when (null? (vector-ref q 0))
(vector-set! q 0 (reverse (vector-ref q 1))) (vector-set! q 1 '()))
(let ((out (vector-ref q 0))) (vector-set! q 0 (cdr out)) (car out))))
;; Drain the queue, applying each action (f state arg*) outside the lock (an action
;; may send/deref the same agent). A validator rejection or a thrown action puts the
;; agent in an error state and halts the queue (JVM :fail mode).
(define (jolt-agent-worker a)
(let loop ()
(let ((act (with-mutex (jolt-agent-mu a)
(if (or (not (jolt-nil? (jolt-agent-err a))) (jagent-q-empty? a))
(begin (jolt-agent-running?-set! a #f)
(condition-broadcast (jolt-agent-cv a)) #f)
(jagent-q-pop! a)))))
(when act
(guard (e (#t (with-mutex (jolt-agent-mu a)
(jolt-agent-err-set! a e)
(condition-broadcast (jolt-agent-cv a)))))
(let* ((old (jolt-agent-state a))
(nv (apply jolt-invoke (car act) old (cdr act))))
(let ((vf (jolt-agent-validator a)))
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf nv)))
(jolt-iref-state-throw)))
(jolt-agent-state-set! a nv)
(iref-notify a old nv)))
(loop)))))
;; send / send-off: enqueue the action, start the worker if idle. (jolt treats them
;; identically — one serialized worker per agent — which is observably a superset of
;; the JVM's fixed/cached pool split.)
(define (jolt-agent-send a f . args)
(with-mutex (jolt-agent-mu a)
(jagent-q-push! a (cons f args))
(unless (jolt-agent-running? a)
(jolt-agent-running?-set! a #t)
(fork-thread (lambda () (jolt-agent-worker a)))))
a)
;; (await & agents): block until each agent's queue has drained.
(define (jolt-agent-await . agents)
(for-each
(lambda (a)
(with-mutex (jolt-agent-mu a)
(let loop ()
(when (or (jolt-agent-running? a) (not (jagent-q-empty? a)))
(condition-wait (jolt-agent-cv a) (jolt-agent-mu a)) (loop)))))
agents)
jolt-nil)
(define (jolt-agent-error a) (jolt-agent-err a))
(define (jolt-agent-restart a new-state . _opts)
(jolt-agent-err-set! a jolt-nil)
(jolt-agent-state-set! a new-state)
a)
;; --- delay (lazy once-forced computation) -----------------------------------
;; (delay body) -> (make-delay (fn [] body)) (overlay macro); force/deref run the
;; thunk once under a lock and cache the value (JVM delays are thread-safe). force
;; (overlay) is (if (delay? x) (deref x) x), so it works once delay?/deref do.
(define-record-type jolt-delay (fields thunk (mutable realized?) (mutable value) (mutable exn) mu)
(nongenerative jolt-delay-v1))
(define (jolt-make-delay thunk) (make-jolt-delay thunk #f jolt-nil #f (make-mutex)))
;; run the thunk once, like Clojure's Delay: if it throws, cache the exception
;; (the delay IS realized) and re-throw it on every deref — do NOT re-run the
;; body (so value-fns memoize and there is no cache-stampede / retried side
;; effect). Store the exception inside the lock, re-raise outside it so the mutex
;; is always released.
(define (jolt-delay-force d)
(with-mutex (jolt-delay-mu d)
(unless (jolt-delay-realized? d)
(guard (e (#t (jolt-delay-exn-set! d e) (jolt-delay-realized?-set! d #t)))
(jolt-delay-value-set! d (jolt-invoke (jolt-delay-thunk d)))
(jolt-delay-realized?-set! d #t))))
(if (jolt-delay-exn d) (raise (jolt-delay-exn d)) (jolt-delay-value d)))
;; --- deref extension --------------------------------------------------------
;; Chain the fully-built jolt-deref (atoms/vars/volatiles/reduced) with futures,
;; promises, agents, and delays; accept the timed (deref ref ms val) arity for the
;; blocking ref types.
(define %pre-conc-deref jolt-deref)
(set! jolt-deref
(lambda (x . opts)
(cond
((jolt-future? x)
(if (null? opts) (jolt-future-deref x)
(jolt-future-deref-timed x (car opts) (cadr opts))))
((jolt-promise? x)
(if (null? opts) (jolt-promise-deref x)
(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
;; post-prelude.ss.
(define (jolt-conc-realized? x)
(cond ((jolt-future? x) (jolt-future-done? x))
((jolt-promise? x) (jolt-promise-delivered? x))
((jolt-delay? x) (jolt-delay-realized? x))
(else #f)))
;; --- bind into clojure.core -------------------------------------------------
(def-var! "clojure.core" "future-call" jolt-future-call)
(def-var! "clojure.core" "future-cancel" jolt-future-cancel)
(def-var! "clojure.core" "future?" jolt-future?)
(def-var! "clojure.core" "future-done?" jolt-native-future-done?)
(def-var! "clojure.core" "future-cancelled?" jolt-native-future-cancelled?)
(def-var! "clojure.core" "promise" jolt-promise-new)
(def-var! "clojure.core" "deliver" jolt-deliver)
;; a promise is an IFn on the JVM: (p val) delivers. Registered as a cold
;; invoke arm; callable-host? feeds the ifn? overlay (multimethods included).
(register-invoke-arm! jolt-promise?
(lambda (p args)
(if (and (pair? args) (null? (cdr args)))
(jolt-deliver p (car args))
(jolt-throw (jolt-host-throwable "clojure.lang.ArityException"
"Wrong number of args passed to a promise")))))
(def-var! "jolt.host" "callable-host?"
(lambda (x) (if (or (jolt-multifn? x) (jolt-promise? x)) #t jolt-nil)))
(def-var! "clojure.core" "agent" jolt-agent-new)
(def-var! "clojure.core" "agent?" jolt-agent?)
(def-var! "clojure.core" "send" jolt-agent-send)
(def-var! "clojure.core" "send-off" jolt-agent-send)
(def-var! "clojure.core" "await" jolt-agent-await)
(def-var! "clojure.core" "agent-error" jolt-agent-error)
(def-var! "clojure.core" "restart-agent" jolt-agent-restart)
(def-var! "clojure.core" "make-delay" jolt-make-delay)
(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
;; running computation, even a tight Scheme loop, can be aborted from another
;; thread. An interrupt TOKEN is a shared box; run-interruptible arms a periodic
;; timer in the eval thread whose handler escapes (via call/cc) when the token is
;; set; interrupt! sets the token from any thread. The aborted eval throws a jolt
;; ex-info {:jolt/interrupted true}, so the thread is REUSED, not abandoned.
;;
;; Caveat: a thread blocked in a __collect_safe foreign call (socket recv/accept,
;; sleep) only sees the interrupt when it returns to Scheme — like the JVM not
;; killing native code.
(define interrupt-check-ticks 100000) ; ~poll interval; responsive + low overhead
(define interrupt-sentinel (cons 'jolt 'interrupted))
(define jolt-kw-interrupted (keyword "jolt" "interrupted"))
(define (jolt-make-interrupt) (box #f))
(define (jolt-interrupt! token) (when (box? token) (set-box! token #t)) jolt-nil)
(define (jolt-interrupted? token) (and (box? token) (unbox token) #t))
(define (jolt-run-interruptible token thunk)
(let ((prev-handler (timer-interrupt-handler)))
(let ((r (call/cc
(lambda (k)
(timer-interrupt-handler
(lambda ()
(if (and (box? token) (unbox token))
(k interrupt-sentinel)
(begin (set-timer interrupt-check-ticks) (void)))))
(set-timer interrupt-check-ticks)
(let ((v (thunk))) (set-timer 0) v)))))
;; restore the prior timer state regardless of outcome.
(set-timer 0)
(timer-interrupt-handler prev-handler)
(if (eq? r interrupt-sentinel)
(jolt-throw (jolt-ex-info "Evaluation interrupted" (jolt-hash-map jolt-kw-interrupted #t)))
r))))
(def-var! "jolt.host" "make-interrupt" jolt-make-interrupt)
(def-var! "jolt.host" "interrupt!" jolt-interrupt!)
(def-var! "jolt.host" "interrupted?" jolt-interrupted?)
(def-var! "jolt.host" "run-interruptible" jolt-run-interruptible)
;; --- java.lang.Thread / java.util.concurrent.CountDownLatch -----------------
;; Real OS threads over Chez fork-thread (shared heap — a captured atom/var is
;; shared). A Thread runs its Runnable thunk; start forks, join waits on a
;; condition latched at completion. CountDownLatch is a counting barrier.
(define (make-jthread thunk) (make-jhost "user-thread" (vector thunk #f (make-mutex) (make-condition))))
(for-each (lambda (nm) (register-class-ctor! nm (lambda (thunk . _) (make-jthread thunk))))
'("Thread" "java.lang.Thread"))
(register-host-methods! "user-thread"
(list (cons "start" (lambda (self)
(let ((st (jhost-state self)) (snap (dyn-binding-stack)))
(fork-thread (lambda ()
(dyn-binding-stack snap)
(guard (e (#t #f)) (jolt-invoke (vector-ref st 0)))
(with-mutex (vector-ref st 2)
(vector-set! st 1 #t)
(condition-broadcast (vector-ref st 3)))))
jolt-nil)))
(cons "run" (lambda (self) (jolt-invoke (vector-ref (jhost-state self) 0)) jolt-nil))
(cons "join" (lambda (self . _)
(let ((st (jhost-state self)))
(with-mutex (vector-ref st 2)
(let loop () (unless (vector-ref st 1) (condition-wait (vector-ref st 3) (vector-ref st 2)) (loop)))))
jolt-nil))
(cons "isAlive" (lambda (self) (not (vector-ref (jhost-state self) 1))))
(cons "interrupt" (lambda (self . _) jolt-nil))
(cons "setDaemon" (lambda (self . _) jolt-nil))))
(define (make-jlatch n) (make-jhost "count-down-latch" (vector n (make-mutex) (make-condition))))
(for-each (lambda (nm) (register-class-ctor! nm (lambda (n . _) (make-jlatch (jnum->exact n)))))
'("CountDownLatch" "java.util.concurrent.CountDownLatch"))
(register-host-methods! "count-down-latch"
(list (cons "countDown" (lambda (self)
(let ((st (jhost-state self)))
(with-mutex (vector-ref st 1)
(when (> (vector-ref st 0) 0) (vector-set! st 0 (- (vector-ref st 0) 1)))
(when (= (vector-ref st 0) 0) (condition-broadcast (vector-ref st 2)))))
jolt-nil))
(cons "await" (lambda (self . _)
(let ((st (jhost-state self)))
(with-mutex (vector-ref st 1)
(let loop () (when (> (vector-ref st 0) 0) (condition-wait (vector-ref st 2) (vector-ref st 1)) (loop)))))
jolt-nil))
(cons "getCount" (lambda (self) (vector-ref (jhost-state self) 0)))))
;; --- main-thread executor ---------------------------------------------------
;; Lets a worker thread (e.g. an nREPL eval future) run a thunk on the thread
;; that owns the GUI main loop. On macOS GTK quartz, g_application_run must run
;; on the process main thread or AppKit aborts (setMainMenu off-main → SIGABRT).
;; Under `joltc nrepl` the accept loop is backgrounded in a future and the
;; primordial thread enters jolt-run-main-pump; glimmer's run marshals its
;; startup through jolt-call-on-main-thread.
;;
;; - With no pump running (`joltc -M:run` calls run directly on the main thread),
;; call-on-main-thread runs the thunk INLINE — unchanged behaviour.
;; - A call from a thunk already executing on the pump runs inline too, so the
;; pump can't deadlock on itself.
;; - Otherwise the thunk is enqueued; the caller blocks until the pump runs it,
;; then receives the value, or the thrown condition is re-raised.
;;
;; stop-main-pump is the graceful-shutdown / external API: it tells the pump to
;; drain whatever is queued and return. The pump-active flag is flipped to #f
;; under jolt-main-queue-mu in the same critical section that decides to exit, and
;; call-on-main-thread reads that flag and enqueues under the SAME mutex, so a job
;; can never slip in after the pump has decided to leave — a call that loses the
;; race simply runs inline instead of blocking forever on a pump that is gone.
(define jolt-main-queue-mu (make-mutex))
(define jolt-main-queue-cv (make-condition))
(define jolt-main-queue '()) ; FIFO of jolt-main-job, guarded by mu
(define jolt-main-pump-active (box #f)) ; #t while run-main-pump owns this thread
(define jolt-main-pump-stop (box #f)) ; set by stop-main-pump to drain + exit
;; thread-local: this thread is the pump, mid-thunk → nested calls run inline.
(define jolt-in-main-pump? (make-thread-parameter #f))
(define-record-type jolt-main-job
(fields thunk (mutable done?) (mutable ok?) (mutable val) mu cv)
(nongenerative jolt-main-job-v1))
(define (jolt-call-on-main-thread thunk)
(if (jolt-in-main-pump?) ; reentrant — already on the pump
(jolt-invoke thunk)
;; Decide-and-enqueue atomically: read pump-active and (if active) push the
;; job under jolt-main-queue-mu, the same lock the pump holds when it flips
;; active to #f on exit. So we either get queued before the pump leaves, or
;; we see #f and fall through to inline — never enqueue onto a dead pump.
(let ((job (with-mutex jolt-main-queue-mu
(and (unbox jolt-main-pump-active)
(let ((j (make-jolt-main-job thunk #f #f jolt-nil
(make-mutex) (make-condition))))
(set! jolt-main-queue (append jolt-main-queue (list j)))
(condition-signal jolt-main-queue-cv)
j)))))
(if (not job)
(jolt-invoke thunk) ; no pump (or stopped) — inline, like -M:run
(begin
(with-mutex (jolt-main-job-mu job)
(let wait ()
(unless (jolt-main-job-done? job)
(condition-wait (jolt-main-job-cv job) (jolt-main-job-mu job))
(wait))))
(if (jolt-main-job-ok? job)
(jolt-main-job-val job)
(raise (jolt-main-job-val job))))))))
(define jolt-pump-kih
(lambda ()
(for-each (lambda (th) (guard (e (#t #f)) (th)))
(reverse (unbox jolt-shutdown-hooks)))
(exit 0)))
;; Park the calling thread until a keyboard interrupt (^C), then run the shutdown
;; hooks and exit. Unlike run-main-pump (whose tight recursive condition-wait
;; loop elides Chez's interrupt poll points, so the handler never fires), this
;; uses a single condition-wait — the form Chez reliably interrupts. The nREPL
;; server parks here; SIGINT is unblocked in this thread first (it was masked by
;; jolt-block-sigint so the accept loop inherited a blocked mask and couldn't
;; absorb ^C in its foreign accept() call).
(define jolt-park-mu (make-mutex))
(define jolt-park-cv (make-condition))
(define (jolt-park-until-interrupt)
(keyboard-interrupt-handler jolt-pump-kih)
(jolt-set-sigint-blocked #f)
(with-mutex jolt-park-mu (condition-wait jolt-park-cv jolt-park-mu))
jolt-nil)
(define (jolt-run-main-pump)
(with-mutex jolt-main-queue-mu
(set-box! jolt-main-pump-stop #f)
(set-box! jolt-main-pump-active #t))
;; dynamic-wind guarantees active is cleared even if the pump escapes abnormally,
;; so a later run-main-pump starts clean and call-on-main-thread never sees a
;; stale #t. The clean-exit path below also clears it under the mutex (the flip
;; that races call-on-main-thread); this is the belt-and-suspenders for escapes.
(dynamic-wind
(lambda () #f)
(lambda ()
(let loop ()
(let ((job (with-mutex jolt-main-queue-mu
(let wait ()
(cond
((not (null? jolt-main-queue))
(let ((j (car jolt-main-queue)))
(set! jolt-main-queue (cdr jolt-main-queue))
j))
((unbox jolt-main-pump-stop)
;; drain done, told to exit — clear active in the same
;; critical section so no job can be enqueued after.
(set-box! jolt-main-pump-active #f)
#f)
(else (condition-wait jolt-main-queue-cv jolt-main-queue-mu)
(wait)))))))
(when job
(let ((r (dynamic-wind
(lambda () (jolt-in-main-pump? #t))
(lambda ()
(guard (e (#t (cons #f e)))
(cons #t (jolt-invoke (jolt-main-job-thunk job)))))
(lambda () (jolt-in-main-pump? #f)))))
(with-mutex (jolt-main-job-mu job)
(jolt-main-job-ok?-set! job (car r))
(jolt-main-job-val-set! job (cdr r))
(jolt-main-job-done?-set! job #t)
(condition-broadcast (jolt-main-job-cv job))))
(loop)))))
(lambda ()
(with-mutex jolt-main-queue-mu (set-box! jolt-main-pump-active #f))))
jolt-nil)
(define (jolt-stop-main-pump)
(with-mutex jolt-main-queue-mu
(set-box! jolt-main-pump-stop #t)
(condition-broadcast jolt-main-queue-cv))
jolt-nil)
;; Shutdown hooks run by jolt-pump-kih (the keyboard-interrupt-handler installed by
;; park-until-interrupt) before (exit 0), so a foreground server (nREPL) can close
;; its socket and drop .nrepl-port on ^C instead of Chez's default mutex-corrupting
;; abort. Newest-first; each hook is isolated so one failing hook can't block the exit.
(define jolt-shutdown-hooks (box '()))
(define (jolt-add-shutdown-hook thunk)
(set-box! jolt-shutdown-hooks (cons thunk (unbox jolt-shutdown-hooks)))
jolt-nil)
;; Per-thread SIGINT mask. A worker thread parked in a foreign call (the nREPL
;; accept loop in c-accept, or a conn handler) can't run Chez's keyboard-interrupt
;; handler on ^C, so if SIGINT is delivered there the process hangs. Block SIGINT
;; in the primordial thread BEFORE forking such workers (they inherit the mask),
;; then park-until-interrupt unblocks it in the primordial once its handler is
;; installed, so ^C is always delivered to the parked thread. pthread_sigmask/
;; sigaddset are libc/libpthread symbols, resolvable once the process object is
;; loaded (as the socket fns already are). 128 bytes covers Linux's 1024-bit
;; sigset_t and is larger than macOS's 4-byte one.
;; foreign-procedure resolves its symbol eagerly, and these POSIX signal fns don't
;; exist on Windows — resolving them unguarded aborted startup ("no entry for
;; pthread_sigmask"). Guard so a non-POSIX host yields #f; jolt-set-sigint-blocked
;; then no-ops (Windows delivers ^C through the console, not a per-thread mask).
(define c-pthread-sigmask
(jolt-foreign-proc-safe "pthread_sigmask" '(int u8* u8*) 'int))
(define c-sigemptyset (jolt-foreign-proc-safe "sigemptyset" '(u8*) 'int))
(define c-sigaddset (jolt-foreign-proc-safe "sigaddset" '(u8* int) 'int))
;; POSIX SIG_BLOCK/SIG_UNBLOCK numerics differ by platform: Linux/glibc 0/1,
;; Darwin/macOS 1/2 (SIG_UNBLOCK is SIG_BLOCK+1 on both). Resolve SIG_BLOCK for
;; this host from the machine-type symbol — macOS builds contain "osx".
(define jolt-sig-block-how
(let* ((s (symbol->string (machine-type)))
(n (string-length s)))
(let loop ((i 0))
(cond
((> (+ i 3) n) 0) ; default: Linux/glibc
((string=? (substring s i (+ i 3)) "osx") 1) ; Darwin/macOS
(else (loop (+ i 1)))))))
(define (jolt-set-sigint-blocked block?)
(when (and c-pthread-sigmask c-sigemptyset c-sigaddset)
(let ((set (make-bytevector 128 0))
(old (make-bytevector 128 0)))
(c-sigemptyset set)
(c-sigaddset set 2) ; SIGINT = 2
(c-pthread-sigmask (if block? jolt-sig-block-how (+ jolt-sig-block-how 1)) set old)))
jolt-nil)
(def-var! "jolt.host" "call-on-main-thread" jolt-call-on-main-thread)
(def-var! "jolt.host" "run-main-pump" jolt-run-main-pump)
(def-var! "jolt.host" "stop-main-pump" jolt-stop-main-pump)
(def-var! "jolt.host" "add-shutdown-hook" jolt-add-shutdown-hook)
(def-var! "jolt.host" "block-sigint" (lambda () (jolt-set-sigint-blocked #t)))
(def-var! "jolt.host" "park-until-interrupt" jolt-park-until-interrupt)
(def-var! "jolt.host" "delete-file" delete-file)

View file

@ -17,8 +17,6 @@
;; A record (jrec) is jolt-map? here (records.ss makes it so) and a collection,
;; so its protocol method (no dash, not a coll method) lands in the base.
(define %dot-rmd record-method-dispatch)
;; Vectors / maps / sets only (records are jolt-map? here). Raw seqs are excluded:
;; coll-interop accepts some seq representations and not others (a
;; plain (seq v) returns nil from .count, a lazy-seq returns the count), an
@ -38,11 +36,36 @@
((or (string=? name "get") (string=? name "valAt"))
(list (apply jolt-get obj args)))
((string=? name "containsKey") (list (jolt-contains? obj (car args))))
;; java.util.Collection.contains(o): VALUE membership (a set is O(1) via
;; contains?; a list/vector/seq is a linear scan — contains? on a vector tests
;; an index, so it is wrong here).
((string=? name "contains")
(list (if (pset? obj)
(jolt-contains? obj (car args))
(let ((x (car args)))
(let loop ((s (jolt-seq obj)))
(cond ((jolt-nil? s) #f)
((jolt=2 (seq-first s) x) #t)
(else (loop (jolt-seq (seq-more s))))))))))
((string=? name "size") (list (jolt-count obj)))
((string=? name "isEmpty") (list (jolt-empty? obj)))
;; java.util.Map views: keySet (a Set), values (a Collection), entrySet.
((and (jolt-map? obj) (string=? name "keySet"))
(list (apply jolt-hash-set (seq->list (jolt-keys obj)))))
((and (jolt-map? obj) (string=? name "values"))
(list (apply jolt-vector (seq->list (jolt-vals obj)))))
((and (jolt-map? obj) (string=? name "entrySet")) (list (jolt-seq obj)))
;; (.iterator coll): a java.util.Iterator over the seq — for a map this is the
;; entry iterator. Without this a map's .iterator falls into the map-as-object
;; branch and is mis-read as a missing :iterator key (nil). Some libraries
;; (e.g. malli's -vmap) iterate a map this way.
((string=? name "iterator") (list (make-jiterator (jolt-seq obj))))
;; (.reduce coll f) / (.reduce coll f init): clojure.lang.IReduce — every
;; persistent collection reduces itself on the JVM.
((string=? name "reduce")
(list (if (pair? (cdr args))
(jolt-reduce (car args) (cadr args) obj)
(jolt-reduce (car args) obj))))
(else #f)))
;; Universal object-methods: on a
@ -65,7 +88,7 @@
((string=? name "equals") (list (if (jolt= obj (car args)) #t #f)))
(else #f)))
(set! record-method-dispatch
(register-method-arm! 30
(lambda (obj method-name rest-args)
(let* ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args)))
(field? (and (> (string-length method-name) 0)
@ -74,12 +97,45 @@
(substring method-name 1 (string-length method-name))
method-name)))
(cond
;; (.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 'pass)))
;; (.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)
(cond
((string=? mname "contains") (if (jolt-truthy? (t-contains? obj (car rest))) #t #f))
((or (string=? mname "valAt") (string=? mname "get"))
(t-get obj (car rest) (if (null? (cdr rest)) jolt-nil (cadr rest))))
((string=? mname "count") (t-count obj))
(else 'pass)))
;; a deftype/record's OWN declared method (matched by name AND arity) wins
;; over the generic collection interop below — e.g. data.priority-map
;; declares both seq[this] (Seqable) and seq[this ascending] (Sorted), and
;; (.seq pm false) must reach the 2-arg one, not dot-coll's plain seq.
((and (not field?) (jrec? obj)
(find-method-any-protocol-arity (jrec-tag obj) mname (+ 1 (length rest))))
=> (lambda (f) (apply jolt-invoke f obj rest)))
;; collection interop first (entry count / seq / nth / get / containsKey).
((and (dot-coll? obj) (dot-coll-method obj mname rest))
=> (lambda (box) (car box)))
;; clojure.lang.Sorted (comparator / entryKey / seqFrom) on a sorted
;; map/set, before the map arm below reads the method name as a key.
;; data.priority-map's subseq/rsubseq reach for these.
((and (not field?) (htable-sorted? obj) (sorted-iface-method? mname))
(sorted-iface-dispatch obj mname rest))
;; (.-field obj) / (. obj -field): field read on a record or map.
(field? (jolt-get obj (keyword #f mname) jolt-nil))
;; non-record map: a universal object-method (getMessage/...) wins first,
@ -90,4 +146,4 @@
(else
(let ((v (jolt-get obj (keyword #f mname) jolt-nil)))
(if (procedure? v) (apply jolt-invoke v obj rest) v)))))
(else (%dot-rmd obj method-name rest-args))))))
(else 'pass)))))

View file

@ -35,25 +35,86 @@
((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).
((ex-info-map? x) (ex-info-class x))
;; persistent collections + namespace report their JVM class names (not jolt's
;; internal :vector/:set/… type keyword), so class-based dispatch — e.g. a
;; defmulti on [(class a) (class b)] — sees a real clojure.lang.* class.
((jns? x) "clojure.lang.Namespace")
((pvec? x) "clojure.lang.PersistentVector")
((pset? x) "clojure.lang.PersistentHashSet")
((pmap? x) "clojure.lang.PersistentArrayMap")
((jolt-lazyseq? x) "clojure.lang.LazySeq")
((empty-list-t? x) "clojure.lang.PersistentList$EmptyList")
((cseq? x) "clojure.lang.PersistentList")
(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.
;; a raw Chez condition Clojure raises a specific class for (records-interop.ss
;; chez-condition-exc-class) reports that JVM class, so (class e) and a
;; (thrown? ArityException …) test match — not the opaque :object fallback.
(register-class-arm!
(lambda (x) (and (chez-condition-exc-class x) #t))
(lambda (x) (let ((p (assoc (chez-condition-exc-class x) class-token-alist)))
(if p (cdr p) "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))
(((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)
;; The PUBLIC clojure.core/type — Clojure's (or (:type meta) (class x)). This is the
;; java host layer's job: the core taxonomy (natives-meta.ss jolt-type, kept under
;; __type-tag for print-method) is JVM-free, and the JVM class mapping lives HERE,
;; next to (class …). The inst/array/byte-buffer host files extend `class` (a
;; class-arm or jolt-type fallthrough) and re-point `type` at this same fn, so the
;; remap of every value — :jolt/inst -> java.util.Date etc. — happens in one place.
(define ty-meta-key (keyword #f "type"))
(define (jolt-type-pub x)
(let* ((m (jolt-meta x))
(override (if (jolt-nil? m) jolt-nil (jolt-get m ty-meta-key jolt-nil))))
(if (not (jolt-nil? override)) override (jolt-class x))))
(def-var! "clojure.core" "type" jolt-type-pub)
;; bare class-name tokens -> canonical JVM class-name strings.
(define class-token-alist
'(("String" . "java.lang.String") ("Number" . "java.lang.Number")
("Boolean" . "java.lang.Boolean") ("Long" . "java.lang.Long")
("Integer" . "java.lang.Integer") ("Double" . "java.lang.Double")
("Float" . "java.lang.Float") ("Byte" . "java.lang.Byte") ("Short" . "java.lang.Short")
("Object" . "java.lang.Object") ("Character" . "java.lang.Character")
("InputStream" . "java.io.InputStream") ("OutputStream" . "java.io.OutputStream")
("File" . "java.io.File") ("Reader" . "java.io.Reader") ("Writer" . "java.io.Writer")
@ -65,6 +126,7 @@
("Charset" . "java.nio.charset.Charset") ("Base64" . "java.util.Base64")
("Exception" . "java.lang.Exception")
("IllegalArgumentException" . "java.lang.IllegalArgumentException")
("ArityException" . "clojure.lang.ArityException")
("IllegalStateException" . "java.lang.IllegalStateException")
("RuntimeException" . "java.lang.RuntimeException")
("UnsupportedOperationException" . "java.lang.UnsupportedOperationException")
@ -87,7 +149,20 @@
("IndexOutOfBoundsException" . "java.lang.IndexOutOfBoundsException")
("UnsupportedEncodingException" . "java.io.UnsupportedEncodingException")
("FileNotFoundException" . "java.io.FileNotFoundException")
("Throwable" . "java.lang.Throwable")))
("Throwable" . "java.lang.Throwable")
;; clojure.lang / java.util types that class-based multimethods dispatch on.
("Fn" . "clojure.lang.Fn") ("IFn" . "clojure.lang.IFn")
("Namespace" . "clojure.lang.Namespace") ("Named" . "clojure.lang.Named")
("Set" . "java.util.Set") ("List" . "java.util.List") ("Map" . "java.util.Map")
("Collection" . "java.util.Collection") ("Iterable" . "java.lang.Iterable")
("CharSequence" . "java.lang.CharSequence") ("Comparable" . "java.lang.Comparable")
("Runnable" . "java.lang.Runnable") ("Callable" . "java.util.concurrent.Callable")
("IPersistentSet" . "clojure.lang.IPersistentSet")
("IPersistentVector" . "clojure.lang.IPersistentVector")
("IPersistentMap" . "clojure.lang.IPersistentMap")
("IPersistentCollection" . "clojure.lang.IPersistentCollection")
("Sequential" . "clojure.lang.Sequential") ("Seqable" . "clojure.lang.Seqable")
("Associative" . "clojure.lang.Associative")))
(for-each
(lambda (pair) (def-var! "clojure.core" (car pair) (cdr pair)))
class-token-alist)
@ -109,6 +184,7 @@
(for-each
(lambda (nm) (def-var! "clojure.core" nm nm))
'("java.lang.Long" "java.lang.Integer" "java.lang.Double" "java.lang.Float"
"java.lang.Byte" "java.lang.Short"
"java.lang.Number" "java.lang.String" "java.lang.Boolean" "java.lang.Character"
"java.lang.Object"
;; exception classes compared against (class e): (= java.net.SocketTimeoutException (class e))
@ -123,7 +199,7 @@
"java.lang.IndexOutOfBoundsException" "java.io.FileNotFoundException"
"java.io.UnsupportedEncodingException"
;; clojure.lang.ExceptionInfo / IExceptionInfo compared against (class e)
"clojure.lang.ExceptionInfo" "clojure.lang.IExceptionInfo"
"clojure.lang.ExceptionInfo" "clojure.lang.IExceptionInfo" "clojure.lang.ArityException"
"java.util.regex.Pattern" "java.net.URI" "java.util.UUID"
"clojure.lang.PersistentQueue"
"clojure.lang.Keyword" "clojure.lang.Symbol" "clojure.lang.Ratio" "clojure.lang.Atom"))

View file

@ -50,7 +50,7 @@
(cond ((null? args) (make-arraylist '()))
((number? (car args)) (make-arraylist '()))
(else (make-arraylist (seq->list (jolt-seq (car args))))))))
(register-host-methods! "arraylist"
(define arraylist-methods
(list
(cons "add" (lambda (self . a)
;; (.add x) -> append+true; (.add i x) -> insert at i, returns nil.
@ -58,6 +58,14 @@
(begin (al-push! self (car a)) #t)
(begin (al-insert-at! self (jnum->exact (car a)) (cadr a)) jolt-nil))))
(cons "add!" (lambda (self x) (al-push! self x) #t))
(cons "addAll" (lambda (self . a)
;; (.addAll coll) appends; (.addAll i coll) inserts at i.
(let* ((at-i (= 2 (length a)))
(i (if at-i (jnum->exact (car a)) (al-cnt self)))
(coll (if at-i (cadr a) (car a))))
(let loop ((xs (seq->list (jolt-seq coll))) (k i))
(if (null? xs) (pair? (seq->list (jolt-seq coll)))
(begin (al-insert-at! self k (car xs)) (loop (cdr xs) (fx+ k 1))))))))
(cons "get" (lambda (self i) (vector-ref (al-vec self) (jnum->exact i))))
(cons "set" (lambda (self i x)
(let* ((idx (jnum->exact i)) (old (vector-ref (al-vec self) idx)))
@ -72,6 +80,43 @@
(cons "toArray" (lambda (self . _) (apply jolt-vector (al->list self))))
(cons "iterator" (lambda (self) (make-jiterator (list->cseq (al->list self)))))
(cons "toString" (lambda (self) (jolt-pr-str (list->cseq (al->list self)))))))
(register-host-methods! "arraylist" arraylist-methods)
;; java.util.LinkedList: the ArrayList backing plus the Deque surface
;; (addFirst/addLast/removeFirst/removeLast/getFirst/getLast/peek/push/pop).
;; tools.reader holds pending splice forms in one and (seq)s / .remove(0)s it.
(define (al-first self) (vector-ref (al-vec self) 0))
(define (al-last self) (vector-ref (al-vec self) (fx- (al-cnt self) 1)))
(define linkedlist-methods
(append arraylist-methods
(list
(cons "addFirst" (lambda (self x) (al-insert-at! self 0 x) jolt-nil))
(cons "addLast" (lambda (self x) (al-push! self x) jolt-nil))
(cons "offer" (lambda (self x) (al-push! self x) #t))
(cons "removeFirst" (lambda (self) (let ((o (al-first self))) (al-remove-at! self 0) o)))
(cons "removeLast" (lambda (self) (let ((o (al-last self))) (al-remove-at! self (fx- (al-cnt self) 1)) o)))
(cons "getFirst" al-first) (cons "getLast" al-last)
(cons "peek" (lambda (self) (if (fx=? 0 (al-cnt self)) jolt-nil (al-first self))))
(cons "poll" (lambda (self) (if (fx=? 0 (al-cnt self)) jolt-nil (let ((o (al-first self))) (al-remove-at! self 0) o))))
(cons "push" (lambda (self x) (al-insert-at! self 0 x) jolt-nil))
(cons "pop" (lambda (self) (let ((o (al-first self))) (al-remove-at! self 0) o))))))
(define (make-linkedlist xs)
(let ((al (make-arraylist xs))) (make-jhost "linkedlist" (jhost-state al))))
(register-host-methods! "linkedlist" linkedlist-methods)
(let ((ctor (lambda args
(cond ((null? args) (make-linkedlist '()))
(else (make-linkedlist (seq->list (jolt-seq (car args)))))))))
(register-class-ctor! "LinkedList" ctor)
(register-class-ctor! "java.util.LinkedList" ctor))
;; ArrayList / LinkedList are Iterable: (seq al) walks the elements (nil if empty),
;; so (seq pending-forms) and reduce/into over one work like the JVM.
(define %al-seq jolt-seq)
(set! jolt-seq
(lambda (x)
(if (and (jhost? x) (or (string=? (jhost-tag x) "arraylist") (string=? (jhost-tag x) "linkedlist")))
(list->cseq (al->list x))
(%al-seq x))))
;; Appendable.append text: append(x) renders x; append(csq,start,end) appends the
;; subsequence csq[start,end) (data.json's writer appends string runs this way).
@ -109,6 +154,9 @@
(cons "flush" (lambda (self) jolt-nil))
(cons "close" (lambda (self) jolt-nil))
(cons "toString" (lambda (self) (sb-str self)))))
;; (str sw) / print a StringWriter -> its accumulated content, like the JVM
;; (str calls toString) — data.csv writes CSV to a StringWriter and reads it back.
(register-str-render! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "writer"))) sb-str)
;; a file-backed writer (clojure.java.io/writer of a File/path): accumulates like
;; StringWriter, then persists to the path on flush/close, so
@ -128,14 +176,26 @@
;; push to the port (so (.write *out* s) and (binding [*out* *err*] …) work);
;; it isn't a buffer, so toString is empty. Lets libraries that touch *out*/*err*
;; (tools.logging, selmer) compile and run.
;; *out*/*err* resolve their port LIVE — 'out -> (current-output-port), 'err ->
;; (current-error-port) — so a (.write *out* …) / (.flush *out*) follows a
;; with-out-str redirect (with-output-to-string rebinds current-output-port) the
;; same way print/__write do. Storing the startup port instead pinned *out* to the
;; real stdout, so rewrite-clj's (z/print) — which writes via *out* — escaped the
;; capture. A stored port object (should any other code make a port-writer) is used
;; as-is.
(define (port-writer-port self)
(let ((p (vector-ref (jhost-state self) 0)))
(cond ((eq? p 'out) (current-output-port))
((eq? p 'err) (current-error-port))
(else p))))
(register-host-methods! "port-writer"
(list (cons "write" (lambda (self x) (display (writer-piece x) (vector-ref (jhost-state self) 0)) jolt-nil))
(cons "append" (lambda (self x . rest) (display (append-text x rest) (vector-ref (jhost-state self) 0)) self))
(cons "flush" (lambda (self) (flush-output-port (vector-ref (jhost-state self) 0)) jolt-nil))
(list (cons "write" (lambda (self x) (display (writer-piece x) (port-writer-port self)) jolt-nil))
(cons "append" (lambda (self x . rest) (display (append-text x rest) (port-writer-port self)) self))
(cons "flush" (lambda (self) (flush-output-port (port-writer-port self)) jolt-nil))
(cons "close" (lambda (self) jolt-nil))
(cons "toString" (lambda (self) ""))))
(def-var! "clojure.core" "*out*" (make-jhost "port-writer" (vector (current-output-port))))
(def-var! "clojure.core" "*err*" (make-jhost "port-writer" (vector (current-error-port))))
(def-var! "clojure.core" "*out*" (make-jhost "port-writer" (vector 'out)))
(def-var! "clojure.core" "*err*" (make-jhost "port-writer" (vector 'err)))
;; PrintWriter — a thin wrapper over a target writer. write/append/print forward
;; the rendered text to the target. clojure.data.json's pretty printer builds
@ -211,6 +271,68 @@
(vector->list (hashtable-keys (hm-tbl self)))))))
(cons "entrySet" (lambda (self) (jolt-seq (hm->pmap self))))
(cons "toString" (lambda (self) (jolt-pr-str (hm->pmap self))))))
;; java.util.concurrent.ConcurrentHashMap — one shared heap, so the mutable
;; HashMap shim serves. (get a-hashmap k) reads the map (clojure.core/get).
(define (make-hashmap-jhost . args)
(let ((ht (make-hashtable hm-hash jolt=2)))
(when (and (pair? args) (or (pmap? (car args)) (hm-hashmap? (car args)))) (hm-copy-into! ht (car args)))
(make-jhost "hashmap" (vector ht))))
(register-class-ctor! "ConcurrentHashMap" make-hashmap-jhost)
(register-class-ctor! "java.util.concurrent.ConcurrentHashMap" make-hashmap-jhost)
(register-get-arm! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "hashmap")))
(lambda (coll k d) (hashtable-ref (hm-tbl coll) k d)))
;; count / contains? over the mutable map shim (clojure.core/count + contains?,
;; which core.cache's SoftCache uses on its backing ConcurrentHashMap).
(define (jhost-hashmap? x) (and (jhost? x) (string=? (jhost-tag x) "hashmap")))
(let ((prev-count jolt-count) (prev-contains jolt-contains?))
(set! jolt-count (lambda (c) (if (jhost-hashmap? c) (hashtable-size (hm-tbl c)) (prev-count c))))
(set! jolt-contains? (lambda (c k) (if (jhost-hashmap? c)
(if (hashtable-contains? (hm-tbl c) k) #t #f)
(prev-contains c k)))))
;; ---- java.lang.ref.Soft/WeakReference + ReferenceQueue ----------------------
;; Real GC reclamation via Chez's generational collector: the referent is held
;; through a weak pair (collected once otherwise unreachable, leaving the bwp
;; object), and a guardian registered on the referent makes the reference itself
;; available the moment its referent is reclaimed — which the ReferenceQueue
;; surfaces as enqueued, exactly like the JVM. (Chez has no softer-than-weak
;; reference, so a SoftReference clears on unreachability rather than under memory
;; pressure — its SoftCache evicts more eagerly than the JVM's, but it is genuine
;; GC eviction, not an unbounded strong cache. Immediates like fixnums/keywords
;; are never collected.)
;; ref-queue state: #(guardian pending-list); reference state: #(weak-pair queue enqueued?).
(define (rq-guardian-of q) (vector-ref (jhost-state q) 0))
(define (rq-add! q ref)
(let ((st (jhost-state q))) (vector-set! st 1 (append (vector-ref st 1) (list ref)))))
(define (rq-pump! q) ; drain GC-reclaimed refs onto the list
(let loop ()
(let ((rep ((rq-guardian-of q)))) (when rep (rq-add! q rep) (loop)))))
(define (rq-poll q)
(rq-pump! q)
(let* ((st (jhost-state q)) (l (vector-ref st 1)))
(if (null? l) jolt-nil (begin (vector-set! st 1 (cdr l)) (car l)))))
(define (a-ref-queue? x) (and (jhost? x) (string=? (jhost-tag x) "ref-queue")))
(define (make-reference v rest)
(let* ((rq (if (pair? rest) (car rest) jolt-nil))
(ref (make-jhost "weak-ref" (vector (weak-cons v #f) rq #f))))
(when (a-ref-queue? rq) ((rq-guardian-of rq) v ref)) ; fire on the referent's collection
ref))
(for-each (lambda (nm) (register-class-ctor! nm (lambda (v . rest) (make-reference v rest))))
'("SoftReference" "java.lang.ref.SoftReference" "WeakReference" "java.lang.ref.WeakReference"))
(register-host-methods! "weak-ref"
(list (cons "get" (lambda (self) (let ((r (car (vector-ref (jhost-state self) 0))))
(if (bwp-object? r) jolt-nil r))))
(cons "clear" (lambda (self) (set-car! (vector-ref (jhost-state self) 0) jolt-nil) jolt-nil))
(cons "isEnqueued" (lambda (self) (vector-ref (jhost-state self) 2)))
(cons "enqueue" (lambda (self)
(let* ((st (jhost-state self)) (rq (vector-ref st 1)))
(if (vector-ref st 2) #f
(begin (vector-set! st 2 #t) (when (a-ref-queue? rq) (rq-add! rq self)) #t)))))))
(for-each (lambda (nm) (register-class-ctor! nm (lambda _ (make-jhost "ref-queue" (vector (make-guardian) '())))))
'("ReferenceQueue" "java.lang.ref.ReferenceQueue"))
(register-host-methods! "ref-queue"
(list (cons "poll" (lambda (self . _) (rq-poll self)))
(cons "remove" (lambda (self . _) (rq-poll self)))))
;; ---- StringReader -----------------------------------------------------------
;; state: a vector #(string pos marked).
@ -265,6 +387,11 @@
;; state: a vector #(wrapped-reader pushed-list)
(register-class-ctor! "PushbackReader"
(lambda (rdr . _) (make-jhost "pushback-reader" (vector rdr '()))))
;; Fully-qualified aliases so (java.io.PushbackReader. …) / (java.io.StringReader. …)
;; resolve to these built-ins even when a library defines a deftype of the same
;; simple name (tools.reader), which would otherwise take the bare-name slot.
(register-class-ctor! "java.io.PushbackReader" (lookup-class class-ctors-tbl "PushbackReader"))
(register-class-ctor! "java.io.StringReader" (lookup-class class-ctors-tbl "StringReader"))
;; LineNumberingPushbackReader: a pushback-reader (jolt doesn't track line
;; numbers; getLineNumber is a stub for error-reporting paths that read it).
(register-class-ctor! "LineNumberingPushbackReader"
@ -328,7 +455,15 @@
(let ((toks (vector-ref (jhost-state self) 0)) (p (vector-ref (jhost-state self) 1)))
(if (< p (length toks))
(begin (vector-set! (jhost-state self) 1 (+ p 1)) (list-ref toks p))
(error #f "NoSuchElementException")))))))
(jolt-throw (jolt-host-throwable "java.util.NoSuchElementException" "no more tokens"))))))
;; StringTokenizer implements java.util.Enumeration — enumeration-seq drives
;; it through these, so alias them onto the token methods.
(cons "hasMoreElements" (lambda (self) (< (vector-ref (jhost-state self) 1) (length (vector-ref (jhost-state self) 0)))))
(cons "nextElement" (lambda (self)
(let ((toks (vector-ref (jhost-state self) 0)) (p (vector-ref (jhost-state self) 1)))
(if (< p (length toks))
(begin (vector-set! (jhost-state self) 1 (+ p 1)) (list-ref toks p))
(jolt-throw (jolt-host-throwable "java.util.NoSuchElementException" "no more tokens"))))))))
;; ---- String / BigInteger / MapEntry constructors ----------------------------
;; (String. bytes [charset]) decodes bytes (a bytevector OR a jolt byte-array)
@ -371,8 +506,12 @@
(list->string (vector->list v)))))
((string? x) x)
(else (jolt-str-render-one x)))))
;; (BigInteger. s) | (BigInteger. s radix) — parse a string in the given radix
;; (default 10). tools.reader's integer parser builds (BigInteger. digits radix).
(register-class-ctor! "BigInteger"
(lambda (v) (parse-int-or-throw v 10 "BigInteger")))
(lambda (v . r) (parse-int-or-throw v (if (null? r) 10 (jnum->exact (car r))) "BigInteger")))
(register-class-ctor! "java.math.BigInteger"
(lambda (v . r) (parse-int-or-throw v (if (null? r) 10 (jnum->exact (car r))) "BigInteger")))
(register-class-ctor! "MapEntry" (lambda (k v) (make-map-entry k v)))
;; JVM exception ctors -> a typed host throwable carrying the canonical :jolt/class
;; (so class / instance? / getMessage / ex-message reflect the real type) and the
@ -394,7 +533,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)
@ -502,20 +642,31 @@
;; record-method-dispatch already routes string? -> jolt-string-method. Add a
;; regex-t arm (Pattern .split / .matcher-less surface used by corpus) by wrapping
;; once more — a regex-t isn't a jhost.
(define %hs-rmd2 record-method-dispatch)
(set! record-method-dispatch
(register-method-arm! 42
(lambda (obj method-name rest-args)
(if (regex-t? obj)
(let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
(cond ((string=? method-name "split")
;; .split returns a String[] — a seq (prints
;; (a b c), not a vector). re-split with no limit; drop trailing
;; empties (JVM default).
(let ((parts (re-split (regex-t-irx obj) (car rest) #f)))
(list->cseq (str-split-drop-trailing parts))))
((string=? method-name "pattern") (regex-t-source obj))
(else (error #f (string-append "No method " method-name " on Pattern")))))
(%hs-rmd2 obj method-name rest-args))))
(let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
(cond
((regex-t? obj)
(cond ((string=? method-name "split")
;; .split returns a String[] — a seq (prints
;; (a b c), not a vector). re-split with no limit; drop trailing
;; empties (JVM default).
(let ((parts (re-split (regex-t-irx obj) (car rest) #f)))
(list->cseq (str-split-drop-trailing parts))))
((string=? method-name "pattern") (regex-t-source obj))
((or (string=? method-name "toString")) (regex-t-source obj))
;; (.matcher pattern s) -> a Matcher (matcher-t) for stepping matches.
((string=? method-name "matcher") (jolt-re-matcher obj (car rest)))
(else (error #f (string-append "No method " method-name " on Pattern")))))
;; java.util.regex.Matcher: .matches (anchored whole-region), .find
;; (next match), .group [n], .groupCount.
((jolt-matcher? obj)
(cond ((string=? method-name "matches") (jolt-matcher-matches obj))
((string=? method-name "find") (not (jolt-nil? (jolt-re-find obj))))
((string=? method-name "group") (apply jolt-matcher-group obj rest))
((string=? method-name "groupCount") (jolt-matcher-group-count obj))
(else (error #f (string-append "No method " method-name " on Matcher")))))
(else 'pass)))))
;; ---- def-var! the registry entry points so emit can also reach them ---------
(def-var! "clojure.core" "host-static-ref" host-static-ref)
@ -557,19 +708,34 @@
;; htable arm: dispatch (.method obj a*) through the table's tag method registry;
;; an unregistered method falls through (sorted colls are htables too).
(define %hs-rmd-htable record-method-dispatch)
(set! record-method-dispatch
(register-method-arm! 43
(lambda (obj method-name rest-args)
(let ((tag (and (htable? obj) (hashtable-ref (htable-h obj) "jolt/type" #f))))
(let* ((mh (and tag (hashtable-ref tagged-methods-tbl (tag->method-key tag) #f)))
(f (and mh (hashtable-ref mh method-name #f))))
(if f
(apply f obj (if (jolt-nil? rest-args) '() (seq->list rest-args)))
(%hs-rmd-htable obj method-name rest-args))))))
'pass)))))
(def-var! "clojure.core" "__register-class-methods!"
(lambda (tag members) (register-tagged-methods! tag (jmap->static-alist members)) jolt-nil))
;; java.lang.ThreadLocal via a Chez thread-parameter: real per-thread storage with
;; a lazy initialValue (the proxy macro lowers (proxy [ThreadLocal] …) to this).
;; .get returns the thread's value, computing initialValue once; .set / .remove.
(define tl-unset (list 'tl-unset))
(define (jolt-make-thread-local init-thunk)
(make-jhost "threadlocal" (vector (make-thread-parameter tl-unset) init-thunk)))
(register-host-methods! "threadlocal"
(list (cons "get" (lambda (self)
(let* ((st (jhost-state self)) (tp (vector-ref st 0)) (v (tp)))
(if (eq? v tl-unset)
(let ((nv (jolt-invoke (vector-ref st 1)))) (tp nv) nv)
v))))
(cons "set" (lambda (self v) ((vector-ref (jhost-state self) 0) v) jolt-nil))
(cons "remove" (lambda (self) ((vector-ref (jhost-state self) 0) tl-unset) jolt-nil))))
(def-var! "jolt.host" "make-thread-local" jolt-make-thread-local)
;; Pluggable instance? — a library registers (fn [class-name-string val] -> true
;; | false | nil); nil means "not my class, fall through". First non-nil wins.
(define user-instance-checks '())
@ -595,10 +761,16 @@
;; values that carry metadata (mirrors jolt-with-meta's set in natives-meta.ss).
(define (hsc-imeta? x)
(or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x)
(jolt-lazyseq? x) (jrec? x) (procedure? x) (symbol-t? x)))
(jolt-lazyseq? x) (jrec? x) (jreify? x) (procedure? x) (symbol-t? x)))
(register-instance-check-arm!
(lambda (type-sym val)
(let ((iface (hsc-last-segment (symbol-t-name type-sym))))
;; the value's own class-graph tags (value-host-tags) are authoritative — the
;; SAME source protocol dispatch reads, so instance? and extend-protocol can't
;; disagree about the interfaces a builtin implements.
(if (let ((tags (value-host-tags val)))
(or (member (symbol-t-name type-sym) tags) (member iface tags)))
#t
(let ((hit (cond
((or (string=? iface "IObj") (string=? iface "IMeta")) (hsc-imeta? val))
((or (string=? iface "IMapEntry") (string=? iface "MapEntry")) (jolt-map-entry? val))
@ -606,8 +778,15 @@
((string=? iface "IPersistentMap") (or (pmap? val) (htable-sorted-map? val)))
((string=? iface "IPersistentVector") (and (pvec? val) (not (jolt-map-entry? val))))
((string=? iface "IPersistentSet") (or (pset? val) (htable-sorted-set? val)))
((or (string=? iface "ISeq") (string=? iface "Seqable"))
((string=? iface "ISeq")
(or (cseq? val) (empty-list-t? val) (jolt-lazyseq? val)))
((string=? iface "LazySeq") (jolt-lazyseq? val))
;; Seqable is anything (seq x) works on — every persistent
;; collection, not just seqs (a vector IS Seqable, not an ISeq).
((string=? iface "Seqable")
(or (cseq? val) (empty-list-t? val) (jolt-lazyseq? val)
(pvec? val) (pmap? val) (pset? val)
(htable-sorted-map? val) (htable-sorted-set? val)))
((string=? iface "Sequential")
(or (pvec? val) (cseq? val) (empty-list-t? val) (jolt-lazyseq? val)))
((string=? iface "IFn")
@ -631,6 +810,17 @@
((string=? iface "Associative")
(or (pmap? val) (htable-sorted-map? val)
(and (pvec? val) (not (jolt-map-entry? val)))))
;; ILookup (valAt): maps and vectors; Indexed (nth): vectors;
;; Counted: the counted collections. A deftype that declares one
;; is matched by type-satisfies? in instance-check-base.
((string=? iface "ILookup")
(or (pmap? val) (htable-sorted-map? val)
(and (pvec? val) (not (jolt-map-entry? val)))))
((string=? iface "Indexed")
(and (pvec? val) (not (jolt-map-entry? val))))
((string=? iface "Counted")
(or (pmap? val) (pset? val) (pvec? val)
(htable-sorted-map? val) (htable-sorted-set? val)))
;; reader jhosts — data.json re-wraps a reader in a new
;; PushbackReader unless (instance? PushbackReader r), so this
;; must hold for repeated reads from one reader to work.
@ -641,7 +831,283 @@
((or (string=? iface "Reader") (string=? iface "BufferedReader"))
(reader-jhost? val))
(else 'none))))
(if (eq? hit 'none) 'pass (if hit #t #f))))))
(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 <name>", pr -> "<name>", .getName -> "<name>"
;; — 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)
;; a deftype/defrecord NAME var holds its ctor; treat it as the class
((procedure? x) (hashtable-ref chez-deftype-ctor-tag x #f))
(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) #\[)))))
;; Class.isInstance(o) == (instance? class o); core.logic's deftype .equals
;; uses (.. this getClass (isInstance o)).
(cons "isInstance" (lambda (self o) (if (instance-check self o) #t #f)))
(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)))
;; --- java.util.Arrays -------------------------------------------------------
(let ((arrays-statics
(list
(cons "equals" (lambda (a b)
(cond ((and (jolt-nil? a) (jolt-nil? b)) #t)
((or (jolt-nil? a) (jolt-nil? b)) #f)
(else (equal? (jolt-array-vec a) (jolt-array-vec b))))))
(cons "fill" (lambda (a v) (vector-fill! (jolt-array-vec a) v) jolt-nil))
(cons "copyOf" (lambda (a n)
(let* ((src (jolt-array-vec a)) (len (jnum->exact n))
(out (make-vector len 0)))
(do ((i 0 (fx+ i 1))) ((fx=? i (min len (vector-length src))))
(vector-set! out i (vector-ref src i)))
(make-jolt-array out (jolt-array-kind a)))))
(cons "copyOfRange" (lambda (a from to)
(let* ((src (jolt-array-vec a)) (f (jnum->exact from)) (tt (jnum->exact to))
(len (- tt f)) (out (make-vector len 0)))
(do ((i 0 (fx+ i 1))) ((fx=? i len))
(vector-set! out i (vector-ref src (+ f i))))
(make-jolt-array out (jolt-array-kind a)))))
(cons "toString" (lambda (a) (jolt-pr-str (apply jolt-vector (vector->list (jolt-array-vec a)))))))))
(register-class-statics! "Arrays" arrays-statics)
(register-class-statics! "java.util.Arrays" arrays-statics))
;; --- java.util.Random -------------------------------------------------------
;; A non-cryptographic PRNG over Chez's `random`. A seed argument is accepted but
;; not honored for reproducibility (jolt has no seedable Random state); callers
;; that need determinism use SecureRandom or their own generator.
(for-each
(lambda (nm) (register-class-ctor! nm (lambda args (make-jhost "random" (vector)))))
'("Random" "java.util.Random"))
(register-host-methods! "random"
(list
(cons "nextBytes" (lambda (self ba)
(let ((v (jolt-array-vec ba)))
(do ((i 0 (fx+ i 1))) ((fx=? i (vector-length v)))
(vector-set! v i (random 256))))
jolt-nil))
(cons "nextInt" (lambda (self . a)
(->num (if (pair? a) (random (jnum->exact (car a))) (- (random 4294967296) 2147483648)))))
(cons "nextLong" (lambda (self) (->num (- (random 18446744073709551616) 9223372036854775808))))
(cons "nextDouble" (lambda (self) (random 1.0)))
(cons "nextFloat" (lambda (self) (random 1.0)))
(cons "nextBoolean" (lambda (self) (fx=? 0 (random 2))))))
;; --- java.util.Optional -----------------------------------------------------
;; Returned by getters across java.time / java.net.http (e.g. HttpRequest.timeout,
;; HttpClient.connectTimeout). Value-equal so (= (Optional/of x) (Optional/of x)).
(define (jt-optional present? value) (make-jhost "optional" (vector present? value)))
(define jt-optional-empty (jt-optional #f jolt-nil))
(define (opt? x) (and (jhost? x) (string=? (jhost-tag x) "optional")))
(define (opt-present? o) (vector-ref (jhost-state o) 0))
(define (opt-value o) (vector-ref (jhost-state o) 1))
(let ((statics (list (cons "of" (lambda (v) (if (jolt-nil? v) (error #f "Optional.of(null)") (jt-optional #t v))))
(cons "ofNullable" (lambda (v) (if (jolt-nil? v) jt-optional-empty (jt-optional #t v))))
(cons "empty" (lambda _ jt-optional-empty)))))
(register-class-statics! "Optional" statics)
(register-class-statics! "java.util.Optional" statics))
(register-host-methods! "optional"
(list (cons "isPresent" (lambda (o) (opt-present? o)))
(cons "isEmpty" (lambda (o) (not (opt-present? o))))
(cons "get" (lambda (o) (if (opt-present? o) (opt-value o) (error #f "Optional.get() on empty Optional"))))
(cons "orElse" (lambda (o d) (if (opt-present? o) (opt-value o) d)))
(cons "orElseGet" (lambda (o f) (if (opt-present? o) (opt-value o) (jolt-invoke f))))
(cons "ifPresent" (lambda (o f) (when (opt-present? o) (jolt-invoke f (opt-value o))) jolt-nil))
(cons "toString" (lambda (o) (if (opt-present? o)
(string-append "Optional[" (jolt-str-render-one (opt-value o)) "]")
"Optional.empty")))))
(register-eq-arm! (lambda (a b) (or (opt? a) (opt? b)))
(lambda (a b) (and (opt? a) (opt? b) (eq? (opt-present? a) (opt-present? b))
(or (not (opt-present? a)) (jolt=2 (opt-value a) (opt-value b))))))
;; --- 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"))
;; common exception hierarchy, so (instance? IOException e) / (catch IOException e)
;; match a more specific throwable a library threw (e.g. http-client's
;; UnknownHostException, caught by clj-http-lite's :ignore-unknown-host?).
(reg-class-supers! "java.lang.Throwable" '("java.lang.Object"))
(reg-class-supers! "java.lang.Exception" '("java.lang.Throwable" "java.lang.Object"))
(reg-class-supers! "java.lang.RuntimeException" '("java.lang.Exception" "java.lang.Throwable" "java.lang.Object"))
(reg-class-supers! "java.io.IOException" '("java.lang.Exception" "java.lang.Throwable" "java.lang.Object"))
(reg-class-supers! "java.io.InterruptedIOException" '("java.io.IOException" "java.lang.Exception" "java.lang.Throwable" "java.lang.Object"))
(reg-class-supers! "java.net.SocketException" '("java.io.IOException" "java.lang.Exception" "java.lang.Throwable" "java.lang.Object"))
(reg-class-supers! "java.net.UnknownHostException" '("java.io.IOException" "java.lang.Exception" "java.lang.Throwable" "java.lang.Object"))
(reg-class-supers! "java.net.ConnectException" '("java.net.SocketException" "java.io.IOException" "java.lang.Exception" "java.lang.Throwable" "java.lang.Object"))
(reg-class-supers! "java.net.SocketTimeoutException" '("java.io.InterruptedIOException" "java.io.IOException" "java.lang.Exception" "java.lang.Throwable" "java.lang.Object"))
;; clojure.lang / java.util ancestry for the builtins (class) reports, so a
;; class-keyed multimethod / (isa? (class x) SomeClass) dispatches like the JVM.
;; (Object is supplied universally by class-isa?, so it need not be listed.)
(reg-class-supers! "clojure.lang.IFn" '("clojure.lang.Fn" "java.lang.Runnable" "java.util.concurrent.Callable"))
;; Keyword and Symbol implement IFn (they are callable: (:k m) / ('s m)), so a
;; (class x)-dispatched multimethod with an IFn method matches them, like the JVM.
(reg-class-supers! "clojure.lang.Keyword" '("clojure.lang.Named" "java.lang.Comparable"
"clojure.lang.IFn" "clojure.lang.Fn"
"java.lang.Runnable" "java.util.concurrent.Callable"))
(reg-class-supers! "clojure.lang.Symbol" '("clojure.lang.Named" "java.lang.Comparable"
"clojure.lang.IFn" "clojure.lang.Fn"
"java.lang.Runnable" "java.util.concurrent.Callable"))
(reg-class-supers! "java.lang.String" '("java.lang.CharSequence" "java.lang.Comparable"))
(reg-class-supers! "clojure.lang.PersistentHashSet" '("clojure.lang.APersistentSet" "clojure.lang.IPersistentSet" "clojure.lang.IPersistentCollection" "java.util.Set" "java.util.Collection" "java.lang.Iterable"))
(reg-class-supers! "clojure.lang.PersistentTreeSet" '("clojure.lang.APersistentSet" "clojure.lang.IPersistentSet" "clojure.lang.IPersistentCollection" "java.util.Set" "java.util.Collection" "java.lang.Iterable"))
(reg-class-supers! "clojure.lang.PersistentVector" '("clojure.lang.APersistentVector" "clojure.lang.IPersistentVector" "clojure.lang.IPersistentCollection" "clojure.lang.Sequential" "clojure.lang.Associative" "java.util.List" "java.util.Collection" "java.lang.Iterable"))
(reg-class-supers! "clojure.lang.PersistentArrayMap" '("clojure.lang.APersistentMap" "clojure.lang.IPersistentMap" "clojure.lang.IPersistentCollection" "clojure.lang.Associative" "java.util.Map" "java.lang.Iterable"))
(reg-class-supers! "clojure.lang.PersistentHashMap" '("clojure.lang.APersistentMap" "clojure.lang.IPersistentMap" "clojure.lang.IPersistentCollection" "clojure.lang.Associative" "java.util.Map" "java.lang.Iterable"))
(reg-class-supers! "clojure.lang.PersistentList" '("clojure.lang.ASeq" "clojure.lang.ISeq" "clojure.lang.IPersistentCollection" "clojure.lang.Sequential" "clojure.lang.Seqable" "java.util.List" "java.util.Collection" "java.lang.Iterable"))
(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)
;; union the modeled class graph (jch, direct edges) with any legacy table entry,
;; so isa?/supers/ancestors see the single hierarchy source plus anything not yet
;; migrated. The closure below traverses these to the full transitive set.
(let ((jch (jch-direct-supers name))
(old (hashtable-ref class-supers-tbl name #f)))
(cond ((and (pair? jch) old)
(let merge ((ss old) (acc jch))
(cond ((null? ss) acc)
((member (car ss) acc) (merge (cdr ss) acc))
(else (merge (cdr ss) (append acc (list (car ss))))))))
((pair? jch) jch)
(old old)
((str-has-dollar? name) '("clojure.lang.AFunction"))
(else '()))))
;; transitive closure of direct supers (set semantics via an accumulator list)
(define (class-ancestors-list name)
(let loop ((pending (class-direct-supers name)) (seen '()))
(cond ((null? pending) (reverse seen))
((member (car pending) seen) (loop (cdr pending) seen))
(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
;; carried class or any of its ancestors (full name or last segment), so a library's
;; (catch UnknownHostException e …) / (catch IOException e …) matches the ex-info
;; envelope it threw. Mirrors the (class e) arm (host-table.ss) for catch dispatch,
;; which lowers to (instance? C e). Non-match returns 'pass so other arms still run.
(register-instance-check-arm!
(lambda (type-sym val)
(if (and (htable? val) (string? (hashtable-ref (htable-h val) "class" #f)))
(let* ((cls (hashtable-ref (htable-h val) "class" #f))
(want (symbol-t-name type-sym))
(want-seg (hsc-last-segment want)))
(let loop ((names (cons cls (class-ancestors-list cls))))
(cond ((null? names) 'pass)
((or (string=? want (car names))
(string=? want-seg (hsc-last-segment (car names)))) #t)
(else (loop (cdr names))))))
'pass)))
;; JVM class assignability for isa? (20-coll): true when child and parent are both
;; class values and parent is child, java.lang.Object (every class's root), or a
;; modeled ancestor of child (full name or last segment). nil for non-class args, so
;; isa? falls through to its hierarchy/vector logic.
(def-var! "jolt.host" "class-isa?"
(lambda (child parent)
(let ((cc (class-key child)) (pp (class-key parent)))
(if (and cc pp)
(let ((pseg (hsc-last-segment pp)))
(if (let loop ((names (cons cc (class-ancestors-list cc))))
(cond ((string=? pp "java.lang.Object") #t)
((null? names) #f)
((or (string=? pp (car names))
(string=? pseg (hsc-last-segment (car names)))) #t)
(else (loop (cdr names)))))
#t jolt-nil))
jolt-nil))))
;; is NAME a class the host models (registered in the class graph, a legacy
;; supers-table entry, or a fn class)? Object itself is modeled.
(define (hsc-class-known? name)
(or (string=? name "java.lang.Object")
(jch-known? name)
(and (hashtable-ref class-supers-tbl name #f) #t)
(str-has-dollar? name)))
;; transitive ancestry, rooted at Object for a concrete class like (supers c);
;; an interface's chain has no Object (its getSuperclass is null). '() for
;; Object itself and for a name the host doesn't model.
(define (class-ancestors-rooted name)
(if (or (string=? name "java.lang.Object") (jch-interface? name))
(class-ancestors-list name)
(let ((as (class-ancestors-list name)))
(cond ((member "java.lang.Object" as) as)
((null? as) (if (hsc-class-known? name) '("java.lang.Object") '()))
(else (append as '("java.lang.Object")))))))
;; (jolt.host/class-supers name) / (jolt.host/class-ancestors name) — a jolt seq of
;; super / ancestor class-name strings (transitive, Object-rooted), or nil when
;; jolt models no hierarchy for it. class-bases is the DIRECT supers (clojure.core
;; `bases` / the class arm of `parents`).
(def-var! "jolt.host" "class-supers"
(lambda (x)
(let ((name (class-key x)))
(if name
(let ((as (class-ancestors-rooted name)))
(if (null? as) jolt-nil (list->cseq as)))
jolt-nil))))
(def-var! "jolt.host" "class-ancestors"
(lambda (x)
(let ((name (class-key x)))
(if name
(let ((as (class-ancestors-rooted name)))
(if (null? as) jolt-nil (list->cseq as)))
jolt-nil))))
(def-var! "jolt.host" "class-bases"
(lambda (x)
(let ((name (class-key x)))
(if name
(let* ((ds (class-direct-supers name))
;; a concrete class's bases include its superclass — Object when
;; nothing more specific is modeled (interfaces have none).
(ds (if (or (string=? name "java.lang.Object")
(jch-interface? name)
(member "java.lang.Object" ds))
ds
(append ds '("java.lang.Object")))))
(if (null? ds) jolt-nil (list->cseq ds)))
jolt-nil))))
;; is X a class value — a jclass, a deftype ctor, or a name string the host
;; graph models?
(def-var! "jolt.host" "class-value?"
(lambda (x)
(if (jclass? x)
#t
(let ((n (class-key x)))
(if (and n (hsc-class-known? n)) #t jolt-nil)))))

View file

@ -21,6 +21,11 @@
(cons "acos" (lambda (x) (->dbl (acos x)))) (cons "atan" (lambda (x) (->dbl (atan x))))
(cons "log" (lambda (x) (->dbl (log x)))) (cons "log10" (lambda (x) (->dbl (/ (log x) (log 10)))))
(cons "exp" (lambda (x) (->dbl (exp x))))
;; getExponent: the unbiased binary exponent of a double (floor(log2|x|));
;; scalb: x * 2^n. test.check's double generator uses both.
(cons "getExponent" (lambda (x) (if (= x 0.0) -1023
(exact (floor (/ (log (abs (exact->inexact x))) (log 2.0)))))))
(cons "scalb" (lambda (x n) (->dbl (* (exact->inexact x) (expt 2.0 (jnum->exact n))))))
(cons "max" (lambda (a b) (if (> a b) a b))) (cons "min" (lambda (a b) (if (< a b) a b)))
(cons "signum" (lambda (x) (cond ((< x 0) -1.0) ((> x 0) 1.0) (else 0.0))))
(cons "PI" (->dbl (* 4 (atan 1)))) (cons "E" (->dbl (exp 1)))
@ -50,9 +55,7 @@
(lambda ()
(unless tried?
(set! tried? #t)
(set! fp (guard (e (#t #f))
(load-shared-object #f)
(foreign-procedure "sched_yield" () int))))
(set! fp (jolt-foreign-proc-safe "sched_yield" '() 'int)))
(if fp (fp) (sleep (make-time 'time-duration 0 0)))
jolt-nil)))
@ -96,6 +99,70 @@
(register-class-statics! "PersistentArrayMap" (list (cons "createWithCheck" pam-create-with-check)))
(register-class-statics! "clojure.lang.PersistentArrayMap" (list (cons "createWithCheck" pam-create-with-check)))
;; clojure.lang.RT/map: build a map from a [k v k v…] array/seq (RT.map). Small
;; maps keep insertion order (PersistentArrayMap). tools.reader builds map and
;; namespaced-map literals this way.
(define (rt-map arr)
(let loop ((xs (if (jolt-nil? arr) '() (seq->list (jolt-seq arr)))) (m (jolt-hash-map)))
(cond ((null? xs) m)
((null? (cdr xs)) (error #f "RT/map: odd key/value count"))
(else (loop (cddr xs) (jolt-assoc m (car xs) (cadr xs)))))))
(register-class-statics! "RT" (list (cons "map" rt-map)))
(register-class-statics! "clojure.lang.RT" (list (cons "map" rt-map)))
;; clojure.lang.PersistentList/create: a list (in order) from a seq; empty -> ().
(define (plist-create x)
(let ((items (seq->list (jolt-seq x))))
(if (null? items) jolt-empty-list (list->cseq items))))
(register-class-statics! "PersistentList" (list (cons "create" plist-create)))
(register-class-statics! "clojure.lang.PersistentList" (list (cons "create" plist-create)))
;; clojure.lang.PersistentHashSet/createWithCheck: a set from a seq, throwing on a
;; duplicate element (tools.reader's #{…} reader reports the dup).
(define (phs-create-with-check x)
(let loop ((xs (seq->list (jolt-seq x))) (s (jolt-hash-set)))
(if (null? xs) s
(let ((e (car xs)))
(if (jolt-truthy? (jolt-contains? s e))
(jolt-throw (jolt-ex-info (string-append "Duplicate key: " (jolt-str-render-one e)) (jolt-hash-map)))
(loop (cdr xs) (jolt-conj1 s e)))))))
(register-class-statics! "PersistentHashSet" (list (cons "createWithCheck" phs-create-with-check)))
(register-class-statics! "clojure.lang.PersistentHashSet" (list (cons "createWithCheck" phs-create-with-check)))
;; java.lang.Character statics. digit(ch, radix) -> the digit value or -1; ch may
;; be a char or an int codepoint (tools.reader passes (int c)). isDigit/
;; isWhitespace take a char; valueOf boxes a char (identity on jolt).
(define (char->cp x) (if (char? x) (char->integer x) (jnum->exact x)))
(define (char-digit-value cp radix)
(let ((d (cond ((and (fx>=? cp 48) (fx<=? cp 57)) (fx- cp 48)) ; 0-9
((and (fx>=? cp 97) (fx<=? cp 122)) (fx+ 10 (fx- cp 97))) ; a-z
((and (fx>=? cp 65) (fx<=? cp 90)) (fx+ 10 (fx- cp 65))) ; A-Z
(else 99))))
(if (fx<? d radix) d -1)))
(define character-statics
(list (cons "digit" (lambda (ch radix) (->num (char-digit-value (char->cp ch) (jnum->exact radix)))))
(cons "isDigit" (lambda (ch) (let ((cp (char->cp ch))) (and (fx>=? cp 48) (fx<=? cp 57)))))
(cons "isWhitespace" (lambda (ch) (char-whitespace? (integer->char (char->cp ch)))))
(cons "valueOf" (lambda (ch) (if (char? ch) ch (integer->char (char->cp ch)))))))
(register-class-statics! "Character" character-statics)
(register-class-statics! "java.lang.Character" character-statics)
;; java.util.regex.Pattern/compile: a regex value from a string pattern.
(define pattern-statics (list (cons "compile" (lambda (s) (jolt-regex (jolt-str-render-one s))))))
(register-class-statics! "Pattern" pattern-statics)
(register-class-statics! "java.util.regex.Pattern" pattern-statics)
;; clojure.lang.BigInt / clojure.lang.Numbers: jolt has one exact-integer type
;; (Chez bignums auto-reduce), so BigInt.fromBigInteger and Numbers.reduceBigInt
;; are identity. tools.reader's number parser threads integers through these.
(define identity-num-statics (list (cons "fromBigInteger" (lambda (x) x))))
(register-class-statics! "BigInt" identity-num-statics)
(register-class-statics! "clojure.lang.BigInt" identity-num-statics)
(register-class-statics! "Numbers"
(list (cons "reduceBigInt" (lambda (x) x)) (cons "toRatio" (lambda (x) x))))
(register-class-statics! "clojure.lang.Numbers"
(list (cons "reduceBigInt" (lambda (x) x)) (cons "toRatio" (lambda (x) x))))
(define (now-millis)
(let ((t (current-time 'time-utc)))
(+ (* 1000 (time-second t)) (quotient (time-nanosecond t) 1000000))))
@ -106,6 +173,9 @@
(list (cons "currentTimeMillis" (lambda () (->num (now-millis))))
(cons "nanoTime" (lambda () (->num (* 1000000 (now-millis)))))
(cons "exit" (lambda args (exit (if (null? args) 0 (jnum->exact (car args))))))
;; System/gc -> a full Chez collection (so weak references clear and their
;; guardians fire); Runtime.gc() routes here too.
(cons "gc" (lambda _ (collect (collect-maximum-generation)) jolt-nil))
;; wrapped in lambdas: the helpers are defined below, resolved at call time.
(cons "getProperty" (lambda (k . d) (apply sys-get-property k d)))
(cons "setProperty" (lambda (k v) (sys-set-property k v)))
@ -113,9 +183,29 @@
(cons "getProperties" (lambda () (sys-properties-map)))
(cons "getenv" (lambda k (apply sys-getenv k)))))
;; java.lang.Long.bitCount: the population count of the value's 64-bit two's-
;; complement (mask to 64 bits so a negative long counts like the JVM, e.g.
;; bitCount(-1) = 64). test.check's splittable PRNG uses it.
(define long-mask64 #xFFFFFFFFFFFFFFFF)
(define long-2^63 (expt 2 63))
(define long-2^64 (expt 2 64))
;; interpret a 64-bit value as a signed long (top bit = sign), like the JVM.
(define (as-signed64 v) (if (>= v long-2^63) (- v long-2^64) v))
(define (long-nlz n) (- 64 (integer-length (bitwise-and (jnum->exact n) long-mask64))))
(define (long-reverse n)
(let ((v (bitwise-and (jnum->exact n) long-mask64)))
(let loop ((i 0) (r 0))
(if (fx=? i 64) (as-signed64 r)
(loop (fx+ i 1)
(bitwise-ior (bitwise-arithmetic-shift-left r 1)
(bitwise-and (bitwise-arithmetic-shift-right v i) 1)))))))
(register-class-statics! "Long"
(list (cons "MAX_VALUE" (->num 9223372036854775807))
(list (cons "TYPE" "long")
(cons "MAX_VALUE" (->num 9223372036854775807))
(cons "MIN_VALUE" (->num -9223372036854775808))
(cons "bitCount" (lambda (n) (->num (bitwise-bit-count (bitwise-and (jnum->exact n) long-mask64)))))
(cons "numberOfLeadingZeros" (lambda (n) (->num (long-nlz n))))
(cons "reverse" (lambda (n) (->num (long-reverse n))))
(cons "parseLong" (lambda (s . r) (parse-int-or-throw s (if (null? r) 10 (jnum->exact (car r))) "parseLong")))
(cons "valueOf" (lambda (s . r) (parse-int-or-throw s (if (null? r) 10 (jnum->exact (car r))) "valueOf")))))
@ -123,6 +213,8 @@
(define (int->u32 n) (if (< n 0) (+ n 4294967296) n))
(register-class-statics! "Integer"
(list (cons "MAX_VALUE" (->num 2147483647)) (cons "MIN_VALUE" (->num -2147483648))
;; the primitive class token (int.class); jolt models a class as its name
(cons "TYPE" "int")
(cons "valueOf" (lambda (x . r)
(if (number? x) (->num x)
(parse-int-or-throw x (if (null? r) 10 (jnum->exact (car r))) "valueOf"))))
@ -133,14 +225,40 @@
(cons "toBinaryString" (lambda (x) (number->string (int->u32 (jnum->exact x)) 2)))
(cons "toString" (lambda (x . r) (number->string (jnum->exact x) (if (null? r) 10 (jnum->exact (car r))))))))
;; Byte / Short bounds (their values are plain integers on jolt; the statics let
;; libraries reference the JVM ranges — clojure.test.check generates over them).
(register-class-statics! "Byte"
(list (cons "TYPE" "byte")
(cons "MAX_VALUE" (->num 127)) (cons "MIN_VALUE" (->num -128))
(cons "valueOf" (lambda (x . r) (->num (if (number? x) x (parse-int-or-throw x 10 "valueOf")))))
(cons "parseByte" (lambda (x . r) (parse-int-or-throw x (if (null? r) 10 (jnum->exact (car r))) "parseByte")))
(cons "toString" (lambda (x . r) (number->string (jnum->exact x))))))
(register-class-statics! "Short"
(list (cons "TYPE" "short")
(cons "MAX_VALUE" (->num 32767)) (cons "MIN_VALUE" (->num -32768))
(cons "valueOf" (lambda (x . r) (->num (if (number? x) x (parse-int-or-throw x 10 "valueOf")))))
(cons "parseShort" (lambda (x . r) (parse-int-or-throw x (if (null? r) 10 (jnum->exact (car r))) "parseShort")))
(cons "toString" (lambda (x . r) (number->string (jnum->exact x))))))
;; java.util.Locale — jolt's case ops are codepoint-based (locale-independent), so
;; the default locale is a no-op token. Libraries set/restore it around formatting
;; to prove output is locale-stable (honeysql's Turkish-İ regression guard).
(register-class-statics! "Locale"
(list (cons "getDefault" (lambda () "und"))
(cons "setDefault" (lambda (x) jolt-nil))
(cons "forLanguageTag" (lambda (tag) (if (string? tag) tag (jolt-str-render-one tag))))
(cons "ROOT" "und") (cons "US" "en-US") (cons "ENGLISH" "en")))
(register-class-statics! "Boolean"
(list (cons "parseBoolean" (lambda (s) (string=? "true" (ascii-string-down (if (string? s) s (jolt-str-render-one s))))))
(list (cons "TYPE" "boolean")
(cons "parseBoolean" (lambda (s) (string=? "true" (ascii-string-down (if (string? s) s (jolt-str-render-one s))))))
(cons "TRUE" #t) (cons "FALSE" #f)))
(register-class-ctor! "Double" ->double)
(register-class-ctor! "Float" ->double)
(register-class-statics! "Double"
(list (cons "parseDouble" parse-double-or-throw)
(list (cons "TYPE" "double")
(cons "parseDouble" parse-double-or-throw)
(cons "valueOf" ->double)
(cons "toString" (lambda (x) (jolt-str-render-one (->double x))))
(cons "isNaN" (lambda (x) (and (flonum? x) (nan? x))))
@ -148,14 +266,21 @@
(cons "MAX_VALUE" 1.7976931348623157e308) (cons "MIN_VALUE" 4.9e-324)
(cons "POSITIVE_INFINITY" +inf.0) (cons "NEGATIVE_INFINITY" -inf.0) (cons "NaN" +nan.0)))
(register-class-statics! "Float"
(list (cons "parseFloat" parse-double-or-throw) (cons "valueOf" ->double)))
(list (cons "TYPE" "float")
(cons "parseFloat" parse-double-or-throw) (cons "valueOf" ->double)))
;; Character: ASCII predicates (the engine is byte/ASCII oriented).
(register-class-statics! "Character"
(list (cons "isUpperCase" (lambda (c) (let ((n (char-code c))) (and (>= n 65) (<= n 90)))))
(list (cons "TYPE" "char")
(cons "isUpperCase" (lambda (c) (let ((n (char-code c))) (and (>= n 65) (<= n 90)))))
(cons "isLowerCase" (lambda (c) (let ((n (char-code c))) (and (>= n 97) (<= n 122)))))
(cons "isDigit" (lambda (c) (let ((n (char-code c))) (and (>= n 48) (<= n 57)))))
(cons "isWhitespace" (lambda (c) (char<=? (integer->char (char-code c)) #\space)))))
;; JVM Character.isWhitespace: Unicode whitespace (so U+2028 line separator
;; counts, like the JVM) MINUS the no-break spaces the JVM excludes
;; (U+00A0/U+2007/U+202F). char<=?space missed everything above ASCII.
(cons "isWhitespace" (lambda (c) (let ((cp (char-code c)))
(and (char-whitespace? (integer->char cp))
(not (fx=? cp #xA0)) (not (fx=? cp #x2007)) (not (fx=? cp #x202F))))))))
;; String/valueOf(Object): "null" for nil, else jolt's str semantics.
;; String/format(fmt args…) / (locale fmt args…) -> the clojure.core format engine.
@ -206,13 +331,34 @@
(register-class-statics! "NumberFormat" nf-statics)
(register-class-statics! "java.text.NumberFormat" nf-statics))
;; Class.forName: an array descriptor ("[C") is its own class token; a class Jolt
;; can back (registered statics/ctor, or a java.*/clojure.* core class) yields a
;; class object; anything else throws a catchable ClassNotFoundException, like the
;; JVM — so the common `(try (Class/forName "optional.Dep") (catch …))` probe a
;; library uses to detect an absent dependency works (e.g. ring's joda-time check).
;; java.* / clojure.* packages jolt does NOT back, even though the broad prefix
;; below would otherwise claim them — optional backends a library feature-probes
;; with (Class/forName …) (e.g. tools.logging's java.util.logging / log4j). Listing
;; them here keeps class-found? honest so the probe sees them absent and skips the
;; backend (jolt has its own logging) instead of trying to use it and crashing.
(define forname-absent-prefixes
'("java.util.logging." "javax.management." "java.lang.management."))
(define (forname-known? nm)
;; exact lookups only — lookup-class would fall back to the short class name, so
;; any "x.y.Class" would spuriously match the registered java.lang.Class.
(or (hashtable-ref class-statics-tbl nm #f)
(hashtable-ref class-ctors-tbl nm #f)
(let ((pre? (lambda (p) (and (>= (string-length nm) (string-length p))
(string=? (substring nm 0 (string-length p)) p)))))
(and (or (pre? "java.") (pre? "clojure.") (pre? "jolt."))
(not (exists pre? forname-absent-prefixes))))))
(register-class-statics! "Class"
;; an array descriptor ("[C", "[I", …) is its own class token (so instance? and
;; class compare equal); other names become a class jhost.
(list (cons "forName" (lambda (nm)
(if (and (> (string-length nm) 0) (char=? (string-ref nm 0) #\[))
nm
(make-jhost "class" (list (cons 'name nm))))))))
(list (cons "forName"
(lambda (nm . _)
(cond
((and (> (string-length nm) 0) (char=? (string-ref nm 0) #\[)) nm)
((forname-known? nm) (make-class-obj nm))
(else (jolt-throw (jolt-host-throwable "java.lang.ClassNotFoundException" nm))))))))
;; ---- System helpers (defined before use above via top-level order) ----------
;; os.name reflects the actual platform (Chez's machine-type names it): a *osx

View file

@ -56,26 +56,56 @@
;; record-method-dispatch (records.ss) gets a jhost arm: dispatch (.method obj a*)
;; through the tag's method table.
(define %hs-record-method-dispatch record-method-dispatch)
(set! record-method-dispatch
;; clojure.lang.Sorted on jolt's sorted-map / sorted-set: comparator / entryKey /
;; seqFrom / seq. data.priority-map's subseq/rsubseq reach for these (its
;; PersistentPriorityMap delegates .comparator to the backing sorted-map). The
;; comparator is returned as a small Comparator object whose .compare runs the
;; map's 3-way fn, since (.. sc comparator (compare a b)) is the calling form.
(define sorted-cmp-kw (keyword #f "cmp"))
(register-host-methods! "jolt-comparator"
(list (cons "compare" (lambda (self a b) (jolt-invoke (jhost-state self) a b)))))
(define (sorted-comparator-of sc)
(let ((c (jolt-ref-get sc sorted-cmp-kw)))
(make-jhost "jolt-comparator" (if (jolt-nil? c) jolt-compare c))))
(define (sorted-iface-method? m)
(or (string=? m "comparator") (string=? m "entryKey")
(string=? m "seqFrom") (string=? m "seq")))
(define (sorted-iface-dispatch obj method rest)
(cond
((string=? method "comparator") (sorted-comparator-of obj))
((string=? method "entryKey") (jolt-first (car rest))) ; map entry -> its key
((string=? method "seq") ; (.seq sc) or (.seq sc ascending?)
(if (or (null? rest) (jolt-truthy? (car rest))) (jolt-seq obj) (jolt-rseq obj)))
;; (.seqFrom sc k ascending?) — the entries from k onward, in order. Done with a
;; comparator filter over the seq (jolt has no tree cursor), like subseq.
((string=? method "seqFrom")
(let* ((k (car rest)) (asc (jolt-truthy? (cadr rest)))
(cmp (jolt-ref-get obj sorted-cmp-kw))
(cmpf (if (jolt-nil? cmp) jolt-compare cmp))
(es (seq->list (jolt-seq obj)))
(keep (filter (lambda (e)
(let ((c (jnum->exact (jolt-invoke cmpf (jolt-first e) k))))
(if asc (>= c 0) (<= c 0))))
es)))
(list->cseq (if asc keep (reverse keep)))))
(else (error #f (string-append "No method " method " on sorted collection")))))
(register-method-arm! 44
(lambda (obj method-name rest-args)
(cond
;; (.getClass x) is universal — the class token for any value (incl. numbers
;; / jhost) — before the per-type arms that would otherwise reject it.
((string=? method-name "getClass") (jolt-class obj))
((jhost? obj)
(let ((mh (hashtable-ref host-methods-tbl (jhost-tag obj) #f)))
(let ((f (and mh (hashtable-ref mh method-name #f))))
(if f
(apply f obj (if (jolt-nil? rest-args) '() (seq->list rest-args)))
(error #f (string-append "No method " method-name " on host " (jhost-tag obj)))))))
((number? obj) (number-method method-name obj))
(else (%hs-record-method-dispatch obj method-name rest-args)))))
((number? obj) (apply number-method method-name obj (if (jolt-nil? rest-args) '() (seq->list rest-args))))
(else 'pass))))
;; java.lang.Number method surface (the boxed-number methods cljc code calls). The
;; integer projections wrap modulo their width (ring-codec relies on byteValue
;; overflow: (.byteValue 255) => -1); the float projections are identity flonums.
(define (number-method method n)
(define (number-method method n . args)
(cond
((string=? method "byteValue") (let ((b (modulo (jnum->exact n) 256))) (->num (if (>= b 128) (- b 256) b))))
((string=? method "shortValue") (let ((b (modulo (jnum->exact n) 65536))) (->num (if (>= b 32768) (- b 65536) b))))
@ -83,20 +113,58 @@
((string=? method "longValue") (->num (jnum->exact n)))
((string=? method "doubleValue") (->num n))
((string=? method "floatValue") (->num n))
((string=? method "toString") (jolt-num->string n))
;; .toString(radix) — BigInteger/Integer render in a base, lowercase like the
;; JVM (rewrite-clj's integer node reconstructs 0xff / 0377 / 2r1001 this way).
((string=? method "toString")
(if (pair? args)
(string-downcase (number->string (jnum->exact n) (jnum->exact (car args))))
(jolt-num->string n)))
((string=? method "hashCode") (->num (jnum->exact n)))
;; Double/Float .isNaN / .isInfinite (a non-flonum is neither).
((string=? method "isNaN") (and (flonum? n) (not (= n n))))
((string=? method "isInfinite") (and (flonum? n) (infinite? n)))
;; BigInteger interop: .negate / .bitLength / .signum / .abs. A jolt integer is
;; a Chez exact integer, so these are native (integer-length = JVM bitLength,
;; matching for negative values too). tools.reader's number parser uses them.
((string=? method "negate") (->num (- (jnum->exact n))))
((string=? method "abs") (->num (abs (jnum->exact n))))
((string=? method "bitLength") (->num (integer-length (jnum->exact n))))
((string=? method "signum") (->num (let ((e (jnum->exact n))) (cond ((> e 0) 1) ((< e 0) -1) (else 0)))))
;; BigInteger.shiftLeft/shiftRight (test.check's size-bounded-bigint): arbitrary
;; precision, so an arithmetic shift by the (positive) amount.
((string=? method "shiftLeft") (->num (bitwise-arithmetic-shift-left (jnum->exact n) (jnum->exact (car args)))))
((string=? method "shiftRight") (->num (bitwise-arithmetic-shift-right (jnum->exact n) (jnum->exact (car args)))))
(else (error #f (string-append "No method " method " for number")))))
;; Mutable static fields: "Class" -> (member -> 1-vector cell). A library that
;; writes a static field — clojure.spec.alpha's (set! (. clojure.lang.RT
;; checkSpecAsserts) flag) — lands here; the analyzer lowers the set! to a
;; set-static-field! call and a plain Class/member read consults the cell first.
(define mutable-statics-tbl (make-hashtable string-hash string=?))
(define (mutable-static-cell class member create?)
(let ((h (or (hashtable-ref mutable-statics-tbl class #f)
(and create? (let ((nh (make-hashtable string-hash string=?)))
(hashtable-set! mutable-statics-tbl class nh) nh)))))
(and h (or (hashtable-ref h member #f)
(and create? (let ((c (vector jolt-nil))) (hashtable-set! h member c) c))))))
(def-var! "jolt.host" "set-static-field!"
(lambda (class member val)
(vector-set! (mutable-static-cell class member #t) 0 val)
val))
;; clojure.lang.RT.checkSpecAsserts — a JVM-internal flag clojure.spec.alpha reads
;; and writes; default false. Pre-seed the cell so a read before any write works.
(vector-set! (mutable-static-cell "clojure.lang.RT" "checkSpecAsserts" #t) 0 #f)
;; ---- emit entry points ------------------------------------------------------
(define (host-static-ref class member)
(let ((h (lookup-class class-statics-tbl class)))
(if h
(let ((v (hashtable-ref h member #f)))
(if v v (error #f (string-append "No static " class "/" member))))
(error #f (string-append "Unknown class " class)))))
(let ((cell (mutable-static-cell class member #f)))
(if cell
(vector-ref cell 0)
(let ((h (lookup-class class-statics-tbl class)))
(if h
(let ((v (hashtable-ref h member #f)))
(if v v (error #f (string-append "No static " class "/" member))))
(error #f (string-append "Unknown class " class)))))))
(define (host-static-call class member . args)
(apply (host-static-ref class member) args))
@ -126,8 +194,9 @@
(and n (integer? n) (->num n))))
(define (parse-int-or-throw s radix what)
(or (parse-int-str s radix)
(error #f (string-append "NumberFormatException: For input string: \""
(if (string? s) s (jolt-str-render-one s)) "\""))))
(jolt-throw (jolt-host-throwable "java.lang.NumberFormatException"
(string-append "For input string: \""
(if (string? s) s (jolt-str-render-one s)) "\"")))))
(define (char-code c) (if (char? c) (char->integer c) (jnum->exact c)))
;; parse a double string (Double/parseDouble, (Double. s)); JVM accepts NaN /
@ -141,7 +210,8 @@
(else (let ((n (string->number t))) (and n (real? n) (exact->inexact n)))))))
(define (parse-double-or-throw s)
(or (parse-double-str s)
(error #f (string-append "NumberFormatException: For input string: \""
(if (string? s) s (jolt-str-render-one s)) "\""))))
(jolt-throw (jolt-host-throwable "java.lang.NumberFormatException"
(string-append "For input string: \""
(if (string? s) s (jolt-str-render-one s)) "\"")))))
(define (->double x) (if (number? x) (exact->inexact x) (parse-double-or-throw x)))

View file

@ -45,11 +45,23 @@
(and (digit? (string-ref s j))
(loop (+ j 1) (+ (* acc 10) (- (char->integer (string-ref s j)) 48))))))))
(define (jolt-inst-from-string ts)
(define (jolt-inst-from-string ts0)
;; a leading '-' marks a negative (proleptic) year; the rest of the field may be
;; more than 4 digits (java.time prints -999999999-…). Read the year up to the
;; first '-' that separates it from the month.
(define neg-year (and (> (string-length ts0) 0) (char=? (string-ref ts0 0) #\-)))
(define ts (if neg-year (substring ts0 1 (string-length ts0)) ts0))
(define len (string-length ts))
(define (fail) (error #f (string-append "Unrecognized #inst timestamp: " ts)))
(let* ((year (or (digits-at ts 0 4) (fail)))
(i 4) (month 1) (day 1) (hh 0) (mm 0) (ss 0) (frac-ms 0) (off-s 0))
(define (fail) (error #f (string-append "Unrecognized #inst timestamp: " ts0)))
(define (read-year)
;; >=4 digits up to a non-digit; java.time uses min-4 but allows more.
(let loop ((j 0) (acc 0) (n 0))
(if (and (< j len) (digit? (string-ref ts j)))
(loop (+ j 1) (+ (* acc 10) (- (char->integer (string-ref ts j)) 48)) (+ n 1))
(if (>= n 4) (cons acc j) #f))))
(let* ((yr (or (read-year) (fail)))
(year (if neg-year (- (car yr)) (car yr)))
(i (cdr yr)) (month 1) (day 1) (hh 0) (mm 0) (ss 0) (frac-ms 0) (off-s 0))
;; -MM
(when (and (< i len) (char=? (string-ref ts i) #\-) (digits-at ts (+ i 1) 2))
(set! month (digits-at ts (+ i 1) 2)) (set! i (+ i 3)))
@ -167,14 +179,21 @@
(else (loop (+ i 1)))))))
(define (parse-ms pattern input)
(let ((pn (string-length pattern)) (inn (string-length input))
(y 1970) (mo 1) (d 1) (hh 0) (mi 0) (ss 0) (pm 'none))
(define (pfail) (error #f (string-append "ParseException: unparseable date \"" input "\"")))
(y 1970) (mo 1) (d 1) (hh 0) (mi 0) (ss 0) (frac-ms 0) (pm 'none))
;; a parse failure is a java.time.format.DateTimeParseException (typed, so a
;; (catch DateTimeParseException …) over a bad date matches), like the JVM.
(define (pfail)
(jolt-throw (jolt-host-throwable "java.time.format.DateTimeParseException"
(string-append "unparseable date \"" input "\"") jolt-nil)))
(define (run-len i c) (let loop ((j i)) (if (and (< j pn) (char=? (string-ref pattern j) c)) (loop (+ j 1)) (- j i))))
(define (read-digits ii) ; -> (val . next), pfail if none
(let loop ((j ii) (acc 0) (any #f))
(if (and (< j inn) (digit? (string-ref input j)))
(loop (+ j 1) (+ (* acc 10) (- (char->integer (string-ref input j)) 48)) #t)
;; read up to `maxw` digits (#f = unbounded). A fixed-width field (k>=2, e.g.
;; HHmm) caps the read at its run length so adjacent numeric fields split.
(define (read-digits-w ii maxw) ; -> (val . next), pfail if none
(let loop ((j ii) (acc 0) (n 0) (any #f))
(if (and (< j inn) (digit? (string-ref input j)) (or (not maxw) (< n maxw)))
(loop (+ j 1) (+ (* acc 10) (- (char->integer (string-ref input j)) 48)) (+ n 1) #t)
(if any (cons acc j) (pfail)))))
(define (read-digits ii) (read-digits-w ii #f))
(define (read-alpha ii) ; -> (str . next)
(let loop ((j ii)) (if (and (< j inn) (char-alphabetic? (string-ref input j))) (loop (+ j 1))
(cons (substring input ii j) j))))
@ -189,29 +208,47 @@
(begin
(when (eq? pm 'pm) (when (< hh 12) (set! hh (+ hh 12))))
(when (eq? pm 'am) (when (= hh 12) (set! hh 0)))
(make-jinst (* 1000 (+ (* (days-from-civil y mo d) 86400) (* hh 3600) (* mi 60) ss))))
(make-jinst (+ (* 1000 (+ (* (days-from-civil y mo d) 86400) (* hh 3600) (* mi 60) ss)) frac-ms)))
(let ((c (string-ref pattern pi)))
(cond
((char-alphabetic? c)
(let ((k (run-len pi c)))
(cond
((char=? c #\y) (let ((r (read-digits ii)))
((char=? c #\y) (let ((r (read-digits-w ii (if (>= k 3) #f k))))
;; 2-digit year (value < 100): JVM sliding window — 00-68 -> 20xx,
;; 69-99 -> 19xx (rfc1036 HTTP dates). A full year stays as-is.
(set! y (let ((v (car r))) (if (< v 100) (if (< v 69) (+ 2000 v) (+ 1900 v)) v)))
(set! y (let ((v (car r))) (if (and (= k 2) (< v 100)) (if (< v 69) (+ 2000 v) (+ 1900 v)) v)))
(loop (+ pi k) (cdr r))))
((char=? c #\M) (if (>= k 3)
(let ((r (read-alpha ii))) (set! mo (or (month-from-name (car r)) (pfail))) (loop (+ pi k) (cdr r)))
(let ((r (read-digits ii))) (set! mo (car r)) (loop (+ pi k) (cdr r)))))
((char=? c #\d) (let ((r (read-digits ii))) (set! d (car r)) (loop (+ pi k) (cdr r))))
((or (char=? c #\H) (char=? c #\h)) (let ((r (read-digits ii))) (set! hh (car r)) (loop (+ pi k) (cdr r))))
((char=? c #\m) (let ((r (read-digits ii))) (set! mi (car r)) (loop (+ pi k) (cdr r))))
((char=? c #\s) (let ((r (read-digits ii))) (set! ss (car r)) (loop (+ pi k) (cdr r))))
(let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! mo (car r)) (loop (+ pi k) (cdr r)))))
((char=? c #\d) (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! d (car r)) (loop (+ pi k) (cdr r))))
((or (char=? c #\H) (char=? c #\h)) (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! hh (car r)) (loop (+ pi k) (cdr r))))
((char=? c #\m) (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! mi (car r)) (loop (+ pi k) (cdr r))))
((char=? c #\s) (let ((r (read-digits-w ii (if (>= k 2) k #f))))
(set! ss (car r))
;; an ISO formatter (modeled here as an ss-pattern with no S
;; field) still accepts an optional fractional second; consume
;; .fff -> millis from the input. Skip when the pattern carries
;; the fraction itself (a following '.'/S handles it).
(let ((j (cdr r)) (pnext (if (< (+ pi k) pn) (string-ref pattern (+ pi k)) #\nul)))
(if (and (not (char=? pnext #\.)) (not (char=? pnext #\S))
(< j inn) (char=? (string-ref input j) #\.)
(< (+ j 1) inn) (digit? (string-ref input (+ j 1))))
(let frac ((p (+ j 1)) (kk 0) (acc 0))
(if (and (< p inn) (digit? (string-ref input p)))
(frac (+ p 1) (+ kk 1) (if (< kk 3) (+ (* acc 10) (- (char->integer (string-ref input p)) 48)) acc))
(begin (set! frac-ms (* acc (expt 10 (max 0 (- 3 kk))))) (loop (+ pi k) p))))
(loop (+ pi k) j)))))
((char=? c #\S) (let frac ((p ii) (kk 0) (acc 0))
(if (and (< p inn) (< kk k) (digit? (string-ref input p)))
(frac (+ p 1) (+ kk 1) (+ (* acc 10) (- (char->integer (string-ref input p)) 48)))
(begin (set! frac-ms (* acc (expt 10 (max 0 (- 3 kk))))) (loop (+ pi k) p)))))
((char=? c #\E) (loop (+ pi k) (cdr (read-alpha ii))))
((char=? c #\a) (let ((r (read-alpha ii)))
(set! pm (if (string=? (ascii-string-down (car r)) "pm") 'pm 'am))
(loop (+ pi k) (cdr r))))
((or (char=? c #\z) (char=? c #\Z) (char=? c #\X)) (loop (+ pi k) (read-tz ii)))
((or (char=? c #\z) (char=? c #\Z) (char=? c #\X) (char=? c #\x) (char=? c #\V) (char=? c #\v)) (loop (+ pi k) (read-tz ii)))
(else (loop (+ pi k) ii)))))
((char=? c #\')
(if (and (< (+ pi 1) pn) (char=? (string-ref pattern (+ pi 1)) #\'))
@ -243,9 +280,21 @@
(register-hash-arm! jinst? (lambda (x) (jolt-hash (jinst-ms x))))
;; java.time.Instant/ZonedDateTime/LocalDateTime values (mk-instant/mk-zoned/mk-local
;; jhosts) are equal when same kind + same epoch-ms — two parsed Instants compare =.
(define (time-jhost? x) (and (jhost? x) (member (jhost-tag x) '("instant" "zoned-dt" "local-dt")) #t))
;; #inst is a java.util.Date — (class x) / (type x) report that, not the internal
;; :jolt/inst tag (which print-method still dispatches on via __type-tag).
(register-class-arm! jinst? (lambda (x) "java.util.Date"))
;; java.time.Instant is nano-precise: two Instants are = when their epoch-nanos
;; match (so an Instant and one shifted by a single nanosecond differ).
(define (jt-instant-tag? x) (and (jhost? x) (string=? (jhost-tag x) "instant")))
(register-eq-arm! (lambda (a b) (or (jt-instant-tag? a) (jt-instant-tag? b)))
(lambda (a b) (and (jt-instant-tag? a) (jt-instant-tag? b)
(= (inst-nanos a) (inst-nanos b)))))
(register-hash-arm! jt-instant-tag? (lambda (x) (jolt-hash (inst-nanos x))))
;; ZonedDateTime / java.sql.Date shim values (mk-zoned/mk-sql-date jhosts) are
;; equal when same kind + same epoch-ms.
(define (time-jhost? x) (and (jhost? x) (member (jhost-tag x) '("zoned-dt" "sql-date")) #t))
(register-eq-arm! (lambda (a b) (or (time-jhost? a) (time-jhost? b)))
(lambda (a b) (and (time-jhost? a) (time-jhost? b)
(string=? (jhost-tag a) (jhost-tag b))
@ -258,7 +307,6 @@
(define %it-type jolt-type)
(set! jolt-type (lambda (x) (if (jinst? x) inst-type-kw (%it-type x))))
(def-var! "clojure.core" "type" jolt-type)
;; instance? java.util.Date -> a jinst; java.time.Instant/LocalDateTime -> the
;; matching jhost tag. The instance? macro passes the class-name symbol.
@ -274,24 +322,57 @@
((string=? tn "Timestamp") #f)
(else 'pass)))
((and (jhost? val) (string=? (jhost-tag val) "instant")) (if (string=? tn "Instant") #t 'pass))
((and (jhost? val) (string=? (jhost-tag val) "local-dt")) (if (string=? tn "LocalDateTime") #t 'pass))
;; java.sql.Date is a java.util.Date subclass (but not a Timestamp).
((and (jhost? val) (string=? (jhost-tag val) "sql-date"))
(cond ((or (string=? tn "Date")) #t) ((string=? tn "Timestamp") #f) (else 'pass)))
(else 'pass)))))
;; inst-ms* is a seed native (the overlay inst-ms reads (get x :ms), now answered).
(def-var! "clojure.core" "inst-ms*" (lambda (i) (jinst-ms i)))
;; --- java.time shim values (jhost objects over host-static.ss registries) -----
;; "local-date" stores an epoch-day (java-time.ss owns the type); ms-of projects it
;; to UTC midnight so existing date math keeps working. "local-dt" stores epoch-day +
;; nano-of-day; the others store epoch-ms.
(define (ms-of d)
(cond ((number? d) d)
((jinst? d) (jinst-ms d))
((and (jhost? d) (member (jhost-tag d) '("instant" "zoned-dt" "local-dt")))
((and (jhost? d) (string=? (jhost-tag d) "local-date"))
(* (vector-ref (jhost-state d) 0) 86400000))
((and (jhost? d) (string=? (jhost-tag d) "local-date-time"))
(+ (* (vector-ref (jhost-state d) 0) 86400000)
(quotient (vector-ref (jhost-state d) 1) 1000000)))
;; "instant" stores epoch-nanos; project to ms (floor) for ms-based callers.
((and (jhost? d) (string=? (jhost-tag d) "instant"))
(inst-floor-div (vector-ref (jhost-state d) 0) 1000000))
((and (jhost? d) (member (jhost-tag d) '("zoned-dt" "calendar" "sql-date")))
(vector-ref (jhost-state d) 0))
(else (error #f "not a date value" d))))
(define (mk-instant ms) (make-jhost "instant" (vector ms)))
;; A java.time.Instant stores epoch-nanos (exact integer). mk-instant takes ms,
;; for the many ms-based call sites; mk-instant-nanos is the nano-precise ctor and
;; inst-nanos the nano accessor (java-time.ss owns the nano-aware arithmetic).
(define (mk-instant-nanos n) (make-jhost "instant" (vector (exact (truncate n)))))
(define (inst-nanos x) (vector-ref (jhost-state x) 0))
(define (mk-instant ms) (mk-instant-nanos (* (ms->exact ms) 1000000)))
(define (mk-zoned ms) (make-jhost "zoned-dt" (vector ms)))
(define (mk-local ms) (make-jhost "local-dt" (vector ms)))
(define (mk-formatter pat) (make-jhost "dt-formatter" (vector pat)))
;; LocalDateTime from epoch-ms (UTC): the java-time.ss "local-date-time" jhost,
;; state [epoch-day nano-of-day].
(define (mk-local ms)
(let* ((ems (exact (truncate ms)))
(ed (inst-floor-div ems 86400000))
(mod (inst-floor-mod ems 86400000)))
(make-jhost "local-date-time" (vector ed (* mod 1000000)))))
;; local-date from epoch-ms: the epoch-day of the UTC day containing ms.
(define (mk-local-date ms) (make-jhost "local-date" (vector (inst-floor-div (exact (truncate ms)) 86400000))))
;; start of the UTC day containing ms.
(define (start-of-utc-day ms)
(* (inst-floor-div (exact (truncate ms)) 86400000) 86400000))
;; a formatter carries its pattern and a locale id (default "en"); the locale
;; selects month/day names in the java-time.ss format engine.
(define (mk-formatter pat . loc) (make-jhost "dt-formatter" (vector pat (if (null? loc) "en" (car loc)))))
(define (fmt-pat f) (vector-ref (jhost-state f) 0))
(define (fmt-locale f) (let ((s (jhost-state f))) (if (> (vector-length s) 1) (vector-ref s 1) "en")))
(define (locale-id l) (if (and (jhost? l) (string=? (jhost-tag l) "locale")) (vector-ref (jhost-state l) 0) "en"))
(define (now-ms) (now-millis)) ; exact ms (= JVM long); now-millis from host-static.ss
;; coerce a user-supplied ms (exact or flonum) to an exact integer for storage.
(define (ms->exact ms) (exact (round ms)))
@ -303,11 +384,17 @@
(register-host-methods! "zoned-dt"
(list (cons "toLocalDateTime" (lambda (self) (mk-local (ms-of self))))
(cons "toInstant" (lambda (self) (mk-instant (ms-of self))))))
(register-host-methods! "local-dt"
;; LocalDate.atZone(zone): the UTC layer treats it as a zoned value at midnight.
;; (java-time.ss registers atStartOfDay and the rest of the local-date surface.)
(register-host-methods! "local-date"
(list (cons "atZone" (lambda (self zone) (mk-zoned (ms-of self))))))
(register-host-methods! "dt-formatter"
(list (cons "withLocale" (lambda (self locale) (mk-formatter (fmt-pat self))))
(cons "format" (lambda (self d) (format-ms (fmt-pat self) (ms-of d))))))
(list (cons "withLocale" (lambda (self locale) (mk-formatter (fmt-pat self) (locale-id locale))))
(cons "withZone" (lambda (self zone) (mk-formatter (fmt-pat self) (fmt-locale self))))
(cons "format" (lambda (self d) (format-ms (fmt-pat self) (ms-of d))))
;; parse a string per the pattern -> an instant value; Instant/from / the
;; LocalDateTime/parse static read its ms back out.
(cons "parse" (lambda (self s) (mk-instant (jinst-ms (parse-ms (fmt-pat self) (jolt-str-render-one s))))))))
;; FormatStyle approximations (no locale DB on this host).
(define style-patterns
@ -331,6 +418,8 @@
(cons "ISO_LOCAL_DATE_TIME" (mk-formatter "yyyy-MM-dd'T'HH:mm:ss"))
;; ISO_INSTANT always renders in UTC with a trailing Z (format-ms is UTC; X -> "Z").
(cons "ISO_INSTANT" (mk-formatter "yyyy-MM-dd'T'HH:mm:ssX"))
;; ISO_ZONED_DATE_TIME: the UTC layer renders/parses it like ISO_INSTANT.
(cons "ISO_ZONED_DATE_TIME" (mk-formatter "yyyy-MM-dd'T'HH:mm:ssX"))
(cons "ofLocalizedDate" (lambda (fs) (style-fmt 'date fs)))
(cons "ofLocalizedTime" (lambda (fs) (style-fmt 'time fs)))
(cons "ofLocalizedDateTime" (lambda (fs) (style-fmt 'datetime fs)))))
@ -339,13 +428,22 @@
(cons "now" (lambda () (mk-instant (now-ms))))
;; Instant/parse an ISO-8601 instant ("…T…Z") -> an instant value.
(cons "parse" (lambda (s) (mk-instant (jinst-ms (jolt-inst-from-string
(if (string? s) s (jolt-str-render-one s)))))))))
(if (string? s) s (jolt-str-render-one s)))))))
;; Instant/from a temporal accessor -> an instant at the same epoch-ms.
(cons "from" (lambda (t) (mk-instant (ms-of t))))))
(register-class-statics! "ZoneId"
(list (cons "systemDefault" (lambda () (make-jhost "zone-id" (vector "system"))))
(cons "of" (lambda (id) (make-jhost "zone-id" (vector id))))))
(register-class-statics! "LocalDateTime"
(list (cons "ofInstant" (lambda (inst zone) (mk-local (ms-of inst))))
(cons "now" (lambda () (mk-local (now-ms))))))
(cons "now" (lambda () (mk-local (now-ms))))
;; LocalDateTime/parse text, or text + a formatter (the UTC layer ignores
;; the parsed offset) -> a local-dt at the parsed instant.
(cons "parse" (lambda (s . fmt)
(let ((str (if (string? s) s (jolt-str-render-one s))))
(mk-local (jinst-ms (if (null? fmt)
(jolt-inst-from-string str)
(parse-ms (fmt-pat (car fmt)) str)))))))))
(let ((locale-ctor (lambda (id . _) (make-jhost "locale" (vector (if (string? id) id (jolt-str-render-one id)))))))
(register-class-ctor! "Locale" locale-ctor)
(register-class-ctor! "java.util.Locale" locale-ctor))
@ -353,26 +451,93 @@
(list (cons "getDefault" (lambda () (make-jhost "locale" (vector "default"))))
(cons "ENGLISH" (make-jhost "locale" (vector "en")))
(cons "US" (make-jhost "locale" (vector "en-US")))
(cons "FRENCH" (make-jhost "locale" (vector "fr")))
(cons "FRANCE" (make-jhost "locale" (vector "fr-FR")))
(cons "GERMAN" (make-jhost "locale" (vector "de")))
(cons "ROOT" (make-jhost "locale" (vector "root")))))
;; java.util.Date / java.sql.Timestamp: #inst's classes. (Date.) = now, (Date. ms)
;; or (Date. another-date) -> a jinst (ms-of accepts a number / jinst / instant), so
;; .getTime / inst? / instance? Date|Timestamp work.
(define (date-ctor . args)
(make-jinst (if (null? args) (now-ms) (ms->exact (ms-of (car args))))))
(cond
((null? args) (make-jinst (now-ms)))
((null? (cdr args)) (make-jinst (ms->exact (ms-of (car args)))))
;; deprecated (Date. year-1900 month0 date [hrs min sec]) — civil fields in UTC.
(else
(let* ((y (+ 1900 (jnum->exact (list-ref args 0))))
(mo (+ 1 (jnum->exact (list-ref args 1))))
(d (jnum->exact (list-ref args 2)))
(hh (if (> (length args) 3) (jnum->exact (list-ref args 3)) 0))
(mm (if (> (length args) 4) (jnum->exact (list-ref args 4)) 0))
(ss (if (> (length args) 5) (jnum->exact (list-ref args 5)) 0)))
(make-jinst (* 1000 (+ (* (days-from-civil y mo d) 86400) (* hh 3600) (* mm 60) ss)))))))
(register-class-ctor! "Date" date-ctor)
(register-class-ctor! "java.util.Date" date-ctor)
(register-class-ctor! "Timestamp" date-ctor)
(register-class-ctor! "java.sql.Timestamp" date-ctor)
;; java.sql.Date: (Date. year-1900 month0 day) builds UTC midnight of that civil
;; date; valueOf parses "yyyy-MM-dd" to the same instant (so the two agree).
(define (sql-date-midnight y mo d) (make-jinst (* 1000 (* (days-from-civil y mo d) 86400))))
;; Date/from(Instant) -> a java.util.Date at the instant's epoch-ms.
(let ((date-statics (list (cons "from" (lambda (inst) (make-jinst (ms->exact (ms-of inst))))))))
(register-class-statics! "Date" date-statics)
(register-class-statics! "java.util.Date" date-statics))
;; java.sql.Date: a distinct class from java.util.Date (a "sql-date" jhost over
;; epoch-ms) so a protocol extended to both routes a sql.Date to its own impl.
;; (Date. year-1900 month0 day) builds UTC midnight of that civil date; valueOf
;; parses "yyyy-MM-dd" to the same instant (so the two agree).
(define (mk-sql-date ms) (make-jhost "sql-date" (vector (ms->exact ms))))
(define (sql-date-midnight y mo d) (mk-sql-date (* 1000 (* (days-from-civil y mo d) 86400))))
(register-class-ctor! "java.sql.Date"
(case-lambda
((ms) (make-jinst (ms->exact (ms-of ms)))) ; (Date. epoch-ms)
((ms) (mk-sql-date (ms-of ms))) ; (Date. epoch-ms)
((y m d) (sql-date-midnight (+ 1900 (jnum->exact y)) (+ 1 (jnum->exact m)) (jnum->exact d)))))
(register-class-statics! "java.sql.Date"
(list (cons "valueOf" (lambda (s) (parse-ms "yyyy-MM-dd" (if (string? s) s (jolt-str-render-one s)))))))
(list (cons "valueOf" (lambda (s) (mk-sql-date (jinst-ms (parse-ms "yyyy-MM-dd" (if (string? s) s (jolt-str-render-one s)))))))))
(register-host-methods! "sql-date"
(list (cons "getTime" (lambda (self) (ms-of self)))
(cons "toInstant" (lambda (self) (mk-instant (ms-of self))))
(cons "toLocalDate" (lambda (self) (mk-local-date (ms-of self))))
(cons "toString" (lambda (self) (inst-rfc3339 (make-jinst (ms-of self)))))))
;; java.util.Calendar: a mutable broken-down UTC time over an epoch-ms. setTime/
;; getTime read/write it; set(field,value) recomputes ms from the field projection.
;; Field constants are Java's int values so .set/.get dispatch on the right field.
(define cal-YEAR 1) (define cal-MONTH 2) (define cal-DAY_OF_MONTH 5)
(define cal-HOUR_OF_DAY 11) (define cal-MINUTE 12) (define cal-SECOND 13)
(define cal-MILLISECOND 14)
(define (cal-ms->fields ms) ; -> vector [y mo0 d hh mi ss frac] (MONTH 0-based, JVM)
(let ((f (inst-fields ms)))
(vector (list-ref f 0) (- (list-ref f 1) 1) (list-ref f 2)
(list-ref f 3) (list-ref f 4) (list-ref f 5) (list-ref f 6))))
(define (cal-fields->ms v)
(+ (* 1000 (+ (* (days-from-civil (vector-ref v 0) (+ 1 (vector-ref v 1)) (vector-ref v 2)) 86400)
(* (vector-ref v 3) 3600) (* (vector-ref v 4) 60) (vector-ref v 5)))
(vector-ref v 6)))
(define (cal-field-index fld)
(cond ((= fld cal-YEAR) 0) ((= fld cal-MONTH) 1) ((= fld cal-DAY_OF_MONTH) 2)
((= fld cal-HOUR_OF_DAY) 3) ((= fld cal-MINUTE) 4) ((= fld cal-SECOND) 5)
((= fld cal-MILLISECOND) 6) (else #f)))
(register-host-methods! "calendar"
(list (cons "setTime" (lambda (self d) (vector-set! (jhost-state self) 0 (ms->exact (ms-of d))) jolt-nil))
(cons "getTime" (lambda (self) (make-jinst (vector-ref (jhost-state self) 0))))
(cons "getTimeInMillis" (lambda (self) (vector-ref (jhost-state self) 0)))
(cons "setTimeInMillis" (lambda (self ms) (vector-set! (jhost-state self) 0 (ms->exact ms)) jolt-nil))
(cons "set" (lambda (self field val)
(let ((v (cal-ms->fields (vector-ref (jhost-state self) 0)))
(idx (cal-field-index (jnum->exact field))))
(when idx (vector-set! v idx (jnum->exact val))
(vector-set! (jhost-state self) 0 (cal-fields->ms v)))
jolt-nil)))
(cons "get" (lambda (self field)
(let ((v (cal-ms->fields (vector-ref (jhost-state self) 0)))
(idx (cal-field-index (jnum->exact field))))
(if idx (vector-ref v idx) 0))))))
(define calendar-statics
(list (cons "getInstance" (lambda _ (make-jhost "calendar" (vector (now-ms)))))
(cons "YEAR" cal-YEAR) (cons "MONTH" cal-MONTH) (cons "DAY_OF_MONTH" cal-DAY_OF_MONTH)
(cons "HOUR_OF_DAY" cal-HOUR_OF_DAY) (cons "MINUTE" cal-MINUTE)
(cons "SECOND" cal-SECOND) (cons "MILLISECOND" cal-MILLISECOND)))
(register-class-statics! "Calendar" calendar-statics)
(register-class-statics! "java.util.Calendar" calendar-statics)
;; java.util.TimeZone: an opaque id holder (format-ms is UTC, so a non-UTC zone is
;; not honored — only the UTC case the corpus uses is exercised).
@ -397,14 +562,21 @@
(cons "format" (lambda (self d) (format-ms (vector-ref (jhost-state self) 0) (ms-of d))))))
;; a jinst's java.util.Date method surface (record-method-dispatch arm).
(define %it-rmd record-method-dispatch)
(set! record-method-dispatch
(register-method-arm! 40
(lambda (obj method-name rest-args)
(cond
((jinst? obj)
(cond ((string=? method-name "getTime") (jinst-ms obj))
;; deprecated java.util.Date accessors (UTC civil fields).
((string=? method-name "getYear") (- (list-ref (inst-fields (jinst-ms obj)) 0) 1900))
((string=? method-name "getMonth") (- (list-ref (inst-fields (jinst-ms obj)) 1) 1))
((string=? method-name "getDate") (list-ref (inst-fields (jinst-ms obj)) 2))
((string=? method-name "getHours") (list-ref (inst-fields (jinst-ms obj)) 3))
((string=? method-name "getMinutes") (list-ref (inst-fields (jinst-ms obj)) 4))
((string=? method-name "getSeconds") (list-ref (inst-fields (jinst-ms obj)) 5))
((string=? method-name "getDay") (list-ref (inst-fields (jinst-ms obj)) 7))
((string=? method-name "toInstant") (mk-instant (jinst-ms obj)))
((string=? method-name "toLocalDate") (mk-local (jinst-ms obj)))
((string=? method-name "toLocalDate") (mk-local-date (jinst-ms obj)))
((string=? method-name "toLocalDateTime") (mk-local (jinst-ms obj)))
((string=? method-name "toString") (inst-rfc3339 obj))
((string=? method-name "equals") (and (pair? (if (jolt-nil? rest-args) '() (seq->list rest-args)))
@ -413,7 +585,7 @@
((string=? method-name "before") (< (jinst-ms obj) (ms-of (car (seq->list rest-args)))))
((string=? method-name "after") (> (jinst-ms obj) (ms-of (car (seq->list rest-args)))))
(else (error #f (string-append "No method " method-name " on Date")))))
(else (%it-rmd obj method-name rest-args)))))
(else 'pass))))
;; Clojure's built-in data readers, so a library that merges default-data-readers
;; or binds *data-readers* (e.g. aero's reader opts) resolves #inst / #uuid.

View file

@ -0,0 +1,333 @@
;; java.io byte/char streams over Chez ports. Each stream is a jhost wrapping a
;; Chez port, so buffering, EOF and binary<->char transcoding come from Chez
;; rather than a hand-rolled buffer.
;;
;; in-stream #(binary-input-port) FileInputStream / ByteArrayInputStream
;; out-stream #(binary-output-port extract acc) FileOutputStream / ByteArrayOutputStream
;; char-reader #(textual-input-port) FileReader / InputStreamReader
;; char-writer #(textual-output-port) FileWriter / OutputStreamWriter
;;
;; Buffered{Reader,Writer,Input,Output}Stream are buffering wrappers; Chez ports
;; are already buffered, so their constructors return the wrapped stream.
;;
;; Loaded after io.ss + natives-array.ss (uses make-jfile/slurp helpers + the
;; byte-array <-> bytevector bridge), and extends io.ss's reader-jhost? / slurp /
;; __close so the new readers/streams flow through slurp / line-seq / with-open.
;; --- byte input stream ------------------------------------------------------
(define (in-stream-port self) (vector-ref (jhost-state self) 0))
(define (make-in-stream port) (make-jhost "in-stream" (vector port)))
(define (in-stream? x) (and (jhost? x) (string=? (jhost-tag x) "in-stream")))
(register-host-methods! "in-stream"
(list
(cons "read"
(lambda (self . rest)
(let ((port (in-stream-port self)))
(if (null? rest)
(let ((b (get-u8 port))) (if (eof-object? b) -1 (->num b)))
(let* ((buf (car rest))
(vec (jolt-array-vec buf))
(off (if (>= (length rest) 3) (jnum->exact (cadr rest)) 0))
(len (if (>= (length rest) 3) (jnum->exact (caddr rest)) (vector-length vec))))
(let loop ((i 0))
(if (>= i len) (->num i)
(let ((b (get-u8 port)))
(if (eof-object? b)
(if (= i 0) -1 (->num i))
(begin (vector-set! vec (+ off i) b) (loop (+ i 1))))))))))))
(cons "readAllBytes" (lambda (self) (let ((bv (get-bytevector-all (in-stream-port self))))
(na-byte-array (if (eof-object? bv) (make-bytevector 0) bv)))))
(cons "skip" (lambda (self n) (let ((bv (get-bytevector-n (in-stream-port self) (jnum->exact n))))
(->num (if (eof-object? bv) 0 (bytevector-length bv))))))
(cons "available" (lambda (self) (->num 0)))
(cons "close" (lambda (self) (close-port (in-stream-port self)) jolt-nil))
(cons "mark" (lambda (self . _) jolt-nil))
(cons "reset" (lambda (self) (guard (e (#t jolt-nil)) (set-port-position! (in-stream-port self) 0) jolt-nil)))
(cons "markSupported" (lambda (self) #f))
(cons "toString" (lambda (self) "#<InputStream>"))))
;; --- byte output stream -----------------------------------------------------
;; state #(port extract acc): extract/acc are #f for a file/passthrough stream;
;; a ByteArrayOutputStream carries the R6RS extraction proc + an accumulator
;; bytevector (Chez's extract resets the port, so snapshot on demand, not per write).
(define (out-stream-port self) (vector-ref (jhost-state self) 0))
(define (out-stream? x) (and (jhost? x) (string=? (jhost-tag x) "out-stream")))
(define (make-out-stream port) (make-jhost "out-stream" (vector port #f #f)))
(define (bv-concat a b)
(if (= 0 (bytevector-length b)) a
(let ((m (make-bytevector (+ (bytevector-length a) (bytevector-length b)))))
(bytevector-copy! a 0 m 0 (bytevector-length a))
(bytevector-copy! b 0 m (bytevector-length a) (bytevector-length b))
m)))
;; all bytes written to a ByteArrayOutputStream so far (folds the latest extract
;; into the accumulator).
(define (baos-bytes self)
(let* ((st (jhost-state self)) (port (vector-ref st 0)) (extract (vector-ref st 1)) (acc (vector-ref st 2)))
(flush-output-port port)
(let ((merged (bv-concat acc (extract))))
(vector-set! st 2 merged) merged)))
(register-host-methods! "out-stream"
(list
(cons "write"
(lambda (self x . rest)
(let ((port (out-stream-port self)))
(cond
((number? x) (put-u8 port (bitwise-and (jnum->exact x) #xff)))
((and (jolt-array? x) (eq? (jolt-array-kind x) 'byte))
(let ((bv (na-bytearray->bv x)))
(if (pair? rest)
(put-bytevector port bv (jnum->exact (car rest)) (jnum->exact (cadr rest)))
(put-bytevector port bv))))
((bytevector? x) (put-bytevector port x))
(else (error #f "OutputStream/write: unsupported" x)))
jolt-nil)))
(cons "flush" (lambda (self) (flush-output-port (out-stream-port self)) jolt-nil))
(cons "close" (lambda (self) (flush-output-port (out-stream-port self))
;; a ByteArrayOutputStream's close is a no-op (toByteArray stays valid);
;; a file stream's port is closed.
(unless (vector-ref (jhost-state self) 1) (close-port (out-stream-port self))) jolt-nil))
(cons "toByteArray" (lambda (self) (na-byte-array (bytevector-copy (baos-bytes self)))))
(cons "size" (lambda (self) (->num (bytevector-length (baos-bytes self)))))
(cons "reset" (lambda (self) (baos-bytes self) (vector-set! (jhost-state self) 2 (make-bytevector 0)) jolt-nil))
(cons "toString" (lambda (self . cs) (decode-bytevector (baos-bytes self)
(if (pair? cs) (list (jolt-str-render-one (car cs))) '()))))))
;; --- char input (Reader) ----------------------------------------------------
(define (char-reader-port self) (vector-ref (jhost-state self) 0))
(define (char-reader? x) (and (jhost? x) (string=? (jhost-tag x) "char-reader")))
(define (make-char-reader port) (make-jhost "char-reader" (vector port)))
(register-host-methods! "char-reader"
(list
(cons "read"
(lambda (self . rest)
(let ((port (char-reader-port self)))
(if (null? rest)
(let ((c (get-char port))) (if (eof-object? c) -1 (->num (char->integer c))))
(let* ((buf (car rest))
(vec (jolt-array-vec buf))
(off (if (>= (length rest) 3) (jnum->exact (cadr rest)) 0))
(len (if (>= (length rest) 3) (jnum->exact (caddr rest)) (vector-length vec))))
(let loop ((i 0))
(if (>= i len) (->num i)
(let ((c (get-char port)))
(if (eof-object? c)
(if (= i 0) -1 (->num i))
(begin (vector-set! vec (+ off i) c) (loop (+ i 1))))))))))))
(cons "readLine" (lambda (self) (let ((l (get-line (char-reader-port self)))) (if (eof-object? l) jolt-nil l))))
(cons "lines" (lambda (self)
(let loop ((acc '()))
(let ((l (get-line (char-reader-port self))))
(if (eof-object? l) (list->cseq (reverse acc)) (loop (cons l acc)))))))
(cons "ready" (lambda (self) #t))
(cons "skip" (lambda (self n) (let loop ((i 0) (k (jnum->exact n)))
(if (or (>= i k) (eof-object? (get-char (char-reader-port self)))) (->num i)
(loop (+ i 1) k)))))
(cons "close" (lambda (self) (close-port (char-reader-port self)) jolt-nil))
(cons "mark" (lambda (self . _) jolt-nil))
(cons "reset" (lambda (self) (guard (e (#t jolt-nil)) (set-port-position! (char-reader-port self) 0) jolt-nil)))
(cons "toString" (lambda (self) "#<Reader>"))))
;; --- char output (Writer) ---------------------------------------------------
(define (char-writer-port self) (vector-ref (jhost-state self) 0))
(define (char-writer? x) (and (jhost? x) (string=? (jhost-tag x) "char-writer")))
(define (make-char-writer port) (make-jhost "char-writer" (vector port)))
(define (cw-text x) (if (number? x) (string (integer->char (jnum->exact x))) (jolt-str-render-one x)))
(register-host-methods! "char-writer"
(list
(cons "write" (lambda (self x . rest)
;; (write str) | (write int) | (write str off len)
(let ((s (cw-text x)))
(put-string (char-writer-port self)
(if (>= (length rest) 2) (substring s (jnum->exact (car rest))
(+ (jnum->exact (car rest)) (jnum->exact (cadr rest)))) s)))
jolt-nil))
(cons "append" (lambda (self x . rest) (put-string (char-writer-port self) (cw-text x)) self))
(cons "newLine" (lambda (self) (put-char (char-writer-port self) #\newline) jolt-nil))
(cons "flush" (lambda (self) (flush-output-port (char-writer-port self)) jolt-nil))
(cons "close" (lambda (self) (close-port (char-writer-port self)) jolt-nil))
(cons "toString" (lambda (self) "#<Writer>"))))
;; --- constructors -----------------------------------------------------------
(define utf8-tx (make-transcoder (utf-8-codec)))
(define (path-of x) (project-relative (file-path-of x)))
(define (src-bytevector x) ; a byte[] or Chez bytevector -> bytevector
(cond ((bytevector? x) x)
((and (jolt-array? x) (eq? (jolt-array-kind x) 'byte)) (na-bytearray->bv x))
(else (error #f "expected a byte array" x))))
(define (reg-ctor! names ctor) (for-each (lambda (n) (register-class-ctor! n ctor)) names))
(reg-ctor! '("FileInputStream" "java.io.FileInputStream")
(lambda (src . _) (make-in-stream (open-file-input-port (path-of src) (file-options) (buffer-mode block)))))
(reg-ctor! '("FileOutputStream" "java.io.FileOutputStream")
(lambda (src . rest)
(let ((append? (and (pair? rest) (jolt-truthy? (car rest)))))
(make-out-stream (open-file-output-port (path-of src)
(if append? (file-options no-fail no-truncate append) (file-options no-fail))
(buffer-mode block))))))
(reg-ctor! '("ByteArrayInputStream" "java.io.ByteArrayInputStream")
(lambda (bytes . rest)
(let ((bv (src-bytevector bytes)))
(make-in-stream (open-bytevector-input-port
(if (>= (length rest) 2)
(let ((off (jnum->exact (car rest))) (len (jnum->exact (cadr rest))))
(let ((sub (make-bytevector len))) (bytevector-copy! bv off sub 0 len) sub))
bv))))))
(reg-ctor! '("ByteArrayOutputStream" "java.io.ByteArrayOutputStream")
(lambda _
(call-with-values open-bytevector-output-port
(lambda (port extract) (make-jhost "out-stream" (vector port extract (make-bytevector 0)))))))
(reg-ctor! '("FileReader" "java.io.FileReader")
(lambda (src . _) (make-char-reader (transcoded-port (open-file-input-port (path-of src) (file-options) (buffer-mode block)) utf8-tx))))
(reg-ctor! '("FileWriter" "java.io.FileWriter")
(lambda (src . rest)
(let ((append? (and (pair? rest) (jolt-truthy? (car rest)))))
(make-char-writer (transcoded-port (open-file-output-port (path-of src)
(if append? (file-options no-fail no-truncate append) (file-options no-fail))
(buffer-mode block)) utf8-tx)))))
;; InputStreamReader / OutputStreamWriter take ownership of the wrapped byte
;; stream's port and transcode it (UTF-8 default; an explicit charset is honored
;; only as UTF-8 here).
(reg-ctor! '("InputStreamReader" "java.io.InputStreamReader")
(lambda (in . _) (make-char-reader (transcoded-port (in-stream-port in) utf8-tx))))
(reg-ctor! '("OutputStreamWriter" "java.io.OutputStreamWriter")
(lambda (out . _) (make-char-writer (transcoded-port (out-stream-port out) utf8-tx))))
;; Buffered* — Chez ports are buffered already; the wrapper is the wrapped stream.
(for-each (lambda (n) (register-class-ctor! n (lambda (inner . _) inner)))
'("BufferedReader" "java.io.BufferedReader"
"BufferedWriter" "java.io.BufferedWriter"
"BufferedInputStream" "java.io.BufferedInputStream"
"BufferedOutputStream" "java.io.BufferedOutputStream"))
;; --- integration: slurp / line-seq / with-open ------------------------------
;; a char-reader joins the reader-jhost set (drain-reader / line-seq read it via
;; its .read method).
(let ((prev reader-jhost?))
(set! reader-jhost? (lambda (x) (or (char-reader? x) (prev x)))))
;; slurp a char-reader (drain chars) or a byte in-stream (drain bytes -> decode).
(let ((prev jolt-slurp))
(set! jolt-slurp
(lambda (src . opts)
(cond
((char-reader? src) (drain-reader src))
((in-stream? src) (decode-bytevector (let ((bv (get-bytevector-all (in-stream-port src))))
(if (eof-object? bv) (make-bytevector 0) bv))
(slurp-encoding opts)))
(else (apply prev src opts)))))
(def-var! "clojure.core" "slurp" jolt-slurp))
;; with-open closes the new stream jhosts via their .close method.
(let ((prev jolt-close))
(set! jolt-close
(lambda (x)
(if (and (jhost? x) (member (jhost-tag x) '("in-stream" "out-stream" "char-reader" "char-writer")))
(begin (record-method-dispatch x "close" jolt-nil) jolt-nil)
(prev x))))
(def-var! "clojure.core" "__close" jolt-close))
;; --- clojure.java.io: byte streams + copy / make-parents / delete-file -------
;; input-stream/output-stream now yield real byte streams (were char reader/writer).
(define (jio-input-stream x)
(cond ((in-stream? x) x)
((jfile? x) (make-in-stream (open-file-input-port (jfile-fs x) (file-options) (buffer-mode block))))
((and (jolt-array? x) (eq? (jolt-array-kind x) 'byte)) (make-in-stream (open-bytevector-input-port (na-bytearray->bv x))))
((bytevector? x) (make-in-stream (open-bytevector-input-port x)))
((and (jhost? x) (string=? (jhost-tag x) "url")) (make-in-stream (open-file-input-port (url-strip-scheme (url-spec x)) (file-options) (buffer-mode block))))
((string? x) (make-in-stream (open-file-input-port (project-relative x) (file-options) (buffer-mode block))))
(else (error #f "io/input-stream: don't know how to open" x))))
(define (jio-output-stream x . rest)
(cond ((out-stream? x) x)
((or (jfile? x) (string? x))
(let ((append? (let loop ((o rest)) (cond ((or (null? o) (null? (cdr o))) #f)
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "append") (jolt-truthy? (cadr o))) #t)
(else (loop (cddr o)))))))
(make-out-stream (open-file-output-port (path-of x)
(if append? (file-options no-fail no-truncate append) (file-options no-fail))
(buffer-mode block)))))
(else (error #f "io/output-stream: don't know how to open" x))))
(def-var! "clojure.java.io" "input-stream" jio-input-stream)
(def-var! "clojure.java.io" "output-stream" jio-output-stream)
;; io/make-parents: create the parent directories of the last path segment.
(define (jio-make-parents . args)
(let ((p (apply-make-file-path args)))
(let loop ((i (- (string-length p) 1)))
(cond ((<= i 0) #f)
((char=? (string-ref p i) #\/) (mkdirs! (substring p 0 i)))
(else (loop (- i 1)))))))
(define (apply-make-file-path args)
(jfile-path (apply jolt-make-file args)))
(def-var! "clojure.java.io" "make-parents" jio-make-parents)
;; io/delete-file: delete the file; raise unless :silently truthy.
(define (jio-delete-file f . opts)
(let ((p (file-path-of f)))
(if (delete-path! p) jolt-nil
(if (and (pair? opts) (jolt-truthy? (car opts))) jolt-nil
(error #f (string-append "Couldn't delete " p))))))
(def-var! "clojure.java.io" "delete-file" jio-delete-file)
;; io/copy: file/path/reader/stream/string/byte[] -> writer/stream/file/path.
;; A byte source copies byte-exact to a byte/file destination (no lossy text
;; round-trip); otherwise the content is read as text. UTF-8 bridges byte<->char.
(define (input-bytes input) ; bytevector for a byte source, else #f
(cond ((in-stream? input) (let ((bv (get-bytevector-all (in-stream-port input)))) (if (eof-object? bv) (make-bytevector 0) bv)))
((bytevector? input) input)
((and (jolt-array? input) (eq? (jolt-array-kind input) 'byte)) (na-bytearray->bv input))
;; a byte-input-stream shim (host tagged-table, :jolt/input-stream — e.g.
;; http-client's ByteArrayInputStream): drain it byte-exact, like slurp.
((and (htable? input) (jolt-truthy? (jolt-ref-get input (keyword "jolt" "input-stream"))))
(drain-byte-stream input))
(else #f)))
(define (input-text input)
(cond ((string? input) input)
((or (char-reader? input) (reader-jhost? input)) (drain-reader input))
((jfile? input) (jolt-slurp input))
((input-bytes input) => (lambda (bv) (decode-bytevector bv '())))
(else (jolt-str-render-one input))))
(define (jio-copy input output . opts)
(cond
((out-stream? output)
(put-bytevector (out-stream-port output)
(or (input-bytes input) (string->utf8 (input-text input)))))
((char-writer? output) (put-string (char-writer-port output) (input-text input)))
((and (jhost? output) (member (jhost-tag output) '("writer" "file-writer" "port-writer" "print-writer")))
(record-method-dispatch output "write" (list->cseq (list (input-text input)))))
((or (jfile? output) (string? output))
(let ((bv (and (not (string? input)) (not (jfile? input)) (input-bytes input))))
(if bv
(let ((port (open-file-output-port (path-of output) (file-options no-fail) (buffer-mode block))))
(put-bytevector port bv) (close-port port))
(jolt-spit output (input-text input)))))
;; a byte-output-stream shim (a host tagged-table with :jolt/output-stream,
;; e.g. http-client's ByteArrayOutputStream): write through its .write method,
;; byte-exact for a byte source.
((and (htable? output) (jolt-truthy? (jolt-ref-get output (keyword "jolt" "output-stream"))))
(let ((bv (input-bytes input)))
(record-method-dispatch output "write"
(list->cseq (list (if bv (make-jolt-array (list->vector (bytevector->u8-list bv)) 'byte)
(input-text input)))))))
(else (error #f "io/copy: don't know how to write to" output)))
jolt-nil)
(def-var! "clojure.java.io" "copy" jio-copy)
;; --- instance? for the java.io stream taxonomy ------------------------------
(register-class-arm! in-stream? (lambda (x) "java.io.InputStream"))
(register-class-arm! out-stream? (lambda (x) "java.io.OutputStream"))
(register-class-arm! char-reader? (lambda (x) "java.io.Reader"))
(register-class-arm! char-writer? (lambda (x) "java.io.Writer"))
(register-instance-check-arm!
(lambda (type-sym val)
(if (not (symbol-t? type-sym)) 'pass
(let ((short (last-dot (symbol-t-name type-sym))))
(cond
((and (in-stream? val) (member short '("InputStream" "FileInputStream" "ByteArrayInputStream"
"BufferedInputStream" "FilterInputStream" "Closeable" "AutoCloseable"))) #t)
((and (out-stream? val) (member short '("OutputStream" "FileOutputStream" "ByteArrayOutputStream"
"BufferedOutputStream" "FilterOutputStream" "Closeable" "AutoCloseable" "Flushable"))) #t)
((and (char-reader? val) (member short '("Reader" "BufferedReader" "FileReader" "InputStreamReader"
"Closeable" "AutoCloseable" "Readable"))) #t)
((and (char-writer? val) (member short '("Writer" "BufferedWriter" "FileWriter" "OutputStreamWriter"
"Closeable" "AutoCloseable" "Flushable" "Appendable"))) #t)
(else 'pass))))))

View file

@ -29,6 +29,70 @@
(hashtable-set! embedded-resources name content))
(define-record-type embedded-res (fields name content) (nongenerative jolt-embres-v1))
;; --- self-contained build artifacts (jolt-eaj) ------------------------------
;; A toolchain-free `jolt build` (the distributed joltc) carries the Chez
;; petite/scheme boots and a prebuilt launcher stub baked into its own boot image.
;; They live in the same table as embedded-resources, but keyed under bytevector
;; values (register-embedded-bytes!) rather than strings; resolve-on-roots /
;; io/resource only ever ask for the string-keyed source entries, so the two
;; coexist. The build driver reads them at heap-build time from files that exist
;; only on the dev machine.
(define (register-embedded-bytes! name bv) (hashtable-set! embedded-resources name bv))
(define (jolt-embedded-bytes name)
(let ((v (hashtable-ref embedded-resources name #f)))
(and (bytevector? v) v)))
;; Read a whole file as a bytevector ("" -> empty). Used to slurp boot/stub files.
(define (read-file-bytes path)
(let ((p (open-file-input-port path)))
(let ((bv (get-bytevector-all p)))
(close-port p)
(if (eof-object? bv) (bytevector) bv))))
;; Write an embedded bytevector resource out to a path. make-boot-file needs the
;; petite/scheme boots as files, so they are spilled to scratch before the call.
(define (jolt-spill-embedded! name path)
(let ((bv (jolt-embedded-bytes name)))
(unless bv (error 'jolt-spill-embedded! "no embedded bytes for" name))
(let ((p (open-file-output-port path (file-options no-fail) (buffer-mode block))))
(put-bytevector p bv)
(close-port p))))
;; Frame an app boot onto a file that already holds the stub bytes. Layout:
;; [stub][boot][boot-length:le64]["JOLTBOOT"]. The stub (host/chez/stub/launcher.c)
;; reads the trailing 16 bytes — the 8-byte magic, then the preceding 8-byte LE
;; length — to locate and register the boot, so a boot that itself contains the
;; magic bytes can't be mistaken for the frame.
(define jolt-payload-magic (string->utf8 "JOLTBOOT"))
(define (jolt-append-payload! path boot-bv)
(let ((head (read-file-bytes path))) ; the stub bytes already written
(let ((p (open-file-output-port path (file-options no-fail) (buffer-mode block)))
(lb (make-bytevector 8 0)))
(bytevector-u64-set! lb 0 (bytevector-length boot-bv) (endianness little))
(put-bytevector p head)
(put-bytevector p boot-bv)
(put-bytevector p lb)
(put-bytevector p jolt-payload-magic)
(close-port p))))
;; chmod 0755 via libc, so the produced binary is executable. load-shared-object
;; with #f pulls the running process's own symbols (chmod is in libc, linked into
;; every Chez binary) — no external toolchain. Falls back to /bin/sh chmod if the
;; symbol can't be resolved.
(define jolt-chmod-755
(let ((c (jolt-foreign-proc-safe "chmod" '(string int) 'int)))
(lambda (path)
(cond
(c (c path #o755))
;; Windows has no chmod and needs none (execute is by extension)
((let ((m (symbol->string (machine-type))))
(let loop ((i 0))
(cond ((> (+ i 2) (string-length m)) #f)
((string=? (substring m i (+ i 2)) "nt") #t)
(else (loop (+ i 1))))))
0)
(else (system (string-append "chmod 755 '" path "'")))))))
;; A user-facing relative path resolves against JOLT_PWD — the user's cwd before
;; the launcher cd'd to the jolt repo root — matching the JVM, where io/file is
;; cwd-relative. (io/resource builds jfiles from the source roots directly, so it
@ -39,11 +103,16 @@
(let ((pwd (getenv "JOLT_PWD")))
(if (and pwd (> (string-length pwd) 0)) (string-append pwd "/" p) p))))
;; (io/file path) / (io/file parent child) — join children with "/".
;; (io/file path) / (io/file parent child) — join children with "/". The File
;; keeps the path AS GIVEN (like the JVM: new File("rel").getPath() is "rel");
;; a relative path resolves against JOLT_PWD only when the filesystem is touched
;; (jfile-fs / slurp / spit / the stream constructors).
(define (jolt-make-file path . rest)
(let loop ((p (project-relative (file-path-of path))) (cs rest))
(let loop ((p (file-path-of path)) (cs rest))
(if (null? cs) (make-jfile p)
(loop (string-append p "/" (file-path-of (car cs))) (cdr cs)))))
;; the on-disk path of a value: a relative path resolves against JOLT_PWD.
(define (jfile-fs f) (project-relative (file-path-of f)))
(define (path-last-segment p)
(let loop ((i (- (string-length p) 1)))
@ -53,16 +122,44 @@
;; directory children as full paths, sorted (the __list-dir seed primitive).
(define (jolt-list-dir path)
(let ((p (file-path-of path)))
(let ((p (project-relative (file-path-of path))))
(map (lambda (e) (string-append p "/" e))
(sort string<? (directory-list p)))))
(define (jolt-dir? path) (if (file-directory? (file-path-of path)) #t #f))
(define (jolt-dir? path) (if (file-directory? (project-relative (file-path-of path))) #t #f))
;; absolute path string (cwd-relative paths resolved against current-directory).
(define (jfile-abs p)
(if (and (> (string-length p) 0) (char=? (string-ref p 0) #\/)) p
(string-append (current-directory) "/" p)))
;; --- file metadata over Chez filesystem ops ---------------------------------
;; byte size of a regular file (0 for a directory or a missing file).
(define (file-byte-size p)
(if (or (not (file-exists? p)) (file-directory? p)) 0
(let ((port (open-file-input-port p))) (let ((n (file-length port))) (close-port port) n))))
;; last-modified as epoch milliseconds (0 if the file is absent).
(define (file-mtime-millis p)
(if (file-exists? p)
(let ((t (file-modification-time p)))
(+ (* (time-second t) 1000) (div (time-nanosecond t) 1000000)))
0))
;; mkdir -p: create p and any missing parents. Returns #t if p ends up a dir.
(define (mkdirs! p)
(unless (or (= 0 (string-length p)) (file-exists? p))
(let loop ((i (- (string-length p) 1)))
(cond ((<= i 0) #f)
((char=? (string-ref p i) #\/)
(let ((parent (substring p 0 i))) (unless (file-exists? parent) (mkdirs! parent))))
(else (loop (- i 1)))))
(guard (e (#t #f)) (mkdir p)))
(and (file-exists? p) (file-directory? p)))
;; delete a file or an (empty) directory; #t on success.
(define (delete-path! p)
(guard (e (#t #f))
(cond ((not (file-exists? p)) #f)
((file-directory? p) (delete-directory p) #t)
(else (delete-file p) #t))))
;; --- java.net.URL (a jhost "url", state #(spec)) ----------------------------
;; A File.toURL value: .toString / .toExternalForm give the spec, .getPath /
;; .getFile strip the "file:" scheme.
@ -88,20 +185,59 @@
;; --- File method surface (record-method-dispatch arm) -----------------------
(define (jfile-method f name args) ; -> boxed result, or #f to fall through
(let ((p (jfile-path f)))
(let ((p (jfile-path f)) ; the path as given (display methods)
(fp (jfile-fs f))) ; JOLT_PWD-resolved on-disk path (FS methods)
(cond
((string=? name "getPath") (list p))
((string=? name "getName") (list (path-last-segment p)))
((string=? name "toString") (list p))
((string=? name "getAbsolutePath")(list (jfile-abs p)))
((string=? name "getCanonicalPath")(list (jfile-abs p)))
((string=? name "toURI") (list (string-append "file:" (jfile-abs p))))
((string=? name "toURL") (list (make-url (string-append "file:" (jfile-abs p)))))
((string=? name "exists") (list (if (file-exists? p) #t #f)))
((string=? name "isDirectory") (list (if (file-directory? p) #t #f)))
((string=? name "isFile") (list (if (and (file-exists? p) (not (file-directory? p))) #t #f)))
((string=? name "getAbsolutePath")(list (jfile-abs fp)))
((string=? name "getCanonicalPath")(list (jfile-abs fp)))
((string=? name "toURI") (list (string-append "file:" (jfile-abs fp))))
((string=? name "toURL") (list (make-url (string-append "file:" (jfile-abs fp)))))
;; io/resource returns a File where the JVM returns a file: URL; answer the
;; two URL methods resource-serving middleware (ring) calls on the result, so
;; it sees a "file" protocol and a path without changing the return type.
((string=? name "getProtocol") (list "file"))
((string=? name "getFile") (list (jfile-abs fp)))
((string=? name "exists") (list (if (file-exists? fp) #t #f)))
((string=? name "isDirectory") (list (if (file-directory? fp) #t #f)))
((string=? name "isFile") (list (if (and (file-exists? fp) (not (file-directory? fp))) #t #f)))
((string=? name "isAbsolute") (list (if (and (> (string-length p) 0) (char=? (string-ref p 0) #\/)) #t #f)))
((string=? name "listFiles") (list (list->cseq (map make-jfile (jolt-list-dir p)))))
((string=? name "listFiles") (list (list->cseq (map make-jfile (jolt-list-dir fp)))))
;; .list -> the child NAMES (a String[]), nil if not a directory.
((string=? name "list")
(list (if (file-directory? fp)
(apply jolt-vector (sort string<? (directory-list fp)))
jolt-nil)))
((string=? name "length") (list (->num (file-byte-size fp))))
((string=? name "lastModified") (list (->num (file-mtime-millis fp))))
((string=? name "canRead") (list (if (file-exists? fp) #t #f)))
((string=? name "canWrite") (list (if (file-exists? fp) #t #f)))
((string=? name "canExecute") (list (if (file-exists? fp) #t #f)))
((string=? name "isHidden") (list (let ((nm (path-last-segment p)))
(if (and (> (string-length nm) 0) (char=? (string-ref nm 0) #\.)) #t #f))))
((string=? name "mkdir") (list (guard (e (#t #f)) (and (not (file-exists? fp)) (begin (mkdir fp) #t)))))
((string=? name "mkdirs") (list (if (mkdirs! fp) #t #f)))
((string=? name "delete") (list (if (delete-path! fp) #t #f)))
((string=? name "deleteOnExit") (list jolt-nil))
((string=? name "setLastModified")(list #t))
((string=? name "createNewFile")
(list (if (file-exists? fp) #f
(guard (e (#t #f)) (close-port (open-output-file fp 'truncate)) #t))))
((string=? name "renameTo")
(list (let ((dst (jfile-fs (car args)))) (guard (e (#t #f)) (rename-file fp dst) #t))))
((string=? name "getParentFile")
(let loop ((i (- (string-length p) 1)))
(cond ((< i 0) (list jolt-nil))
((char=? (string-ref p i) #\/) (list (make-jfile (if (= i 0) "/" (substring p 0 i)))))
(else (loop (- i 1))))))
((string=? name "getAbsoluteFile") (list (make-jfile (jfile-abs p))))
((string=? name "getCanonicalFile") (list (make-jfile (jfile-abs p))))
((string=? name "compareTo") (list (->num (let ((o (file-path-of (car args))))
(cond ((string<? p o) -1) ((string>? p o) 1) (else 0))))))
((string=? name "equals") (list (and (jfile? (car args)) (string=? p (jfile-path (car args))))))
((string=? name "hashCode") (list (->num (string-hash p))))
((string=? name "getParent")
(let loop ((i (- (string-length p) 1)))
(cond ((< i 0) (list jolt-nil))
@ -109,14 +245,13 @@
(else (loop (- i 1))))))
(else #f))))
(define %io-rmd record-method-dispatch)
(set! record-method-dispatch
(register-method-arm! 41
(lambda (obj method-name rest-args)
(if (jfile? obj)
(let* ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args)))
(r (jfile-method obj method-name rest)))
(if r (car r) (error #f "no File method" method-name)))
(%io-rmd obj method-name rest-args))))
'pass)))
;; .isDirectory / .listFiles emit to jolt-host-call (rt.ss), not record-method-
;; dispatch — the shims there assume a path STRING target. Make them jfile-aware
@ -126,7 +261,7 @@
(lambda (method target . args)
(cond
((and (jfile? target) (string=? method "isDirectory"))
(if (file-directory? (jfile-path target)) #t #f))
(if (file-directory? (jfile-fs target)) #t #f))
((and (jfile? target) (string=? method "listFiles"))
(list->cseq (map make-jfile (jolt-list-dir target))))
(else (apply %io-host-call method target args)))))
@ -201,7 +336,7 @@
(loop (cons (bitwise-and (jnum->exact b) #xff) acc))))))
(define (jolt-slurp src . opts)
(cond
((jfile? src) (read-file-string (jfile-path src)))
((jfile? src) (read-file-string (jfile-fs src)))
((embedded-res? src) (embedded-res-content src))
((reader-jhost? src) (drain-reader src))
;; bytes (a bytevector or a jolt byte-array): decode with :encoding (UTF-8
@ -223,7 +358,7 @@
(else (loop (cddr o))))))
(define (jolt-spit path content . opts)
(let* ((p (file-path-of path))
(let* ((p (project-relative (file-path-of path)))
(port (open-output-file p (if (spit-append? opts) 'append 'truncate))))
(put-string port (jolt-str-render-one content))
(close-port port)
@ -247,7 +382,6 @@
(define io-kw-file (keyword "jolt" "file"))
(define %io-type jolt-type)
(set! jolt-type (lambda (x) (if (jfile? x) io-kw-file (%io-type x))))
(def-var! "clojure.core" "type" jolt-type)
;; (instance? java.io.File f): the instance? macro passes the class-name symbol;
;; match "File" / "java.io.File" (and any *.File) against a jfile.
@ -275,12 +409,18 @@
(define (jolt-close x)
(cond
((jolt-nil? x) jolt-nil)
((and (jhost? x) (member (jhost-tag x) '("string-reader" "pushback-reader" "writer")))
((and (jhost? x) (member (jhost-tag x) '("string-reader" "pushback-reader" "writer"
"file-writer" "port-writer" "print-writer")))
(record-method-dispatch x "close" jolt-nil) jolt-nil)
;; a library's stream shim (tagged-table) closes via its registered .close
;; method (a no-op for in-memory streams); absent method -> no-op.
((htable? x) (guard (e (#t jolt-nil)) (record-method-dispatch x "close" jolt-nil)) jolt-nil)
((jfile? x) jolt-nil)
;; a deftype/defrecord that implements a `close` method (java.io.Closeable /
;; AutoCloseable, e.g. tools.reader's reader types) closes through it — the
;; same method (.close x) would dispatch to.
((and (jrec? x) (jrec-cl x "close"))
(record-method-dispatch x "close" jolt-nil) jolt-nil)
(else
(let ((closef (jolt-get x (keyword #f "close") jolt-nil)))
(if (and (not (jolt-nil? closef)) (procedure? closef))
@ -294,10 +434,14 @@
;; a StringReader (host-static.ss jhost) so .read/.mark/.reset and slurp work.
(define (seq-source->string x)
(apply string-append (map jolt-str-render-one (seq->list x))))
;; io/reader returns an in-memory StringReader (the full Reader contract incl.
;; (read), mark/reset and pushback). The streaming java.io.FileReader /
;; BufferedReader classes (io-streams.ss) read a Chez port directly when a caller
;; wants to avoid loading the whole source.
(define (jolt-io-reader x)
(cond
((reader-jhost? x) x)
((jfile? x) (host-new "StringReader" (read-file-string (jfile-path x))))
((jfile? x) (host-new "StringReader" (read-file-string (jfile-fs x))))
((embedded-res? x) (host-new "StringReader" (embedded-res-content x)))
((and (jhost? x) (string=? (jhost-tag x) "url"))
(host-new "StringReader" (read-file-string (url-strip-scheme (url-spec x)))))
@ -361,14 +505,48 @@
((file-exists? (string-append (car roots) "/" nm))
(make-url (string-append "file:" (car roots) "/" nm)))
(else (loop (cdr roots)))))))
;; getResources: every source root that holds the named resource, as file: URLs
;; (enumeration-seq just calls seq, so a list serves). ring's static-resource
;; symlink check enumerates these to confirm a served file sits under a root.
(define (cl-get-resources self name)
(let ((nm (jolt-str-render-one name)))
(let loop ((roots (get-source-roots)) (acc '()))
(cond ((null? roots) (list->cseq (reverse acc)))
((file-exists? (string-append (car roots) "/" nm))
(loop (cdr roots) (cons (make-url (string-append "file:" (car roots) "/" nm)) acc)))
(else (loop (cdr roots) acc))))))
(register-host-methods! "classloader"
(list (cons "getResource" cl-get-resource)
(cons "getResources" cl-get-resources)
(cons "getResourceAsStream"
(lambda (self name)
(let ((u (cl-get-resource self name)))
(if (jolt-nil? u) jolt-nil (host-new "StringReader" (jolt-slurp (url-strip-scheme (url-spec u))))))))))
(register-class-statics! "ClassLoader" (list (cons "getSystemClassLoader" (lambda () the-classloader))))
(register-class-statics! "java.lang.ClassLoader" (list (cons "getSystemClassLoader" (lambda () the-classloader))))
;; clojure.lang.RT/baseLoader — the resource-resolving class loader (RT/baseLoader
;; is how libraries reach Clojure's base loader, e.g. aws-api's resources ns).
(register-class-statics! "RT" (list (cons "baseLoader" (lambda () the-classloader))))
(register-class-statics! "clojure.lang.RT" (list (cons "baseLoader" (lambda () the-classloader))))
;; clojure.lang.RT/nextID — process-unique increasing id (AtomicInteger(1)
;; getAndIncrement), used by id generators such as core.logic's lvar.
(define rt-next-id-counter 1)
(define (rt-next-id)
(let ((v rt-next-id-counter))
(set! rt-next-id-counter (+ rt-next-id-counter 1))
v))
(register-class-statics! "RT" (list (cons "nextID" rt-next-id)))
(register-class-statics! "clojure.lang.RT" (list (cons "nextID" rt-next-id)))
;; clojure.lang.Util — hash/equality helpers libraries call directly (core.logic's
;; LCons.hashCode uses Util/hash). hash = Java hashCode (0 for nil); hasheq = the
;; value hash jolt's = uses; equiv = value equality; identical = reference identity.
(let ((util-statics
(list (cons "hash" (lambda (x) (if (jolt-nil? x) 0 (record-method-dispatch x "hashCode" jolt-nil))))
(cons "hasheq" (lambda (x) (jolt-hash x)))
(cons "equiv" (lambda (a b) (if (jolt= a b) #t #f)))
(cons "identical" (lambda (a b) (if (eq? a b) #t #f))))))
(register-class-statics! "Util" util-statics)
(register-class-statics! "clojure.lang.Util" util-statics))
;; Thread/currentThread -> a fresh thread jhost wrapping THIS thread's interrupt
;; flag (the box from current-interrupt-box, host-static.ss), so .interrupt from
;; any thread sets the target thread's flag and .isInterrupted reads it without
@ -377,6 +555,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))
@ -393,6 +576,32 @@
(if (pair? rest)
(jolt-make-file (string-append (file-path-of a) "/" (file-path-of (car rest))))
(jolt-make-file a))))
;; File statics: the platform separators plus createTempFile / listRoots.
(define temp-file-counter 0)
(define (file-create-temp prefix suffix . dir)
(let* ((d (cond ((pair? dir) (file-path-of (car dir)))
((getenv "TMPDIR") => (lambda (t) t))
(else "/tmp")))
(sfx (if (or (null? (list suffix)) (jolt-nil? suffix)) ".tmp" (jolt-str-render-one suffix))))
(set! temp-file-counter (+ temp-file-counter 1))
(let loop ((n temp-file-counter))
(let ((p (string-append d "/" (jolt-str-render-one prefix)
(number->string (now-millis)) "-" (number->string n) sfx)))
(if (file-exists? p) (loop (+ n 1))
(begin (close-port (open-output-file p 'truncate)) (make-jfile p)))))))
(let ((statics (list (cons "separator" "/")
(cons "separatorChar" #\/)
(cons "pathSeparator" ":")
(cons "pathSeparatorChar" #\:)
(cons "createTempFile" file-create-temp)
(cons "listRoots" (lambda () (jolt-vector (make-jfile "/")))))))
(register-class-statics! "File" statics)
(register-class-statics! "java.io.File" statics))
(register-class-ctor! "java.io.File"
(lambda (a . rest)
(if (pair? rest)
(jolt-make-file (string-append (file-path-of a) "/" (file-path-of (car rest))))
(jolt-make-file a))))
;; UUID: randomUUID / fromString statics + a (UUID. s) string ctor.
(register-class-statics! "UUID"
(list (cons "randomUUID" (lambda () (jolt-random-uuid)))
@ -400,7 +609,51 @@
(register-class-statics! "java.util.UUID"
(list (cons "randomUUID" (lambda () (jolt-random-uuid)))
(cons "fromString" (lambda (s) (jolt-parse-uuid (jolt-str-render-one s))))))
(register-class-ctor! "UUID" (lambda (s) (jolt-parse-uuid (jolt-str-render-one s))))
;; (UUID. msb lsb): build from the most/least-significant 64-bit halves (the JVM's
;; 2-long ctor), the form test.check's uuid generator uses. (UUID. s) parses a
;; string. The 128 bits format as the canonical 8-4-4-4-12 lowercase hex string.
(define (uuid-long->hex16 n)
(let* ((u (bitwise-and (jnum->exact n) #xFFFFFFFFFFFFFFFF))
(s (string-downcase (number->string u 16)))) ; JVM UUIDs are lowercase
(string-append (make-string (- 16 (string-length s)) #\0) s)))
(define (uuid-from-halves msb lsb)
(let ((h (uuid-long->hex16 msb)) (l (uuid-long->hex16 lsb)))
(make-juuid (string-append (substring h 0 8) "-" (substring h 8 12) "-" (substring h 12 16)
"-" (substring l 0 4) "-" (substring l 4 16)))))
(define (uuid-ctor . args)
(if (= (length args) 2)
(uuid-from-halves (car args) (cadr args))
(jolt-parse-uuid (jolt-str-render-one (car args)))))
(register-class-ctor! "UUID" uuid-ctor)
(register-class-ctor! "java.util.UUID" uuid-ctor)
;; (Long. n) / (Long. "n"): a Long is just jolt's integer; return it (parse a string).
(register-class-ctor! "Long" (lambda (x) (if (string? x) (parse-int-or-throw x 10 "Long") (->num (jnum->exact x)))))
(register-class-ctor! "java.lang.Long" (lambda (x) (if (string? x) (parse-int-or-throw x 10 "Long") (->num (jnum->exact x)))))
;; (Integer. n) / (Integer. "n"): jolt's integer, range-checked like intCast.
(define (integer-ctor x)
(jolt-int-cast (if (string? x) (parse-int-or-throw x 10 "Integer") x)))
(register-class-ctor! "Integer" integer-ctor)
(register-class-ctor! "java.lang.Integer" integer-ctor)
;; (Double. x) / (Double. "x"): jolt's double.
(define (double-ctor x)
(if (string? x)
(let ((n (string->number x)))
(if n (exact->inexact n)
(jolt-throw (jolt-host-throwable "java.lang.NumberFormatException"
(string-append "For input string: \"" x "\"")))))
(jolt-double x)))
(register-class-ctor! "Double" double-ctor)
(register-class-ctor! "java.lang.Double" double-ctor)
;; (Boolean. "true") / (Boolean. b): true for the string "true" (case-insensitive,
;; anything else false) or the boolean itself — Boolean.valueOf semantics; the
;; box is jolt's plain boolean.
(define (boolean-ctor x)
(cond ((string? x) (string-ci=? x "true"))
((boolean? x) x)
(else #f)))
(register-class-ctor! "Boolean" boolean-ctor)
(register-class-ctor! "java.lang.Boolean" boolean-ctor)
;; --- java.net.URI -----------------------------------------------------------
;; A minimal RFC-3986 split into scheme/authority/host/port/path/query/fragment,
@ -469,6 +722,9 @@
(define (uri-field u k) (let ((p (assq k (jhost-state u)))) (if p (cdr p) jolt-nil)))
(register-class-ctor! "URI" (lambda (s) (uri-parse (jolt-str-render-one s))))
(register-class-ctor! "java.net.URI" (lambda (s) (uri-parse (jolt-str-render-one s))))
;; URI/create — the static factory, same as the (URI. s) constructor.
(register-class-statics! "URI" (list (cons "create" (lambda (s) (uri-parse (jolt-str-render-one s))))))
(register-class-statics! "java.net.URI" (list (cons "create" (lambda (s) (uri-parse (jolt-str-render-one s))))))
(register-host-methods! "uri"
(list (cons "toString" (lambda (u) (uri-field u 'string)))
(cons "toASCIIString" (lambda (u) (uri-field u 'string)))
@ -485,6 +741,14 @@
(cons "hashCode" (lambda (u) (string-hash (uri-field u 'string))))
(cons "equals" (lambda (u o) (and (jhost? o) (string=? (jhost-tag o) "uri")
(string=? (uri-field u 'string) (uri-field o 'string)))))))
;; (= u1 u2) is value equality by string form (the .equals method above only
;; serves explicit (.equals …)); hash matches so a URI works as a map key / set
;; member (ring/hiccup compare (URI. "/") values).
(define (uri-jhost? x) (and (jhost? x) (string=? (jhost-tag x) "uri")))
(register-eq-arm! (lambda (a b) (or (uri-jhost? a) (uri-jhost? b)))
(lambda (a b) (and (uri-jhost? a) (uri-jhost? b)
(string=? (uri-field a 'string) (uri-field b 'string)))))
(register-hash-arm! uri-jhost? (lambda (x) (string-hash (uri-field x 'string))))
;; str / pr-str of a uri -> its string form.
(register-str-render! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "uri")))
(lambda (x) (uri-field x 'string)))

2307
host/chez/java/java-time.ss Normal file

File diff suppressed because it is too large Load diff

View file

@ -85,42 +85,22 @@
(define (na-bytes x) (if (and (jolt-array? x) (eq? (jolt-array-kind x) 'byte)) x (na-byte-array x)))
(define (na-bytes? x) (and (jolt-array? x) (eq? (jolt-array-kind x) 'byte)))
(define (na-identity x) x)
(define (na-byte x)
(let ((b (bitwise-and (exact (floor x)) #xff))) (if (>= b 128) (- b 256) b)))
(define (na-short x)
(let ((s (bitwise-and (exact (floor x)) #xffff))) (if (>= s #x8000) (- s #x10000) s)))
(define (na-byte x) (jolt-byte-cast x))
(define (na-short x) (jolt-short-cast x))
;; --- chunked seqs -----------------------------------------------------------
;; A vector's seq is a REAL chunked-seq: (seq v) carries its backing vector +
;; element index (seq.ss cseq-vec), so chunked-seq? is true and chunk-first hands
;; out a 32-element block (a pvec slice) while chunk-rest is the seq at the next
;; block boundary — the Clojure/CLJS ChunkedSeq contract (chunk-first ++
;; chunk-rest == the seq). The eager buffer model (chunk-buffer/chunk-append/
;; chunk) builds a plain cseq; chunk-cons/first/rest fall back to seq ops over it.
(define na-chunk-size 32)
;; The chunked-seq accessors (chunked-seq? / chunk-first / chunk-rest / chunk-next)
;; live in seq.ss with the cseq core they read; here we only bind them plus the
;; chunk-builder API (clojure.lang.ChunkBuffer + chunk-cons). chunk-buffer collects
;; appended items, chunk seals them into a pvec chunk, and chunk-cons prepends that
;; chunk onto a rest seq as a real ChunkedCons (cseq-chunked) — empty chunk == just
;; the rest, like clojure.core/chunk-cons.
(define-record-type jolt-chunkbuf (fields (mutable items)) (nongenerative jolt-chunkbuf-v1))
(define (na-chunk-buffer cap) (make-jolt-chunkbuf '()))
(define (na-chunk-append b x) (jolt-chunkbuf-items-set! b (append (jolt-chunkbuf-items b) (list x))) b)
(define (na-chunk b) (list->cseq (jolt-chunkbuf-items b)))
(define (na-chunk-cons chunk rest) (jolt-concat chunk rest))
;; backing (vector . end-of-block index) for a vector-seq cell, or #f.
(define (na-vblock s)
(and (cseq? s) (cseq-cvec s)
(let* ((v (cseq-cvec s)) (i (cseq-ci s)))
(cons v (fxmin (fx+ i na-chunk-size) (pvec-count v))))))
(define (na-chunked-seq? x) (and (na-vblock x) #t))
(define (na-chunk-first s)
(let ((vb (na-vblock s)))
(if vb (make-pvec (vec-copy-range (pvec-v (car vb)) (cseq-ci s) (cdr vb)))
(jolt-first s)))) ; eager-buffer fallback
(define (na-chunk-rest s)
(let ((vb (na-vblock s)))
(if vb (if (fx>=? (cdr vb) (pvec-count (car vb))) jolt-empty-list (vec->seq (car vb) (cdr vb)))
(jolt-rest s))))
(define (na-chunk-next s)
(let ((vb (na-vblock s)))
(if vb (if (fx>=? (cdr vb) (pvec-count (car vb))) jolt-nil (vec->seq (car vb) (cdr vb)))
(jolt-next s))))
(define (na-chunk b) (make-pvec (list->vector (jolt-chunkbuf-items b))))
(define (na-chunk-cons chunk rest)
(if (fx=? 0 (pvec-count chunk)) rest (cseq-chunked chunk 0 rest)))
;; --- extend the collection dispatchers to see a jolt-array ------------------
(define %na-count jolt-count)
@ -135,10 +115,11 @@
(let ((v (jolt-array-vec c)) (j (exact (na-idx i))))
(if (and (>= j 0) (< j (vector-length v))) (vector-ref v j) d))
(%na-nth c i d)))))
(def-var! "jolt.host" "array-value?" (lambda (x) (if (jolt-array? x) #t jolt-nil)))
(define %na-get jolt-get)
(set! jolt-get
(case-lambda
((c k) (if (jolt-array? c) (jolt-nth c k) (%na-get c k)))
((c k) (if (jolt-array? c) (jolt-nth c k jolt-nil) (%na-get c k)))
((c k d) (if (jolt-array? c) (jolt-nth c k d) (%na-get c k d)))))
;; aset (overlay) writes through jolt.host/ref-put! — mutate the slot, return arr.
;; count/nth/seq/get above are NATIVE-OPS (inlined at call sites), so aget/alength/
@ -156,7 +137,6 @@
;; (jolt-type …) for arrays, so extending jolt-type covers both.
(define %na-type jolt-type)
(set! jolt-type (lambda (x) (if (jolt-array? x) (na-array-class-name x) (%na-type x))))
(def-var! "clojure.core" "type" jolt-type)
;; instance? over an array class token ([I, [C, …). An array token reaches us as
;; a string ("[C", from (Class/forName "[C")) — the dispatcher leaves it a string

View file

@ -19,7 +19,9 @@
(define (queue-peek q) (if (null? (jolt-queue-front q)) jolt-nil (car (jolt-queue-front q))))
(define (queue-pop q)
(let ((f (jolt-queue-front q)))
(cond ((null? f) (error 'pop "can't pop empty queue"))
;; popping an empty PersistentQueue returns it (Clojure's pop: if f==null
;; return this) — unlike a vector, which throws.
(cond ((null? f) q)
((null? (cdr f)) (make-jolt-queue (reverse (jolt-queue-rear q)) '() (fx- (jolt-queue-cnt q) 1)))
(else (make-jolt-queue (cdr f) (jolt-queue-rear q) (fx- (jolt-queue-cnt q) 1))))))

View file

@ -108,10 +108,30 @@
((string=? cs "utf-32le") (string->utf32 s (endianness little)))
(else (string->utf8 s)))))
;; Object.hashCode parity: Java's specified String hash and Clojure's Symbol hash
;; (Util.hashCombine), so (.hashCode s) / (.hashCode sym) match the JVM. 32-bit int.
(define (jolt-u32 x) (bitwise-and x #xFFFFFFFF))
(define (jolt-s32 x) (let ((m (jolt-u32 x))) (if (>= m #x80000000) (- m #x100000000) m)))
(define (java-string-hash s)
(let ((n (string-length s)))
(let loop ((i 0) (h 0))
(if (fx<? i n)
(loop (fx+ i 1) (jolt-s32 (+ (* 31 h) (char->integer (string-ref s i)))))
(jolt-s32 h)))))
(define (java-hash-combine seed hash)
(let* ((su (jolt-u32 seed))
(sl (bitwise-arithmetic-shift-left su 6))
(sr (bitwise-arithmetic-shift-right (jolt-s32 su) 2))
(add (+ (jolt-u32 hash) #x9e3779b9 sl sr)))
(jolt-s32 (bitwise-xor su (jolt-u32 add)))))
(define (java-symbol-hash name ns)
(java-hash-combine (java-string-hash name) (if ns (java-string-hash ns) 0)))
(define (jolt-string-method method s rest)
(define (arg n) (list-ref rest n))
(cond
((string=? method "toString") s)
((string=? method "hashCode") (java-string-hash s))
((string=? method "toLowerCase") (ascii-string-down s))
((string=? method "toUpperCase") (ascii-string-up s))
((string=? method "trim") (str-trim s))
@ -303,7 +323,9 @@
(define (str-replace-all pat repl s)
(if (jolt-regex? pat)
(re-replace (regex-t-irx pat) s repl #t)
(str-replace-literal s pat repl)))
;; literal match: a char/number match or replacement (str/replace s \a \b)
;; coerces to a string, as on the JVM.
(str-replace-literal s (str-needle pat) (str-needle repl))))
(define (str-replace-literal-first s a b)
(let ((alen (string-length a)) (i (str-index-of s a 0)))
(if (fx<? i 0) s
@ -311,7 +333,7 @@
(define (str-replace pat repl s)
(if (jolt-regex? pat)
(re-replace (regex-t-irx pat) s repl #f)
(str-replace-literal-first s pat repl)))
(str-replace-literal-first s (str-needle pat) (str-needle repl))))
(def-var! "clojure.core" "str-upper" str-upper)
(def-var! "clojure.core" "str-lower" str-lower)

View file

@ -0,0 +1,163 @@
;; records-interop.ss — JVM-emulation taxonomy split out of records.ss: the
;; ex-info class accessors, the exception supertype hierarchy, and instance-check
;; / case-string (the (instance? Class x) decision table). Loaded right after
;; records.ss; instance-check forward-refs nothing in records.ss at load time.
;; pmap? guard: ex-info maps are plain hash-maps, never sorted-map htables — and a
;; bare jolt-get on a sorted-map would invoke its comparator on :jolt/type and throw.
(define (ex-info-map? v)
(and (pmap? v) (jolt=2 (jolt-get v jolt-kw-ex-type jolt-nil) jolt-kw-ex-info)))
(define (ex-info-class v)
(let ((c (jolt-get v jolt-kw-class jolt-nil)))
(if (string? c) c "clojure.lang.ExceptionInfo")))
;; Is `wanted` (simple name) `cls` or a supertype of it? The exception hierarchy
;; lives in the one class graph (class-hierarchy.ss) — resolve the simple name to
;; its graph key and ask jch-isa?, so exceptions and every other class share a
;; single source of truth (ExceptionInfo -> IExceptionInfo is a graph edge).
(define (exception-isa? cls wanted)
(jch-isa? (jch-fqn-of-simple cls) wanted))
;; A raw Chez condition (an arity or non-seqable error Chez itself raised, not a
;; jolt ex-info) carries no jolt exception class. Map the ones Clojure raises a
;; specific class for, by message, so (class e) and (instance? C e) match the JVM.
;; Returns a simple class name or #f.
(define (ri-substring? needle hay)
(let ((nl (string-length needle)) (hl (string-length hay)))
(let loop ((i 0))
(cond ((> (+ i nl) hl) #f)
((string=? needle (substring hay i (+ i nl))) #t)
(else (loop (+ i 1)))))))
(define (chez-condition-exc-class v)
(and (condition? v) (message-condition? v)
(let ((m (condition-message v)))
(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
;; later (io, inst-time, natives-array, natives-queue, host-static-classes)
;; register an arm with register-instance-check-arm! instead of set!-wrapping
;; instance-check; an arm returns #t/#f to decide or 'pass to defer to the next.
;; Newest arm is checked first (matches the old outermost-wins set! order).
;; instance-check-base is the JVM taxonomy fallback when no arm decides.
(define instance-check-registry '())
(define (register-instance-check-arm! f) ; f: (type-sym val) -> #t | #f | 'pass
(set! instance-check-registry (cons f instance-check-registry)))
;; (instance? C raw-condition): match when C is the condition's mapped class or a
;; supertype of it (ArityException is also an IllegalArgumentException, etc.).
(register-instance-check-arm!
(lambda (type-sym val)
(let ((k (chez-condition-exc-class val)))
(if k (if (exception-isa? k (last-dot (symbol-t-name type-sym))) #t #f) 'pass))))
;; Object / java.lang.Object is the root of the type hierarchy: every non-nil
;; value is an instance of Object; nil is not an instance of anything.
(register-instance-check-arm!
(lambda (type-sym val)
(let ((tn (symbol-t-name type-sym)))
(if (or (string=? tn "Object") (string=? tn "java.lang.Object"))
(not (jolt-nil? val))
'pass))))
(define (instance-check-base type-sym val)
(let ((tname (symbol-t-name type-sym)))
(cond
((jrec? val)
(let ((tag (jrec-tag val)))
(or (string=? tag tname)
;; a simple name matches a qualified tag only at a `.` boundary:
;; "a.b.IntervalFD" is an IntervalFD, but "a.b.MultiIntervalFD" is NOT
;; (a raw string-suffix would wrongly match the latter).
(let ((tl (string-length tag)) (nl (string-length tname)))
(and (fx>? tl nl)
(char=? (string-ref tag (fx- (fx- tl nl) 1)) #\.)
(string=? (substring tag (fx- tl nl) tl) tname)))
;; a protocol/interface the type implements (defprotocol generates an
;; interface; (instance? SomeProtocol record) is true when the record
;; implements it — core.match dispatches on instance? IPatternCompile).
(type-satisfies? tag tname)
(type-satisfies? tag (last-dot tname)))))
((jreify? val) (let ((short (last-dot tname)))
;; every Clojure reify implements IObj/IMeta (carries metadata).
(or (member short '("IObj" "IMeta"))
(and (memp (lambda (p) (string=? (last-dot p) short)) (jreify-protos val)) #t))))
((ex-info-map? val) (exception-isa? (last-dot (ex-info-class val)) (last-dot tname)))
(else (case-string tname val)))))
(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)
type-sym)))
(let loop ((rs instance-check-registry))
(if (null? rs)
(instance-check-base ts val)
(let ((r ((car rs) ts val)))
(if (eq? r 'pass) (loop (cdr rs)) r))))))
(define (case-string tname val)
(cond
((member tname '("Number" "java.lang.Number")) (number? val))
((member tname '("Long" "java.lang.Long" "Integer" "java.lang.Integer"))
(and (number? val) (exact? val) (integer? val)))
((member tname '("Double" "java.lang.Double" "Float" "java.lang.Float")) (and (number? val) (flonum? val)))
((member tname '("Ratio" "clojure.lang.Ratio")) (and (number? val) (exact? val) (rational? val) (not (integer? val))))
((member tname '("String" "java.lang.String" "CharSequence" "java.lang.CharSequence")) (string? val))
((member tname '("Boolean" "java.lang.Boolean")) (boolean? val))
((member tname '("Character" "java.lang.Character")) (char? val))
((member tname '("Keyword" "clojure.lang.Keyword")) (keyword? val))
((member tname '("Symbol" "clojure.lang.Symbol")) (jolt-symbol? val))
((member tname '("Atom" "clojure.lang.Atom")) (jolt-atom? val))
((member tname '("IFn" "clojure.lang.IFn" "Fn" "clojure.lang.Fn")) (procedure? val))
((member tname '("Pattern" "java.util.regex.Pattern")) (regex-t? val))
((member tname '("URI" "java.net.URI"))
(and (jhost? val) (string=? (jhost-tag val) "uri")))
((member tname '("File" "java.io.File")) (jfile? val))
((member tname '("UUID" "java.util.UUID")) (juuid? val))
(else #f)))
;; str of a record uses a custom (Object toString) impl if the type defines one
;; (deftype with no default toString relies on this); otherwise the map form
;; without the leading # (Clojure's record .toString). converters.ss loads before
;; 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)))

View file

@ -0,0 +1,122 @@
#!/bin/sh
# joltc self-build smoke (jolt-eaj): build joltc as a self-contained binary, then
# use THAT binary to compile a jolt app with Chez and cc removed from the
# environment — the whole point of the feature. The produced app must then run
# and match the same expected output as build-smoke.sh.
root="$(CDPATH= cd -- "$(dirname -- "$0")/../.." && pwd)"
cd "$root"
# Preflight: building joltc itself needs the Chez kernel dev files (libkernel.a +
# scheme.h) and a C compiler, same as build-smoke.sh. A distro chezscheme package
# ships neither, so skip there (CI included).
csv="$JOLT_CHEZ_CSV"
if [ -z "$csv" ]; then
chez_bin="$(command -v chez || command -v scheme || command -v petite || true)"
if [ -n "$chez_bin" ]; then
base="$(cd "$(dirname "$chez_bin")/.." 2>/dev/null && pwd)"
for d in "$base"/lib/csv*/*/; do
[ -f "${d}libkernel.a" ] && csv="${d%/}" && break
done
fi
fi
if ! command -v cc >/dev/null 2>&1 || [ -z "$csv" ] || [ ! -f "$csv/scheme.h" ] || [ ! -f "$csv/libkernel.a" ]; then
echo "joltc self-build smoke: skipped (Chez kernel dev files or C compiler not available)"
exit 0
fi
export JOLT_CHEZ_CSV="$csv"
# 1. Build joltc (debug profile — faster; the self-contained app-build mechanism
# is identical to release, only Chez compile settings differ).
joltc="$root/target/debug/joltc"
echo "joltc self-build smoke: building $joltc"
if ! chez --script host/chez/build-joltc.ss debug "$joltc" >/dev/null 2>&1; then
echo " FAIL: build-joltc.ss exited non-zero"
exit 1
fi
[ -x "$joltc" ] || { echo " FAIL: no joltc executable produced"; exit 1; }
# 2. The distributed joltc must run with no Chez install: a basic eval.
got_e="$(env -i HOME="$HOME" "$joltc" -e '(reduce + (range 10))' 2>&1)"
if [ "$got_e" != "45" ]; then
echo " FAIL: joltc -e under empty env gave '$got_e', want 45"
exit 1
fi
# 2b. JOLT_TRACE must take effect in the BUILT binary. The env check runs at
# runtime (the launcher), NOT at heap-build where JOLT_TRACE is always unset — so
# an uncaught error shows a tail-frame trace recovering the TCO-elided chain, and
# exactly ONE trace block (the launcher must not double-print it).
got_tr="$(env -i HOME="$HOME" JOLT_TRACE=1 "$joltc" -e '(defn a [x] (+ x 1)) (defn b [x] (a x)) (b :x)' 2>&1)"
if ! printf '%s' "$got_tr" | grep -q ' trace:' || ! printf '%s' "$got_tr" | grep -q 'b'; then
echo " FAIL: JOLT_TRACE=1 in the built joltc produced no tail-frame trace"
echo "--- got ---"; echo "$got_tr"; exit 1
fi
if [ "$(printf '%s' "$got_tr" | grep -c ' trace:')" != "1" ]; then
echo " FAIL: built joltc double-printed the trace block"
echo "--- got ---"; echo "$got_tr"; exit 1
fi
# 3. Build an app through the distributed joltc with an EMPTY environment — no
# PATH at all, so no chez, no cc, no shell tools are reachable. This is the core
# guarantee: joltc compiles apps entirely on its own.
app="$(mktemp -d)/build-app"
cp -r "$root/test/chez/build-app" "$app"
out="$app/app"
echo "joltc self-build smoke: compiling app.core via the binary (no chez/cc on PATH)"
if ! env -i HOME="$HOME" JOLT_PWD="$app" "$joltc" build -m app.core -o "$out" >/dev/null 2>&1; then
echo " FAIL: self-contained jolt build exited non-zero"
rm -rf "$(dirname "$app")"
exit 1
fi
[ -x "$out" ] || { echo " FAIL: no app executable produced"; rm -rf "$(dirname "$app")"; exit 1; }
# 4. The produced app runs from a neutral cwd and matches build-smoke's output.
got="$(cd / && "$out" alpha bb ccc 2>&1)"
want='embedded resource ok
HELLO FROM A BUILT BINARY!
HELLO FROM A BUILT BINARY!
args: [alpha bb ccc]
sum: 10
greet-default: greet:default
greet-loud: greet:loud
greet-soft: greet:soft'
rm -rf "$(dirname "$app")"
if [ "$got" != "$want" ]; then
echo " FAIL: produced app output mismatch"
echo "--- want ---"; echo "$want"
echo "--- got ----"; echo "$got"
exit 1
fi
# 5. Static native linking through the distributed joltc: it bundles the Chez
# kernel, so with the system cc (but still no external Chez) it re-links a stub
# that bakes a :jolt/native :static archive into the app. The app then calls the
# C function with the archive removed from disk. Uses the normal PATH so cc — and
# the kernel's link deps (lz4/…) — are found, but Chez stays out of the build.
napp="$(mktemp -d)/native-app"
mkdir -p "$napp/src/app"
printf 'int jolt_static_answer(void){return 42;}\n' > "$napp/greet.c"
cc -c "$napp/greet.c" -o "$napp/greet.o" && ar rcs "$napp/libgreet.a" "$napp/greet.o"
cat > "$napp/src/app/core.clj" <<'EOF'
(ns app.core (:require [jolt.ffi :as ffi]))
(ffi/defcfn answer "jolt_static_answer" [] :int)
(defn -main [& _] (println "answer:" (answer)))
EOF
cat > "$napp/deps.edn" <<EOF
{:paths ["src"]
:jolt/native [{:name "greet" :static {:archive "$napp/libgreet.a"}}]}
EOF
nout="$napp/app"
echo "joltc self-build smoke: static-linking a native lib via the binary (no external Chez)"
if ! JOLT_PWD="$napp" "$joltc" build -m app.core -o "$nout" >/dev/null 2>&1; then
echo " FAIL: static native build via distributed joltc exited non-zero"
rm -rf "$(dirname "$napp")"; exit 1
fi
rm -f "$napp/libgreet.a" "$napp/greet.o" # nothing to load at runtime
got_n="$(cd / && "$nout" 2>&1)"
rm -rf "$(dirname "$napp")"
if [ "$got_n" != "answer: 42" ]; then
echo " FAIL: static-linked app (via distributed joltc) output mismatch"
echo "--- got ----"; echo "$got_n"; exit 1
fi
echo "joltc self-build smoke: passed (joltc runs + builds a working app with no external toolchain, incl. static native linking)"

View file

@ -49,6 +49,13 @@
(cseq-lazy x (lambda () (force-lazyseq coll)))
(%ls-cons x coll))))
;; (conj lazyseq x): conj onto a seq prepends, like any seq — (conj (rest xs) y).
;; rest returns a lazyseq, so this is a common path; without it conj reports the
;; lazyseq as an "unsupported collection".
(define %ls-conj1 jolt-conj1)
(set! jolt-conj1 (lambda (coll x)
(if (jolt-lazyseq? coll) (jolt-cons x coll) (%ls-conj1 coll x))))
;; A lazyseq is a NEW value type, so the dispatchers that DON'T route through
;; jolt-seq must learn it or a raw (unrealized) lazyseq escapes — e.g. the corpus
;; compares (= [1 3 5] (take-nth 2 …)) against the raw lazyseq, and jolt=2 would
@ -65,10 +72,15 @@
(set! jolt-nth (case-lambda
((coll i) (if (jolt-lazyseq? coll) (%ls-nth (jolt-seq coll) i) (%ls-nth coll i)))
((coll i d) (if (jolt-lazyseq? coll) (%ls-nth (jolt-seq coll) i d) (%ls-nth coll i d)))))
;; a lazy seq prints as its realized seq — force, then re-dispatch through the printer.
(register-pr-str-arm! jolt-lazyseq? (lambda (x) (jolt-pr-str (jolt-seq x))))
(register-pr-readable-arm! jolt-lazyseq? (lambda (x) (jolt-pr-readable (jolt-seq x))))
(register-str-render! jolt-lazyseq? (lambda (x) (jolt-str-render-one (jolt-seq x))))
;; a lazy seq prints as its realized seq — force, then re-dispatch through the
;; printer. An empty realized lazy seq is still a sequence, printing "()" (like a
;; JVM LazySeq), not "nil" — so (lazy-seq nil) and (rest '(1)) render "()".
(register-pr-str-arm! jolt-lazyseq?
(lambda (x) (let ((s (jolt-seq x))) (if (jolt-nil? s) "()" (jolt-pr-str s)))))
(register-pr-readable-arm! jolt-lazyseq?
(lambda (x) (let ((s (jolt-seq x))) (if (jolt-nil? s) "()" (jolt-pr-readable s)))))
(register-str-render! jolt-lazyseq?
(lambda (x) (let ((s (jolt-seq x))) (if (jolt-nil? s) "()" (jolt-str-render-one s)))))
;; seq? — a lazy seq IS a seq (predicates.ss's jolt-seq? predates the lazyseq
;; record). Unlike the native-op dispatchers above (called via a direct top-level

View file

@ -17,6 +17,108 @@
(define (set-source-roots! roots) (set! source-roots roots))
(define (get-source-roots) source-roots)
;; --- data readers (#tag literals) -------------------------------------------
;; A project's data_readers.{clj,cljc} at a source root maps a tag symbol to a
;; qualified reader fn (e.g. {time/date time-literals.data-readers/date}). We
;; merge those into clojure.core/*data-readers* and require each reader's
;; namespace, then while loading source rewrite a registered #tag form into a
;; call (reader-fn 'inner-form) so the value is built at runtime. #inst/#uuid and
;; #"regex" stay built-in (the analyzer lowers them); only tags present in
;; *data-readers* are rewritten. data-readers-active gates the per-form walk so
;; projects without data readers (the common case) pay nothing.
(define data-readers-active #f)
(define (data-readers-table) (var-deref "clojure.core" "*data-readers*"))
;; tag keyword (:#time/date) -> its registered reader symbol, or #f.
(define (data-reader-symbol tag)
(and (keyword? tag)
(let ((nm (keyword-t-name tag)))
(and (> (string-length nm) 0) (char=? (string-ref nm 0) #\#)
(let* ((bare (substring nm 1 (string-length nm)))
(slash (let loop ((i 0))
(cond ((>= i (string-length bare)) #f)
((char=? (string-ref bare i) #\/) i)
(else (loop (+ i 1))))))
(sym (if slash
(jolt-symbol (substring bare 0 slash) (substring bare (+ slash 1) (string-length bare)))
(jolt-symbol #f bare)))
(t (data-readers-table))
(v (and (pmap? t) (jolt-get t sym))))
(and v (not (jolt-nil? v)) v))))))
;; change-tracking walk: rewrite registered #tag forms, keep everything else
;; (and its identity/metadata) intact. Mirrors reader.ss rdr-form->data but keeps
;; set FORMS for the compiler spine instead of building real sets.
(define (ldr-conv-each xs)
(let loop ((xs xs) (acc '()) (changed #f))
(if (null? xs) (values (reverse acc) changed)
(let ((c (ldr-apply-readers (car xs))))
(loop (cdr xs) (cons c acc) (or changed (not (eq? c (car xs)))))))))
(define (ldr-apply-readers x)
(cond
((and (pmap? x) (eq? (jolt-get x rdr-kw-jolt-type) rdr-kw-jolt-tagged))
(let ((rdr (data-reader-symbol (jolt-get x rdr-kw-tag)))
(inner (ldr-apply-readers (jolt-get x rdr-kw-form))))
(cond
(rdr
;; Clojure applies a data reader at read time and substitutes its result
;; as code. A reader that returns a FORM (a list — e.g. borkdude.html's
;; #html expands to (->Html (str …))) must be compiled, so splice it in.
;; A reader that returns a VALUE (time-literals #time/date -> a Date) is
;; left as a runtime call (reader-fn 'inner): the value rebuilds at
;; startup, which also keeps a non-serializable constant out of an AOT
;; build. Apply is guarded — a reader that can't run at load time (its
;; deps not ready) falls back to the runtime call too.
(let ((result (and (symbol-t? rdr) (not (jolt-nil? (symbol-t-ns rdr)))
(guard (e (#t #f))
(let ((fn (var-deref (symbol-t-ns rdr) (symbol-t-name rdr))))
(and (procedure? fn) (jolt-invoke fn inner)))))))
(if (cseq? result)
result
(jolt-list rdr (jolt-list (jolt-symbol #f "quote") inner)))))
((eq? inner (jolt-get x rdr-kw-form)) x)
(else (rdr-make-tagged (jolt-get x rdr-kw-tag) inner)))))
((rdr-set-form? x)
(let-values (((items changed) (ldr-conv-each (seq->list (jolt-get x rdr-kw-value)))))
(if changed (rdr-carry-meta x (rdr-make-set items)) x)))
((pvec? x)
(let-values (((items changed) (ldr-conv-each (vector->list (pvec-v x)))))
(if changed (rdr-carry-meta x (apply jolt-vector items)) x)))
((pmap? x)
(let ((order (hashtable-ref rdr-map-order x #f)))
(if order
(let-values (((kvs changed) (ldr-conv-each order)))
(if changed (rdr-carry-meta x (rdr-make-map kvs)) x))
(let-values (((kvs changed) (ldr-conv-each (pmap-fold x (lambda (k v a) (cons k (cons v a))) '()))))
(if changed (rdr-carry-meta x (apply jolt-hash-map kvs)) x)))))
((cseq? x)
(let-values (((items changed) (ldr-conv-each (seq->list x))))
(if changed (rdr-carry-meta x (apply jolt-list items)) x)))
(else x)))
;; read+merge one data_readers file: a literal {tag-sym reader-sym …} map.
(define (merge-data-readers-file path)
(let* ((src (read-file-string path)))
(let-values (((m j) (rdr-read-form src 0 (string-length src))))
(when (and (not (rdr-eof? m)) (pmap? m))
(let ((cur (data-readers-table)))
(def-var! "clojure.core" "*data-readers*"
(apply jolt-assoc (if (pmap? cur) cur empty-pmap)
(pmap-fold m (lambda (k v a) (cons k (cons v a))) '()))))
(set! data-readers-active #t)
;; eagerly load each reader fn's namespace so the rewritten call resolves.
(pmap-fold m (lambda (k v a)
(when (and (symbol-t? v) (symbol-t-ns v) (not (jolt-nil? (symbol-t-ns v))))
(guard (e (#t #f)) (load-namespace (symbol-t-ns v))))
a)
#f)))))
(define (load-data-readers!)
(for-each
(lambda (root)
(let ((clj (string-append root "/data_readers.clj"))
(cljc (string-append root "/data_readers.cljc")))
(cond ((file-exists? clj) (merge-data-readers-file clj))
((file-exists? cljc) (merge-data-readers-file cljc)))))
source-roots))
;; --- namespace -> file path -------------------------------------------------
;; "app.commonmark-test" -> "app/commonmark_test": split on '.', munge '-'->'_'
;; per segment, join with '/'. Matches Clojure's ns->file munging.
@ -36,14 +138,31 @@
(else (loop (cdr cs) (cons (car cs) seg) segs)))))
;; First existing <root>/rel.clj or <root>/rel.cljc on the search roots, else #f.
;; A self-contained joltc binary embeds jolt-core + stdlib source keyed by their
;; root-relative path ("clojure/string.clj"); those are checked first, so a
;; `require` resolves with no source on disk. The dev bin/joltc has an empty
;; source store, so the two hashtable probes miss and it falls straight to disk.
(define (resolve-on-roots rel)
(let loop ((roots source-roots))
(if (null? roots) #f
(let ((clj (string-append (car roots) "/" rel ".clj"))
(cljc (string-append (car roots) "/" rel ".cljc")))
(cond ((file-exists? clj) clj)
((file-exists? cljc) cljc)
(else (loop (cdr roots))))))))
(let ((eclj (string-append rel ".clj")) (ecljc (string-append rel ".cljc")))
(cond
((string? (hashtable-ref embedded-resources eclj #f)) eclj)
((string? (hashtable-ref embedded-resources ecljc #f)) ecljc)
(else
(let loop ((roots source-roots))
(if (null? roots) #f
(let ((clj (string-append (car roots) "/" rel ".clj"))
(cljc (string-append (car roots) "/" rel ".cljc")))
(cond ((file-exists? clj) clj)
((file-exists? cljc) cljc)
(else (loop (cdr roots)))))))))))
;; Read a namespace source. An embedded key (resolve-on-roots above, or the
;; build driver's app-order entries) reads its baked string; everything else is
;; a real path read off disk. Bytevector entries (the bundled boots/stub) are not
;; source, so a string? guard skips them.
(define (ldr-read-source path)
(let ((emb (hashtable-ref embedded-resources path #f)))
(if (string? emb) emb (read-file-string path))))
(define (find-ns-file name) (resolve-on-roots (ns-name->rel name)))
@ -55,6 +174,14 @@
(vector-for-each (lambda (c) (hashtable-set! loaded-ns (var-cell-ns c) #t))
(hashtable-values var-table))
;; clojure.core.async ships native channel primitives (async.ss) AND a Clojure
;; overlay (stdlib/clojure/core/async.clj) with the higher-level dataflow API
;; (alts!, pipe, mult, mix, pub/sub, map, merge, …). The primitives pre-seed the
;; namespace above, which would make a `require` no-op and skip the overlay. Drop
;; it from the loaded set so a require pulls the overlay from the source roots
;; (like clojure.test); the primitives stay defined either way.
(hashtable-delete! loaded-ns "clojure.core.async")
;; Does `name` already have vars in the var-table? A namespace baked into the
;; image after the snapshot above — an AOT'd app namespace in a `jolt build`
;; binary — exists in memory with no source file; a later `require` of it must
@ -82,17 +209,21 @@
;; more forms", which would silently drop the entire rest of the file; here we
;; skip the no-op form and continue to true end-of-string.
(define (load-jolt-file path)
(let* ((src (read-file-string path)) (end (string-length src)))
(let loop ((i 0))
(when (< i end)
(let-values (((form j) (rdr-read-form src i end)))
(when (> j i)
(unless (rdr-eof? form)
(when (getenv "JOLT_TRACE_LOAD")
(display " [load-form] " (current-error-port))
(display (jolt-pr-str form) (current-error-port)) (newline (current-error-port)))
(jolt-compile-eval-form form (chez-current-ns)))
(loop j)))))))
(let* ((src (ldr-read-source path)) (end (string-length src)))
;; parameterize (not a bare set!) so a require nested in this file's ns form
;; restores path when control returns to the rest of this file.
(parameterize ((rdr-source-file path)) ; list forms read here carry :file = path
(let loop ((i 0))
(when (< i end)
(let-values (((form j) (rdr-read-form src i end)))
(when (> j i)
(unless (rdr-eof? form)
(when (getenv "JOLT_TRACE_LOAD")
(display " [load-form] " (current-error-port))
(display (jolt-pr-str form) (current-error-port)) (newline (current-error-port)))
(jolt-compile-eval-form (if data-readers-active (ldr-apply-readers form) form)
(chez-current-ns)))
(loop j))))))))
;; load-namespace: load `name`'s source once. Marked loaded BEFORE eval so a
;; dependency cycle terminates (Clojure's behavior). The caller's current ns is
@ -129,50 +260,93 @@
(else '()))))
(and (pair? items) (symbol-t? (car items)) (symbol-t-name (car items)))))
;; A libspec under a prefix joins onto it: a bare symbol `string` -> `prefix.string`,
;; a vector `[string :as s]` -> `[prefix.string :as s]` (opts preserved).
(define (prefix-join prefix lib)
(cond
((symbol-t? lib) (jolt-symbol #f (string-append prefix "." (symbol-t-name lib))))
((pvec? lib)
(let ((items (seq->list lib)))
(if (and (pair? items) (symbol-t? (car items)))
(apply jolt-vector (jolt-symbol #f (string-append prefix "." (symbol-t-name (car items)))) (cdr items))
lib)))
(else lib)))
;; The prefix-list form of a require/use spec: a LIST `(prefix lib …)` expands to
;; one spec per lib (prefix.lib), so (:require (clojure [string :as str])) means
;; clojure.string :as str. A vector / symbol spec is already a single lib.
(define (expand-spec s)
(if (or (cseq? s) (empty-list-t? s))
(let ((items (seq->list s)))
(if (and (pair? items) (symbol-t? (car items)) (pair? (cdr items)))
(map (lambda (lib) (prefix-join (symbol-t-name (car items)) lib)) (cdr items))
(list s)))
(list s)))
;; --- require/use that LOAD ---------------------------------------------------
;; Override the alias-only versions from natives-str.ss. Load each spec's target
;; (no-op if baked/already loaded), THEN register its :as/:refer under the caller
;; ns (chez-register-spec! reads the current ns, restored by load-namespace).
(define (loader-require . specs)
(for-each
(lambda (s)
(let ((target (spec-target-name s)))
(when target (load-namespace target)))
(chez-register-spec! (chez-current-ns) s))
(lambda (s0)
(for-each
(lambda (s)
(let ((target (spec-target-name s)))
(when target (load-namespace target)))
(chez-register-spec! (chez-current-ns) s))
(expand-spec s0)))
specs)
jolt-nil)
(def-var! "clojure.core" "require" loader-require)
(define (loader-use . specs)
(define (loader-use . specs0)
(for-each
(lambda (spec)
(let ((target (spec-target-name spec)))
(when target (load-namespace target)))
(chez-register-spec! (chez-current-ns) spec)
(let* ((items (cond ((pvec? spec) (seq->list spec))
((or (cseq? spec) (empty-list-t? spec)) (seq->list spec))
((symbol-t? spec) (list spec))
(else '())))
(target (and (pair? items) (symbol-t? (car items)) (symbol-t-name (car items))))
(filtered (let scan ((xs (if (pair? items) (cdr items) '())))
(cond ((null? xs) #f)
((and (keyword? (car xs))
(member (keyword-t-name (car xs)) '("only" "refer"))) #t)
(else (scan (cdr xs)))))))
(when (and target (not filtered))
(chez-register-refer-all! (chez-current-ns) target))))
specs)
(lambda (spec0)
(for-each
(lambda (spec)
(let ((target (spec-target-name spec)))
(when target (load-namespace target)))
(chez-register-spec! (chez-current-ns) spec)
(let* ((items (cond ((pvec? spec) (seq->list spec))
((symbol-t? spec) (list spec))
(else '())))
(target (and (pair? items) (symbol-t? (car items)) (symbol-t-name (car items))))
(filtered (let scan ((xs (if (pair? items) (cdr items) '())))
(cond ((null? xs) #f)
((and (keyword? (car xs))
(member (keyword-t-name (car xs)) '("only" "refer"))) #t)
(else (scan (cdr xs)))))))
(when (and target (not filtered))
(chez-register-refer-all! (chez-current-ns) target))))
(expand-spec spec0)))
specs0)
jolt-nil)
(def-var! "clojure.core" "use" loader-use)
(def-var! "clojure.core" "load-file" jolt-load-file)
;; load: each arg is a "/"-rooted resource path like "/app/extra"; load the file
;; for it relative to the search roots (strip the leading slash, try .clj/.cljc).
;; The directory of a namespace's resource path: "clojure.tools.reader-test" ->
;; "clojure/tools" (drop the last segment of ns-name->rel). "" for a top-level ns.
(define (ns-rel-dir name)
(let* ((r (ns-name->rel name)))
(let loop ((k (fx- (string-length r) 1)))
(cond ((fx<? k 0) "")
((char=? (string-ref r k) #\/) (substring r 0 k))
(else (loop (fx- k 1)))))))
;; load: an arg starting with "/" is a root-relative resource path ("/app/extra");
;; otherwise it is resolved against the CURRENT namespace's directory, matching
;; Clojure — (load "common_tests") from clojure.tools.reader-test loads
;; clojure/tools/common_tests.clj. Strip the leading slash / try .clj/.cljc.
(define (jolt-load . paths)
(for-each
(lambda (p)
(let* ((rel (if (and (> (string-length p) 0) (char=? (string-ref p 0) #\/))
(substring p 1 (string-length p)) p))
(let* ((rel (cond
((and (> (string-length p) 0) (char=? (string-ref p 0) #\/))
(substring p 1 (string-length p)))
(else (let ((dir (ns-rel-dir (chez-current-ns))))
(if (string=? dir "") p (string-append dir "/" p))))))
(f (resolve-on-roots rel)))
(if f (load-jolt-file f)
(error #f "Could not locate resource on source roots" p))))
@ -205,8 +379,19 @@
;; Expose source-root control + ns loading to Clojure (jolt.main / jolt.deps).
(def-var! "jolt.host" "set-source-roots!"
(lambda (roots) (set-source-roots! (seq->list roots)) jolt-nil))
(lambda (roots) (set-source-roots! (seq->list roots)) (load-data-readers!) jolt-nil))
(def-var! "jolt.host" "source-roots" (lambda () (list->cseq source-roots)))
(def-var! "jolt.host" "load-namespace" (lambda (n) (load-namespace n) jolt-nil))
(def-var! "jolt.host" "file-exists?" (lambda (p) (if (file-exists? p) #t #f)))
(def-var! "jolt.host" "getenv" (lambda (n) (let ((v (getenv n))) (if v v jolt-nil))))
;; jolt version string. A self-contained binary build bakes the real tag into the
;; saved heap by emitting (set! jolt-baked-version "…") in flat.ss; a dev run off
;; the seed leaves it #f and falls back to $JOLT_VERSION (bin/joltc sets it from
;; `git describe`), then "dev".
(define jolt-baked-version #f)
(def-var! "jolt.host" "jolt-version"
(lambda ()
(or jolt-baked-version
(let ((v (getenv "JOLT_VERSION"))) (and v (> (string-length v) 0) v))
"dev")))

View file

@ -61,26 +61,36 @@
(define (jolt-defmulti-setup name-sym dispatch . opts)
(let-values (((dk h) (parse-mm-opts opts)))
(let ((mf (make-jolt-multifn (symbol-t-name name-sym) dispatch
(new-mm-table) dk h (new-mm-table))))
(def-var! (chez-current-ns) (symbol-t-name name-sym) mf)
(let* ((sns (symbol-t-ns name-sym))
;; the macro qualifies the name with its EXPANSION ns, so a defmulti
;; deferred inside a fn (a deftest body) still defines in the ns it
;; was written in, not whatever ns is current when it finally runs.
(ns (if (string? sns) sns (chez-current-ns)))
(mf (make-jolt-multifn (symbol-t-name name-sym) dispatch
(new-mm-table) dk h (new-mm-table))))
(def-var! ns (symbol-t-name name-sym) mf)
mf)))
;; (defmethod-setup 'mm dispatch-val impl) — add a method. Auto-creates the multifn
;; if absent (defmethod before defmulti — rare; identity dispatch as a fallback).
(define (jolt-defmethod-setup mm-sym dval impl)
(define (jolt-defmethod-setup mm-sym dval impl . rest)
(let* ((nm (symbol-t-name mm-sym))
(sns (symbol-t-ns mm-sym))
(qns (and sns (not (jolt-nil? sns)) (not (null? sns)) sns))
;; the macro passes its EXPANSION ns so a defmethod deferred inside a
;; fn resolves like the JVM (against the ns it was written in, not the
;; ns current when it runs); absent (old emitted code) fall back to the
;; runtime ns.
(here (if (and (pair? rest) (string? (car rest))) (car rest) (chez-current-ns)))
;; qualified (cf.mm/ext) resolves in its own ns (cross-ns defmethod);
;; unqualified resolves in the current ns, else a :refer's home ns (so a
;; unqualified resolves in the writing ns, else a :refer's home ns (so a
;; defmethod on a referred multifn lands on the real one), else stays in
;; the current ns (a shadow, as before).
;; the writing ns (a shadow, as before).
(mns (cond
(qns (or (chez-resolve-alias (chez-current-ns) qns) qns))
((var-cell-lookup (chez-current-ns) nm) (chez-current-ns))
((chez-resolve-refer (chez-current-ns) nm) => values)
(else (chez-current-ns))))
(qns (or (chez-resolve-alias here qns) qns))
((var-cell-lookup here nm) here)
((chez-resolve-refer here nm) => values)
(else here)))
(cur (var-deref mns nm))
(mf (if (jolt-multifn? cur) cur
;; auto-create: copy the dispatch fn + default from a same-named

View file

@ -4,15 +4,16 @@
;; binds the public clojure.core names to them. Loaded after def-var! (rt.ss) +
;; the collections + seq tiers. hash-map/array-map/hash-set/set/rand semantics.
;; hash-map / hash-set: variadic kvs / elems straight onto the existing ctors.
;; array-map: Clojure preserves insertion order, but jolt's `=` is structural and
;; the parity corpus compares by value, so a pmap is observationally equal for
;; the tested cases; keys-ordering is a separate (untested-here) concern.
(define (jolt-array-map . kvs) (apply jolt-hash-map kvs))
;; array-map: insertion-ordered, any size (Clojure's PersistentArrayMap, via
;; createAsIfByAssoc). hash-map: hash order (PersistentHashMap). The map LITERAL
;; ctor (jolt-hash-map, emitted for {...}) is array-ordered up to 8 entries and
;; hash beyond, matching RT.map.
(define (jolt-array-map . kvs) (jolt-array-map-build kvs))
(define (jolt-hash-map-fn . kvs) (jolt-hash-map-build kvs))
;; set: realize any seqable to a list, then dedup through the set ctor. nil -> #{}.
(define (jolt-set coll)
(if (jolt-nil? coll) (jolt-hash-set) (apply jolt-hash-set (seq->list coll))))
;; set lives in the kernel overlay tier (clojure/core/00-kernel.clj): it's a pure
;; composition (apply hash-set (seq coll)) the compiler uses only off the emit path,
;; so the Clojure version lowers to the same code without a bootstrap cycle.
;; rand: a flonum in [0, n) (n defaults to 1.0) — jolt is all-flonum, so the
;; result is a double like every other number.
@ -20,9 +21,8 @@
(let ((r (random 1.0)))
(if (null? n) r (* r (exact->inexact (car n))))))
(def-var! "clojure.core" "hash-map" jolt-hash-map)
(def-var! "clojure.core" "hash-map" jolt-hash-map-fn)
(def-var! "clojure.core" "hash-set" jolt-hash-set)
(def-var! "clojure.core" "array-map" jolt-array-map)
(def-var! "clojure.core" "set" jolt-set)
(def-var! "clojure.core" "rand" jolt-rand)
(def-var! "clojure.core" "map-entry?" jolt-map-entry?)

View file

@ -22,26 +22,46 @@
(jolt-assoc (if user user (jolt-hash-map))
jolt-kw-var-ns (var-cell-ns x)
jolt-kw-var-name (var-cell-name x))))
((or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jolt-lazyseq? x) (jrec? x) (procedure? x))
(hashtable-ref meta-table x jolt-nil))
(else jolt-nil)))
;; a deftype implementing clojure.lang.IObj stores meta in a field and threads
;; it through its own assoc/withMeta (core.logic's Substitutions/LVar/LCons),
;; so dispatch to its meta method rather than the identity side-table — which
;; the deftype's reconstructed instances would not share.
((and (jrec? x) (jrec-cl x "meta")) => (lambda (m) (jolt-invoke m x)))
;; everything else (collections, fns, reify, atoms/agents and any reference
;; type) reads the identity side-table; a value with no entry is nil meta.
(else (hashtable-ref meta-table x jolt-nil))))
;; fresh-identity copy of a metadatable value (so attaching meta doesn't mutate
;; the original). cseq/procedure can't be copied meaningfully — keyed in place.
(define (meta-copy x)
(cond
((pvec? x) (make-pvec (pvec-v x) (pvec-ent x)))
((pmap? x) (make-pmap (pmap-root x) (pmap-cnt x)))
((pmap? x) (make-pmap (pmap-root x) (pmap-cnt x) (pmap-order x)))
((pset? x) (make-pset (pset-m x)))
((jrec? x) (make-jrec (jrec-tag x) (jrec-pairs x)))
((jrec? x) (make-jrec (jrec-desc x) (jrec-vec-copy (jrec-vals x)) (jrec-ext x)))
;; a reify shares its (read-only) method table + protos but gets a fresh
;; identity, so attaching meta leaves the original's meta untouched. Every
;; Clojure reify implements IObj.
((jreify? x) (make-jreify (jreify-methods x) (jreify-protos x)))
;; () is a shared singleton — a fresh instance keeps meta off every other ().
((empty-list-t? x) (fresh-empty-list))
(else x))) ; cseq / procedure
;; a list/seq node gets a fresh identity too (Clojure's PersistentList is
;; immutable — (with-meta a-list m) returns a NEW list). Keying meta on the
;; original mutated it, so (with-meta xs {:k xs}) built a self-referential
;; cycle that loops *print-meta* printing.
((cseq? x) (make-cseq (cseq-head x) (cseq-tail x) (cseq-forced? x)
(cseq-list? x) (cseq-cvec x) (cseq-ci x) (cseq-crest x)))
((jolt-lazyseq? x) (make-jolt-lazyseq (jolt-lazyseq-thunk x) (jolt-lazyseq-val x)
(jolt-lazyseq-realized? x)))
(else x))) ; procedure
(define (jolt-with-meta x m)
(cond
((symbol-t? x) (make-symbol-t (symbol-t-ns x) (symbol-t-name x) m))
((or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jolt-lazyseq? x) (jrec? x) (procedure? x))
;; a deftype with an explicit clojure.lang.IObj withMeta carries meta in a
;; field; dispatch to it (see jolt-meta) so the meta survives reconstruction.
((and (jrec? x) (jrec-cl x "withMeta")) => (lambda (meth) (jolt-invoke meth x m)))
((or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jolt-lazyseq? x) (jrec? x) (jreify? x) (procedure? x))
(let ((c (meta-copy x)))
(if (jolt-nil? m) (hashtable-delete! meta-table c) (hashtable-set! meta-table c m))
c))
@ -128,4 +148,10 @@
((procedure? x) ty-fn)
(else ty-object))))
;; jolt-type is the keyword TAXONOMY (:string/:set/:jolt/inst/…) — jolt's native
;; value model, with no JVM in it. print-method/print-dup dispatch on it (via
;; __type-tag). The PUBLIC clojure.core/type is Clojure's (or (:type meta) (class
;; x)) — a JVM class — but that mapping belongs to the java host layer (host-class.ss
;; rebinds `type` next to `class`), so this core layer stays JVM-free.
(def-var! "clojure.core" "__type-tag" jolt-type)
(def-var! "clojure.core" "type" jolt-type)

View file

@ -17,11 +17,12 @@
(define (jolt-bit-clear x n) (bitwise-and (->int x) (bitwise-not (bit-mask n))))
(define (jolt-bit-flip x n) (bitwise-xor (->int x) (bit-mask n)))
(define (jolt-bit-test x n) (not (zero? (bitwise-and (->int x) (bit-mask n)))))
;; unsigned-bit-shift-right: logical shift over 64-bit longs. For the common
;; non-negative operand it equals the arithmetic shift; the negative-operand
;; 64-bit-window case is not modeled.
;; unsigned-bit-shift-right: LOGICAL right shift over a 64-bit long (Java >>>),
;; so a negative operand shifts in zeros from its 64-bit two's-complement window
;; ((>>> -1 1) = 2^63-1), not the sign. The shift count is taken mod 64.
(define (jolt-unsigned-bit-shift-right x n)
(bitwise-arithmetic-shift-right (->int x) (->int n)))
(bitwise-arithmetic-shift-right (bitwise-and (->int x) #xFFFFFFFFFFFFFFFF)
(bitwise-and (->int n) 63)))
;; ---- string->scalar parsers -------------------------------------------------
(define (ascii-digit? c) (and (char>=? c #\0) (char<=? c #\9)))

View file

@ -16,20 +16,19 @@
(seq->list (jolt-seq names))))
jolt-nil)
;; --- reader-conditional / re-matcher: tagged maps (reader-conditional? + the
;; matcher consumers are overlay tagged-value predicates that read :jolt/type).
;; --- reader-conditional: a tagged map (reader-conditional? is an overlay
;; tagged-value predicate that reads :jolt/type). STAYS NATIVE: building a
;; :jolt/type-tagged map is part of the native value model — an overlay defn
;; returning {:jolt/type ...} silently fails to bind during the seed mint (the
;; guard around each prelude form swallows the load-time error), the same reason
;; every other tagged-value constructor (atom/volatile!/tagged-literal) is native.
;; re-matcher / re-find / re-groups are the stateful matcher API in regex.ss.
(define nr-kw-type (keyword "jolt" "type"))
(define nr-kw-rc (keyword "jolt" "reader-conditional"))
(define nr-kw-form (keyword #f "form"))
(define nr-kw-spl (keyword #f "splicing?"))
(define nr-kw-mat (keyword "jolt" "matcher"))
(define nr-kw-re (keyword #f "re"))
(define nr-kw-s (keyword #f "s"))
(define nr-kw-pos (keyword #f "pos"))
(define (nr-reader-conditional form splicing?)
(jolt-hash-map nr-kw-type nr-kw-rc nr-kw-form form nr-kw-spl splicing?))
(define (nr-re-matcher re s)
(jolt-hash-map nr-kw-type nr-kw-mat nr-kw-re re nr-kw-s s nr-kw-pos 0.0))
;; --- macroexpand-1 / macroexpand: expand a (quoted) call form via the runtime
;; macro table (host-contract hc-macro?/hc-expand-1; forward-referenced, resolved
@ -47,6 +46,13 @@
(def-var! "clojure.core" "__reader-features" nr-reader-features-get)
(def-var! "clojure.core" "__reader-features-set!" nr-reader-features-set!)
(def-var! "clojure.core" "reader-conditional" nr-reader-conditional)
(def-var! "clojure.core" "re-matcher" nr-re-matcher)
(def-var! "clojure.core" "macroexpand-1" nr-macroexpand-1)
;; letfn is a special form (the analyzer lowers it to letrec*, checked before any
;; macro), but on the JVM it is also a clojure.core macro that (resolve 'letfn)
;; finds — like let / loop / fn here. Intern a var so resolution matches; the value
;; is never invoked (the analyzer handles every (letfn …) form), and it is NOT
;; marked a macro, so macroexpand leaves a letfn form alone (it is special).
(def-var! "clojure.core" "letfn"
(lambda args (jolt-throw (jolt-ex-info "letfn is a special form" (jolt-hash-map)))))
(def-var! "clojure.core" "macroexpand" nr-macroexpand)

View file

@ -17,13 +17,16 @@
;; call routes through jolt-invoke. A `reduced` step stops the fold — reduce-seq
;; (seq.ss) already short-circuits on a jolt-reduced.
;; ============================================================================
;; The map transducer's step fn supports multiple inputs ([result input & inputs]),
;; so a multi-collection sequence/transduce — or medley's sequence-padded, which
;; calls (f acc i1 i2 …) — applies f across all of them: (rf result (apply f inputs)).
(define (td-map f)
(lambda (rf)
(lambda a
(case (length a)
((0) (jolt-invoke rf))
((1) (jolt-invoke rf (car a)))
(else (jolt-invoke rf (car a) (jolt-invoke f (cadr a))))))))
(else (jolt-invoke rf (car a) (apply jolt-invoke f (cdr a))))))))
(define (td-filter pred)
(lambda (rf)
(lambda a
@ -101,7 +104,10 @@
(define (jolt-mapcat f . colls)
(if (null? colls)
(td-mapcat f)
(apply jolt-concat (seq->list (apply jolt-map f colls)))))
;; lazily concat the per-element results — no seq->list, so mapcat over an
;; infinite source stays lazy; the outer lazy-seq node defers the first
;; element so a side-effecting f does not fire at construction (LazySeq).
(jolt-make-lazy-seq (lambda () (jolt-seq (lazy-concat-seq (apply jolt-map f colls)))))))
;; take-while / drop-while: 1-arg -> transducer; 2-arg -> a seq over the coll.
(define (take-while-seq pred s)
@ -113,7 +119,7 @@
(define jolt-take-while
(case-lambda
((pred) (td-take-while pred))
((pred coll) (take-while-seq pred (jolt-seq coll)))))
((pred coll) (jolt-make-lazy-seq (lambda () (jolt-seq (take-while-seq pred (jolt-seq coll))))))))
(define (drop-while-seq pred coll)
(let loop ((s (jolt-seq coll)))
(if (and (not (jolt-nil? s)) (jolt-truthy? (jolt-invoke pred (seq-first s))))
@ -122,7 +128,7 @@
(define jolt-drop-while
(case-lambda
((pred) (td-drop-while pred))
((pred coll) (drop-while-seq pred coll))))
((pred coll) (jolt-make-lazy-seq (lambda () (jolt-seq (drop-while-seq pred coll)))))))
;; partition: (partition n coll), (partition n step coll), or
;; (partition n step pad coll). Only complete partitions of size n are kept;
@ -130,9 +136,9 @@
;; runs out). Each partition is a seq; the whole result is a lazy seq of seqs.
(define jolt-partition
(case-lambda
((n coll) (partition* (->idx n) (->idx n) #f #f coll))
((n step coll) (partition* (->idx n) (->idx step) #f #f coll))
((n step pad coll) (partition* (->idx n) (->idx step) #t pad coll))))
((n coll) (jolt-make-lazy-seq (lambda () (jolt-seq (partition* (->idx n) (->idx n) #f #f coll)))))
((n step coll) (jolt-make-lazy-seq (lambda () (jolt-seq (partition* (->idx n) (->idx step) #f #f coll)))))
((n step pad coll) (jolt-make-lazy-seq (lambda () (jolt-seq (partition* (->idx n) (->idx step) #t pad coll)))))))
(define (take-n n s) ; -> (values list-of-first-n remaining-seq taken-count)
(let loop ((n n) (s s) (acc '()))
(if (or (fx<=? n 0) (jolt-nil? s))
@ -177,9 +183,12 @@
(if (jolt-nil? s) jolt-empty-list
(list->cseq (list-sort less? (seq->list s))))))
;; identical?: jolt reference identity, defined as (= a b) over the
;; value model, where interned keywords/small values compare equal.
(define (jolt-identical? a b) (jolt= a b))
;; identical?: reference identity (Clojure ==). eq? gives pointer identity over
;; the value model — interned keywords/fixnums/nil compare equal, distinct
;; collections do not. Must NOT be value equality: a deftype whose .equals calls
;; (identical? this o) to short-circuit (e.g. core.logic's Substitutions) would
;; otherwise recur forever (identical? -> = -> equiv -> .equals -> identical?).
(define (jolt-identical? a b) (eq? a b))
;; Give the seq.ss native procedures their transducer (1-arg) arity — the emitter
;; lowers (map f)/(filter p)/(take n) at the wrong arity to the bare procedure
@ -216,7 +225,23 @@
;; rseq: vectors + sorted colls only (Clojure), the reverse of the ascending seq.
(define (jolt-rseq coll)
(if (or (pvec? coll) (htable-sorted? coll))
(list->cseq (reverse (seq->list (jolt-seq coll))))
(jolt-throw (jolt-ex-info "rseq requires a vector or sorted collection" (jolt-hash-map)))))
(cond
((or (pvec? coll) (htable-sorted? coll))
(list->cseq (reverse (seq->list (jolt-seq coll)))))
;; a deftype/record implementing clojure.lang.Reversible (rseq) — e.g.
;; data.priority-map — drives rseq through its own method.
((and (jrec? coll) (find-method-any-protocol (jrec-tag coll) "rseq"))
=> (lambda (f) (jolt-invoke f coll)))
(else (jolt-throw (jolt-ex-info "rseq requires a vector or sorted collection" (jolt-hash-map))))))
(def-var! "clojure.core" "rseq" jolt-rseq)
;; clojure.core/unchecked-* — host-defined wrapping (Java long) arithmetic from
;; seq.ss. def-var!'d here because def-var! isn't bound when seq.ss loads.
(let ((d! (lambda (n v) (def-var! "clojure.core" n v))))
(d! "unchecked-add" jolt-unchecked-add) (d! "unchecked-add-int" jolt-unchecked-add)
(d! "unchecked-subtract" jolt-unchecked-sub) (d! "unchecked-subtract-int" jolt-unchecked-sub)
(d! "unchecked-multiply" jolt-unchecked-mul) (d! "unchecked-multiply-int" jolt-unchecked-mul)
(d! "unchecked-negate" jolt-uncneg) (d! "unchecked-negate-int" jolt-uncneg)
(d! "unchecked-inc" jolt-uncinc) (d! "unchecked-inc-int" jolt-uncinc)
(d! "unchecked-dec" jolt-uncdec) (d! "unchecked-dec-int" jolt-uncdec)
(d! "unchecked-divide-int" jolt-unchecked-div) (d! "unchecked-remainder-int" jolt-unchecked-rem))

View file

@ -25,28 +25,61 @@
(def-var! "clojure.core" "volatile!" jolt-volatile!)
(def-var! "clojure.core" "deref" jolt-deref)
;; --- transduce / sequence ----------------------------------------------------
;; (transduce xform f coll) / (transduce xform f init coll): build the transformed
;; reducing fn (xform f), reduce it over coll (reduce-seq honors `reduced`), then
;; run the completion (1-arg) arity. The 3-arg init defaults to (f) — the rf's
;; 0-arity, e.g. (+) = 0, (conj) = [].
(define jolt-transduce
(case-lambda
((xform f coll) (jolt-transduce xform f (jolt-invoke f) coll))
((xform f init coll)
(let* ((xf (jolt-invoke xform f))
(res (reduce-seq xf init (jolt-seq coll))))
(jolt-invoke xf res)))))
;; --- sequence ----------------------------------------------------------------
;; transduce lives in the overlay (clojure/core/22-coll.clj): it's a pure
;; composition (xf (reduce xf init coll)) over reduce, so the Clojure version
;; lowers to the same code the native shim did. sequence stays native (below):
;; its transformer iterator drives the reduced box + lazy realization directly.
;; (sequence coll) -> a seq; (sequence xform coll) -> a LAZY seq of coll transformed
;; by xform. A transformer iterator (mirrors clojure.core's TransformerIterator):
;; pull one input at a time through (xform rf), where rf buffers each emitted value;
;; emit the buffer lazily, pulling more input only when it drains. So an infinite or
;; expensive source is consumed incrementally — (first (sequence (map inc) (range)))
;; returns at once. Honors `reduced` (stop pulling) and runs the 1-arg completion to
;; flush a stateful xform (partition-all / dedupe / a trailing partition).
(define (sequence-xf xform coll)
(let* ((buf (box '())) ; emitted values for the current step, reversed
(rf (case-lambda
(() jolt-nil)
((acc) acc)
((acc x) (set-box! buf (cons x (unbox buf))) acc)))
(xrf (jolt-invoke xform rf)))
;; advance the source until buf holds output or the input is drained+completed.
(define (fill src acc completed)
(let loop ((src src) (acc acc) (completed completed))
(cond
((pair? (unbox buf)) (values src acc completed))
(completed (values src acc #t))
((jolt-reduced? acc)
(jolt-invoke xrf (jolt-reduced-val acc)) ; completion may flush
(loop src (jolt-reduced-val acc) #t))
(else
(let ((s (jolt-seq src)))
(if (jolt-nil? s)
(begin (jolt-invoke xrf acc) (loop src acc #t)) ; complete -> flush
(loop (seq-more s) (jolt-invoke xrf acc (seq-first s)) completed)))))))
;; Resolve the next chunk now (one fill pulls just enough input to emit or to
;; exhaust), so the result is a real cseq | empty — `empty` is jolt-empty-list
;; at the top (so an empty result still prints "()") and jolt-nil inside a tail
;; (the cseq terminator). The TAILS stay lazy, so an infinite source is fine.
(define (step src acc completed empty)
(let-values (((src2 acc2 comp2) (fill src acc completed)))
(let ((out (reverse (unbox buf))))
(set-box! buf '())
(if (null? out)
empty
(let build ((o out))
(if (null? (cdr o))
(cseq-lazy (car o) (lambda () (step src2 acc2 comp2 jolt-nil)))
(cseq-lazy (car o) (lambda () (build (cdr o))))))))))
(step coll jolt-nil #f jolt-empty-list)))
;; (sequence coll) -> a seq; (sequence xform coll) -> coll transformed by xform.
;; Materialized eagerly through into-xform then seq'd (corpus inputs are finite; a
;; fully-lazy pull is future work). Honors reduced via into-xform/reduce-seq.
(define jolt-sequence
(case-lambda
((coll) (jolt-seq coll))
((xform coll) (jolt-seq (into-xform (jolt-vector) xform coll)))))
((xform coll) (sequence-xf xform coll))))
(def-var! "clojure.core" "transduce" jolt-transduce)
(def-var! "clojure.core" "sequence" jolt-sequence)
;; --- cat ---------------------------------------------------------------------

View file

@ -74,7 +74,8 @@
;; :refer :all — bring in every public var (require :refer :all)
((and (keyword? v) (string=? (keyword-t-name v) "all"))
(chez-register-refer-all! cns target))
((pvec? v)
;; :refer [a b] or :refer (a b) — both forms list names to bring in.
((or (pvec? v) (cseq? v) (empty-list-t? v))
(for-each (lambda (n)
(when (symbol-t? n) (chez-register-refer! cns (symbol-t-name n) target)))
(seq->list v))))))))
@ -128,17 +129,23 @@
(list->cseq (map intern-ns! (vector->list (hashtable-keys seen))))))
;; ns-publics / ns-map / ns-interns: a {sym -> var-cell} jolt map built by scanning
;; the var-table for defined cells in the namespace. (Private vars are not tracked
;; yet, so ns-publics == ns-interns.) ns-aliases is an empty map (map? is true).
(define (ns-vars-pmap nm)
;; the var-table for defined cells in the namespace. ns-interns/ns-map keep every
;; var; ns-publics drops the ones marked ^:private (defn-/def ^:private), like the
;; JVM. ns-aliases is an empty map (map? is true).
(define (var-private? c)
(let ((m (hashtable-ref var-meta-table c #f)))
(and m (jolt-truthy? (jolt-get m (keyword #f "private"))))))
(define (ns-vars-pmap-when nm keep?)
(let ((m (jolt-hash-map)))
(vector-for-each
(lambda (c)
(when (and (string=? (var-cell-ns c) nm) (var-cell-defined? c))
(when (and (string=? (var-cell-ns c) nm) (var-cell-defined? c) (keep? c))
(set! m (jolt-assoc m (jolt-symbol #f (var-cell-name c)) c))))
(hashtable-values var-table))
m))
(define (jolt-ns-publics desig) (ns-vars-pmap (ns-desig->name desig)))
(define (ns-vars-pmap nm) (ns-vars-pmap-when nm (lambda (c) #t)))
(define (jolt-ns-publics desig) (ns-vars-pmap-when (ns-desig->name desig) (lambda (c) (not (var-private? c)))))
(define (jolt-ns-interns desig) (ns-vars-pmap (ns-desig->name desig)))
;; ns-aliases: the {alias-sym -> ns-value} registered under `desig`
;; (default the current ns) via require :as / alias. Reads ns-alias-table.
@ -253,6 +260,9 @@
;; intern: create/set a var ns/sym to val (or an unbound cell). Returns the var.
(define (jolt-intern ns-desig sym . vopt)
(let ((nm (ns-desig->name ns-desig)) (s (symbol-t-name sym)))
;; the namespace must exist (Namespace.find), like the JVM's intern
(unless (hashtable-ref ns-registry nm #f)
(jolt-throw (jolt-ex-info (string-append "No namespace: " nm " found") empty-pmap)))
(if (pair? vopt) (def-var! nm s (car vopt)) (declare-var! nm s))))
;; alias / ns-unalias: register/drop an :as alias under the current (or given) ns.
@ -275,15 +285,48 @@
(chez-register-refer! cns (var-cell-name c) target)))
(hashtable-values var-table))
jolt-nil))
(define (jolt-refer-clojure . _) jolt-nil)
;; (:refer-clojure :exclude [names…]) — clojure.core always resolves on Chez, so
;; the only thing to track is the EXCLUDE set: an excluded name is not
;; clojure.core/name, so syntax-quote qualifies it to the current ns instead (a ns
;; that excludes and defines its own, e.g. core.logic.fd's ==).
(define ns-core-exclude-table (make-hashtable equal-hash equal?)) ; cns -> (name -> #t)
(define (chez-register-core-exclude! cns name)
(let ((h (or (hashtable-ref ns-core-exclude-table cns #f)
(let ((h (make-hashtable string-hash string=?)))
(hashtable-set! ns-core-exclude-table cns h) h))))
(hashtable-set! h name #t)))
(define (chez-core-excluded? cns name)
(let ((h (hashtable-ref ns-core-exclude-table cns #f)))
(and h (hashtable-ref h name #f) #t)))
(define (jolt-refer-clojure . args)
(let ((cns (chez-current-ns)))
(let loop ((a args))
(when (and (pair? a) (pair? (cdr a)))
(when (and (keyword? (car a)) (string=? (keyword-t-name (car a)) "exclude"))
(for-each (lambda (n) (when (symbol-t? n)
(chez-register-core-exclude! cns (symbol-t-name n))))
(seq->list (cadr a))))
(loop (cddr a)))))
jolt-nil)
;; alter-meta! / reset-meta!: update a var's metadata (var-meta-table, rt.ss).
;; alter-meta! / reset-meta!: a var's metadata lives in var-meta-table (rt.ss);
;; any other reference (atom/agent/namespace) uses the identity meta side-table
;; jolt-meta reads.
(define (jolt-alter-meta! ref f . args)
(let* ((cur (or (hashtable-ref var-meta-table ref #f) (jolt-hash-map)))
(new (apply jolt-invoke f cur args)))
(hashtable-set! var-meta-table ref new)
new))
(define (jolt-reset-meta! ref m) (hashtable-set! var-meta-table ref m) m)
(if (var-cell? ref)
(let* ((cur (or (hashtable-ref var-meta-table ref #f) (jolt-hash-map)))
(new (apply jolt-invoke f cur args)))
(hashtable-set! var-meta-table ref new)
new)
(let* ((cur (let ((m (jolt-meta ref))) (if (jolt-nil? m) (jolt-hash-map) m)))
(new (apply jolt-invoke f cur args)))
(hashtable-set! meta-table ref new)
new)))
(define (jolt-reset-meta! ref m)
(if (var-cell? ref)
(hashtable-set! var-meta-table ref m)
(hashtable-set! meta-table ref m))
m)
;; --- RESOLVE FRICTION: native-op cells -------------------------------------
;; Native-op primitives (+ map reduce …) are INLINED at emit, so they have no
@ -322,8 +365,8 @@
(def-var! "clojure.core" "in-ns" jolt-in-ns)
(def-var! "clojure.core" "all-ns" jolt-all-ns)
(def-var! "clojure.core" "ns-publics" jolt-ns-publics)
(def-var! "clojure.core" "ns-map" jolt-ns-publics)
(def-var! "clojure.core" "ns-interns" jolt-ns-publics)
(def-var! "clojure.core" "ns-map" jolt-ns-interns)
(def-var! "clojure.core" "ns-interns" jolt-ns-interns)
(def-var! "clojure.core" "ns-aliases" jolt-ns-aliases)
(def-var! "clojure.core" "ns-refers" jolt-ns-refers)
(def-var! "clojure.core" "ns-imports" jolt-ns-imports)

View file

@ -63,6 +63,17 @@
;; a lazy-seq carries its own realized? flag (lazy-bridge.ss). The overlay
;; realized? reads :jolt/type and throws on a jolt-lazyseq record.
((jolt-lazyseq? x) (jolt-lazyseq-realized? x))
;; a seq cell answers by its forced flag: the rest of a realized lazy
;; chain is a cseq under jolt's seq model, and (realized? (rest s)) after
;; a next must be true like the JVM's realized LazySeq — never a throw
;; whose message renders the (possibly infinite) seq.
;; a PLAIN seq (list/cons/range — not a lazy-seq wrapper) is not an
;; IPending on the JVM: realized? throws.
((or (cseq? x) (empty-list-t? x))
(jolt-throw (jolt-host-throwable
"java.lang.ClassCastException"
(string-append "class " (guard (e (#t "?")) (jolt-class-name x))
" cannot be cast to class clojure.lang.IPending"))))
(else (jolt-invoke overlay-realized? x))))))
;; clojure.edn/read over a reader: drain the jhost reader, then read through the
;; overlay read-string so the opts map (:readers/:default/:eof) is honored.
@ -78,27 +89,28 @@
(def-var! "clojure.core" "line-seq"
(lambda (rdr)
(if (reader-jhost? rdr) (chez-line-seq rdr) (jolt-invoke overlay-line-seq rdr)))))
;; JVM-parity numeric tower: the overlay (20-coll.clj) carries an
;; all-flonum number-predicate web with no Ratio concept (ratio? -> false,
;; double? -> not-integer, float? -> double?, rational? -> int?), which
;; misclassifies exact rationals on the Chez tower (e.g. (double? 1/2) -> true).
;; Re-assert the native tower-correct versions (predicates.ss) so they win over
;; the overlay defs. int?/double? alias integer?/float?. == is value-equality.
;; JVM-parity numeric tower. integer?/float? are on the compiler emit/inference
;; path (so they stay native) but the overlay (20-coll.clj) still carries an
;; all-flonum int?/double? (int? -> integer?, double? -> not-integer) that
;; misclassifies exact rationals (e.g. (double? 1/2) -> true). Re-assert the
;; native tower-correct versions so they win over those overlay defs. int?/double?
;; alias integer?/float?. == is value-equality. (ratio?/rational? are now correct
;; in the overlay, built on jolt.host tower tests, so they need no re-assertion.)
(def-var! "clojure.core" "integer?" jolt-integer?)
(def-var! "clojure.core" "int?" jolt-integer?)
(def-var! "clojure.core" "float?" jolt-float?)
(def-var! "clojure.core" "double?" jolt-float?)
(def-var! "clojure.core" "ratio?" jolt-ratio?)
(def-var! "clojure.core" "rational?" jolt-rational?)
;; ratio?/rational? now live (correctly) in the overlay, so they no longer need a
;; native re-assertion here. decimal? stays (bigdec re-binds it).
(def-var! "clojure.core" "decimal?" jolt-decimal?)
(def-var! "clojure.core" "==" jolt-num-equiv)
;; chunked-seq? is true for a vector's seq (a real chunked-seq); the overlay's
;; always-false stub loaded over the host fn, so re-assert it.
(def-var! "clojure.core" "chunked-seq?" na-chunked-seq?)
;; record? is a host type check (jrec?), not the overlay's (some? (get x
;; :jolt/deftype)) — the get-trick invokes a sorted-map's comparator on
;; :jolt/deftype and throws. Matches the JVM (instance? IRecord).
(def-var! "clojure.core" "record?" (lambda (x) (jrec? x)))
;; record? is a host type check — true only for a defrecord, not a bare deftype
;; (jrec-record?), matching the JVM (instance? IRecord). The overlay's
;; (some? (get x :jolt/deftype)) get-trick would invoke a sorted-map comparator.
(def-var! "clojure.core" "record?" (lambda (x) (jrec-record? x)))
;; read / read+string over a HOST reader jhost (java.io StringReader/PushbackReader):
;; the overlay's IReader protocol only covers the reify map-reader, so a (read
@ -111,13 +123,13 @@
((stream)
(if (reader-jhost? stream)
(let-values (((form found?) (host-reader-read-form stream)))
(if found? form (jolt-throw (jolt-ex-info "EOF while reading" (empty-pmap)))))
(if found? form (jolt-throw (jolt-ex-info "EOF while reading" empty-pmap))))
(jolt-invoke ov-read stream)))
((stream e? ev)
(if (reader-jhost? stream)
(let-values (((form found?) (host-reader-read-form stream)))
(cond (found? form)
((jolt-truthy? e?) (jolt-throw (jolt-ex-info "EOF while reading" (empty-pmap))))
((jolt-truthy? e?) (jolt-throw (jolt-ex-info "EOF while reading" empty-pmap)))
(else ev)))
(jolt-invoke ov-read stream e? ev))))))
(let ((ov-rps (var-deref "clojure.core" "read+string")))
@ -130,7 +142,7 @@
(let* ((s (drain-reader stream)) (pr (jolt-parse-next s)))
(if (jolt-nil? pr)
(begin (reader-refill! stream "")
(if (jolt-truthy? e?) (jolt-throw (jolt-ex-info "EOF while reading" (empty-pmap)))
(if (jolt-truthy? e?) (jolt-throw (jolt-ex-info "EOF while reading" empty-pmap))
(jolt-vector ev "")))
(let ((rest (jolt-nth pr 1)))
(reader-refill! stream rest)

View file

@ -12,11 +12,9 @@
(define (jolt-vector? x) (pvec? x))
(define (jolt-set? x) (pset? x))
(define (jolt-seq? x) (or (cseq? x) (empty-list-t? x)))
;; (list? x): a list-marked cseq node or the empty list (). A lazy/vector-backed
;; seq, (rest list), (seq coll), (map …) are seqs but not lists.
(define (jolt-list-pred? x) (or (and (cseq? x) (cseq-list? x)) (empty-list-t? x)))
;; list? lives in the overlay (clojure/core/20-coll.clj) — see jolt.host/cseq? etc.
(define (jolt-coll-pred? x)
(or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x)))
(or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jolt-lazyseq? x)))
(define (jolt-number? x) (number? x))
(define (jolt-string? x) (string? x))
(define (jolt-char-pred? x) (char? x))
@ -27,13 +25,18 @@
;; BigDecimal). decimal? is always false (no BigDecimal type).
(define (jolt-integer? x) (and (number? x) (exact? x) (integer? x)))
(define (jolt-float? x) (and (number? x) (flonum? x)))
(define (jolt-ratio? x) (and (number? x) (exact? x) (rational? x) (not (integer? x))))
(define (jolt-rational? x) (and (number? x) (exact? x)))
;; ratio?/rational? live in the overlay (clojure/core/20-coll.clj), built on the
;; jolt.host tower tests. decimal? stays native: the optional bigdec module
;; (java/bigdec.ss) re-binds it to jbigdec?, so it can't be a static overlay const.
(define (jolt-decimal? x) #f)
(define (jolt-fn? x) (procedure? x))
(define (jolt-boolean-pred? x) (boolean? x))
;; (boolean x) coerces truthiness (nil/false -> false, else true).
;; (boolean x) coerces truthiness (nil/false -> false, else true). MUST stay native:
;; the backend's emit path calls clojure.core/boolean for every :if node
;; (backend_scheme.clj bool tracking), so it has to exist before ANY compilation,
;; including the kernel overlay tier (whose own fns contain `if`). Migrating it even
;; to the kernel tier deadlocks: compiling the tier that defines boolean needs boolean.
(define (jolt-boolean x) (if (jolt-truthy? x) #t #f))
;; (name x): keyword/symbol -> name string; string -> itself.
@ -57,8 +60,6 @@
(def-var! "clojure.core" "char?" jolt-char-pred?)
(def-var! "clojure.core" "integer?" jolt-integer?)
(def-var! "clojure.core" "float?" jolt-float?)
(def-var! "clojure.core" "ratio?" jolt-ratio?)
(def-var! "clojure.core" "rational?" jolt-rational?)
(def-var! "clojure.core" "decimal?" jolt-decimal?)
;; == numeric value-equality (ignores exactness, unlike =): (== 3 3.0) -> true.
;; 1-arity is trivially true; 2+ args must all be numbers (Numbers.equiv throws
@ -80,10 +81,30 @@
(def-var! "clojure.core" "vector?" jolt-vector?)
(def-var! "clojure.core" "set?" jolt-set?)
(def-var! "clojure.core" "seq?" jolt-seq?)
(def-var! "clojure.core" "list?" jolt-list-pred?)
(def-var! "clojure.core" "coll?" jolt-coll-pred?)
(def-var! "clojure.core" "fn?" jolt-fn?)
(def-var! "clojure.core" "boolean?" jolt-boolean-pred?)
(def-var! "clojure.core" "boolean" jolt-boolean)
(def-var! "clojure.core" "name" jolt-name)
(def-var! "clojure.core" "namespace" jolt-namespace)
;; --- jolt.host raw type-test primitives -------------------------------------
;; Some clojure.core predicates bottom out at host tests overlay Clojure can't
;; reach. Expose the ones the migratable predicates need so the overlay versions
;; lower to exactly these calls — no perf loss. rational-type? is the Chez TYPE
;; test (exact rational), distinct from clojure.core/rational? (which gates on
;; number? first). exact? is wrapped TOTAL (Chez's raw exact? errors on a
;; non-number); rational-type? already returns #f for a non-match.
;;
;; Only the tests consumed by the migrated predicates (ratio?/rational? -> exact?,
;; rational-type?; list? -> cseq?/cseq-list?/empty-list?) are exposed. The rest of
;; the predicate web stays native and is NOT exposed: map?/set?/seq?/coll? are
;; extended at runtime with sorted/record/lazy arms, decimal? is extended by the
;; optional bigdec module, integer?/float? are on the compiler emit/inference path,
;; and vector? is reached by the kernel-tier peek during bootstrap.
(define (jh-exact? x) (and (number? x) (exact? x)))
(def-var! "jolt.host" "exact?" jh-exact?)
(def-var! "jolt.host" "rational-type?" rational?)
(def-var! "jolt.host" "cseq?" cseq?)
(def-var! "jolt.host" "empty-list?" empty-list-t?)
(def-var! "jolt.host" "cseq-list?" cseq-list?)

View file

@ -47,25 +47,22 @@
((jolt-transient? x)
(case (jolt-transient-kind x)
((vec) "#<transient vector>") ((set) "#<transient set>") (else "#<transient map>")))
((pvec? x)
(let ((acc '()))
(let loop ((i (fx- (pvec-count x) 1)))
(when (fx>=? i 0)
(set! acc (cons (jolt-pr-readable (pvec-nth-d x i jolt-nil)) acc))
(loop (fx- i 1))))
(string-append "[" (jolt-str-join acc) "]")))
((pset? x)
(string-append "#{" (jolt-str-join (pset-fold x (lambda (e a) (cons (jolt-pr-readable e) a)) '())) "}"))
((pmap? x)
(string-append "{" (jolt-str-join
(pmap-fold x (lambda (k v a)
(cons (string-append (jolt-pr-readable k) " " (jolt-pr-readable v)) a)) '())) "}"))
((empty-list-t? x) "()")
((cseq? x)
(string-append "(" (jolt-str-join
(let loop ((s x) (acc '()))
(if (jolt-nil? s) (reverse acc)
(loop (jolt-seq (seq-more s)) (cons (jolt-pr-readable (seq-first s)) acc))))) ")"))
((pvec? x) (if (jolt-print-hash?) "#"
(with-deeper-print
(string-append "[" (jolt-str-join (jolt-limited-vec-strs x jolt-pr-readable)) "]"))))
((pset? x) (if (jolt-print-hash?) "#"
(with-deeper-print
(string-append "#{" (jolt-str-join (jolt-limited-list-strs
(pset-fold x (lambda (e a) (cons (jolt-pr-readable e) a)) '()))) "}"))))
((pmap? x) (if (jolt-print-hash?) "#"
(with-deeper-print
(string-append "{" (jolt-str-join (jolt-limited-list-strs
(pmap-fold x (lambda (k v a)
(cons (string-append (jolt-pr-readable k) " " (jolt-pr-readable v)) a)) '()))) "}"))))
((empty-list-t? x) (if (jolt-print-hash?) "#" "()"))
((cseq? x) (if (jolt-print-hash?) "#"
(with-deeper-print
(string-append "(" (jolt-str-join (jolt-limited-seq-strs x jolt-pr-readable)) ")"))))
(else (jolt-pr-str x))))
(define (jolt-pr-readable-dispatch x)
(let loop ((as jolt-pr-readable-arms))

View file

@ -47,8 +47,25 @@
(memv c '(#\( #\) #\[ #\] #\{ #\} #\" #\; #\@ #\^ #\` #\~ #\\))))
(define (rdr-digit? c) (and (char>=? c #\0) (char<=? c #\9)))
(define (rdr-octal? c) (and (char>=? c #\0) (char<=? c #\7)))
(define (rdr-all-digits? s from to)
(and (> to from)
(let loop ((i from))
(cond ((>= i to) #t)
((rdr-digit? (string-ref s i)) (loop (+ i 1)))
(else #f)))))
;; every char of s in [from,to) is an octal digit (and the span is non-empty).
(define (rdr-all-octal? s from to)
(and (fx<? from to)
(let loop ((i from)) (cond ((fx=? i to) #t) ((rdr-octal? (string-ref s i)) (loop (fx+ i 1))) (else #f)))))
;; Advance past whitespace, commas, and ;-to-end-of-line comments.
;; EDN strict mode (clojure.edn): auto-resolved keywords are invalid, and each
;; discarded (#_) form is handed to rdr-discard-cb so the edn layer validates
;; its tagged elements through :readers/:default like the JVM.
(define rdr-edn-mode (make-parameter #f))
(define rdr-discard-cb (make-parameter #f))
(define (rdr-skip-ws s i end)
(let loop ((i i))
(cond
@ -56,7 +73,8 @@
((rdr-ws? (string-ref s i)) (loop (+ i 1)))
((char=? (string-ref s i) #\;)
(let eol ((j (+ i 1)))
(if (or (>= j end) (char=? (string-ref s j) #\newline))
(if (or (>= j end) (char=? (string-ref s j) #\newline)
(char=? (string-ref s j) #\return))
(loop j)
(eol (+ j 1)))))
(else i))))
@ -110,12 +128,17 @@
(slash (rdr-string-index-char body #\/)))
(cond
;; ratio a/b -> exact rational (= JVM Ratio); reduces to an exact integer
;; when d divides n.
;; when d divides n. Both parts must be plain digit runs (1/-1 is an
;; invalid token); a zero denominator is the JVM's divide error.
(slash
(let ((n (string->number (substring body 0 slash)))
(d (string->number (substring body (+ slash 1) blen))))
(and (integer? n) (integer? d) (not (= d 0))
(* sign (/ n d)))))
(let ((ns (substring body 0 slash))
(ds (substring body (+ slash 1) blen)))
(and (rdr-all-digits? ns 0 (string-length ns))
(rdr-all-digits? ds 0 (string-length ds))
(let ((n (string->number ns)) (d (string->number ds)))
(when (= d 0)
(jolt-throw (jolt-host-throwable "java.lang.ArithmeticException" "Divide by zero")))
(* sign (/ n d))))))
;; hex 0x..
((and (>= blen 2) (char=? (string-ref body 0) #\0)
(or (char=? (string-ref body 1) #\x) (char=? (string-ref body 1) #\X)))
@ -129,6 +152,16 @@
(and radix (integer? radix) (>= radix 2) (<= radix 36)
(let ((v (rdr-parse-radix (substring body (+ ri 1) blen) radix)))
(and v (* sign v)))))))
;; octal 0NNN: a leading 0 followed by octal digits (Clojure reads 042 as 34,
;; not decimal 42). "0" alone, 0x.., 0r.. and a float "0.5" are handled
;; elsewhere or fall through (a non-octal digit fails rdr-all-octal?).
((and (>= blen 2) (char=? (string-ref body 0) #\0) (rdr-all-octal? body 1 blen))
(let ((o (rdr-parse-radix (substring body 1 blen) 8))) (and o (* sign o))))
;; a leading zero on a plain multi-digit integer is invalid (the octal
;; branch above accepted real octals; 08/09 match the JVM's trailing
;; "invalid number" alternative)
((and (>= blen 2) (char=? (string-ref body 0) #\0) (rdr-all-digits? body 1 blen))
#f)
;; bigint suffix N
((and (> blen 1) (char=? (string-ref body (- blen 1)) #\N))
(let ((n (string->number (substring body 0 (- blen 1)))))
@ -160,7 +193,7 @@
;; opening quote already consumed; read to the closing quote, processing escapes.
(define (rdr-read-string-lit s i end)
(let loop ((i i) (acc '()))
(when (>= i end) (jolt-throw (jolt-ex-info "EOF while reading string" (empty-pmap))))
(when (>= i end) (jolt-throw (jolt-ex-info "EOF while reading string" empty-pmap)))
(let ((c (string-ref s i)))
(cond
((char=? c #\") (values (list->string (reverse acc)) (+ i 1)))
@ -174,7 +207,16 @@
((#\") (loop (+ i 2) (cons #\" acc)))
((#\b) (loop (+ i 2) (cons #\backspace acc)))
((#\f) (loop (+ i 2) (cons #\page acc)))
((#\0) (loop (+ i 2) (cons #\nul acc)))
;; octal escape \ooo: 1-3 octal digits (Clojure's \0..\377), so \000
;; is one null char, not \0 + literal "00".
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)
(let oct ((j (+ i 1)) (val 0) (cnt 0))
(if (and (fx<? cnt 3) (fx<? j end) (rdr-octal? (string-ref s j)))
(oct (fx+ j 1) (fx+ (fx* val 8) (fx- (char->integer (string-ref s j)) 48)) (fx+ cnt 1))
(begin
(when (> val 255)
(jolt-throw (jolt-ex-info "Octal escape sequence must be in range [0, 377]" empty-pmap)))
(loop j (cons (integer->char val) acc))))))
((#\u)
(let-values (((cp j) (rdr-hex->int s (+ i 2) 4)))
;; A \u escape is a UTF-16 code unit. jolt chars are Unicode scalars,
@ -192,12 +234,13 @@
(loop j (cons #\xFFFD acc)))))
((and (fx>=? cp #xD800) (fx<=? cp #xDFFF)) (loop j (cons #\xFFFD acc)))
(else (loop j (cons (integer->char cp) acc))))))
(else (loop (+ i 2) (cons e acc))))))
(else (jolt-throw (jolt-ex-info (string-append "Unsupported escape character: \\" (string e))
empty-pmap))))))
(else (loop (+ i 1) (cons c acc)))))))
;; backslash already consumed; read a Clojure character literal.
(define (rdr-read-char s i end)
(when (>= i end) (jolt-throw (jolt-ex-info "EOF while reading char" (empty-pmap))))
(when (>= i end) (jolt-throw (jolt-ex-info "EOF while reading char" empty-pmap)))
(let ((c0 (string-ref s i)))
(if (char-alphabetic? c0)
;; named / unicode / single-letter: collect the alnum run
@ -224,9 +267,12 @@
((char=? (string-ref name 0) #\u)
(integer->char (string->number (substring name 1 (string-length name)) 16)))
((char=? (string-ref name 0) #\o)
(integer->char (string->number (substring name 1 (string-length name)) 8)))
(let ((v (string->number (substring name 1 (string-length name)) 8)))
(when (or (not v) (> v 255))
(jolt-throw (jolt-ex-info "Octal escape sequence must be in range [0, 377]" empty-pmap)))
(integer->char v)))
(else (jolt-throw (jolt-ex-info (string-append "Unsupported character: \\" name)
(empty-pmap))))))
empty-pmap)))))
;; --- token (symbol / keyword / number / nil|true|false) ---------------------
(define (rdr-read-token s i end)
@ -242,14 +288,39 @@
(values #f tok)
(values (substring tok 0 slash) (substring tok (+ slash 1) (string-length tok))))))
(define (rdr-numeric-lead? tok)
(let ((len (string-length tok)))
(and (> len 0)
(let ((c0 (string-ref tok 0)))
(or (rdr-digit? c0)
(and (or (char=? c0 #\+) (char=? c0 #\-)) (> len 1)
(rdr-digit? (string-ref tok 1))))))))
(define (rdr-invalid-token tok)
(jolt-throw (jolt-host-throwable "java.lang.RuntimeException"
(string-append "Invalid token: " tok))))
(define (rdr-token->value tok)
(let ((n (rdr-try-number tok)))
(cond
(n n)
;; a token that starts like a number but doesn't parse as one is an
;; invalid number (1a, 08, 0x2g, 2r2), never a symbol — like the JVM.
((rdr-numeric-lead? tok)
(jolt-throw (jolt-host-throwable "java.lang.NumberFormatException"
(string-append "Invalid number: " tok))))
((string=? tok "nil") jolt-nil)
((string=? tok "true") #t)
((string=? tok "false") #f)
(else (let-values (((ns name) (rdr-sym-parts tok))) (jolt-symbol ns name))))))
(else
(let ((len (string-length tok)))
;; a lone "/" is the division symbol, and "ns//" names it in a
;; namespace (clojure.core//); otherwise a leading or trailing slash
;; leaves an empty ns/name part — an invalid token.
(when (and (> len 1)
(or (char=? (string-ref tok 0) #\/)
(and (char=? (string-ref tok (- len 1)) #\/)
(not (and (> len 2) (char=? (string-ref tok (- len 2)) #\/))))))
(rdr-invalid-token tok))
(let-values (((ns name) (rdr-sym-parts tok))) (jolt-symbol ns name)))))))
;; --- collections ------------------------------------------------------------
;; Read forms until the close delimiter; returns (values reversed?-no list j).
@ -257,7 +328,7 @@
(let loop ((i i) (acc '()))
(let ((i (rdr-skip-ws s i end)))
(cond
((>= i end) (jolt-throw (jolt-ex-info "EOF while reading" (empty-pmap))))
((>= i end) (jolt-throw (jolt-ex-info "EOF while reading" empty-pmap)))
((char=? (string-ref s i) close) (values (reverse acc) (+ i 1)))
(else
(let-values (((form j) (rdr-read-form s i end)))
@ -273,6 +344,14 @@
;; sequence in a weak side-table the host contract's form-map-pairs consults.
(define rdr-map-order (make-weak-eq-hashtable))
(define (rdr-make-map es)
;; the JVM reader rejects duplicate literal keys before building the map
(let dupchk ((kvs es) (seen empty-pset))
(when (pair? kvs)
(let ((k (car kvs)))
(when (jolt-truthy? (jolt-contains? seen k))
(jolt-throw (jolt-host-throwable "java.lang.IllegalArgumentException"
(string-append "Duplicate key: " (jolt-pr-str k)))))
(dupchk (cddr kvs) (pset-conj seen k)))))
(let ((m (apply jolt-hash-map es)))
(when (pair? es) (hashtable-set! rdr-map-order m es))
m))
@ -289,14 +368,17 @@
(define (rdr-meta-map m)
(cond
((keyword? m) (jolt-hash-map m #t))
((symbol-t? m) (jolt-hash-map rdr-kw-tag (symbol-t-name m)))
;; ^Type -> {:tag Type} with the SYMBOL (Clojure parity — core.match's
;; array-tag and other libs look the tag up as a symbol; jolt's tag consumers
;; tolerate a symbol). ^"Type" keeps the string.
((symbol-t? m) (jolt-hash-map rdr-kw-tag m))
((string? m) (jolt-hash-map rdr-kw-tag m))
((pmap? m) m)
(else (jolt-hash-map rdr-kw-tag m))))
(define (rdr-merge-meta old new)
(if (pmap? old)
(pmap-fold new (lambda (k v acc) (jolt-assoc1 acc k v)) old)
(pmap-fold-fwd new (lambda (k v acc) (jolt-assoc1 acc k v)) old)
new))
(define (rdr-attach-meta target meta)
@ -304,7 +386,6 @@
((symbol-t? target)
(make-symbol-t (symbol-t-ns target) (symbol-t-name target)
(rdr-merge-meta (symbol-t-meta target) meta)))
((empty-list-t? target) target)
;; Lists/vectors/maps/sets attach metadata to the value itself, as Clojure's
;; reader does. Reading DATA (read-string, edn) then preserves it. A list form
;; is code: ^Type (expr) is a compile-time hint on the FORM, read off the form
@ -313,7 +394,11 @@
;; (with-meta form meta) for a meta-carrying collection literal in code, so
;; (meta ^{:tag :int} [1 2]) / ^:foo {} still works.
(else
(let ((c (jolt-with-meta target meta)))
;; Merge onto any metadata the target already carries (a list form picks up
;; :line/:column first, then ^meta folds its keys on top).
(let* ((old (jolt-meta target))
(merged (rdr-merge-meta (if (jolt-nil? old) jolt-nil old) meta))
(c (jolt-with-meta target merged)))
;; jolt-with-meta copies a pmap, giving it a fresh identity the rdr-map-order
;; side-table (source key order for left-to-right map-literal eval) loses —
;; carry the order entry over to the copy.
@ -321,6 +406,45 @@
(when order (hashtable-set! rdr-map-order c order)))
c))))
;; --- source position --------------------------------------------------------
;; List forms (code) carry 1-based :line/:column, plus :file when the compiler
;; bound rdr-source-file. read-string leaves the file unset. The analyzer reads
;; this back via jolt.host/form-position to stamp :pos on call nodes; macros and
;; (meta (read-string "(…)")) see it too.
(define rdr-source-file (make-thread-parameter #f))
(define rdr-kw-line (keyword #f "line"))
(define rdr-kw-column (keyword #f "column"))
(define rdr-kw-file (keyword #f "file"))
;; Forms are read left-to-right, so the indices queried are non-decreasing within
;; one source string — keep a cursor and count newlines only over the delta
;; (O(n) total, not O(n^2)). A different string or a backward index resets it.
(define rdr-pos-cursor (make-thread-parameter #f)) ; #f | (vector s i line col)
(define (rdr-line-col-at s i)
(let* ((cur (rdr-pos-cursor))
(reuse (and (vector? cur) (eq? (vector-ref cur 0) s)
(fx<=? (vector-ref cur 1) i)))
(k0 (if reuse (vector-ref cur 1) 0))
(l0 (if reuse (vector-ref cur 2) 1))
(c0 (if reuse (vector-ref cur 3) 1)))
(let loop ((k k0) (line l0) (col c0))
(if (fx>=? k i)
(begin (rdr-pos-cursor (vector s k line col)) (values line col))
(if (char=? (string-ref s k) #\newline)
(loop (fx+ k 1) (fx+ line 1) 1)
(loop (fx+ k 1) line (fx+ col 1)))))))
(define (rdr-pos-meta line col)
(let ((f (rdr-source-file)))
(if f
(jolt-hash-map rdr-kw-line line rdr-kw-column col rdr-kw-file f)
(jolt-hash-map rdr-kw-line line rdr-kw-column col))))
(define (rdr-attach-pos lst line col)
(if (empty-list-t? lst) ; () is interned, can't carry meta (= Clojure)
lst
(rdr-attach-meta lst (rdr-pos-meta line col))))
;; --- # dispatch -------------------------------------------------------------
;; #(...) anonymous fn shorthand: % -> p1, %N -> pN, %& -> rest. The
;; fixed arity is the MAX positional used (Clojure: #(do %2 %&) -> [p1 p2 & rest]).
@ -391,7 +515,7 @@
(let* ((splice (and (< i end) (char=? (string-ref s i) #\@)))
(start (if splice (+ i 1) i)))
(let-values (((form j) (rdr-read-form s start end)))
(when (rdr-eof? form) (jolt-throw (jolt-ex-info "EOF after #?" (empty-pmap))))
(when (rdr-eof? form) (jolt-throw (jolt-ex-info "EOF after #?" empty-pmap)))
(let ((items (cond ((pvec? form) (seq->list form))
((or (cseq? form) (empty-list-t? form)) (seq->list form))
(else '()))))
@ -410,8 +534,69 @@
(values (cadr xs) j)))
(else (loop (cddr xs)))))))))
(define (rdr-string-rindex-char str c)
(let loop ((i (- (string-length str) 1)))
(cond ((< i 0) #f) ((char=? (string-ref str i) c) i) (else (loop (- i 1))))))
;; A record/type literal tag (#ns.Type{..} / #ns.Type[..]) is any tag containing
;; a dot — Clojure routes those to a constructor instead of a data reader.
(define (rdr-record-tag? tok) (and (rdr-string-rindex-char tok #\.) #t))
;; #a.b.C{..} -> (a.b/map->C {..}); #a.b.C[..] -> (a.b/->C ..). The factory call
;; compiles like any invoke; defrecord interns map->C/->C in the type's ns.
(define (rdr-record-ctor-form tok form)
(let* ((di (rdr-string-rindex-char tok #\.))
(ns (substring tok 0 di))
(simple (substring tok (+ di 1) (string-length tok))))
(cond
((pmap? form)
(jolt-list (jolt-symbol ns (string-append "map->" simple)) form))
((pvec? form)
(apply jolt-list (jolt-symbol ns (string-append "->" simple))
(vector->list (pvec-v form))))
(else (jolt-throw (jolt-ex-info
(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))))
(when (>= i end) (jolt-throw (jolt-ex-info "EOF after #" empty-pmap)))
(let ((c (string-ref s i)))
(cond
((char=? c #\{) ; #{...} set
@ -419,12 +604,19 @@
(values (rdr-make-set elems) j)))
((char=? c #\() ; #(...) anonymous fn shorthand
(rdr-read-anon-fn s i end))
((char=? c #\") ; #"..." regex -> tagged :regex (raw source)
((char=? c #\") ; #"..." -> a regex VALUE (Clojure parity:
;; the reader constructs the Pattern, so a macro gets a regex, not a form).
;; The analyzer compiles a regex value to the same :regex IR leaf via its
;; source string.
(let-values (((src j) (rdr-read-regex s (+ i 1) end)))
(values (rdr-make-tagged (keyword #f "regex") src) j)))
(values (jolt-re-pattern src) j)))
((char=? c #\_) ; #_ discard the next form
(let-values (((_ j) (rdr-read-form s (+ i 1) end)))
(when (rdr-eof? _) (jolt-throw (jolt-ex-info "EOF after #_" (empty-pmap))))
(let-values (((d j) (rdr-read-form s (+ i 1) end)))
(when (rdr-eof? d) (jolt-throw (jolt-ex-info "EOF after #_" empty-pmap)))
;; edn validates the discarded element (its tags go through the same
;; :readers/:default pipeline; an unreadable one throws)
(let ((cb (rdr-discard-cb)))
(when cb (jolt-invoke cb d)))
(rdr-read-form s j end)))
((char=? c #\') ; #'x var-quote -> (var x)
(let-values (((form j) (rdr-read-form s (+ i 1) end)))
@ -433,7 +625,7 @@
(let-values (((mform j) (rdr-read-form s (+ i 1) end)))
(let-values (((target k) (rdr-read-form s j end)))
(when (rdr-eof? target)
(jolt-throw (jolt-ex-info "EOF after #^meta" (empty-pmap))))
(jolt-throw (jolt-ex-info "EOF after #^meta" empty-pmap)))
(values (rdr-attach-meta target (rdr-meta-map mform)) k))))
((char=? c #\#) ; ## symbolic value: ##Inf / ##-Inf / ##NaN
(let-values (((tok j) (rdr-read-token s (+ i 1) end)))
@ -441,21 +633,25 @@
((string=? tok "-Inf") -inf.0)
((string=? tok "NaN") +nan.0)
(else (jolt-throw (jolt-ex-info (string-append "unknown ## literal: " tok)
(empty-pmap)))))
empty-pmap))))
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)))
(when (rdr-eof? form) (jolt-throw (jolt-ex-info "EOF after #tag" (empty-pmap))))
(values (rdr-make-tagged (keyword #f (string-append "#" tok)) form) k)))))))
(when (rdr-eof? form) (jolt-throw (jolt-ex-info "EOF after #tag" empty-pmap)))
(if (rdr-record-tag? tok) ; #ns.Type{..}/[..] record literal
(values (rdr-record-ctor-form tok form) k)
(values (rdr-make-tagged (keyword #f (string-append "#" tok)) form) k))))))))
;; regex literal source: raw chars to the closing quote; \" is an escaped quote,
;; every other backslash sequence is kept verbatim (regex engine semantics).
(define (rdr-read-regex s i end)
(let loop ((i i) (acc '()))
(when (>= i end) (jolt-throw (jolt-ex-info "EOF while reading regex" (empty-pmap))))
(when (>= i end) (jolt-throw (jolt-ex-info "EOF while reading regex" empty-pmap)))
(let ((c (string-ref s i)))
(cond
((char=? c #\") (values (list->string (reverse acc)) (+ i 1)))
@ -472,6 +668,17 @@
(let ((auto? (and (< i end) (char=? (string-ref s i) #\:))))
(let ((i (if auto? (+ i 1) i)))
(let-values (((tok j) (rdr-read-token s i end)))
(let ((len (string-length tok)))
;; ":" and "::" alone, a leading or trailing slash (a name of exactly
;; "/" is fine, :ns//), or an auto-resolved keyword in edn (no
;; resolution context) are invalid tokens.
(when (or (= len 0)
(and (> len 1) (char=? (string-ref tok 0) #\/))
(and (> len 1) (char=? (string-ref tok (- len 1)) #\/)
(not (and (> len 2) (char=? (string-ref tok (- len 2)) #\/)))))
(rdr-invalid-token (string-append (if auto? "::" ":") tok)))
(when (and auto? (rdr-edn-mode))
(rdr-invalid-token (string-append "::" tok))))
(let-values (((ns name) (rdr-sym-parts tok)))
(if auto?
(let* ((cur (chez-current-ns))
@ -490,8 +697,9 @@
(values rdr-eof i)
(let ((c (string-ref s i)))
(cond
((char=? c #\() (let-values (((es j) (rdr-read-seq s (+ i 1) end #\))))
(values (apply jolt-list es) j)))
((char=? c #\() (let-values (((line col) (rdr-line-col-at s i)))
(let-values (((es j) (rdr-read-seq s (+ i 1) end #\))))
(values (rdr-attach-pos (apply jolt-list es) line col) j))))
((char=? c #\[) (let-values (((es j) (rdr-read-seq s (+ i 1) end #\])))
(values (apply jolt-vector es) j)))
((char=? c #\{) (let-values (((es j) (rdr-read-seq s (+ i 1) end #\})))
@ -508,21 +716,24 @@
;; inert: ``42 reads as 42, ```"meow" as "meow".
((char=? c #\`)
(let-values (((form j) (rdr-read-form s (+ i 1) end)))
(when (rdr-eof? form) (jolt-throw (jolt-ex-info "EOF after `" (empty-pmap))))
(when (rdr-eof? form) (jolt-throw (jolt-ex-info "EOF after `" empty-pmap)))
(values (if (rdr-self-eval-literal? form)
form
(jolt-list (jolt-symbol #f "syntax-quote") form))
j)))
((char=? c #\@) (rdr-wrap s (+ i 1) end (jolt-symbol "clojure.core" "deref")))
;; ~ / ~@ read as clojure.core/unquote(-splicing), like the JVM reader —
;; so code that inspects pattern/template data (core.logic's defne) sees
;; the qualified symbol it expects.
((char=? c #\~)
(if (and (< (+ i 1) end) (char=? (string-ref s (+ i 1)) #\@))
(rdr-wrap s (+ i 2) end (jolt-symbol #f "unquote-splicing"))
(rdr-wrap s (+ i 1) end (jolt-symbol #f "unquote"))))
(rdr-wrap s (+ i 2) end (jolt-symbol "clojure.core" "unquote-splicing"))
(rdr-wrap s (+ i 1) end (jolt-symbol "clojure.core" "unquote"))))
((char=? c #\^)
(let-values (((mform j) (rdr-read-form s (+ i 1) end)))
(let-values (((target k) (rdr-read-form s j end)))
(when (rdr-eof? target)
(jolt-throw (jolt-ex-info "EOF after ^meta" (empty-pmap))))
(jolt-throw (jolt-ex-info "EOF after ^meta" empty-pmap)))
(values (rdr-attach-meta target (rdr-meta-map mform)) k))))
(else
(let-values (((tok j) (rdr-read-token s i end)))
@ -537,7 +748,7 @@
(define (rdr-wrap s i end head)
(let-values (((form j) (rdr-read-form s i end)))
(when (rdr-eof? form)
(jolt-throw (jolt-ex-info "EOF while reading reader macro" (empty-pmap))))
(jolt-throw (jolt-ex-info "EOF while reading reader macro" empty-pmap)))
(values (jolt-list head form) j)))
;; --- form -> data -----------------------------------------------------------
@ -557,42 +768,200 @@
(let ((c (rdr-form->data (car xs))))
(loop (cdr xs) (cons c acc) (or changed (not (eq? c (car xs)))))))))
;; carry the reader metadata, converting its nested forms too — a set/tagged
;; literal inside a ^{…} map (^{:k #{…}}) must become a value like the rest of
;; the data, not stay the tagged set-form.
(define (rdr-carry-meta src dst)
(let ((m (jolt-meta src))) (if (jolt-nil? m) dst (jolt-with-meta dst m))))
(let ((m (jolt-meta src))) (if (jolt-nil? m) dst (jolt-with-meta dst (rdr-form->data m)))))
(define (rdr-form->data x)
;; tag keyword (:#time/date) -> its *data-readers* reader fn, or #f. The fn's
;; namespace must already be loaded (the loader requires them when a project's
;; data_readers.{clj,cljc} registers a tag).
(define (rdr-data-reader-fn tag)
(and (keyword? tag)
(let ((nm (keyword-t-name tag)))
(and (> (string-length nm) 0) (char=? (string-ref nm 0) #\#)
(let* ((bare (substring nm 1 (string-length nm)))
(slash (let loop ((i 0))
(cond ((>= i (string-length bare)) #f)
((char=? (string-ref bare i) #\/) i)
(else (loop (+ i 1))))))
(sym (if slash
(jolt-symbol (substring bare 0 slash) (substring bare (+ slash 1) (string-length bare)))
(jolt-symbol #f bare)))
(dr (var-deref "clojure.core" "*data-readers*"))
(v (and (pmap? dr) (jolt-get dr sym))))
(and v (not (jolt-nil? v)) (symbol-t? v) (not (jolt-nil? (symbol-t-ns v)))
(guard (e (#t #f))
(let ((fn (var-deref (symbol-t-ns v) (symbol-t-name v))))
(and (procedure? fn) fn)))))))))
;; the bare tag SYMBOL for a :#name / :#ns/name reader keyword (strip the leading
;; #, split a qualified tag on /). *default-data-reader-fn* receives it.
(define (rdr-tag->symbol tag)
(let* ((nm (keyword-t-name tag))
(bare (if (and (> (string-length nm) 0) (char=? (string-ref nm 0) #\#))
(substring nm 1 (string-length nm)) nm)))
(let loop ((i 0))
(cond ((>= i (string-length bare)) (jolt-symbol #f bare))
((char=? (string-ref bare i) #\/)
(jolt-symbol (substring bare 0 i) (substring bare (+ i 1) (string-length bare))))
(else (loop (+ i 1)))))))
;; *default-data-reader-fn* — a (fn [tag value]) consulted for an unregistered
;; tag, or #f when unset/nil. Honors a `binding` (var-deref reads the stack).
(define (rdr-default-data-reader-fn)
(guard (e (#t #f))
(let ((v (var-deref "clojure.core" "*default-data-reader-fn*")))
(and (not (jolt-nil? v)) (procedure? v) v))))
;; strict #inst validation: RFC-3339 calendar fields must be real (month 1-12,
;; day valid for the month incl. leap years, hour < 24, minute/second < 60).
(define (rdr-2dig s i)
(and (< (+ i 1) (string-length s))
(rdr-digit? (string-ref s i)) (rdr-digit? (string-ref s (+ i 1)))
(+ (* 10 (- (char->integer (string-ref s i)) 48))
(- (char->integer (string-ref s (+ i 1))) 48))))
(define (rdr-leap? y) (and (= 0 (modulo y 4)) (or (not (= 0 (modulo y 100))) (= 0 (modulo y 400)))))
(define (rdr-inst-throw s)
(jolt-throw (jolt-host-throwable "java.lang.RuntimeException"
(string-append "Unrecognized date/time syntax: " s))))
(define (rdr-validate-inst! s)
;; progressive RFC-3339 like clojure.instant: yyyy[-MM[-dd[Thh[:mm[:ss[.f]]]]]]
;; with an optional Z/±hh:mm offset; each present field must be in range
;; (months 1-12, day valid for the month incl. leap years, hour < 24, min < 60).
(let* ((len (string-length s))
(y (and (>= len 4) (rdr-all-digits? s 0 4) (string->number (substring s 0 4)))))
(unless y (rdr-inst-throw s))
(when (>= len 5)
(unless (char=? (string-ref s 4) #\-) (rdr-inst-throw s))
(let ((mo (rdr-2dig s 5)))
(unless (and mo (>= mo 1) (<= mo 12)) (rdr-inst-throw s))
(when (>= len 8)
(unless (char=? (string-ref s 7) #\-) (rdr-inst-throw s))
(let ((d (rdr-2dig s 8)))
(unless (and d (>= d 1)
(<= d (vector-ref (if (rdr-leap? y)
'#(31 29 31 30 31 30 31 31 30 31 30 31)
'#(31 28 31 30 31 30 31 31 30 31 30 31))
(- mo 1))))
(rdr-inst-throw s))
(when (>= len 11)
(unless (char=? (string-ref s 10) #\T) (rdr-inst-throw s))
(let ((h (rdr-2dig s 11)))
(unless (and h (<= h 23)) (rdr-inst-throw s))
(when (>= len 14)
(when (char=? (string-ref s 13) #\:)
(let ((mi (rdr-2dig s 14)))
(unless (and mi (<= mi 59)) (rdr-inst-throw s)))))))))))))
;; strict #uuid: canonical 8-4-4-4-12 hex groups.
(define (rdr-validate-uuid! s)
(define (hexrun? from to)
(let loop ((i from))
(cond ((>= i to) #t)
((let ((c (char-downcase (string-ref s i))))
(or (rdr-digit? c) (and (char>=? c #\a) (char<=? c #\f))))
(loop (+ i 1)))
(else #f))))
(unless (and (= (string-length s) 36)
(char=? (string-ref s 8) #\-) (char=? (string-ref s 13) #\-)
(char=? (string-ref s 18) #\-) (char=? (string-ref s 23) #\-)
(hexrun? 0 8) (hexrun? 9 13) (hexrun? 14 18) (hexrun? 19 23) (hexrun? 24 36))
(jolt-throw (jolt-host-throwable "java.lang.IllegalArgumentException"
(string-append "Invalid UUID string: " s)))))
;; read-string / read data seam: construct the value for a #tag literal. #inst,
;; #uuid and #"regex" are built in; any other tag is applied from *data-readers*,
;; then *default-data-reader-fn*. An unregistered tag with no default handler stays
;; a tagged FORM (lenient — clojure.edn raises instead).
(define (rdr-construct-tag tag inner)
(cond
((eq? tag (keyword #f "#inst"))
(when (string? inner) (rdr-validate-inst! inner))
(jolt-inst-from-string inner))
((eq? tag (keyword #f "#uuid"))
(when (string? inner) (rdr-validate-uuid! inner))
(jolt-uuid-from-string inner))
((eq? tag (keyword #f "regex")) (jolt-re-pattern inner))
;; the M-literal form: construct the BigDecimal from its numeric text
((eq? tag (keyword #f "bigdec")) (jolt-bigdec-from-string inner))
(else (let ((fn (rdr-data-reader-fn tag)))
(if fn (jolt-invoke fn inner)
(let ((dfn (rdr-default-data-reader-fn)))
(if dfn (jolt-invoke dfn (rdr-tag->symbol tag) inner)
;; no reader for the tag: a proper tagged-literal value, like
;; Clojure's *default-data-reader-fn* (tagged-literal), so
;; tagged-literal? / :tag / :form / printing all work — not the
;; internal reader form. clojure.edn reads raw forms via
;; __read-form-raw, so its :readers/:default path is unaffected.
(jolt-tagged-literal (rdr-tag->symbol tag) inner))))))))
;; rdr-form->data*: convert the VALUE structure (set/tagged/nested forms). The
;; wrapper below adds the metadata, so the unchanged branches return x bare.
(define (rdr-form->data* x)
(cond
((and (pmap? x) (eq? (jolt-get x rdr-kw-jolt-type) rdr-kw-jolt-tagged))
(rdr-construct-tag (jolt-get x rdr-kw-tag) (rdr-form->data (jolt-get x rdr-kw-form))))
((rdr-set-form? x)
(let ((items (jolt-get x rdr-kw-value)))
(rdr-carry-meta x
(let loop ((i 0) (s empty-pset))
(if (fx>=? i (pvec-count items)) s
(loop (fx+ i 1) (pset-conj s (rdr-form->data (pvec-nth-d items i jolt-nil)))))))))
(let loop ((i 0) (s empty-pset))
(if (fx>=? i (pvec-count items)) s
(let ((v (rdr-form->data (pvec-nth-d items i jolt-nil))))
(when (jolt-truthy? (jolt-contains? s v))
(jolt-throw (jolt-host-throwable "java.lang.IllegalArgumentException"
(string-append "Duplicate key: " (jolt-pr-str v)))))
(loop (fx+ i 1) (pset-conj s v)))))))
((pvec? x)
(let-values (((items changed) (rdr-conv-each (vector->list (pvec-v x)))))
(if changed (rdr-carry-meta x (apply jolt-vector items)) x)))
(if changed (apply jolt-vector items) x)))
((pmap? x)
(let ((order (hashtable-ref rdr-map-order x #f)))
(if order
(let-values (((kvs changed) (rdr-conv-each order)))
(if changed
(let ((m (rdr-make-map kvs))) (rdr-carry-meta x m))
x))
(if changed (rdr-make-map kvs) x))
(let-values (((kvs changed)
(rdr-conv-each (pmap-fold x (lambda (k v a) (cons k (cons v a))) '()))))
(if changed (rdr-carry-meta x (apply jolt-hash-map kvs)) x)))))
(if changed (apply jolt-hash-map kvs) x)))))
((cseq? x)
(let-values (((items changed) (rdr-conv-each (seq->list x))))
(if changed (rdr-carry-meta x (apply jolt-list items)) x)))
(if changed (apply jolt-list items) x)))
(else x)))
;; Read DATA always carries metadata, converting its nested forms too — Clojure's
;; reader reads a ^{…} map with the same read() as any value, so a set/tagged
;; literal in metadata is a value, not a form. Carry it whether or not the value
;; itself changed (a set-form in the metadata of an otherwise-unchanged value).
(define (rdr-form->data x)
(let ((v (rdr-form->data* x)) (m (jolt-meta x)))
(if (jolt-nil? m) v (jolt-with-meta v (rdr-form->data m)))))
;; --- the two host seams -----------------------------------------------------
;; a top-level read: a stray close delimiter is unmatched (read-seq consumes the
;; close of an open collection; anything reaching here is unbalanced input).
(define (rdr-read-top s i end)
(let ((k (rdr-skip-ws s i end)))
(when (and (< k end)
(let ((c (string-ref s k)))
(or (char=? c #\)) (char=? c #\]) (char=? c #\}))))
(jolt-throw (jolt-ex-info (string-append "Unmatched delimiter: "
(string (string-ref s k)))
empty-pmap)))
(rdr-read-form s k end)))
;; clojure.core/read-string: first form, or nil for blank / comment-only input
;; (parse-string wart, matched deliberately). jolt-read-form-raw keeps set FORMS
;; for the compiler spine (compile-eval); the data seam converts them to sets.
(define (jolt-read-form-raw s)
(let-values (((form j) (rdr-read-form s 0 (string-length s))))
(let-values (((form j) (rdr-read-top s 0 (string-length s))))
(if (rdr-eof? form) jolt-nil form)))
;; the edn seam: strict mode (no auto-resolved keywords), each #_ discard handed
;; to the callback for tag validation, and a distinct EOF sentinel so the edn
;; layer can honor its :eof option (nil input is a plain EOF).
(define (jolt-read-form-edn s cb)
(if (jolt-nil? s)
(keyword "jolt" "reader-eof")
(parameterize ((rdr-edn-mode #t)
(rdr-discard-cb (if (jolt-nil? cb) #f cb)))
(let-values (((form j) (rdr-read-top s 0 (string-length s))))
(if (rdr-eof? form) (keyword "jolt" "reader-eof") form)))))
(define (jolt-read-string s)
(let ((form (jolt-read-form-raw s)))
(if (jolt-nil? form) form (rdr-form->data form))))
@ -600,7 +969,7 @@
;; __parse-next: [form rest-of-string] or nil when only whitespace/comments left.
(define (jolt-parse-next s)
(let ((end (string-length s)))
(let-values (((form j) (rdr-read-form s 0 end)))
(let-values (((form j) (rdr-read-top s 0 end)))
(if (rdr-eof? form)
jolt-nil
(jolt-vector (rdr-form->data form) (substring s j end))))))
@ -609,11 +978,30 @@
;; is the :#name keyword the reader produced; #uuid/#inst reuse the inst-time ctors.
(define (jolt-read-tagged tag form)
(cond
((eq? tag (keyword #f "#uuid")) (jolt-uuid-from-string form))
((eq? tag (keyword #f "#inst")) (jolt-inst-from-string form))
(else (jolt-throw (jolt-ex-info (string-append "No reader function for tag " (jolt-pr-str tag))
(empty-pmap))))))
((eq? tag (keyword #f "#uuid"))
(when (string? form) (rdr-validate-uuid! form))
(jolt-uuid-from-string form))
((eq? tag (keyword #f "#inst"))
(when (string? form) (rdr-validate-inst! form))
(jolt-inst-from-string form))
((eq? tag (keyword #f "bigdec")) (jolt-bigdec-from-string form))
;; No registered reader: consult *default-data-reader-fn*, else throw a clean,
;; catchable ex-info naming the tag, like the JVM's "No reader function for tag
;; foobar" (empty-pmap is a VALUE — the old (empty-pmap) applied it as a
;; procedure and crashed the Chez VM).
(else (let ((dfn (rdr-default-data-reader-fn)))
(if dfn (jolt-invoke dfn (rdr-tag->symbol tag) form)
(let* ((nm (keyword-t-name tag))
(bare (if (and (> (string-length nm) 0) (char=? (string-ref nm 0) #\#))
(substring nm 1 (string-length nm)) nm)))
(jolt-throw (jolt-ex-info (string-append "No reader function for tag " bare) empty-pmap))))))))
(def-var! "clojure.core" "read-string" jolt-read-string)
(def-var! "clojure.core" "__parse-next" jolt-parse-next)
(def-var! "clojure.core" "__read-tagged" jolt-read-tagged)
;; __read-form-raw: the read form WITHOUT building values — set/tagged literals
;; stay FORMS. clojure.edn reads this so it applies a #tag through its :readers/
;; :default (a #inst can be overridden to defer), rather than read-string building
;; the built-in #inst eagerly (which fails on a non-string like #inst ^:ref […]).
(def-var! "clojure.core" "__read-form-raw" jolt-read-form-raw)
(def-var! "clojure.core" "__read-form-edn" jolt-read-form-edn)

View file

@ -1,115 +0,0 @@
;; records-interop.ss — JVM-emulation taxonomy split out of records.ss: the
;; ex-info class accessors, the exception supertype hierarchy, and instance-check
;; / case-string (the (instance? Class x) decision table). Loaded right after
;; records.ss; instance-check forward-refs nothing in records.ss at load time.
;; pmap? guard: ex-info maps are plain hash-maps, never sorted-map htables — and a
;; bare jolt-get on a sorted-map would invoke its comparator on :jolt/type and throw.
(define (ex-info-map? v)
(and (pmap? v) (jolt=2 (jolt-get v jolt-kw-ex-type jolt-nil) jolt-kw-ex-info)))
(define (ex-info-class v)
(let ((c (jolt-get v jolt-kw-class jolt-nil)))
(if (string? c) c "clojure.lang.ExceptionInfo")))
;; immediate-parent chain of the JVM exception hierarchy (simple names). Drives
;; instance? across exception supertypes — (instance? Throwable (ex-info …)) etc.
(define exception-parent
'(("ExceptionInfo" . "RuntimeException")
("RuntimeException" . "Exception")
("IllegalArgumentException" . "RuntimeException")
("NumberFormatException" . "IllegalArgumentException")
("IllegalStateException" . "RuntimeException")
("UnsupportedOperationException" . "RuntimeException")
("ArithmeticException" . "RuntimeException")
("NullPointerException" . "RuntimeException")
("ClassCastException" . "RuntimeException")
("IndexOutOfBoundsException" . "RuntimeException")
("ConcurrentModificationException" . "RuntimeException")
("NoSuchElementException" . "RuntimeException")
("UncheckedIOException" . "RuntimeException")
("InterruptedException" . "Exception")
("IOException" . "Exception")
("FileNotFoundException" . "IOException")
("UnsupportedEncodingException" . "IOException")
("UnknownHostException" . "IOException")
("SocketException" . "IOException")
("ConnectException" . "IOException")
("SocketTimeoutException" . "IOException")
("MalformedURLException" . "IOException")
("SSLException" . "IOException")
("Exception" . "Throwable")
("Error" . "Throwable")
("AssertionError" . "Error")
("Throwable" . "Object")))
;; Is `wanted` (simple name) `cls` or a supertype of it? ExceptionInfo also
;; implements the IExceptionInfo interface.
(define (exception-isa? cls wanted)
(let loop ((c cls))
(cond ((not c) #f)
((string=? c wanted) #t)
((and (string=? c "ExceptionInfo") (string=? wanted "IExceptionInfo")) #t)
(else (let ((p (assoc c exception-parent))) (loop (and p (cdr p))))))))
;; instance-check: (type-sym val) — type/protocol membership. Host shims loaded
;; later (io, inst-time, natives-array, natives-queue, host-static-classes)
;; register an arm with register-instance-check-arm! instead of set!-wrapping
;; instance-check; an arm returns #t/#f to decide or 'pass to defer to the next.
;; Newest arm is checked first (matches the old outermost-wins set! order).
;; instance-check-base is the JVM taxonomy fallback when no arm decides.
(define instance-check-registry '())
(define (register-instance-check-arm! f) ; f: (type-sym val) -> #t | #f | 'pass
(set! instance-check-registry (cons f instance-check-registry)))
(define (instance-check-base type-sym val)
(let ((tname (symbol-t-name type-sym)))
(cond
((jrec? val)
(let ((tag (jrec-tag val)))
(or (string=? tag tname)
(and (> (string-length tag) (string-length tname))
(string=? (substring tag (- (string-length tag) (string-length tname)) (string-length tag)) tname)))))
((jreify? val) (let ((short (last-dot tname)))
(and (memp (lambda (p) (string=? (last-dot p) short)) (jreify-protos val)) #t)))
((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)
(or (= 0 (string-length type-sym))
(not (char=? (string-ref type-sym 0) #\[))))
(jolt-symbol #f type-sym)
type-sym)))
(let loop ((rs instance-check-registry))
(if (null? rs)
(instance-check-base ts val)
(let ((r ((car rs) ts val)))
(if (eq? r 'pass) (loop (cdr rs)) r))))))
(define (case-string tname val)
(cond
((member tname '("Number" "java.lang.Number")) (number? val))
((member tname '("Long" "java.lang.Long" "Integer" "java.lang.Integer"))
(and (number? val) (exact? val) (integer? val)))
((member tname '("Double" "java.lang.Double" "Float" "java.lang.Float")) (and (number? val) (flonum? val)))
((member tname '("Ratio" "clojure.lang.Ratio")) (and (number? val) (exact? val) (rational? val) (not (integer? val))))
((member tname '("String" "java.lang.String" "CharSequence" "java.lang.CharSequence")) (string? val))
((member tname '("Boolean" "java.lang.Boolean")) (boolean? val))
((member tname '("Character" "java.lang.Character")) (char? val))
((member tname '("Keyword" "clojure.lang.Keyword")) (keyword? val))
((member tname '("Symbol" "clojure.lang.Symbol")) (jolt-symbol? val))
((member tname '("Atom" "clojure.lang.Atom")) (jolt-atom? val))
((member tname '("IFn" "clojure.lang.IFn" "Fn" "clojure.lang.Fn")) (procedure? val))
((member tname '("Pattern" "java.util.regex.Pattern")) (regex-t? val))
((member tname '("URI" "java.net.URI"))
(and (jhost? val) (string=? (jhost-tag val) "uri")))
((member tname '("File" "java.io.File")) (jfile? val))
((member tname '("UUID" "java.util.UUID")) (juuid? val))
(else #f)))
;; str of a record uses a custom (Object toString) impl if the type defines one
;; (deftype with no default toString relies on this); otherwise the map form
;; without the leading # (Clojure's record .toString). converters.ss loads before
;; records.ss, so this set! sees the registry — forward refs resolve at call time.
(def-var! "clojure.core" "instance-check" instance-check)

File diff suppressed because it is too large Load diff

View file

@ -33,6 +33,14 @@
(apply %chez-error args)))
(load "vendor/irregex/irregex.scm")
;; irregex rejects a quantifier applied to anything that already contains one —
;; including a GROUP like (a+)* — because sre-repeater? recurses through submatch.
;; Java only rejects a DANGLING double quantifier (a**); it allows a quantifier on
;; a group whose body is quantified. Restrict the check to a bare leading * / + so
;; a** still errors but (a+)* parses (cuerdas's format tokenizer needs this).
(set! sre-repeater?
(lambda (sre) (and (pair? sre) (memq (car sre) '(* +)) #t)))
;; Unicode property classes \p{...}: irregex's string syntax has no
;; \p{...}, so translate a fixed set of property names
;; to ASCII char classes before compiling. ASCII-only — \p{L} would need
@ -92,6 +100,36 @@
(write-char c out) (loop (fx+ i 1) #f))
(else (write-char c out) (loop (fx+ i 1) in-class))))))))
;; Inside a [...] class, irregex reads a '-' that follows a shorthand class
;; (\w \d \s \W \D \S) as the start of a range and errors ("bad char-set"); Java
;; reads it as a literal hyphen (a shorthand can't be a range endpoint). Escape
;; such a '-' to \- so the class parses. Only a '-' right after a shorthand and
;; not the class terminator is touched; a '-' after a plain char (a real range
;; like [a-z]) is left alone.
(define (escape-class-shorthand-dash src)
(let ((len (string-length src)) (out (open-output-string)))
(let loop ((i 0) (in-class #f) (after-shorthand #f))
(if (fx>=? i len)
(get-output-string out)
(let ((c (string-ref src i)))
(cond
;; an escape pair: \w-style shorthand sets after-shorthand inside a class
((and (char=? c #\\) (fx<? (fx+ i 1) len))
(let ((n (string-ref src (fx+ i 1))))
(write-char c out) (write-char n out)
(loop (fx+ i 2) in-class
(and in-class (memv n '(#\w #\d #\s #\W #\D #\S)) #t))))
((and (not in-class) (char=? c #\[))
(write-char c out) (loop (fx+ i 1) #t #f))
((and in-class (char=? c #\]))
(write-char c out) (loop (fx+ i 1) #f #f))
;; the case Java reads as a literal hyphen
((and in-class after-shorthand (char=? c #\-)
(fx<? (fx+ i 1) len) (not (char=? (string-ref src (fx+ i 1)) #\])))
(write-char #\\ out) (write-char #\- out)
(loop (fx+ i 1) in-class #f))
(else (write-char c out) (loop (fx+ i 1) in-class #f))))))))
;; Java/Clojure inline flags: a leading (?imsx…) group sets a flag over the whole
;; pattern. irregex has the same semantics but as constructor OPTIONS, not inline
;; syntax (it rejects (?s)/(?s:…)), so peel any leading flag groups off the source
@ -121,9 +159,23 @@
;; A jolt regex value: the source string (for printing / str) + the compiled
;; irregex. regex? recognizes it; the printer renders #"source".
(define-record-type regex-t (fields source irx) (nongenerative jolt-regex-v1))
;; A capturing pattern is compiled with irregex's BACKTRACKING matcher ('backtrack),
;; not its DFA. java.util.regex is itself a leftmost-first backtracking engine, so
;; this matches the JVM's submatch semantics; irregex's DFA is POSIX leftmost-longest
;; and, worse, leaks a non-participating alternation group's capture (e.g.
;; #"(?:([0-9])|([0-9])r([0-9]+))" on "2r11" left group 1 = "2"), which broke
;; tools.reader's number reader. Non-capturing patterns keep the fast DFA — with no
;; groups to read, its whole-match result is all a caller sees. The count comes from
;; a first cheap compile; a capturing pattern is recompiled once (patterns compile
;; once and cache in the regex-t).
(define (jolt-regex source)
(let-values (((opts pat) (regex-parse-flags source)))
(make-regex-t source (apply irregex (translate-prop-classes pat) opts))))
(let* ((p (translate-prop-classes (escape-class-shorthand-dash pat)))
(irx (apply irregex p opts)))
(make-regex-t source
(if (> (irregex-num-submatches irx) 0)
(apply irregex p 'backtrack opts)
irx)))))
(define (jolt-regex? x) (regex-t? x))
(define (jolt-re-pattern x) (if (regex-t? x) x (jolt-regex x)))
@ -143,9 +195,59 @@
(let ((m (irregex-match (regex-t-irx (jolt-re-pattern re)) s)))
(if m (irx-result m) jolt-nil)))
(define (jolt-re-find re s)
(let ((m (irregex-search (regex-t-irx (jolt-re-pattern re)) s)))
(if m (irx-result m) jolt-nil)))
;; A stateful matcher (java.util.regex.Matcher): the compiled pattern, the target
;; string, the next search position, and the last successful irregex match. re-find
;; over a matcher steps through non-overlapping matches; re-groups returns the
;; groups of the last one.
(define-record-type matcher-t
(fields irx str (mutable pos) (mutable last))
(nongenerative jolt-matcher-v1))
(define (jolt-re-matcher re s)
(make-matcher-t (regex-t-irx (jolt-re-pattern re)) s 0 #f))
(define (jolt-matcher? x) (matcher-t? x))
;; re-find: stateless over (re s), or stateful over a matcher (advance + remember).
(define jolt-re-find
(case-lambda
((re s)
(let ((m (irregex-search (regex-t-irx (jolt-re-pattern re)) s)))
(if m (irx-result m) jolt-nil)))
((m)
(let* ((str (matcher-t-str m))
(len (string-length str))
(start (matcher-t-pos m))
(mm (and (<= start len) (irregex-search (matcher-t-irx m) str start))))
(if mm
(let ((ms (irregex-match-start-index mm 0))
(e (irregex-match-end-index mm 0)))
(matcher-t-last-set! m mm)
;; advance past this match: to its end, or one past a zero-width match
;; (which may sit past the search origin, e.g. a lookahead/boundary).
(matcher-t-pos-set! m (if (> e ms) e (+ e 1)))
(irx-result mm))
(begin (matcher-t-last-set! m #f) jolt-nil))))))
;; re-groups: the groups of the matcher's last successful find. Throws when no
;; match has succeeded, like Clojure's IllegalStateException "No match found".
(define (jolt-re-groups m)
(let ((last (matcher-t-last m)))
(if last (irx-result last)
(jolt-throw (jolt-ex-info "No match found" (jolt-hash-map))))))
;; java.util.regex.Matcher methods over a matcher-t. .matches anchors a full-region
;; match and remembers it for .group; .group n returns submatch n (0 = whole) or
;; nil; .groupCount is the pattern's capturing-group count.
(define (jolt-matcher-matches m)
(let ((mm (irregex-match (matcher-t-irx m) (matcher-t-str m))))
(matcher-t-last-set! m mm)
(if mm #t #f)))
(define (jolt-matcher-group m . n)
(let ((last (matcher-t-last m)))
(if last
(let ((s (irregex-match-substring last (if (pair? n) (->idx (car n)) 0))))
(if s s jolt-nil))
(jolt-throw (jolt-ex-info "No match available" (jolt-hash-map))))))
(define (jolt-matcher-group-count m) (irregex-num-submatches (matcher-t-irx m)))
;; All non-overlapping matches, left to right. Advance past each match end (or by
;; one on a zero-width match). nil when there are no matches (Clojure: seq-able as
@ -156,12 +258,17 @@
(let loop ((start 0) (acc '()))
(let ((m (and (<= start len) (irregex-search irx s start))))
(if m
(let ((e (irregex-match-end-index m 0)))
(loop (if (> e start) e (+ start 1)) (cons (irx-result m) acc)))
(let ((ms (irregex-match-start-index m 0))
(e (irregex-match-end-index m 0)))
;; to the match end, or one past a zero-width match (relative to its
;; own start, which may be past the search origin).
(loop (if (> e ms) e (+ e 1)) (cons (irx-result m) acc)))
(list->cseq (reverse acc)))))))
(def-var! "clojure.core" "re-pattern" jolt-re-pattern)
(def-var! "clojure.core" "re-matches" jolt-re-matches)
(def-var! "clojure.core" "re-find" jolt-re-find)
(def-var! "clojure.core" "re-seq" jolt-re-seq)
(def-var! "clojure.core" "re-matcher" jolt-re-matcher)
(def-var! "clojure.core" "re-groups" jolt-re-groups)
(def-var! "clojure.core" "regex?" jolt-regex?)

View file

@ -11,6 +11,17 @@
;; Emitted programs do `(load "host/chez/rt.ss")`; this loads values.ss in turn.
(load "host/chez/values.ss")
;; Resolve a libc entry point at RUN time. A literal (foreign-procedure "name" …)
;; in COMPILED code becomes a fasl relocation resolved when the boot loads — on a
;; platform lacking the symbol (chmod/sigaddset on Windows) that kills the boot
;; before any guard can run. eval defers the lookup to evaluation time, where the
;; guard works; returns #f when the entry doesn't exist.
(define (jolt-foreign-proc-safe name args res)
(guard (e (#t #f))
(load-shared-object #f)
(and (foreign-entry? name)
(eval `(foreign-procedure ,name ,args ,res)))))
(load "host/chez/collections.ss")
(load "host/chez/seq.ss")
@ -22,20 +33,157 @@
;; pass an exact integer through, error if it doesn't fit a fixnum or isn't a
;; number. The hint is a promise the value is a fixnum-range long; the body's fx*
;; ops rely on it. (^double params coerce with the built-in exact->inexact.)
;; A ^long is a 64-bit value; a Chez fixnum is only 61-bit, so a value that
;; overflows the fixnum range (a full-width long, e.g. from unchecked / wrapping
;; arithmetic) passes through as an exact integer rather than erroring. fx ops in
;; the body still require fixnums (they raise on a bignum), but generic /
;; unchecked-* ops handle it.
(define (jolt->fx x)
(let ((n (cond ((fixnum? x) x)
((flonum? x) (exact (truncate x)))
((rational? x) (exact (truncate x)))
(else (error 'jolt "^long hint: not a number" x)))))
(if (fixnum? n) n (error 'jolt "^long hint: value out of fixnum range" x))))
(cond ((fixnum? x) x)
((and (number? x) (exact? x) (integer? x)) x)
((flonum? x) (exact (truncate x)))
((rational? x) (exact (truncate x)))
(else (error 'jolt "^long hint: not a number" x))))
;; jolt `not`: only nil and false are falsey.
(define (jolt-not x) (if (jolt-truthy? x) #f #t))
;; --- exceptions --------------------------------------------------------------
;; throw raises the jolt value RAW (no envelope);
;; catch (emitted as `guard`) binds it directly. Chez `raise` accepts any
;; object, so a thrown number/map/ex-info all work; uncaught -> non-zero exit.
(define (jolt-throw v) (raise v))
;; throw raises a Chez condition WRAPPING the jolt value; catch (emitted as
;; `guard`) and jolt-report-uncaught unwrap it back via jolt-unwrap-throw.
;; Raising the value RAW broke when a throw crossed the host/`eval` boundary:
;; Chez re-wrapped the non-condition into a compound condition whose
;; message-extraction APPLIES the value (crashing on an empty-map :data ->
;; "attempt to apply non-procedure"), and the real message was lost. A real
;; condition propagates intact through any number of eval boundaries.
;; Capture the live continuation at the throw site (identity-tagged with the
;; thrown value) so an uncaught error can walk the native frames back to a Clojure
;; stack trace (source-registry.ss). call/cc is paid only on a throw, never per
;; call; the captured k is walked, never invoked.
(define jolt-throw-cont (make-thread-parameter #f))
;; --- tail-frame history: a ring of rings (opt-in) ----------------------------
;; TCO erases tail-called frames from the native continuation, so an uncaught
;; error's backtrace shows only the surviving non-tail spine — the immediate error
;; site is often a tail call and is missing. When tracing is enabled (JOLT_TRACE,
;; wired in compile-eval.ss), each compiled fn records its frame-name on entry, and
;; the reporter reads this history to recover TCO-elided frames.
;;
;; The store is MIT-Scheme's "history" shape — a ring of rings. The OUTER ring
;; holds one RIB per non-tail subproblem (the real call spine); each rib's INNER
;; ring holds the recent tail-calls made AT that subproblem. A non-tail entry
;; advances the outer ring (a fresh rib); a tail entry rotates the current rib's
;; inner ring. So a tight tail loop (mutual recursion, a non-recur self-tail-call)
;; churns ONE rib's small inner ring instead of flushing the outer spine — the
;; caller context that led into the loop survives. Both rings are fixed-size, so
;; the whole history is bounded: a constant space factor, NOT a change to the
;; asymptotic space TCO guarantees.
;;
;; Whether an entry is tail or non-tail is set by the CALLER: the emitter marks a
;; tail call with (jolt-trace-mark! #t) right before it; a non-tail entry is the
;; default. NOTE this is best-effort: a tail call routed through jolt-invoke to a
;; target that has no entry prologue (a core/native fn, an anonymous fn held in a
;; var) does not consume the mark, so a following non-tail frame can be mislabeled
;; as a tail rotation — a cosmetic mis-grouping in the trace, never a wrong result.
(define jolt-trace-outer-size 48) ; ribs (non-tail spine depth kept)
(define jolt-trace-inner-size 6) ; tail-calls kept per subproblem
;; A history: #(ribs-vector outer-head outer-count). A rib: #(name-vector head count).
(define (jolt-make-rib) (vector (make-vector jolt-trace-inner-size #f) 0 0))
(define (jolt-make-history)
(let ((ribs (make-vector jolt-trace-outer-size #f)))
(let loop ((i 0))
(when (fx<? i jolt-trace-outer-size)
(vector-set! ribs i (jolt-make-rib)) (loop (fx+ i 1))))
(vector ribs 0 0)))
;; A global switch (all threads) plus a per-thread ring, lazily created on first
;; use — so code run on a spawned thread (a future/agent) records into ITS OWN
;; history, not the enabling thread's (make-thread-parameter hands a new thread the
;; initial #f, so we can't rely on inheritance).
(define jolt-trace-on? #f)
(define jolt-trace-ring (make-thread-parameter #f))
(define jolt-trace-tail? (make-thread-parameter #f)) ; caller-set, consumed per entry
(define (jolt-trace-enable!) (set! jolt-trace-on? #t) (jolt-trace-ring (jolt-make-history)))
;; this thread's ring, created on demand while tracing is on
(define (jolt-trace-cur-ring)
(or (jolt-trace-ring)
(and jolt-trace-on? (let ((h (jolt-make-history))) (jolt-trace-ring h) h))))
;; Drop accumulated history at a top-level boundary (compile-eval.ss calls this per
;; top-level form) so an error's trace shows only the forms that led to it, not the
;; frames of earlier, already-returned REPL/eval forms.
(define (jolt-trace-reset!)
(when (jolt-trace-ring) (jolt-trace-ring (jolt-make-history)) (jolt-trace-tail? #f)))
(define (jolt-trace-mark! t) (jolt-trace-tail? t))
;; push name into a rib's inner ring
(define (jolt-rib-push! rib name)
(let ((buf (vector-ref rib 0)) (i (vector-ref rib 1)) (cnt (vector-ref rib 2)))
(vector-set! buf i name)
(vector-set! rib 1 (fxmod (fx+ i 1) jolt-trace-inner-size))
(when (fx<? cnt jolt-trace-inner-size) (vector-set! rib 2 (fx+ cnt 1)))))
;; a non-tail entry: advance the outer ring, reset the new rib, seed it with name
(define (jolt-history-nontail! h name)
(let* ((ribs (vector-ref h 0)) (oh (vector-ref h 1)) (oc (vector-ref h 2))
(rib (vector-ref ribs oh)))
(vector-set! rib 1 0) (vector-set! rib 2 0)
(jolt-rib-push! rib name)
(vector-set! h 1 (fxmod (fx+ oh 1) jolt-trace-outer-size))
(when (fx<? oc jolt-trace-outer-size) (vector-set! h 2 (fx+ oc 1)))))
;; a tail entry: rotate the CURRENT rib's inner ring (bootstrap a rib if none yet)
(define (jolt-history-tail! h name)
(if (fx=? (vector-ref h 2) 0)
(jolt-history-nontail! h name)
(let* ((ribs (vector-ref h 0))
(cur (fxmod (fx+ (fx- (vector-ref h 1) 1) jolt-trace-outer-size)
jolt-trace-outer-size)))
(jolt-rib-push! (vector-ref ribs cur) name))))
;; Record a frame entry, routed by the caller's tail mark; then reset the mark so a
;; subsequent entry reached WITHOUT a mark (e.g. via apply) defaults to non-tail.
(define (jolt-trace-push! name)
(let ((h (jolt-trace-cur-ring)))
(when h
(if (jolt-trace-tail?) (jolt-history-tail! h name) (jolt-history-nontail! h name))
(jolt-trace-tail? #f)))
jolt-nil)
;; a rib's inner names, most-recent (deepest) tail first
(define (jolt-rib-names rib)
(let ((buf (vector-ref rib 0)) (head (vector-ref rib 1)) (cnt (vector-ref rib 2)))
(let loop ((k 1) (acc '()))
(if (fx>? k cnt)
(reverse acc)
(loop (fx+ k 1)
(cons (vector-ref buf (fxmod (fx+ (fx- head k) jolt-trace-inner-size)
jolt-trace-inner-size))
acc))))))
;; The whole history flattened to frame-names, most-recent (deepest) first:
;; current rib's tail-history, then its non-tail caller's, and so on outward.
(define (jolt-trace-snapshot)
(let ((h (jolt-trace-ring)))
(if (not h) '()
(let* ((ribs (vector-ref h 0)) (oh (vector-ref h 1)) (oc (vector-ref h 2)))
(let loop ((k 1) (acc '()))
(if (fx>? k oc)
(apply append (reverse acc))
(let ((idx (fxmod (fx+ (fx- oh k) jolt-trace-outer-size) jolt-trace-outer-size)))
(loop (fx+ k 1) (cons (jolt-rib-names (vector-ref ribs idx)) acc)))))))))
(define-condition-type &jolt-throw &condition
make-jolt-throw-condition jolt-throw-condition?
(value jolt-throw-condition-value))
;; Fallback &message for a leaked condition; the real message always comes from
;; the unwrapped value via ex-message.
(define (jolt-throw-message v)
(if (and (pmap? v)
(jolt=2 (jolt-get v jolt-kw-ex-type jolt-nil) jolt-kw-ex-info))
(let ((m (jolt-get v jolt-kw-message jolt-nil)))
(if (string? m) m "jolt error"))
"jolt error"))
(define (jolt-throw v)
(call/cc (lambda (k)
(jolt-throw-cont (cons v k))
(raise (condition (make-message-condition (jolt-throw-message v))
(make-jolt-throw-condition v))))))
(define (jolt-unwrap-throw x)
(if (jolt-throw-condition? x) (jolt-throw-condition-value x) x))
;; ex-info builds the tagged map {:jolt/type :jolt/ex-info :message :data :cause}
;; — a real jolt-hash-map, so the ex-data/ex-message/ex-cause tier fns read it
;; via jolt-get for free. Arity 2 (msg data) or 3 (msg data cause).
@ -103,7 +251,21 @@
;; 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
;; hand-rolled :jolt/ex-info table, which carries only the class.
(def-var! "jolt.host" "throwable" jolt-host-throwable)
;; var def-time metadata: the :def emit passes the def's reader meta
;; (^:private / ^Type tag / docstring -> {:doc}) here, stored in an eq side-table
;; keyed by the cell. jolt-meta (natives-meta.ss) merges it onto {:ns :name},
@ -179,6 +341,59 @@
;; bare nil renders as the empty string (a nil ELEMENT inside a collection still
;; prints "nil", which jolt-pr-str handles).
(define (jolt-final-str x) (if (jolt-nil? x) "" (jolt-pr-str x)))
;; --- *print-level* / *print-length* -----------------------------------------
;; Both vars default to nil (= unlimited). A non-nil number limits collection
;; nesting depth / element count in BOTH printers (jolt-pr-str here and
;; jolt-pr-readable in printing.ss). Cells captured lazily — the vars are def'd
;; after rt.ss. The nil default takes a fast path: jolt-print-hash? is #f and the
;; limited-string walkers never truncate.
(define plevel-cell #f)
(define plength-cell #f)
(define (jolt-print-level)
(unless plevel-cell (set! plevel-cell (jolt-var "clojure.core" "*print-level*")))
(let ((v (jolt-var-get plevel-cell))) (and (number? v) v)))
(define (jolt-print-length)
(unless plength-cell (set! plength-cell (jolt-var "clojure.core" "*print-length*")))
(let ((v (jolt-var-get plength-cell))) (and (number? v) v)))
(define jolt-print-depth (make-thread-parameter 0))
;; A collection at depth >= *print-level* renders as "#". The top-level collection
;; is depth 0, so *print-level* 0 collapses any collection, 1 keeps the outermost.
(define (jolt-print-hash?)
(let ((lvl (jolt-print-level))) (and lvl (fx>=? (jolt-print-depth) lvl))))
;; Rendered element strings of a vector (by index), honoring *print-length*: at
;; most N, then "...". render-one runs at the current (already bumped) depth.
(define (jolt-limited-vec-strs x render-one)
(let ((len (pvec-count x)) (lim (jolt-print-length)))
(let loop ((i 0) (acc '()))
(cond ((fx>=? i len) (reverse acc))
((and lim (fx>=? i lim)) (reverse (cons "..." acc)))
(else (loop (fx+ i 1) (cons (render-one (pvec-nth-d x i jolt-nil)) acc)))))))
;; Rendered element strings of a seq, walked lazily so an infinite seq is realized
;; only up to *print-length*.
(define (jolt-limited-seq-strs s render-one)
(let ((lim (jolt-print-length)))
(let loop ((s s) (i 0) (acc '()))
(cond ((jolt-nil? s) (reverse acc))
((and lim (fx>=? i lim)) (reverse (cons "..." acc)))
(else (loop (jolt-seq (seq-more s)) (fx+ i 1) (cons (render-one (seq-first s)) acc)))))))
;; Truncate an already-collected element-string list (set / map, finite) to
;; *print-length*, appending "..." when more remain.
(define (jolt-limited-list-strs strs)
(let ((lim (jolt-print-length)))
(if (not lim) strs
(let loop ((s strs) (i 0) (acc '()))
(cond ((null? s) (reverse acc))
((fx>=? i lim) (reverse (cons "..." acc)))
(else (loop (cdr s) (fx+ i 1) (cons (car s) acc))))))))
;; bump the print depth around a collection's element rendering — but only when
;; *print-level* is set, since depth is consulted only to enforce it. With the
;; common nil default this is a plain begin, so printing pays no parameterize.
(define-syntax with-deeper-print
(syntax-rules ()
((_ body ...) (if (jolt-print-level)
(parameterize ((jolt-print-depth (fx+ (jolt-print-depth) 1))) body ...)
(begin body ...)))))
;; A host shim registers a type's str-style rendering via register-pr-str-arm! (or
;; register-pr-arm! in printing.ss for both printers at once) instead of
;; set!-wrapping jolt-pr-str. Disjoint types, checked before the base cases.
@ -199,18 +414,23 @@
(if (or (jolt-nil? ns) (not ns) (eq? ns '())) (symbol-t-name x)
(string-append ns "/" (symbol-t-name x)))))
((regex-t? x) (string-append "#\"" (regex-t-source x) "\""))
((pvec? x) (let ((acc '())) (let loop ((i (fx- (pvec-count x) 1)))
(when (fx>=? i 0) (set! acc (cons (jolt-pr-str (pvec-nth-d x i jolt-nil)) acc)) (loop (fx- i 1))))
(string-append "[" (jolt-str-join acc) "]")))
((pset? x) (string-append "#{" (jolt-str-join (pset-fold x (lambda (e a) (cons (jolt-pr-str e) a)) '())) "}"))
((pmap? x) (string-append "{" (jolt-str-join
(pmap-fold x (lambda (k v a) (cons (string-append (jolt-pr-str k) " " (jolt-pr-str v)) a)) '())) "}"))
;; lists / cons / lazy seqs all print as (...) — forces a finite seq.
((empty-list-t? x) "()")
((cseq? x) (string-append "(" (jolt-str-join
(let loop ((s x) (acc '()))
(if (jolt-nil? s) (reverse acc)
(loop (jolt-seq (seq-more s)) (cons (jolt-pr-str (seq-first s)) acc))))) ")"))
((pvec? x) (if (jolt-print-hash?) "#"
(with-deeper-print
(string-append "[" (jolt-str-join (jolt-limited-vec-strs x jolt-pr-str)) "]"))))
((pset? x) (if (jolt-print-hash?) "#"
(with-deeper-print
(string-append "#{" (jolt-str-join (jolt-limited-list-strs
(pset-fold x (lambda (e a) (cons (jolt-pr-str e) a)) '()))) "}"))))
((pmap? x) (if (jolt-print-hash?) "#"
(with-deeper-print
(string-append "{" (jolt-str-join (jolt-limited-list-strs
(pmap-fold x (lambda (k v a) (cons (string-append (jolt-pr-str k) " " (jolt-pr-str v)) a)) '()))) "}"))))
;; lists / cons / lazy seqs all print as (...) — forces a finite seq (or up to
;; *print-length* of an infinite one).
((empty-list-t? x) (if (jolt-print-hash?) "#" "()"))
((cseq? x) (if (jolt-print-hash?) "#"
(with-deeper-print
(string-append "(" (jolt-str-join (jolt-limited-seq-strs x jolt-pr-str)) ")"))))
(else (format "~a" x))))
(define (jolt-pr-str x)
(let loop ((as jolt-pr-str-arms))
@ -253,13 +473,18 @@
;; jolt-pr-str (above), and the var-cell machinery — so loaded last.
(load "host/chez/multimethods.ss")
;; the single JVM class/interface graph — value-host-tags, instance?, isa?/supers,
;; and the exception hierarchy all derive from it. Before records.ss so
;; value-host-tags can build on jch-tags.
(load "host/chez/java/class-hierarchy.ss")
;; records + protocols: defrecord/deftype/defprotocol/
;; extend-type/reify. A jrec record type set!-extended into the collection
;; dispatchers + a protocol registry. After multimethods.ss (chez-current-ns) and
;; the dispatchers/printers it wraps (collections/seq/values/converters/printing/
;; transients).
(load "host/chez/records.ss")
(load "host/chez/records-interop.ss") ; exception hierarchy + instance-check taxonomy
(load "host/chez/java/records-interop.ss") ; exception hierarchy + instance-check taxonomy
;; metadata: meta / with-meta over an identity-keyed
;; side-table. After records.ss (jrec) + the collection ctors it copies.
@ -268,7 +493,7 @@
;; host class tokens: bare class names (String/Keyword/File...) ->
;; canonical JVM class-name strings + (class x). After natives-meta.ss (jolt-type)
;; and the printer (jolt-str-render-one).
(load "host/chez/host-class.ss")
(load "host/chez/java/host-class.ss")
;; dynamic vars: *clojure-version* / *unchecked-math* constants the host
;; binds natively. After collections.ss (jolt-hash-map) + def-var!.
@ -324,32 +549,39 @@
;; portable String/CharSequence surface record-method-dispatch falls through to on
;; a string target. After regex.ss (jolt-re-pattern/regex-t-irx) + records.ss
;; (which references jolt-string-method).
(load "host/chez/natives-str.ss")
(load "host/chez/java/natives-str.ss")
;; host class statics + constructors: host-static-ref/
;; host-static-call/host-new + the jhost method registry. Loads LAST — it extends
;; record-method-dispatch (records.ss) and reuses natives-str helpers (str-trim,
;; ascii-string-down, re-split, str-split-drop-trailing) + the regex-t accessors.
(load "host/chez/host-static.ss") ; registries + jhost + coercion helpers
(load "host/chez/host-static-methods.ss") ; Class/member static methods + fields
(load "host/chez/host-static-classes.ss") ; instantiable host object classes
(load "host/chez/java/host-static.ss") ; registries + jhost + coercion helpers
(load "host/chez/java/host-static-methods.ss") ; Class/member static methods + fields
(load "host/chez/java/host-static-classes.ss") ; instantiable host object classes
(load "host/chez/java/byte-buffer.ss") ; java.nio.ByteBuffer over a byte-array
;; generic dot-form dispatch: field access + map/vector member access
;; for the `.` / `.-field` desugar. Loads after host-static.ss so it wraps every
;; record-method-dispatch arm (jhost/number/regex/jrec/string) and falls through.
(load "host/chez/dot-forms.ss")
(load "host/chez/java/dot-forms.ss")
;; java.io.File + host file I/O: path-backed jfile record, slurp/spit/
;; flush, file-seq dir primitives, clojure.java.io/file. Loads LAST so its jfile
;; arm wraps the fully-built record-method-dispatch and the str/type/instance-check
;; extensions sit over every prior shim.
(load "host/chez/io.ss")
(load "host/chez/java/io.ss")
;; #inst values + java.time formatting: jinst (RFC3339 ms) +
;; DateTimeFormatter/Instant/ZoneId/LocalDateTime/FormatStyle/Locale/Date. Loads
;; LAST — it extends record-method-dispatch / jolt-get / jolt= / jolt-hash /
;; jolt-pr-str / jolt-type / instance-check and uses host-static.ss's registries.
(load "host/chez/inst-time.ss")
(load "host/chez/java/inst-time.ss")
;; java.time value types: LocalDate / LocalTime / LocalDateTime / Instant as
;; tz-free jhost values (epoch-day / nano-of-day / epoch-ms). Loads after
;; inst-time.ss — it reuses its civil<->days helpers, the jhost registries, and
;; re-registers a few LocalDateTime/Instant statics to use the richer reps.
(load "host/chez/java/java-time.ss")
;; Chez-side data reader: read-string / __parse-next /
;; __read-tagged. Loads after inst-time.ss — __read-tagged reuses its #uuid/#inst
@ -358,7 +590,7 @@
;; clojure.math: native flonum-math shims def-var!'d into the
;; clojure.math ns. Self-contained (only def-var! + Chez math), order-independent.
(load "host/chez/math.ss")
(load "host/chez/java/math.ss")
;; reader/macro runtime support: #?() feature set, reader-conditional + re-matcher
;; tagged-map ctors, macroexpand. After ns.ss; macroexpand call-time-refs the macro
@ -368,12 +600,17 @@
;; Java-style arrays: object/typed array constructors + a jolt-array
;; backing; extends count/nth/seq/get/ref-put! so the overlay aget/aset/alength see
;; it. After the dispatchers it chains.
(load "host/chez/natives-array.ss")
(load "host/chez/java/natives-array.ss")
;; java.io byte/char streams (FileInputStream/…/ByteArrayOutputStream/Buffered*)
;; over Chez ports. After io.ss (extends its slurp/__close/reader-jhost?) and
;; natives-array.ss (the byte-array <-> bytevector bridge).
(load "host/chez/java/io-streams.ss")
;; clojure.lang.PersistentQueue: a functional queue + EMPTY static.
;; Chains seq/count/empty?/peek/pop/conj/sequential?/class/instance?/printer, so
;; load after natives-array (the dispatchers it extends).
(load "host/chez/natives-queue.ss")
(load "host/chez/java/natives-queue.ss")
;; syntax-quote form builders: __sqcat/__sqvec/__sqmap/__sqset/
;; __sq1, def-var!'d into clojure.core. A cross-compiled macro expander (analyzer
@ -385,14 +622,18 @@
;; (JVM) semantics. Loaded LAST — chains the fully-built jolt-deref and conveys the
;; thread-local binding stack (dyn-binding.ss) into workers. pmap/pcalls/pvalues
;; (overlay, over `future`) light up once future-call exists here.
(load "host/chez/concurrency.ss")
(load "host/chez/java/concurrency.ss")
;; clojure.core.async: real-thread blocking channels + go/go-loop/
;; thread macros, def-var!'d into clojure.core.async. After concurrency.ss (reuses
;; ms->duration) and the collection/seq layer.
(load "host/chez/async.ss")
(load "host/chez/java/async.ss")
;; BigDecimal: the jbigdec value type + bigdec/decimal?/class/equality/
;; printing. Loads LAST so its set!-wraps of jolt-class/jolt=2/the printers sit
;; outermost over every earlier extension.
(load "host/chez/bigdec.ss")
(load "host/chez/java/bigdec.ss")
;; Native stack traces: jv$ns$name -> source registry + continuation frame walk +
;; uncaught-throwable renderer. After the printers/equality it relies on.
(load "host/chez/source-registry.ss")

View file

@ -11,7 +11,7 @@
;; reset between cases so there is no leakage — same isolation a fresh process gives.
;;
;; chez --script host/chez/run-corpus.ss
;; JOLT_CHEZ_ZJ_FLOOR=N override the regression floor (default 2730)
;; JOLT_CHEZ_ZJ_FLOOR=N override the regression floor (default 3390)
;; JOLT_CORPUS_LIMIT=N every-Nth stride (fast iteration; floor drops to 0)
;; JOLT_DUMP_CRASH_LABELS=1 list crash + allowlisted labels
(import (chezscheme))
@ -196,7 +196,7 @@
;; Regression floor: fail on any NEW divergence or if pass drops below the floor.
(define base-floor (let ((s (getenv "JOLT_CHEZ_ZJ_FLOOR")))
(if s (string->number s) 2730)))
(if s (string->number s) 3390)))
(define floor (if limit 0 base-floor))
(when (or (> (length diverged) 0) (< pass floor))
(printf "REGRESSION: pass ~a < floor ~a or ~a new divergence(s)\n"

104
host/chez/run-devirt.ss Normal file
View file

@ -0,0 +1,104 @@
;; run-devirt.ss — protocol-call devirtualization gate (backend_scheme emit).
;;
;; The inference annotates a monomorphic protocol call with :devirt-type/-proto/
;; -method (jolt.passes.types); the back end then resolves the impl by that static
;; tag. This gate pins both halves: the emitted form uses find-protocol-method, and
;; evaluating it returns the same value the ordinary dispatch would — for a record's
;; inline impl, an extend-type impl, and across distinct receiver types.
;;
;; chez --script host/chez/run-devirt.ss
(import (chezscheme))
(load "host/chez/rt.ss")
(set-chez-ns! "clojure.core")
(load "host/chez/seed/prelude.ss")
(load "host/chez/post-prelude.ss")
(set-chez-ns! "user")
(load "host/chez/host-contract.ss")
(load "host/chez/seed/image.ss")
(load "host/chez/compile-eval.ss")
(define analyze (var-deref "jolt.analyzer" "analyze"))
(define emit (var-deref "jolt.backend-scheme" "emit"))
(define kw (lambda (n) (keyword #f n)))
(define (evals src) (jolt-compile-eval (string-append "(do " src ")") "user"))
;; define two record types implementing one protocol — Circle via an inline impl,
;; Square via extend-type — plus instances to dispatch on.
(evals "(defprotocol Shape (area [s]))")
(evals "(defrecord Circle [r] Shape (area [s] (:r s)))")
(evals "(defrecord Square [w])")
(evals "(extend-type Square Shape (area [s] (* (:w s) (:w s))))")
(evals "(def c (->Circle 7))")
(evals "(def sq (->Square 5))")
;; analyze (area RECV), annotate it as a devirt call on `type`, and emit. RECV is a
;; var name (c/sq) the emitted code resolves at eval time.
(define (devirt-emit type recv)
(let* ((ir (analyze (make-analyze-ctx "user") (jolt-ce-read (string-append "(area " recv ")"))))
(dv (jolt-assoc ir (kw "devirt-type") type (kw "devirt-proto") "Shape"
(kw "devirt-method") "area")))
(emit dv)))
(define fails 0) (define total 0)
(define (check label actual expected)
(set! total (+ total 1))
(unless (equal? actual expected)
(set! fails (+ fails 1))
(printf " FAIL ~a: got ~s expected ~s\n" label actual expected)))
(define (has-sub? s sub)
(let ((n (string-length s)) (m (string-length sub)))
(let loop ((i 0)) (cond ((> (+ i m) n) #f)
((string=? (substring s i (+ i m)) sub) #t)
(else (loop (+ i 1)))))))
;; eval an emitted Scheme string in the loaded runtime (var-deref resolves c/sq).
(define (run-emit scm) (eval (read (open-input-string scm)) (interaction-environment)))
(let ((e (devirt-emit "user.Circle" "c")))
(check "emit uses devirt-resolve" (has-sub? e "devirt-resolve") #t)
(check "devirt inline impl == dispatch" (run-emit e) (evals "(area c)"))) ; 7
(let ((e (devirt-emit "user.Square" "sq")))
(check "devirt extend-type impl == dispatch" (run-emit e) (evals "(area sq)"))) ; 25
;; a normal (no devirt) call still goes through dispatch and agrees — the path the
;; megamorphic / unknown-receiver site keeps.
(let ((e (emit (analyze (make-analyze-ctx "user") (jolt-ce-read "(area c)")))))
(check "non-devirt path no devirt-resolve" (has-sub? e "devirt-resolve") #f)
(check "non-devirt still dispatches" (run-emit e) 7))
;; a record that relies on the protocol's Object default (no direct impl): the
;; inference still types it as a concrete record and annotates devirt, so the
;; emitted call must resolve the same value dispatch would. find-protocol-method
;; on the record's own tag misses here, so the devirt path has to fall back to
;; ordinary dispatch (else it applies #f and crashes).
(evals "(extend-protocol Shape Object (area [s] :obj-default))")
(evals "(defrecord Plain [n])")
(evals "(def pl (->Plain 9))")
(let ((e (devirt-emit "user.Plain" "pl")))
(check "devirt Object-default == dispatch" (run-emit e) (evals "(area pl)"))) ; :obj-default
;; in a direct-link build a devirt site caches the resolved impl in a per-site cell
;; (resolved once, reused) instead of resolving per call. Annotate the (area x) in a
;; def body and emit the top form; the result must carry the cell and still be right.
(let* ((set-direct-link! (var-deref "jolt.backend-scheme" "set-direct-link!"))
(emit-top-form (var-deref "jolt.backend-scheme" "emit-top-form"))
(dn (analyze (make-analyze-ctx "user") (jolt-ce-read "(def usearea (fn [x] (area x)))")))
(ar0 (jolt-nth (jolt-get (jolt-get dn (kw "init")) (kw "arities")) 0))
(inv (jolt-get ar0 (kw "body")))
(inv2 (jolt-assoc inv (kw "devirt-type") "user.Circle" (kw "devirt-proto") "Shape" (kw "devirt-method") "area"))
(dn2 (jolt-assoc dn (kw "init")
(jolt-assoc (jolt-get dn (kw "init")) (kw "arities")
(jolt-vector (jolt-assoc ar0 (kw "body") inv2))))))
(set-direct-link! #t)
(let ((e (emit-top-form dn2)))
(set-direct-link! #f)
(check "devirt in a def caches in a per-site cell" (has-sub? e "_dvc$") #t)
(check "cached cell still resolves the impl" (has-sub? e "devirt-resolve") #t)
;; eval the def, then call it: caches on first call, reuses after — still 7.
(run-emit e)
(check "cached devirt == dispatch (1st call)" (jolt-invoke (var-deref "user" "usearea") (var-deref "user" "c")) 7)
(check "cached devirt == dispatch (2nd call, from cell)" (jolt-invoke (var-deref "user" "usearea") (var-deref "user" "c")) 7)))
(if (= fails 0)
(begin (printf "devirt gate: ~a/~a passed\n" total total) (exit 0))
(begin (printf "devirt gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))

82
host/chez/run-fieldnum.ss Normal file
View file

@ -0,0 +1,82 @@
;; run-fieldnum.ss — ^double record field reads unbox to fl-ops (jolt-evr9 R2).
;;
;; A record field tagged ^double reads back as a flonum (:double in the lattice),
;; so hintless arithmetic over those fields — (* (:x a) (:x b)) — lowers to fl-ops,
;; the same machinery as a ^double param. Two halves pinned here: (1) the ctor
;; coerces a ^double field to a flonum at construction (JVM parity, and what makes
;; the fl-op sound), and (2) field-field arithmetic over a record param (typed by
;; the whole-program fixpoint) emits fl*.
;;
;; chez --script host/chez/run-fieldnum.ss
(import (chezscheme))
(load "host/chez/rt.ss")
(set-chez-ns! "clojure.core")
(load "host/chez/seed/prelude.ss")
(load "host/chez/post-prelude.ss")
(set-chez-ns! "user")
(load "host/chez/host-contract.ss")
(load "host/chez/seed/image.ss")
(load "host/chez/compile-eval.ss")
(define analyze (var-deref "jolt.analyzer" "analyze"))
(define set-record-shapes! (var-deref "jolt.passes.types" "set-record-shapes!"))
(define set-protocol-methods! (var-deref "jolt.passes.types" "set-protocol-methods!"))
(define wp-infer! (var-deref "jolt.passes.types" "wp-infer!"))
(define run-passes (var-deref "jolt.passes" "run-passes"))
(define emit (var-deref "jolt.backend-scheme" "emit"))
(define (anode src) (analyze (make-analyze-ctx "user") (jolt-ce-read src)))
(define (evals src) (jolt-compile-eval (string-append "(do " src ")") "user"))
(define (contains-sub? s sub)
(let ((n (string-length s)) (m (string-length sub)))
(let loop ((i 0))
(cond ((> (+ i m) n) #f)
((string=? (substring s i (+ i m)) sub) #t)
(else (loop (+ i 1)))))))
(define fails 0) (define total 0)
(define (check label actual expected)
(set! total (+ total 1))
(unless (equal? actual expected)
(set! fails (+ fails 1))
(printf " FAIL ~a: got ~s expected ~s\n" label actual expected)))
;; a record with ^double fields; the ctor must coerce an integer arg to a flonum.
(evals "(defrecord V [^double x ^double y])")
(check "ctor coerces ^double field to flonum" (flonum? (evals "(:x (->V 1 2))")) #t)
(check "coerced field value matches" (evals "(:x (->V 1 2))") 1.0)
(check "a flonum arg passes through" (evals "(:y (->V 1.5 2.5))") 2.5)
;; dot is hintless; its caller passes V instances, so the fixpoint types a/b as V
;; records, the ^double fields read :double, and the field-field arithmetic unboxes.
(define dot (anode "(def dot (fn [a b] (+ (* (:x a) (:x b)) (* (:y a) (:y b)))))"))
(define used (anode "(def used (fn [] (dot (->V 1.0 2.0) (->V 3.0 4.0))))"))
(set-record-shapes! (chez-record-shapes-map))
(set-protocol-methods! (jolt-hash-map))
(wp-infer! (jolt-vector dot used))
(set-optimize! #t)
(define dot-emit (emit (run-passes dot (make-analyze-ctx "user"))))
(check "field-field arithmetic unboxes to fl*" (contains-sub? dot-emit "fl*") #t)
(check "field-field arithmetic unboxes to fl+" (contains-sub? dot-emit "fl+") #t)
;; a ^V param hint types the param with no inferable caller (open-world / cross-fn:
;; the receiver isn't a ctor return). This is the record-ctor-key path — without it
;; the hint is dead and the reads fall back to generic jolt-get + boxed arithmetic.
(define hinted (anode "(def hyp (fn [^V v] (+ (* (:x v) (:x v)) (* (:y v) (:y v)))))"))
(define hint-emit (emit (run-passes hinted (make-analyze-ctx "user"))))
(check "^V param hint bare-indexes field reads" (contains-sub? hint-emit "jrec-field-at") #t)
(check "^V param hint unboxes arithmetic" (contains-sub? hint-emit "fl*") #t)
(check "^V param hint leaves no generic jolt-get" (contains-sub? hint-emit "jolt-get") #f)
;; an UNTAGGED field stays generic — no fl-op (the read is :any, not :double).
(evals "(defrecord W [p q])")
(define dotw (anode "(def dotw (fn [a b] (* (:p a) (:p b))))"))
(define usew (anode "(def usew (fn [] (dotw (->W 1.0 2.0) (->W 3.0 4.0))))"))
(set-record-shapes! (chez-record-shapes-map))
(wp-infer! (jolt-vector dotw usew))
(check "untagged field stays generic (no fl*)"
(contains-sub? (emit (run-passes dotw (make-analyze-ctx "user"))) "fl*") #f)
(if (= fails 0)
(begin (printf "fieldnum gate: ~a/~a passed\n" total total) (exit 0))
(begin (printf "fieldnum gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))

View file

@ -0,0 +1,72 @@
;; run-fieldread.ss — native record field-read gate (backend_scheme emit).
;;
;; When the inference types a keyword-lookup receiver as a record (it carries the
;; field-order :shape + :hint :struct), the back end reads the field by its static
;; slot via jrec-field-at instead of jolt-get. This gate pins the emit shape and
;; that the value matches jolt-get — for a declared field, a non-field key (no
;; bare path), and a default-arg form (no bare path).
;;
;; chez --script host/chez/run-fieldread.ss
(import (chezscheme))
(load "host/chez/rt.ss")
(set-chez-ns! "clojure.core")
(load "host/chez/seed/prelude.ss")
(load "host/chez/post-prelude.ss")
(set-chez-ns! "user")
(load "host/chez/host-contract.ss")
(load "host/chez/seed/image.ss")
(load "host/chez/compile-eval.ss")
(define analyze (var-deref "jolt.analyzer" "analyze"))
(define emit (var-deref "jolt.backend-scheme" "emit"))
(define kw (lambda (n) (keyword #f n)))
(define (evals src) (jolt-compile-eval (string-append "(do " src ")") "user"))
(evals "(defrecord Vec3 [x y z])")
(evals "(def a (->Vec3 10 20 30))")
;; emit (:KEY a [default]) with arg 0 marked as a Vec3 struct receiver.
(define (mark-emit src)
(let* ((ir (analyze (make-analyze-ctx "user") (jolt-ce-read src)))
(a0 (jolt-nth (jolt-get ir (kw "args")) 0))
(marked (jolt-assoc a0 (kw "hint") (kw "struct")
(kw "shape") (jolt-vector (kw "x") (kw "y") (kw "z"))))
(args (jolt-get ir (kw "args")))
(args2 (jolt-assoc args 0 marked)))
(emit (jolt-assoc ir (kw "args") args2))))
(define (run-emit scm) (eval (read (open-input-string scm)) (interaction-environment)))
(define (has-sub? s sub)
(let ((n (string-length s)) (m (string-length sub)))
(let loop ((i 0)) (cond ((> (+ i m) n) #f)
((string=? (substring s i (+ i m)) sub) #t)
(else (loop (+ i 1)))))))
(define fails 0) (define total 0)
(define (check label actual expected)
(set! total (+ total 1))
(unless (equal? actual expected)
(set! fails (+ fails 1))
(printf " FAIL ~a: got ~s expected ~s\n" label actual expected)))
;; a declared field -> bare-index path, value matches jolt-get
(let ((e (mark-emit "(:y a)")))
(check "declared field uses jrec-field-at" (has-sub? e "jrec-field-at") #t)
(check "field 1 -> static slot 1" (has-sub? e " 1 ") #t)
(check "bare read == jolt-get" (run-emit e) (evals "(:y a)"))) ; 20
;; first/last fields too
(check "field x == jolt-get" (run-emit (mark-emit "(:x a)")) (evals "(:x a)")) ; 10
(check "field z == jolt-get" (run-emit (mark-emit "(:z a)")) (evals "(:z a)")) ; 30
;; a key that is NOT a declared field -> no bare path, still correct (nil)
(let ((e (mark-emit "(:w a)")))
(check "non-field key no jrec-field-at" (has-sub? e "jrec-field-at") #f)
(check "non-field key == jolt-get" (run-emit e) (evals "(:w a)"))) ; nil
;; a default-arg form keeps jolt-get (the bare path is no-default only)
(let ((e (mark-emit "(:y a 99)")))
(check "default-arg keeps jolt-get" (has-sub? e "jrec-field-at") #f))
(if (= fails 0)
(begin (printf "fieldread gate: ~a/~a passed\n" total total) (exit 0))
(begin (printf "fieldread gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))

76
host/chez/run-narrow.ss Normal file
View file

@ -0,0 +1,76 @@
;; run-narrow.ss — nilable record types + flow-sensitive some?/nil? narrowing.
;;
;; A protocol method (or `if`) returning a record-or-nil types as a NILABLE record:
;; some?/nil? do NOT fold on it (it might be nil), so a runtime guard stays. Inside
;; (if (some? x) ..) / (if x ..) the then-branch narrows x to the non-nil record, so
;; its field reads bare-index and unbox. This is the ray tracer's
;; (let [scattered (scatter ..)] (if (some? scattered) (.. (:ray scattered) ..))).
;;
;; The load-bearing soundness check: the nil case must still take the else branch —
;; narrowing must NOT fold the guard away (else a real nil reaches the bare read).
;;
;; chez --script host/chez/run-narrow.ss
(import (chezscheme))
(load "host/chez/rt.ss")
(set-chez-ns! "clojure.core")
(load "host/chez/seed/prelude.ss")
(load "host/chez/post-prelude.ss")
(set-chez-ns! "user")
(load "host/chez/host-contract.ss")
(load "host/chez/seed/image.ss")
(load "host/chez/compile-eval.ss")
(define analyze (var-deref "jolt.analyzer" "analyze"))
(define set-record-shapes! (var-deref "jolt.passes.types" "set-record-shapes!"))
(define set-protocol-methods! (var-deref "jolt.passes.types" "set-protocol-methods!"))
(define wp-infer! (var-deref "jolt.passes.types" "wp-infer!"))
(define run-passes (var-deref "jolt.passes" "run-passes"))
(define emit (var-deref "jolt.backend-scheme" "emit"))
(define (anode src) (analyze (make-analyze-ctx "user") (jolt-ce-read src)))
(define (evals src) (jolt-compile-eval (string-append "(do " src ")") "user"))
(define (built scm) (eval (read (open-input-string scm)) (interaction-environment)))
(define (sub? s t)(let((n(string-length s))(m(string-length t)))(let loop((i 0))(cond((>(+ i m)n)#f)((string=?(substring s i(+ i m))t)#t)(else(loop(+ i 1)))))))
(define fails 0) (define total 0)
(define (check label actual expected)
(set! total (+ total 1))
(unless (equal? actual expected)
(set! fails (+ fails 1))
(printf " FAIL ~a: got ~s expected ~s\n" label actual expected)))
(evals "(defrecord R [^double k])")
(evals "(defprotocol P (m [x]))")
(evals "(defrecord A [v] P (m [x] (->R 1.0)))")
(evals "(defrecord B [v] P (m [x] (if (< (:v x) 0) (->R 2.0) nil)))") ; B.m returns R-or-nil
(set-record-shapes! (chez-record-shapes-map))
(set-protocol-methods! (chez-protocol-methods-map))
(set-optimize! #t)
(define na (anode "(defrecord A [v] P (m [x] (->R 1.0)))"))
(define nb (anode "(defrecord B [v] P (m [x] (if (< (:v x) 0) (->R 2.0) nil)))"))
;; guarded read: inside (some? s), s narrows to non-nil R -> (:k s) bare-indexes + unboxes
(define f (anode "(def f (fn [a] (let [s (m a)] (if (some? s) (* (:k s) 2.0) 0.0))))"))
(wp-infer! (jolt-vector na nb f))
(define fe (emit (run-passes f (make-analyze-ctx "user"))))
(check "guarded nullable read bare-indexes" (sub? fe "jrec-field-at") #t)
(check "guarded nullable read unboxes to fl*" (sub? fe "fl*") #t)
;; CORRECTNESS + the load-bearing soundness check: the nil case must take the else
;; branch (the guard is preserved), not run the bare read on nil.
(built fe)
(define ff (var-deref "user" "f"))
(check "non-nil (A.m -> R 1.0)" (jolt-invoke ff (evals "(->A 5)")) 2.0)
(check "non-nil (B.m v<0 -> R 2.0)" (jolt-invoke ff (evals "(->B -5)")) 4.0)
(check "nil case takes else (guard preserved, no crash)"
(jolt-invoke ff (evals "(->B 5)")) 0.0)
;; an UNGUARDED nullable read must stay safe: jrec-field-at falls back to jolt-get on
;; nil. (Its result type is conservative — no unbox — so this just checks no crash.)
(define g (anode "(def g (fn [a] (let [s (m a)] (:k s))))"))
(define ge (emit (run-passes g (make-analyze-ctx "user"))))
(built ge)
(define gg (var-deref "user" "g"))
(check "unguarded nullable read on nil returns nil" (jolt-nil? (jolt-invoke gg (evals "(->B 5)"))) #t)
(check "unguarded nullable read on non-nil returns the field" (jolt-invoke gg (evals "(->A 5)")) 1.0)
(if (= fails 0)
(begin (printf "narrow gate: ~a/~a passed\n" total total) (exit 0))
(begin (printf "narrow gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))

108
host/chez/run-numwp.ss Normal file
View file

@ -0,0 +1,108 @@
;; run-numwp.ss — hintless whole-program :double inference gate (jolt-evr9 R3).
;;
;; run-wp.ss drives the structural (record) fixpoint; this drives its numeric
;; refinement: a hintless fn whose every call site passes a flonum has its param
;; typed :double, which the back end then unboxes to fl-ops — no ^double hint. The
;; bridge is a synthetic [param :double] nhint (jolt.passes/inject-wp-nhints) that
;; the existing hint-directed pass + entry coercion consume unchanged.
;;
;; Soundness pinned here: :double only (never :long — an untyped integer can be a
;; bignum), so a caller passing an integer leaves the param generic; an escaped fn
;; keeps :any.
;;
;; chez --script host/chez/run-numwp.ss
(import (chezscheme))
(load "host/chez/rt.ss")
(set-chez-ns! "clojure.core")
(load "host/chez/seed/prelude.ss")
(load "host/chez/post-prelude.ss")
(set-chez-ns! "user")
(load "host/chez/host-contract.ss")
(load "host/chez/seed/image.ss")
(load "host/chez/compile-eval.ss")
(define analyze (var-deref "jolt.analyzer" "analyze"))
(define set-record-shapes! (var-deref "jolt.passes.types" "set-record-shapes!"))
(define set-protocol-methods! (var-deref "jolt.passes.types" "set-protocol-methods!"))
(define wp-infer! (var-deref "jolt.passes.types" "wp-infer!"))
(define param-num-seeds-for (var-deref "jolt.passes.types" "param-num-seeds-for"))
(define inject-wp-nhints (var-deref "jolt.passes" "inject-wp-nhints"))
(define annotate (var-deref "jolt.passes.numeric" "annotate"))
(define run-passes (var-deref "jolt.passes" "run-passes"))
(define emit (var-deref "jolt.backend-scheme" "emit"))
(define pr-str (var-deref "clojure.core" "pr-str"))
(define (anode src) (analyze (make-analyze-ctx "user") (jolt-ce-read src)))
(define (contains-sub? s sub)
(let ((n (string-length s)) (m (string-length sub)))
(let loop ((i 0))
(cond ((> (+ i m) n) #f)
((string=? (substring s i (+ i m)) sub) #t)
(else (loop (+ i 1)))))))
(define fails 0) (define total 0)
(define (check label actual expected)
(set! total (+ total 1))
(unless (equal? actual expected)
(set! fails (+ fails 1))
(printf " FAIL ~a: got ~s expected ~s\n" label actual expected)))
(set-record-shapes! (jolt-hash-map))
(set-protocol-methods! (jolt-hash-map))
;; sq is hintless; its only caller passes a flonum literal, so the fixpoint must
;; type x :double across the fn boundary.
(define sq (anode "(def sq (fn [x] (* x x)))"))
(define usef (anode "(def usef (fn [] (sq 2.0)))"))
(wp-infer! (jolt-vector sq usef))
(define nseed (param-num-seeds-for "user/sq"))
(check "sq has a numeric param seed" (jolt-truthy? nseed) #t)
(when (jolt-truthy? nseed)
(check "x seeded :double" (contains-sub? (pr-str nseed) ":double") #t))
;; the bridge: inject the derived nhint, run the numeric pass, emit -> fl*.
(define sq-opt (annotate (inject-wp-nhints sq)))
(check "sq body unboxes to fl*" (contains-sub? (emit sq-opt) "fl*") #t)
;; and the param is coerced at entry like a ^double param (no-op on a real flonum).
(check "sq coerces param at entry" (contains-sub? (emit sq-opt) "exact->inexact") #t)
;; a caller passing an INTEGER must NOT make the param :double — an untyped integer
;; can be a bignum, so fl-ops would diverge. The param stays generic.
(define sqi (anode "(def sqi (fn [x] (* x x)))"))
(define usei (anode "(def usei (fn [] (sqi 2)))"))
(wp-infer! (jolt-vector sqi usei))
(check "integer caller leaves param generic"
(jolt-truthy? (param-num-seeds-for "user/sqi")) #f)
;; a fn used in value position (escapes) has unknown callers -> no double seed.
(define esc (anode "(def esc (fn [x] (* x x)))"))
(define hof (anode "(def hof (fn [g] (g 2.0)))"))
(define ecl (anode "(def ecaller (fn [] (hof esc)))")) ; esc escapes
(wp-infer! (jolt-vector esc hof ecl))
(check "escaped fn keeps no double seed"
(jolt-truthy? (param-num-seeds-for "user/esc")) #f)
;; :double flows through a returning helper: mag returns a flonum, so a param fed
;; only (mag _) results types :double too (cross-fn return propagation).
(define mag (anode "(def mag (fn [a] (* a 2.0)))"))
(define dist (anode "(def dist (fn [b] (+ b b)))"))
(define dcl (anode "(def dcaller (fn [] (dist (mag 3.0))))"))
(wp-infer! (jolt-vector mag dist dcl))
(check "param fed a flonum-returning call types :double"
(jolt-truthy? (param-num-seeds-for "user/dist")) #t)
;; end to end through the real build pipeline: with optimize on, run-passes wires
;; the WP fixpoint's :double seeds into the numeric pass (inject-wp-nhints) so the
;; emitted def unboxes — proves the production path fires, not just the bridge in
;; isolation.
(set-optimize! #t)
(define sq2 (anode "(def sq2 (fn [x] (* x x)))"))
(define use2 (anode "(def use2 (fn [] (sq2 4.0)))"))
(wp-infer! (jolt-vector sq2 use2))
(check "run-passes unboxes a hintless double fn"
(contains-sub? (emit (run-passes sq2 (make-analyze-ctx "user"))) "fl*") #t)
(if (= fails 0)
(begin (printf "numwp gate: ~a/~a passed\n" total total) (exit 0))
(begin (printf "numwp gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))

70
host/chez/run-protoret.ss Normal file
View file

@ -0,0 +1,70 @@
;; run-protoret.ss — protocol-method return-type inference gate.
;;
;; A protocol method whose impls all return the same record type has a monomorphic
;; return: collect-pm-rets! joins the impl return types, and call-ret-type then types
;; a (method recv ..) call as that record — so a field read off the result bare-
;; indexes. This is the ray tracer's (:ray (scatter material ..)): scatter's impls
;; all return a ScatterResult, so the bounced ray types without a hint.
;;
;; chez --script host/chez/run-protoret.ss
(import (chezscheme))
(load "host/chez/rt.ss")
(set-chez-ns! "clojure.core")
(load "host/chez/seed/prelude.ss")
(load "host/chez/post-prelude.ss")
(set-chez-ns! "user")
(load "host/chez/host-contract.ss")
(load "host/chez/seed/image.ss")
(load "host/chez/compile-eval.ss")
(define analyze (var-deref "jolt.analyzer" "analyze"))
(define set-record-shapes! (var-deref "jolt.passes.types" "set-record-shapes!"))
(define set-protocol-methods! (var-deref "jolt.passes.types" "set-protocol-methods!"))
(define wp-infer! (var-deref "jolt.passes.types" "wp-infer!"))
(define run-passes (var-deref "jolt.passes" "run-passes"))
(define emit (var-deref "jolt.backend-scheme" "emit"))
(define (anode src) (analyze (make-analyze-ctx "user") (jolt-ce-read src)))
(define (evals src) (jolt-compile-eval (string-append "(do " src ")") "user"))
(define (sub? s t)(let((n(string-length s))(m(string-length t)))(let loop((i 0))(cond((>(+ i m)n)#f)((string=?(substring s i(+ i m))t)#t)(else(loop(+ i 1)))))))
(define fails 0) (define total 0)
(define (check label actual expected)
(set! total (+ total 1))
(unless (equal? actual expected)
(set! fails (+ fails 1))
(printf " FAIL ~a: got ~s expected ~s\n" label actual expected)))
(evals "(defrecord R [^double k])")
(evals "(defprotocol P (m [x]))")
(evals "(defrecord A [v] P (m [x] (->R 1.0)))")
(evals "(defrecord B [v] P (m [x] (->R 2.0)))")
(evals "(defprotocol Q (q [x]))")
(evals "(defrecord C [v] Q (q [x] (->R 3.0)))")
(evals "(defrecord D [v] Q (q [x] 7)))") ; one impl returns a number, not R
(set-record-shapes! (chez-record-shapes-map))
(set-protocol-methods! (chez-protocol-methods-map))
(set-optimize! #t)
;; analyze the impl-registering forms + a consumer; the fixpoint collects the
;; impl return types. (the analyzed defrecord nodes carry register-inline-method.)
(define na (anode "(defrecord A [v] P (m [x] (->R 1.0)))"))
(define nb (anode "(defrecord B [v] P (m [x] (->R 2.0)))"))
(define nc (anode "(defrecord C [v] Q (q [x] (->R 3.0)))"))
(define nd (anode "(defrecord D [v] Q (q [x] 7))"))
(define f (anode "(def f (fn [a] (* (:k (m a)) 2.0)))"))
(define g (anode "(def g (fn [a] (:k (q a))))"))
(wp-infer! (jolt-vector na nb nc nd f g))
;; m's impls all return R -> (:k (m a)) reads off an R -> bare-index + unbox.
(define fe (emit (run-passes f (make-analyze-ctx "user"))))
(check "monomorphic protocol return bare-indexes the field read" (sub? fe "jrec-field-at") #t)
(check "monomorphic protocol return unboxes the ^double field" (sub? fe "fl") #t)
;; q's impls return R and a number -> joined to non-record -> stays generic (sound).
(define ge (emit (run-passes g (make-analyze-ctx "user"))))
(check "mixed-return protocol keeps generic jolt-get" (sub? ge "jolt-get") #t)
(check "mixed-return protocol does not bare-index" (sub? ge "jrec-field-at") #f)
(if (= fails 0)
(begin (printf "protoret gate: ~a/~a passed\n" total total) (exit 0))
(begin (printf "protoret gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))

View file

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

108
host/chez/run-wp.ss Normal file
View file

@ -0,0 +1,108 @@
;; run-wp.ss — whole-program param-type fixpoint gate (jolt.passes.types/wp-infer!).
;;
;; run-infer.ss drives the per-form inference; this drives the inter-procedural
;; driver: analyze a multi-def unit, run wp-infer!, and assert that a record type
;; flows across fn boundaries — a callee's param picks up its caller's ctor return
;; type, so a field read off it is marked for the bare-index back-end path.
;;
;; chez --script host/chez/run-wp.ss
(import (chezscheme))
(load "host/chez/rt.ss")
(set-chez-ns! "clojure.core")
(load "host/chez/seed/prelude.ss")
(load "host/chez/post-prelude.ss")
(set-chez-ns! "user")
(load "host/chez/host-contract.ss")
(load "host/chez/seed/image.ss")
(load "host/chez/compile-eval.ss")
(define analyze (var-deref "jolt.analyzer" "analyze"))
(define run-inference (var-deref "jolt.passes.types" "run-inference"))
(define set-record-shapes! (var-deref "jolt.passes.types" "set-record-shapes!"))
(define set-protocol-methods! (var-deref "jolt.passes.types" "set-protocol-methods!"))
(define wp-infer! (var-deref "jolt.passes.types" "wp-infer!"))
(define param-seeds-for (var-deref "jolt.passes.types" "param-seeds-for"))
(define reinfer-def (var-deref "jolt.passes.types" "reinfer-def"))
(define pr-str (var-deref "clojure.core" "pr-str"))
(define (anode src) (analyze (make-analyze-ctx "user") (jolt-ce-read src)))
(define (contains-sub? s sub)
(let ((n (string-length s)) (m (string-length sub)))
(let loop ((i 0))
(cond ((> (+ i m) n) #f)
((string=? (substring s i (+ i m)) sub) #t)
(else (loop (+ i 1)))))))
(define fails 0) (define total 0)
(define (check label actual expected)
(set! total (+ total 1))
(unless (equal? actual expected)
(set! fails (+ fails 1))
(printf " FAIL ~a: got ~s expected ~s\n" label actual expected)))
;; Node record shape (left/right untagged), like binary-trees.
(set-record-shapes!
(jolt-hash-map "user/->Node"
(jolt-hash-map (keyword #f "fields") (jolt-vector (keyword #f "left") (keyword #f "right"))
(keyword #f "tags") (jolt-vector jolt-nil jolt-nil)
(keyword #f "type") "user.Node")))
(set-protocol-methods! (jolt-hash-map))
;; a 3-def unit: make-tree returns ->Node, run calls check-tree with a make-tree
;; result, so check-tree's `node` param must be inferred as a Node.
(define mt (anode "(def make-tree (fn [depth] (if (zero? depth) (->Node nil nil) (->Node (make-tree (dec depth)) (make-tree (dec depth))))))"))
(define ct (anode "(def check-tree (fn [node] (:left node)))"))
(define rn (anode "(def run (fn [d] (check-tree (make-tree d))))"))
(wp-infer! (jolt-vector mt ct rn))
;; check-tree's param `node` should be seeded with a struct carrying the Node type
(define seed (param-seeds-for "user/check-tree"))
(check "check-tree has a param seed" (jolt-truthy? seed) #t)
(when (jolt-truthy? seed)
(check "node seeded as user.Node struct"
(contains-sub? (pr-str seed) "user.Node") #t))
;; reinfer-def then must mark the (:left node) read site for the bare-index path
(define marked (reinfer-def ct seed))
(check "read site marked :hint :struct" (contains-sub? (pr-str marked) ":hint :struct") #t)
;; a fn used only via value position (escape) must NOT be specialized — unknown
;; callers make a concrete seed unsound.
(define ev (anode "(def use-it (fn [f] (f 1)))"))
(define ec (anode "(def caller (fn [] (use-it check-tree)))")) ; check-tree escapes
(wp-infer! (jolt-vector mt ct rn ev ec))
(check "escaped fn keeps no param seed" (jolt-truthy? (param-seeds-for "user/check-tree")) #f)
;; a self-recursive fn that recurses on a NILABLE field (an untagged record field
;; is :any, so the child can be nil) must NOT be specialized — the recursion can
;; pass nil, so typing the param as a non-nil record would be unsound.
(define ctr (anode "(def walk (fn [node] (let [l (:left node)] (if (nil? l) 1 (walk l)))))"))
(define rnr (anode "(def run2 (fn [d] (walk (make-tree d))))"))
(wp-infer! (jolt-vector mt ctr rnr))
(check "self-recursive nilable param not specialized"
(jolt-truthy? (param-seeds-for "user/walk")) #f)
;; a self-recursive fn that recurses passing the SAME record type (make-tree always
;; returns a Node) is still safe to specialize — the recursion preserves the type.
(define mtt (anode "(def grow (fn [n acc] (if (zero? n) acc (grow (dec n) (->Node acc acc)))))"))
(define gcl (anode "(def gcaller (fn [] (grow 5 (->Node nil nil))))"))
(wp-infer! (jolt-vector mtt gcl))
(check "self-recursive same-type param keeps its seed"
(jolt-truthy? (param-seeds-for "user/grow")) #t)
;; a recursive fn that threads a param STRAIGHT THROUGH its recursion (same arg at
;; the same position) must keep that param's type — a pass-through self-call adds no
;; information and must not poison the param to :any. This is the ray tracer's
;; hittables, passed unchanged through ray-cast's recursion while its reduce element
;; reads the records' fields.
(define cwalk (anode "(def cwalk (fn [hs] (reduce (fn [acc h] (:left h)) nil hs)))"))
(define crec (anode "(def crec (fn [hs d] (if (< d 0) nil (do (cwalk hs) (crec hs (- d 1))))))"))
(define cdrv (anode "(def cdrive (fn [] (crec [(->Node nil nil) (->Node nil nil)] 5)))"))
(wp-infer! (jolt-vector cwalk crec cdrv))
(check "recursion pass-through param keeps its vec element type"
(contains-sub? (pr-str (param-seeds-for "user/crec")) "user.Node") #t)
(if (= fails 0)
(begin (printf "wp gate: ~a/~a passed\n" total total) (exit 0))
(begin (printf "wp gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

View file

@ -31,11 +31,29 @@
;; cvec is #f for every other seq; stored as two fields (not a cons) so a vector
;; seq cell costs no extra allocation. The rest of the seq layer ignores them, so
;; first/rest/count/printing are unchanged.
(define-record-type cseq (fields head (mutable tail) (mutable forced?) list? cvec ci) (nongenerative chez-cseq-v3))
(define (cseq-realized head tail) (make-cseq head tail #t #f #f 0)) ; tail already a seq
(define (cseq-lazy head tail-thunk) (make-cseq head tail-thunk #f #f #f 0))
(define (cseq-list head tail) (make-cseq head tail #t #t #f 0)) ; a PersistentList node
(define (cseq-vec head tail-thunk v i) (make-cseq head tail-thunk #f #f v i)) ; vector-backed
;; crest: the ChunkedCons case — cvec holds a STANDALONE chunk pvec (<=32 already-
;; realized elements), ci the offset within it, and crest the seq AFTER the whole
;; chunk (the clojure.lang.ChunkedCons _more). This is what map/filter/range emit
;; so their result is itself a chunked-seq (chained chunked transforms each batch
;; by 32, like the JVM). crest is #f for a plain vector-backed seq (whose "rest"
;; is the next 32-block of the SAME cvec) and for every non-chunked cell.
(define-record-type cseq (fields head (mutable tail) (mutable forced?) list? cvec ci crest) (nongenerative chez-cseq-v4))
(define (cseq-realized head tail) (make-cseq head tail #t #f #f 0 #f)) ; tail already a seq
(define (cseq-lazy head tail-thunk) (make-cseq head tail-thunk #f #f #f 0 #f))
(define (cseq-list head tail) (make-cseq head tail #t #t #f 0 #f)) ; a PersistentList node
(define (cseq-vec head tail-thunk v i) (make-cseq head tail-thunk #f #f v i #f)) ; vector-backed
;; A ChunkedCons cell over a standalone chunk pvec: head is chunk[i], walking
;; (seq-more) advances within the chunk and then continues into `rest`. `rest` is
;; the already-coerced after-chunk seq (cseq | jolt-nil | a jolt-lazyseq), held in
;; crest for chunk-rest/chunk-next and forced lazily by the tail thunk at the chunk
;; boundary so a chunked map over an infinite chunked source stays productive.
(define (cseq-chunked chunk i rest)
(make-cseq (pvec-nth-d chunk i jolt-nil)
(lambda () (let ((i1 (fx+ i 1)))
(if (fx<? i1 (pvec-count chunk))
(cseq-chunked chunk i1 rest)
(jolt-seq rest))))
#f #f chunk i rest))
(define (seq-first s) (cseq-head s))
(define (seq-more s) ; force the tail; returns a seq (cseq | jolt-nil)
(if (cseq-forced? s) (cseq-tail s)
@ -85,10 +103,25 @@
;; the seq leaf ops the emitter lowers core fns to
;; ============================================================================
(define (jolt-first x) (let ((s (jolt-seq x))) (if (jolt-nil? s) jolt-nil (seq-first s))))
(define (jolt-rest x) ; () when the seq has 0/1 elements (NOT nil)
;; rest = Clojure's more(): the tail as a (possibly empty) seq, NOT nil, and
;; WITHOUT realizing it. A forced cseq (list / realized chain) hands back its tail
;; directly. An UNFORCED tail (vector / string / lazy-seq cell) is returned as a
;; deferred seq so (rest s) does not realize the next node — matching Clojure,
;; where (rest (iterate f x)) does not call f and a side-effecting lazy seq is
;; realized one element at a time. next = (seq (rest s)) still realizes one.
;; jolt-make-lazy-seq (lazy-bridge.ss) resolves at call time.
(define (jolt-rest x)
(let ((s (jolt-seq x)))
(if (jolt-nil? s) jolt-empty-list
(let ((m (seq-more s))) (if (jolt-nil? m) jolt-empty-list m)))))
(cond
((jolt-nil? s) jolt-empty-list)
((cseq-forced? s) (let ((m (cseq-tail s))) (if (jolt-nil? m) jolt-empty-list m)))
;; the lazyseq forces to a seq (cseq | nil); an empty realized lazyseq is
;; still a sequence value, printing "()" (see lazy-bridge.ss), so (rest s)
;; is never nil even when the tail is empty. jolt-seq coerces seq-more's
;; result (which may be jolt-empty-list, e.g. map's tail) back to cseq | nil,
;; the contract force-lazyseq relies on — else (seq (rest s)) of an empty
;; tail yields a truthy empty-list and walkers (distinct, dedupe) overrun.
(else (jolt-make-lazy-seq (lambda () (jolt-seq (seq-more s))))))))
(define (jolt-next x) ; nil when the rest is empty
;; next = (seq (rest x)): the rest must be RE-SEQ'd so an empty tail collapses to
;; nil. seq-more on a lazy seq (e.g. map's) forces to jolt-empty-list, which is
@ -119,34 +152,394 @@
(if (jolt-nil? s) last (loop (jolt-seq (seq-more s)) (seq-first s)))))
;; nth over a seq (walks; forces lazily). default? selects the 3-arg behavior.
(define (seq-nth coll i default? d)
(if (fx<? i 0) (if default? d (error 'nth "index out of bounds"))
(if (fx<? i 0) (if default? d (jolt-throw (jolt-host-throwable "java.lang.IndexOutOfBoundsException" "index out of bounds")))
(let loop ((s (jolt-seq coll)) (i i))
(cond ((jolt-nil? s) (if default? d (error 'nth "index out of bounds")))
(cond ((jolt-nil? s) (if default? d (jolt-throw (jolt-host-throwable "java.lang.IndexOutOfBoundsException" "index out of bounds"))))
((fx=? i 0) (seq-first s))
(else (loop (jolt-seq (seq-more s)) (fx- i 1)))))))
;; --- checked arithmetic: JVM Numbers.ops-style category dispatch -------------
;; Every arithmetic/comparison site (the inlined jolt-n* macros in call position,
;; the variadic shims in value position) funnels a binary op through ONE dispatch:
;; both operands inside Chez's tower take the native op with JVM contagion rules
;; patched in (a double operand wins — Chez's exact-zero shortcut must not leak:
;; (* 1.5 0) is 0.0, not 0; an exact zero divisor throws ArithmeticException, a
;; double zero divisor yields ##Inf/##NaN); an operand OUTSIDE the tower (e.g.
;; BigDecimal) falls to a slow hook the numeric shim extends (java/bigdec.ss).
;; A non-numeric operand is a ClassCastException, like the JVM.
(define (jolt-num-cast-throw x)
(if (jolt-nil? x)
(jolt-throw (jolt-host-throwable "java.lang.NullPointerException" ""))
(jolt-throw (jolt-host-throwable
"java.lang.ClassCastException"
(string-append "class " (jolt-class-name x)
" cannot be cast to class java.lang.Number")))))
(define (jolt-div0-throw)
(jolt-throw (jolt-host-throwable "java.lang.ArithmeticException" "Divide by zero")))
;; slow hooks: one per op, taking over when an operand is outside Chez's tower.
;; A numeric shim (java/bigdec.ss) set!-extends them; the base case is the JVM's:
;; not a number -> ClassCastException. The hooks are BINARY and never re-enter
;; the variadic shims, so extension order can't recurse.
(define (jolt-add-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
(define (jolt-sub-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
(define (jolt-mul-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
(define (jolt-div-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
;; comparison of operands outside the Chez tower: numeric shims extend this to a
;; 3-way compare; anything left over is not a number.
(define (jolt-num-cmp-slow a b)
(jolt-num-cast-throw (if (number? a) b a)))
(define (jolt-add2 a b)
(if (and (number? a) (number? b)) (+ a b) (jolt-add-slow a b)))
(define (jolt-sub2 a b)
(if (and (number? a) (number? b)) (- a b) (jolt-sub-slow a b)))
(define (jolt-mul2 a b)
(if (and (number? a) (number? b))
(if (or (flonum? a) (flonum? b))
(fl* (real->flonum a) (real->flonum b))
(* a b))
(jolt-mul-slow a b)))
(define (jolt-div2 a b)
(if (and (number? a) (number? b))
(if (or (flonum? a) (flonum? b))
(fl/ (real->flonum a) (real->flonum b))
(if (eqv? b 0) (jolt-div0-throw) (/ a b)))
(jolt-div-slow a b)))
(define (jolt-lt2 a b)
(if (and (number? a) (number? b)) (< a b) (< (jolt-num-cmp-slow a b) 0)))
(define (jolt-gt2 a b)
(if (and (number? a) (number? b)) (> a b) (> (jolt-num-cmp-slow a b) 0)))
(define (jolt-le2 a b)
(if (and (number? a) (number? b)) (<= a b) (<= (jolt-num-cmp-slow a b) 0)))
(define (jolt-ge2 a b)
(if (and (number? a) (number? b)) (>= a b) (>= (jolt-num-cmp-slow a b) 0)))
;; min/max return the ORIGINAL operand (type and exactness kept, like
;; Numbers.min): (min 1 2.0) is 1, not 1.0. A NaN operand wins.
(define (jolt-min2 a b)
(cond ((and (flonum? a) (nan? a)) a)
((and (flonum? b) (nan? b)) b)
(else (if (jolt-lt2 a b) a b))))
(define (jolt-max2 a b)
(cond ((and (flonum? a) (nan? a)) a)
((and (flonum? b) (nan? b)) b)
(else (if (jolt-gt2 a b) a b))))
;; quot/rem/mod over the full tower: truncating division; a double operand makes
;; the result a double; mod has floor semantics (result takes the divisor's
;; sign). A zero divisor throws ArithmeticException in both worlds (JVM double
;; quot/rem check the divisor before dividing). Non-tower operands hit the
;; set!-extensible slow hooks.
(define (jolt-quot-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
(define (jolt-rem-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
(define (jolt-mod-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
(define (jolt-quot a b)
(cond ((not (and (number? a) (number? b))) (jolt-quot-slow a b))
((or (flonum? a) (flonum? b))
(let ((n (real->flonum a)) (d (real->flonum b)))
(if (fl= d 0.0) (jolt-div0-throw)
(let ((q (fl/ n d)))
(when (or (nan? q) (infinite? q))
(jolt-throw (jolt-host-throwable "java.lang.NumberFormatException"
"Infinite or NaN")))
(fltruncate q)))))
((eqv? b 0) (jolt-div0-throw))
((and (integer? a) (integer? b)) (quotient a b))
(else (truncate (/ a b)))))
(define (jolt-rem a b)
(cond ((not (and (number? a) (number? b))) (jolt-rem-slow a b))
((or (flonum? a) (flonum? b))
(let ((n (real->flonum a)) (d (real->flonum b)))
(if (fl= d 0.0) (jolt-div0-throw)
(let ((q (fl/ n d)))
(when (or (nan? q) (infinite? q))
(jolt-throw (jolt-host-throwable "java.lang.NumberFormatException"
"Infinite or NaN")))
(fl- n (fl* d (fltruncate q)))))))
((eqv? b 0) (jolt-div0-throw))
((and (integer? a) (integer? b)) (remainder a b))
(else (- a (* b (truncate (/ a b)))))))
(define (jolt-mod a b)
(cond ((not (and (number? a) (number? b))) (jolt-mod-slow a b))
((and (integer? a) (integer? b) (not (flonum? a)) (not (flonum? b)))
(if (eqv? b 0) (jolt-div0-throw) (modulo a b)))
(else
(let ((m (jolt-rem a b)))
(if (or (zero? m) (eq? (negative? m) (negative? b))) m (jolt-add2 m b))))))
;; value-position arithmetic (the higher-order forms: (reduce + []), (apply * xs)).
;; Scheme's +/-/*// already implement the JVM-parity numeric tower: exact+exact ->
;; exact, exact/exact -> Ratio, any flonum -> flonum. Identities (+)=0 / (*)=1 are
;; exact, matching exact integer arithmetic. The hot path uses the inlined native
;; ops, not these.
(define (jolt-add . xs) (apply + xs))
(define (jolt-sub . xs) (apply - xs))
(define (jolt-mul . xs) (apply * xs))
(define (jolt-div . xs) (apply / xs))
;; Folded through the binary dispatch so contagion/edge rules hold; identities
;; (+)=0 / (*)=1 are exact, matching exact integer arithmetic. The hot path uses
;; the inlined native ops, not these.
;; recognizer for slow-path numeric types; numeric shims extend it.
(define (jolt-num-slow? x) #f)
(define (jolt-num-check1 x) ; (+ x)/(* x) return x but still type-check it
(if (or (number? x) (jolt-num-slow? x)) x (jolt-num-cast-throw x)))
(define (jolt-add . xs)
(cond ((null? xs) 0)
((null? (cdr xs)) (jolt-num-check1 (car xs)))
(else (fold-left jolt-add2 (car xs) (cdr xs)))))
(define (jolt-arity0-throw name)
(jolt-throw (jolt-host-throwable
"clojure.lang.ArityException"
(string-append "Wrong number of args (0) passed to: clojure.core/" name))))
(define (jolt-sub . xs)
(cond ((null? xs) (jolt-arity0-throw "-"))
((null? (cdr xs)) (jolt-sub2 0 (car xs)))
(else (fold-left jolt-sub2 (car xs) (cdr xs)))))
(define (jolt-mul . xs)
(cond ((null? xs) 1)
((null? (cdr xs)) (jolt-num-check1 (car xs)))
(else (fold-left jolt-mul2 (car xs) (cdr xs)))))
(define (jolt-div . xs)
(cond ((null? xs) (jolt-arity0-throw "/"))
((null? (cdr xs)) (jolt-div2 1 (car xs)))
(else (fold-left jolt-div2 (car xs) (cdr xs)))))
(define (jolt-min x . xs) (fold-left jolt-min2 x xs))
(define (jolt-max x . xs) (fold-left jolt-max2 x xs))
;; variadic comparison chains for value position ((apply < xs)).
(define (jolt-cmp-chain op2)
(lambda (x . xs)
(let loop ((a x) (rest xs))
(cond ((null? rest) #t)
((op2 a (car rest)) (loop (car rest) (cdr rest)))
(else #f)))))
(define jolt-lt (jolt-cmp-chain jolt-lt2))
(define jolt-gt (jolt-cmp-chain jolt-gt2))
(define jolt-le (jolt-cmp-chain jolt-le2))
(define jolt-ge (jolt-cmp-chain jolt-ge2))
;; call-position arithmetic: inlined macros with the both-Chez-numbers fast path
;; open-coded; anything else falls to the binary dispatch above. Comparisons
;; return a genuine Scheme boolean (the backend's truthy elision relies on it).
(define-syntax jolt-n+
(syntax-rules ()
((_) 0)
((_ a) (jolt-add a))
((_ ea eb) (let ((a ea) (b eb))
(if (and (number? a) (number? b)) (+ a b) (jolt-add a b))))
((_ a b c ...) (jolt-n+ (jolt-n+ a b) c ...))))
(define-syntax jolt-n-
(syntax-rules ()
((_) (jolt-sub))
((_ a) (jolt-sub a))
((_ ea eb) (let ((a ea) (b eb))
(if (and (number? a) (number? b)) (- a b) (jolt-sub a b))))
((_ a b c ...) (jolt-n- (jolt-n- a b) c ...))))
(define-syntax jolt-n*
(syntax-rules ()
((_) 1)
((_ a) (jolt-mul a))
((_ ea eb) (let ((a ea) (b eb))
(if (and (number? a) (number? b))
(if (or (flonum? a) (flonum? b))
(fl* (real->flonum a) (real->flonum b))
(* a b))
(jolt-mul a b))))
((_ a b c ...) (jolt-n* (jolt-n* a b) c ...))))
(define-syntax jolt-n-div
(syntax-rules ()
((_) (jolt-div))
((_ a) (jolt-div a))
((_ a b) (jolt-div2 a b))
((_ a b c ...) (jolt-n-div (jolt-div2 a b) c ...))))
(define-syntax define-n-cmp
(syntax-rules ()
((_ name op op2)
(define-syntax name
(syntax-rules ()
((_) (op2))
((_ a) (begin a #t))
((_ ea eb) (let ((a ea) (b eb))
(if (and (number? a) (number? b)) (op a b) (op2 a b))))
((_ ea eb c (... ...)) (let ((a ea) (b eb))
(and (name a b) (name b c (... ...))))))))))
(define-n-cmp jolt-n< < jolt-lt2)
(define-n-cmp jolt-n> > jolt-gt2)
(define-n-cmp jolt-n<= <= jolt-le2)
(define-n-cmp jolt-n>= >= jolt-ge2)
(define-syntax jolt-n-min
(syntax-rules ()
((_) (jolt-min))
((_ a) (jolt-min a))
((_ a b) (jolt-min2 a b))
((_ a b c ...) (jolt-n-min (jolt-min2 a b) c ...))))
(define-syntax jolt-n-max
(syntax-rules ()
((_) (jolt-max))
((_ a) (jolt-max a))
((_ a b) (jolt-max2 a b))
((_ a b c ...) (jolt-n-max (jolt-max2 a b) c ...))))
;; --- unchecked (Java long) arithmetic: wrap to signed 64 bits ----------------
;; Clojure's unchecked-* (and +/-/* under *unchecked-math*) are long ops that
;; WRAP on overflow; jolt's checked arithmetic is arbitrary-precision. These
;; truncate to the low 64 bits as a two's-complement signed long. Chez fixnums are
;; 61-bit, so wrapping uses bignum bit ops + a mask (no fx fast path). The backend
;; emits the binary jolt-unc* for :long-typed unchecked ops; the variadic
;; clojure.core/unchecked-* fns reduce through them.
(define unc-mask64 #xFFFFFFFFFFFFFFFF)
(define unc-2^63 #x8000000000000000)
(define unc-2^64 #x10000000000000000)
(define unc-neg-2^63 (- unc-2^63))
;; Wrap to a signed 64-bit value. Fast path: an exact integer already in
;; [-2^63, 2^63) is its own wrap — skip the bignum mask, which on Chez (61-bit
;; fixnums) allocates for any value past 2^60. Only an out-of-range result (a
;; multiply overflowing into 128 bits) needs the mask + sign fixup.
(define (jolt-wrap64 x)
(if (and (exact? x) (integer? x) (>= x unc-neg-2^63) (< x unc-2^63))
x
(let ((m (bitwise-and (if (and (number? x) (exact? x) (integer? x)) x (exact (floor x))) unc-mask64)))
(if (>= m unc-2^63) (- m unc-2^64) m))))
;; unchecked-* only WRAP integer (long) math; on a flonum OR ratio operand they
;; are an ordinary numeric op, since *unchecked-math* never wraps a non-long —
;; Clojure's unchecked-add falls back to regular arithmetic for non-primitives:
;; (unchecked-multiply 1.5 2.0) => 3.0, (unchecked-add 2/3 2/3) => 4/3, not a
;; truncated long. (test.check's rand-double is (* double-unit shifted), and
;; gen/ratio sums ratios, both under *unchecked-math*.) Wrap iff both are exact
;; integers.
(define (unc-int? x) (and (exact? x) (integer? x)))
(define (jolt-uncadd2 a b) (if (and (unc-int? a) (unc-int? b)) (jolt-wrap64 (+ a b)) (+ a b)))
(define (jolt-uncsub2 a b) (if (and (unc-int? a) (unc-int? b)) (jolt-wrap64 (- a b)) (- a b)))
(define (jolt-uncmul2 a b) (if (and (unc-int? a) (unc-int? b)) (jolt-wrap64 (* a b)) (* a b)))
(define (jolt-uncinc x) (if (unc-int? x) (jolt-wrap64 (+ x 1)) (+ x 1)))
(define (jolt-uncdec x) (if (unc-int? x) (jolt-wrap64 (- x 1)) (- x 1)))
(define (jolt-uncneg x) (if (unc-int? x) (jolt-wrap64 (- x)) (- x)))
(define (jolt-unchecked-add . xs) (if (null? xs) 0 (fold-left jolt-uncadd2 (car xs) (cdr xs))))
(define (jolt-unchecked-mul . xs) (if (null? xs) 1 (fold-left jolt-uncmul2 (car xs) (cdr xs))))
(define (jolt-unchecked-sub . xs)
(cond ((null? xs) 0) ((null? (cdr xs)) (jolt-uncneg (car xs))) (else (fold-left jolt-uncsub2 (car xs) (cdr xs)))))
(define (jolt-unchecked-div a b) (quotient (jolt-wrap64 a) (jolt-wrap64 b)))
(define (jolt-unchecked-rem a b) (remainder (jolt-wrap64 a) (jolt-wrap64 b)))
;; the clojure.core/unchecked-* vars are def-var!'d in natives-seq.ss (def-var! is
;; defined after this file loads).
;; --- ^long ops that tolerate a full 64-bit value -----------------------------
;; A ^long is 64-bit but a Chez fixnum is only 61-bit, so the backend's fast fx
;; ops would raise on a value past 2^60 (e.g. a long from the PRNG / wrapping
;; arithmetic). These take the fx fast path when the operands ARE fixnums and fall
;; back to the generic op otherwise — so ^long comparisons / quot / min etc. on a
;; full-width long stay correct. Macros (define-syntax) so the fast path inlines.
(define-syntax define-l-binop
(syntax-rules ()
((_ name fxop genop)
(define-syntax name
(syntax-rules ()
((_ a b) (let ((x a) (y b))
(if (and (fixnum? x) (fixnum? y)) (fxop x y) (genop x y)))))))))
(define-l-binop jolt-l< fx<? <)
(define-l-binop jolt-l<= fx<=? <=)
(define-l-binop jolt-l> fx>? >)
(define-l-binop jolt-l>= fx>=? >=)
(define-l-binop jolt-l= fx=? =)
(define-l-binop jolt-l-min fxmin min)
(define-l-binop jolt-l-max fxmax max)
(define-l-binop jolt-l-quot fxquotient quotient)
(define-l-binop jolt-l-rem fxremainder remainder)
(define-l-binop jolt-l-mod fxmodulo modulo)
(define-syntax jolt-l-inc (syntax-rules () ((_ a) (let ((x a)) (if (fixnum? x) (fx1+ x) (+ x 1))))))
(define-syntax jolt-l-dec (syntax-rules () ((_ a) (let ((x a)) (if (fixnum? x) (fx1- x) (- x 1))))))
;; ============================================================================
;; IFn dispatch — the dynamic "value as fn" fallback. A callee that the emitter
;; can't statically resolve to a procedure (a keyword/coll/proc held in a local)
;; routes here. Off the arithmetic/self-recursion hot path by construction.
;; ============================================================================
;; (pred . handler) arms making a host type invocable; handler gets (f args).
(define jolt-invoke-arms '())
(define (register-invoke-arm! pred handler)
(set! jolt-invoke-arms (cons (cons pred handler) jolt-invoke-arms)))
(define (jolt-invoke-arm-for f)
(let loop ((as jolt-invoke-arms))
(cond ((null? as) #f)
(((caar as) f) (cdar as))
(else (loop (cdr as))))))
(define (jolt-invoke f . args)
(cond
((procedure? f) (apply f args))
((keyword? f) (apply jolt-get (car args) f (cdr args))) ; (:k m [d]) -> (get m :k [d])
((jolt-symbol? f) (apply jolt-get (car args) f (cdr args))) ; ('s m [d]) -> (get m 's [d])
;; a VECTOR invokes as nth (a bad index throws, like IPersistentVector.invoke);
;; maps and sets invoke as get.
((pvec? f) (if (and (pair? args) (null? (cdr args)))
(jolt-nth f (car args))
(apply jolt-get f args)))
((jolt-coll? f) (apply jolt-get f args)) ; (coll k [d]) -> (get coll k [d])
((jolt-transient? f) (apply jolt-get f args)) ; a transient vec/map/set is callable on the JVM
(else (error 'invoke "not a fn" f))))
;; a record/reify implementing clojure.lang.IFn is callable: dispatch to its
;; inline `invoke` method with the value itself as the leading `this`.
((and (jrec? f) (find-method-any-protocol (jrec-tag f) "invoke"))
=> (lambda (m) (apply jolt-invoke m f args)))
((and (reified-methods f) (hashtable-ref (reified-methods f) "invoke" #f))
=> (lambda (m) (apply jolt-invoke m f args)))
;; host types registered as callable (promise delivers, …): consulted only
;; after every built-in case missed, so the hot dispatch pays nothing.
((jolt-invoke-arm-for f) => (lambda (h) (h f args)))
;; calling a non-fn: a ClassCastException naming the operator's CLASS (like
;; the JVM's "class clojure.lang.LazySeq cannot be cast to ... IFn" — never
;; the value, whose printed form may be unbounded: ((range)) must throw, not
;; hang rendering an infinite seq). Thrown via jolt-throw so it is catchable
;; and carries the throw-site continuation for a stack trace.
(else (jolt-throw (jolt-host-throwable "java.lang.ClassCastException"
(string-append
"class "
(guard (e (#t "value"))
(let ((c (jolt-class-name f)))
(if (string? c) c (jolt-pr-str f))))
" cannot be cast to class clojure.lang.IFn"))))))
;; ============================================================================
;; chunked-seq accessors — the host side of the Clojure IChunkedSeq contract
;; (chunk-first ++ chunk-rest == the seq). Two chunked shapes share the cseq
;; record: a vector-backed seq (cvec = whole pvec, ci = absolute index, crest #f,
;; rest = next 32-block of cvec) and a ChunkedCons (cvec = standalone chunk pvec,
;; crest = the after-chunk seq). natives-array.ss binds these into clojure.core and
;; the chunk-buffer/chunk/chunk-cons builder API on top of them.
;; ============================================================================
(define seq-chunk-size 32)
;; (chunk-pvec . end-index) for a chunked cell, else #f. A ChunkedCons block is the
;; whole remaining chunk (crest carries what comes after); a vector seq block is the
;; next <=32 elements within cvec.
(define (na-vblock s)
(and (cseq? s) (cseq-cvec s)
(let ((v (cseq-cvec s)) (i (cseq-ci s)))
(cons v (if (cseq-crest s) (pvec-count v) (fxmin (fx+ i seq-chunk-size) (pvec-count v)))))))
(define (na-chunked-seq? x) (and (na-vblock x) #t))
;; Copy the block [i, end) straight out of the pvec trie's 32-element leaf node
;; (pv-chunk-for is O(log n)). seq-chunk-size == pv-width and vector-seq blocks are
;; 32-aligned, so a block is exactly one leaf; the rare non-aligned window crossing
;; a leaf boundary falls back to per-index reads. Flattening the whole backing
;; vector per block (pvec-v) made chunk-first O(n), so walking chunk-by-chunk was
;; O(n^2). A ChunkedCons chunk is a small tail-only pvec, so the leaf IS the chunk.
(define (na-chunk-first s)
(let ((vb (na-vblock s)))
(if vb
(let* ((pv (car vb)) (i (cseq-ci s)) (end (cdr vb)) (len (fx- end i))
(node (pv-chunk-for pv i)) (off (fxand i pv-mask)))
(if (fx<=? (fx+ off len) (vector-length node))
(make-pvec (vec-copy-range node off (fx+ off len)))
(let ((out (make-vector len)))
(let loop ((j 0))
(if (fx<? j len)
(begin (vector-set! out j (pvec-nth-d pv (fx+ i j) jolt-nil)) (loop (fx+ j 1)))
(make-pvec out))))))
(jolt-first s)))) ; eager-buffer fallback
;; chunk-rest / chunk-next: drop the whole current chunk. For a ChunkedCons that is
;; crest (the after-chunk seq); for a vector seq it is the seq at the next block.
(define (na-chunk-rest s)
(cond
((and (cseq? s) (cseq-crest s))
(let ((r (jolt-seq (cseq-crest s)))) (if (jolt-nil? r) jolt-empty-list r)))
((na-vblock s) => (lambda (vb)
(if (fx>=? (cdr vb) (pvec-count (car vb))) jolt-empty-list (vec->seq (car vb) (cdr vb)))))
(else (jolt-rest s))))
(define (na-chunk-next s)
(cond
((and (cseq? s) (cseq-crest s)) (jolt-seq (cseq-crest s)))
((na-vblock s) => (lambda (vb)
(if (fx>=? (cdr vb) (pvec-count (car vb))) jolt-nil (vec->seq (car vb) (cdr vb)))))
(else (jolt-next s))))
;; ============================================================================
;; map / filter / reduce / into / remove + range / take / concat / apply
@ -156,44 +549,96 @@
;; an empty seq, so (= () (map f [])) is true and (nil? (map f [])) is false.
;; jolt-empty-list seqs back to nil, so it stays a valid lazy-tail terminator for
;; the non-empty case (printing / seq= / reduce all walk via jolt-seq).
;; Single-coll map (core.clj's [f coll] arity). Chunk-preserving: when the source
;; seq is chunked, realize the WHOLE first chunk — apply f to every element eagerly
;; into a fresh chunk — and chunk-cons it onto a lazy map of chunk-rest, so the
;; result is itself a chunked-seq. A non-chunked source maps one element at a time.
(define (map-seq f s)
(if (jolt-nil? s) jolt-empty-list
(cseq-lazy (jolt-invoke f (seq-first s)) (lambda () (map-seq f (jolt-seq (seq-more s)))))))
(cond
((jolt-nil? s) jolt-empty-list)
((na-chunked-seq? s)
(let* ((c (na-chunk-first s)) (n (pvec-count c)) (out (make-vector n)))
(let loop ((i 0))
(if (fx<? i n)
(begin (vector-set! out i (jolt-invoke f (pvec-nth-d c i jolt-nil))) (loop (fx+ i 1)))
(cseq-chunked (make-pvec out) 0
(jolt-make-lazy-seq (lambda () (jolt-seq (map-seq f (jolt-seq (na-chunk-rest s)))))))))))
(else
(cseq-lazy (jolt-invoke f (seq-first s)) (lambda () (map-seq f (jolt-seq (seq-more s))))))))
(define (map-seq* f seqs) ; multi-collection map; stops at the shortest
(if (any-nil? seqs) jolt-empty-list
(cseq-lazy (apply jolt-invoke f (map seq-first seqs))
(lambda () (map-seq* f (map (lambda (s) (jolt-seq (seq-more s))) seqs))))))
;; map is fully lazy: Clojure's (map f coll) is a LazySeq whose body — including
;; (f (first coll)) — runs only when forced, so a side-effecting f does not fire
;; at construction. Wrap the (eager-headed) map-seq in a lazy-seq node; forcing it
;; once yields the cseq chain, which then iterates with no per-element overhead.
;; jolt-seq coerces map-seq's result (cseq | jolt-empty-list) to cseq | nil, the
;; contract force-lazyseq relies on (see jolt-rest).
(define (jolt-map f . colls)
(if (null? (cdr colls))
(map-seq f (jolt-seq (car colls)))
(map-seq* f (map jolt-seq colls))))
(jolt-make-lazy-seq (lambda () (jolt-seq (map-seq f (jolt-seq (car colls))))))
(jolt-make-lazy-seq (lambda () (jolt-seq (map-seq* f (map jolt-seq colls)))))))
;; Chunk-preserving, like core.clj filter: a chunked source has pred applied to the
;; whole chunk, the kept elements packed into a fresh (possibly smaller) chunk, and
;; that chunk-cons'd onto a lazy filter of chunk-rest. An all-rejected chunk emits
;; no empty cell — it recurses straight into chunk-rest (chunk-cons of an empty
;; chunk == its rest). A non-chunked source filters one element at a time.
(define (filter-seq pred s keep)
(let loop ((s s))
(cond ((jolt-nil? s) jolt-empty-list) ; empty result is () (see map-seq)
((eq? keep (jolt-truthy? (jolt-invoke pred (seq-first s))))
(cseq-lazy (seq-first s) (lambda () (filter-seq pred (jolt-seq (seq-more s)) keep))))
(else (loop (jolt-seq (seq-more s)))))))
(define (jolt-filter pred coll) (filter-seq pred (jolt-seq coll) #t))
(define (jolt-remove pred coll) (filter-seq pred (jolt-seq coll) #f))
(cond
((jolt-nil? s) jolt-empty-list) ; empty result is () (see map-seq)
((na-chunked-seq? s)
(let* ((c (na-chunk-first s)) (n (pvec-count c)))
(let loop ((i 0) (acc '()))
(if (fx<? i n)
(let ((x (pvec-nth-d c i jolt-nil)))
(loop (fx+ i 1) (if (eq? keep (jolt-truthy? (jolt-invoke pred x))) (cons x acc) acc)))
(let ((kept (reverse acc)))
(if (null? kept)
(filter-seq pred (jolt-seq (na-chunk-rest s)) keep)
(cseq-chunked (make-pvec (list->vector kept)) 0
(jolt-make-lazy-seq
(lambda () (jolt-seq (filter-seq pred (jolt-seq (na-chunk-rest s)) keep)))))))))))
(else
(let walk ((s s))
(cond ((jolt-nil? s) jolt-empty-list)
((eq? keep (jolt-truthy? (jolt-invoke pred (seq-first s))))
(cseq-lazy (seq-first s) (lambda () (filter-seq pred (jolt-seq (seq-more s)) keep))))
(else (walk (jolt-seq (seq-more s)))))))))
;; filter/remove are fully lazy (LazySeq): defer the predicate and the source seq
;; until forced, like Clojure. (lazy-seq* = a 0-arg lazy node coercing to cseq|nil.)
(define (jolt-filter pred coll)
(jolt-make-lazy-seq (lambda () (jolt-seq (filter-seq pred (jolt-seq coll) #t)))))
(define (jolt-remove pred coll)
(jolt-make-lazy-seq (lambda () (jolt-seq (filter-seq pred (jolt-seq coll) #f)))))
;; honors `reduced`: a reducing fn that returns (reduced x) stops the fold and
;; unwraps to x (so does a reduced INIT). Checked at entry, so the value returned
;; by the last step is unwrapped on the next turn before the seq is consulted.
;; reduce a vector's backing store directly by index from element i — no per-
;; element seq cells. Honors `reduced`. The chunked-seq fast path.
;; Reduce a chunk pvec from index i. Returns the accumulator RAW — a `reduced` box
;; is returned unwrapped-by reduce-seq, not here — so a ChunkedCons continuation can
;; see early termination instead of folding it back into the running value.
(define (vec-reduce f acc v i)
(let ((n (pvec-count v)) (raw (pvec-v v)))
(let loop ((i i) (acc acc))
(cond ((jolt-reduced? acc) (jolt-reduced-val acc))
(cond ((jolt-reduced? acc) acc)
((fx>=? i n) acc)
(else (loop (fx+ i 1) (jolt-invoke f acc (vector-ref raw i))))))))
(define (reduce-seq f acc s)
(cond
((jolt-reduced? acc) (jolt-reduced-val acc))
((jolt-nil? s) acc)
;; a vector-backed (chunked) seq reduces its vector directly, in a tight loop.
((and (cseq? s) (cseq-cvec s)) (vec-reduce f acc (cseq-cvec s) (cseq-ci s)))
;; a chunked seq reduces its chunk pvec directly, in a tight loop. A vector seq
;; (crest #f) reduces the whole backing vector and is then done; a ChunkedCons
;; reduces this chunk and continues into its after-chunk rest.
((and (cseq? s) (cseq-cvec s))
(let ((acc2 (vec-reduce f acc (cseq-cvec s) (cseq-ci s))))
(cond ((jolt-reduced? acc2) (jolt-reduced-val acc2))
((cseq-crest s) (reduce-seq f acc2 (jolt-seq (cseq-crest s))))
(else acc2))))
(else (reduce-seq f (jolt-invoke f acc (seq-first s)) (jolt-seq (seq-more s))))))
(define jolt-reduce
(case-lambda
@ -201,11 +646,11 @@
(if (jolt-nil? s) (jolt-invoke f) ; (reduce f []) -> (f)
(reduce-seq f (seq-first s) (jolt-seq (seq-more s))))))
((f init coll)
;; IReduceInit: a reify/record with its own `reduce` method drives the
;; reduction (reduce f init (reify clojure.lang.IReduceInit (reduce [_ f i] ...))).
;; IReduceInit: a deftype/record OR reify with its own `reduce` method drives
;; the reduction, e.g. (reduce f init (reify clojure.lang.IReduceInit
;; (reduce [_ f i] ...))) or the same on a deftype.
(cond
((and (jreify? coll) (reified-methods coll)
(hashtable-ref (reified-methods coll) "reduce" #f))
((iface-method coll "reduce" 3)
=> (lambda (m) (let ((r (jolt-invoke m coll f init)))
(if (jolt-reduced? r) (jolt-reduced-val r) r))))
(else (reduce-seq f init (jolt-seq coll)))))))
@ -216,32 +661,73 @@
;; falls back to a copy-on-write wrapper for other targets (lists, sorted colls,
;; nil), so those keep the old per-step jolt-conj behaviour.
(define (jolt-into to from)
(meta-carry to
(jolt-persistent! (reduce-seq (lambda (t x) (jolt-conj! t x)) (jolt-transient-new to) (jolt-seq from)))))
;; only an editable collection rides the transient path; anything else
;; (PersistentQueue, sorted colls, seqs) folds through conj, like RT's
;; instanceof IEditableCollection split.
(if (or (pvec? to) (pmap? to) (pset? to))
(meta-carry to
(jolt-persistent! (reduce-seq (lambda (t x) (jolt-conj! t x)) (jolt-transient-new to) (jolt-seq from))))
(meta-carry to
(reduce-seq (lambda (acc x) (jolt-conj1 acc x)) to (jolt-seq from)))))
(define (range-from n) (cseq-lazy n (lambda () (range-from (+ n 1)))))
(define (range-bounded n end step)
;; A bounded range is a real chunked-seq, like clojure.lang.LongRange: eager, with
;; chunk-first handing out a block of up to 32 consecutive values. Each block is
;; materialized into a pvec and chunk-cons'd onto a lazy continuation, so a chunked
;; map/filter over a range batches by 32 (the JVM's observable realization), while a
;; huge range still produces its tail one block at a time.
;; An empty range is () (jolt-empty-list), NOT nil — (range 0) and (range 5 5) are
;; empty seqs in Clojure, so (= () (range 0)) holds, and () seqs back to nil so it
;; also terminates the chunked tail (see jolt-take).
(define (range-chunked n end step)
(if (if (> step 0.0) (< n end) (> n end))
(cseq-lazy n (lambda () (range-bounded (+ n step) end step)))
jolt-nil))
(let loop ((i 0) (v n) (acc '()))
(if (and (fx<? i seq-chunk-size) (if (> step 0.0) (< v end) (> v end)))
(loop (fx+ i 1) (+ v step) (cons v acc))
(cseq-chunked (make-pvec (list->vector (reverse acc))) 0
(jolt-make-lazy-seq (lambda () (jolt-seq (range-chunked v end step)))))))
jolt-empty-list))
;; numeric tower: exact 0/1 defaults so (range 3) yields exact ints
;; (= JVM longs); flonum args still produce flonums (Scheme arithmetic preserves).
;; (range) with no bound is the lazy, NON-chunked (iterate inc' 0) form.
(define jolt-range
(case-lambda
(() (range-from 0))
((end) (range-bounded 0 end 1))
((start end) (range-bounded start end 1))
((start end step) (range-bounded start end step))))
((end) (range-chunked 0 end 1))
((start end) (range-chunked start end 1))
((start end step) (range-chunked start end step))))
;; An empty take result is () (jolt-empty-list), NOT nil — (take 0 coll) and
;; (take n []) are empty seqs in Clojure, so (= () (take 0 [:a])) and printing
;; "()" hold. jolt-empty-list seqs back to nil, so it also terminates the lazy
;; tail when n hits 0 mid-stream (see map-seq).
;; The LAST element (n=1) terminates without touching the rest, so (take n s)
;; realizes exactly n elements of a side-effecting seq — matching Clojure, where
;; (take 0 (rest s)) never seqs coll. Realizing one more, as forcing seq-more at
;; the boundary would, over-runs the source by one (medley's sequence-padded).
(define (jolt-take n coll)
(let ((n (->idx n)))
(let loop ((n n) (s (jolt-seq coll)))
(if (or (fx<=? n 0) (jolt-nil? s)) jolt-nil
(cseq-lazy (seq-first s) (lambda () (loop (fx- n 1) (jolt-seq (seq-more s)))))))))
;; lazy (LazySeq): realize exactly n elements, none at construction. (take
;; Double/POSITIVE_INFINITY coll) takes the whole coll on the JVM (the count
;; never reaches 0); test.check's rose-tree unchunk relies on it. Coercing +inf.0
;; to a fixnum index would throw, so take all up front in that case.
(jolt-make-lazy-seq
(lambda ()
(jolt-seq
(if (and (flonum? n) (infinite? n))
(if (> n 0.0) (jolt-seq coll) jolt-empty-list)
(let ((n (->idx n)))
(let loop ((n n) (s (jolt-seq coll)))
(cond
((or (fx<=? n 0) (jolt-nil? s)) jolt-empty-list)
((fx=? n 1) (cseq-lazy (seq-first s) (lambda () jolt-empty-list)))
(else (cseq-lazy (seq-first s) (lambda () (loop (fx- n 1) (jolt-seq (seq-more s))))))))))))))
(define (jolt-drop n coll)
(let loop ((n (->idx n)) (s (jolt-seq coll)))
(if (or (fx<=? n 0) (jolt-nil? s)) (if (jolt-nil? s) jolt-empty-list s)
(loop (fx- n 1) (jolt-seq (seq-more s))))))
(jolt-make-lazy-seq
(lambda ()
(jolt-seq
(let loop ((n (->idx n)) (s (jolt-seq coll)))
(if (or (fx<=? n 0) (jolt-nil? s)) (if (jolt-nil? s) jolt-empty-list s)
(loop (fx- n 1) (jolt-seq (seq-more s)))))))))
;; lazily append seq a then the seqable produced by the thunk `brest` — the rest
;; is NOT forced until a is exhausted, so concat is fully lazy (Clojure semantics).
@ -252,14 +738,32 @@
(if (jolt-nil? a) (jolt-seq (brest))
(cseq-lazy (seq-first a) (lambda () (concat2 (jolt-seq (seq-more a)) brest)))))
(define (jolt-concat . colls)
(cond ((null? colls) jolt-empty-list)
((null? (cdr colls)) (jolt-seq (car colls)))
(else (concat2 (jolt-seq (car colls)) (lambda () (apply jolt-concat (cdr colls)))))))
(jolt-make-lazy-seq
(lambda ()
(jolt-seq
(cond ((null? colls) jolt-empty-list)
((null? (cdr colls)) (jolt-seq (car colls)))
(else (concat2 (jolt-seq (car colls)) (lambda () (apply jolt-concat (cdr colls))))))))))
;; (apply f a b ... coll): spread the trailing seqable into the call.
;; Lazily concatenate a (possibly infinite) SEQ of colls — what (apply concat ss)
;; means, but without realizing ss. Pulls one coll at a time, concatenating it with
;; a lazy tail, so mapcat / (apply concat …) over an infinite source stays lazy.
(define (lazy-concat-seq ss)
(let ((s (jolt-seq ss)))
(if (jolt-nil? s)
jolt-empty-list
(jolt-concat (seq-first s)
(jolt-make-lazy-seq (lambda () (lazy-concat-seq (seq-more s))))))))
;; (apply f a b ... coll): spread the trailing seqable into the call. concat is
;; special-cased: it produces a LAZY result, so spreading an infinite tail through
;; a Scheme variadic (which must realize it) would hang — route to lazy-concat-seq,
;; prepending any fixed leading colls.
(define (jolt-apply f . args)
(let* ((r (reverse args)) (spread (seq->list (jolt-seq (car r)))) (fixed (reverse (cdr r))))
(apply jolt-invoke f (append fixed spread))))
(let* ((r (reverse args)) (tail (car r)) (fixed (reverse (cdr r))))
(if (eq? f jolt-concat)
(lazy-concat-seq (fold-right jolt-cons (jolt-seq tail) fixed))
(apply jolt-invoke f (append fixed (seq->list (jolt-seq tail)))))))
;; ============================================================================
;; numeric predicates / identity — usable in fn AND value position (map/filter).
@ -269,8 +773,14 @@
;; Parity over the full integer range (JVM even?/odd? accept any integer,
;; bignums included); a fixnum-only fxand crashes on a large value (e.g. a hash).
(define (parity-int n) (if (flonum? n) (exact (floor n)) n))
(define (jolt-even? n) (even? (parity-int n)))
(define (jolt-odd? n) (odd? (parity-int n)))
(define (jolt-parity-check n)
(unless (and (number? n) (exact? n) (integer? n))
(jolt-throw (jolt-host-throwable
"java.lang.IllegalArgumentException"
(string-append "Argument must be an integer: "
(guard (e (#t "?")) (jolt-str n)))))))
(define (jolt-even? n) (jolt-parity-check n) (even? (parity-int n)))
(define (jolt-odd? n) (jolt-parity-check n) (odd? (parity-int n)))
(define (jolt-pos? n) (> n 0))
(define (jolt-neg? n) (< n 0))
(define (jolt-zero? n) (= n 0))
@ -279,8 +789,18 @@
;; ============================================================================
;; keys / vals — return seqs (nil on the empty map), HAMT-iteration order
;; ============================================================================
(define (jolt-keys m) (if (jolt-nil? m) jolt-nil (list->cseq (pmap-fold m (lambda (k v a) (cons k a)) '()))))
(define (jolt-vals m) (if (jolt-nil? m) jolt-nil (list->cseq (pmap-fold m (lambda (k v a) (cons v a)) '()))))
;; keys/vals of anything empty is nil (RT.keys over a nil seq); a non-empty
;; non-map still fails (its elements are not MapEntries).
(define (jolt-keys m)
(cond ((jolt-nil? m) jolt-nil)
((pmap? m) (list->cseq (pmap-fold m (lambda (k v a) (cons k a)) '())))
((jolt-nil? (jolt-seq m)) jolt-nil)
(else (list->cseq (pmap-fold m (lambda (k v a) (cons k a)) '())))))
(define (jolt-vals m)
(cond ((jolt-nil? m) jolt-nil)
((pmap? m) (list->cseq (pmap-fold m (lambda (k v a) (cons v a)) '())))
((jolt-nil? (jolt-seq m)) jolt-nil)
(else (list->cseq (pmap-fold m (lambda (k v a) (cons v a)) '())))))
;; ============================================================================
;; sequential equality + hash (hooks called from values.ss / collections.ss);

View file

@ -18,6 +18,51 @@ check() {
}
pass=0
# An uncaught error reports the source location of the top-level form (stderr).
check_loc() {
err="$(bin/joltc -e "$1" 2>&1 >/dev/null)"
if printf '%s' "$err" | grep -q "$2"; then
pass=$((pass + 1))
else
echo " FAIL (loc): $1"
echo " want stderr to contain \`$2\`, got \`$err\`"
fails=$((fails + 1))
fi
}
# An uncaught error's stack trace must name the runtime-eval'd fn frames that
# survive TCO (the non-tail spine), even though the eval path registers no source
# map — "print what is available". Asserts a substring appears under " trace:".
check_trace() {
err="$(bin/joltc -e "$1" 2>&1 >/dev/null)"
if printf '%s' "$err" | grep -q ' trace:' && printf '%s' "$err" | grep -q "$2"; then
pass=$((pass + 1))
else
echo " FAIL (trace): $1"
echo " want stderr trace to contain \`$2\`, got \`$err\`"
fails=$((fails + 1))
fi
}
# JOLT_TRACE opts into the tail-frame history (the ring of rings): every $2 (an
# ERE) must match the " trace:" block. Used to assert TCO-elided frames are
# recovered and non-tail caller context survives a tail loop.
check_trace_on() {
err="$(JOLT_TRACE=1 bin/joltc -e "$1" 2>&1 >/dev/null)"
ok=1
printf '%s' "$err" | grep -q ' trace:' || ok=0
shift
for want in "$@"; do
printf '%s' "$err" | grep -Eq "$want" || ok=0
done
if [ "$ok" = 1 ]; then
pass=$((pass + 1))
else
echo " FAIL (trace-on): want [$*] in trace, got \`$err\`"
fails=$((fails + 1))
fi
}
check '(+ 1 2)' '3'
check '(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (fib 15)' '610'
check '(->> (range 10) (filter even?) (map (fn [x] (* x x))) (reduce +))' '120'
@ -31,6 +76,188 @@ check '(deref (future (+ 1 2)))' '3'
check '(/ 1 2)' '1/2'
check '(= 3 3.0)' 'false'
check '(== 3 3.0)' 'true'
# a deftype whose simple name collides with a built-in host class must not shadow
# the java class: (java.io.PushbackReader. …) still builds the java reader (has
# .read), while the bare name in the deftype's own ns is the deftype. (Fresh -e
# process per check, so the deftype doesn't leak.)
check '(do (deftype PushbackReader [x]) (.read (java.io.PushbackReader. (java.io.StringReader. "A") 1)))' '65'
check '(do (deftype PushbackReader [x]) (.-x (PushbackReader. 42)))' '42'
check_loc '(throw (ex-info "boom" {}))' ' at 1:'
# A throw that crosses the eval boundary (eval / load-string) must surface its
# ex-info :message, not Chez's "attempt to apply non-procedure" noise from
# re-wrapping a raw value raised through `eval`.
check '(try (eval (read-string "(throw (ex-info \"boom\" {}))")) (catch :default e (ex-message e)))' 'boom'
check '(try (load-string "(+") (catch :default e (ex-message e)))' 'EOF while reading'
# An uncaught throw prints the ex-info message alongside its source location.
check_loc '(throw (ex-info "boom" {}))' 'boom'
check_loc '(do (+ 1 1) (/ 1 0))' ' at 1:'
# Runtime-eval'd fns aren't source-mapped, but their native frame names survive on
# the non-tail spine; the trace must show them. deepest/+ are tail calls (erased);
# middle and outer wait on a non-tail (inc …) so their frames are live at the throw.
trace_prog='(defn deepest [x] (+ x 1)) (defn middle [x] (inc (deepest x))) (defn outer [x] (inc (middle x))) (outer :nan)'
check_trace "$trace_prog" 'middle'
check_trace "$trace_prog" 'outer'
# JOLT_TRACE (tail-frame history / ring of rings). An all-tail chain is entirely
# TCO-erased from the continuation, but the history recovers every frame — incl.
# `deepest`, the actual error site.
check_trace_on '(defn deepest [x] (+ x 1)) (defn middle [x] (deepest x)) (defn outer [x] (middle x)) (outer :nan)' \
'deepest' 'middle' 'outer'
# A tail loop (a<->b) under a NON-tail caller: the loop is confined to one rib's
# bounded inner ring, so the caller context (`driver`, `top`) is NOT flushed out —
# the point of the ring of rings.
check_trace_on '(declare b) (defn a [n] (if (zero? n) (+ :x 1) (b (dec n)))) (defn b [n] (a n)) (defn driver [] (inc (a 6))) (defn top [] (inc (driver))) (top)' \
'driver' 'top'
# A ^long/^double return hint wraps the body in a coercion, so the hinted fn's call
# is NOT a tail call — its own frame is still live and must appear (not be elided).
check_trace_on '(defn g [n] (+ :x n)) (defn ^long f [n] (g n)) (f 3)' 'f' 'g'
# History is per top-level form: a later form's error trace shows its own frames
# (h2/u2), not frames from an earlier, already-returned form (h1/u1).
check_trace_on '(defn h1 [x] (inc x)) (defn u1 [] (inc (h1 5))) (u1) (defn h2 [x] (+ :x x)) (defn u2 [] (inc (h2 5))) (u2)' \
'h2' 'u2'
err_stale="$(JOLT_TRACE=1 bin/joltc -e '(defn h1 [x] (inc x)) (defn u1 [] (inc (h1 5))) (u1) (defn h2 [x] (+ :x x)) (defn u2 [] (inc (h2 5))) (u2)' 2>&1 >/dev/null)"
if printf '%s' "$err_stale" | grep -q 'h1'; then
echo " FAIL (trace-on): stale frame h1 from an earlier form leaked into the trace"
fails=$((fails + 1))
else
pass=$((pass + 1))
fi
# A file-backed project run maps each runtime-compiled frame to ns/name (file:line)
# — the eval path registers source in trace mode, so the trace isn't bare names.
tr_proj="$(mktemp -d)"
mkdir -p "$tr_proj/src/tp"
printf '{:paths ["src"] :aliases {:run {:main-opts ["-m" "tp.core"]}}}\n' > "$tr_proj/deps.edn"
printf '(ns tp.core)\n(defn deep [x] (+ x 1))\n(defn mid [x] (inc (deep x)))\n(defn -main [& _] (mid :nan))\n' > "$tr_proj/src/tp/core.clj"
tr_out="$(JOLT_TRACE=1 JOLT_PWD="$tr_proj" bin/joltc -M:run 2>&1)"
if printf '%s' "$tr_out" | grep -Eq 'tp\.core/deep \(.*/tp/core\.clj:2\)'; then
pass=$((pass + 1))
else
echo " FAIL: JOLT_TRACE trace should map a frame to ns/name (file:line)"
printf '%s\n' "$tr_out" | sed 's/^/ | /'
fails=$((fails + 1))
fi
rm -rf "$tr_proj"
# --help prints usage, and lists the nREPL server under its real flag name.
help_out="$(bin/joltc --help 2>/dev/null)"
if printf '%s' "$help_out" | grep -q -- '--nrepl-server'; then
pass=$((pass + 1))
else
echo " FAIL: --help should list --nrepl-server"
fails=$((fails + 1))
fi
# clojure.test extension points (assert-expr / do-report / report) need separate
# top-level forms — assert-expr must register before `is` expands — so this is a
# multi-form `joltc run`, not an -e one-liner. The file self-checks its tallies.
ct_out="$(bin/joltc run test/chez/clojure-test.clj 2>/dev/null)"
if printf '%s' "$ct_out" | grep -q 'CLOJURE-TEST OK'; then
pass=$((pass + 1))
else
echo " FAIL: clojure.test extension points"
echo " $(printf '%s' "$ct_out" | grep CLOJURE-TEST | tail -1)"
fails=$((fails + 1))
fi
# A data reader that returns a CODE form (deps.edn data_readers.clj -> reader fn)
# must have its result spliced in and COMPILED, like Clojure — #code [:x] becomes
# (+ 40 2) and evaluates to 42, not the literal list. A project run so the source
# root's data_readers.clj is picked up.
dr_out="$(JOLT_PWD="$root/test/chez/datareader-app" bin/joltc run -m drtest.main 2>/dev/null | tail -1)"
if [ "$dr_out" = "42" ]; then
pass=$((pass + 1))
else
echo " FAIL: code-returning data reader (#code) not compiled — got \`$dr_out\`, want 42"
fails=$((fails + 1))
fi
# A required namespace's own :as aliases must not leak into the requirer: fix.main
# aliases clojure.string as ss and requires fix.lib (which aliases clojure.set as
# ss); (ss/upper-case "hi") in main must stay clojure.string -> "HI #{1 2}".
al_out="$(JOLT_PWD="$root/test/chez/alias-leak-app" bin/joltc run -m fix.main 2>/dev/null | tail -1)"
if [ "$al_out" = "HI #{1 2}" ]; then
pass=$((pass + 1))
else
echo " FAIL: a loaded ns's alias leaked into its requirer — got \`$al_out\`, want \`HI #{1 2}\`"
fails=$((fails + 1))
fi
# Unit-checks the REPL read-until-complete predicate over balanced/unbalanced,
# string, comment and regex-literal inputs. A multi-form `joltc run` so jolt.main
# is loaded and its private var resolves; the file self-checks and prints a sentinel.
rr_out="$(bin/joltc run test/chez/repl-reader-test.clj 2>/dev/null)"
if printf '%s' "$rr_out" | grep -q 'REPL-READER OK'; then
pass=$((pass + 1))
else
echo " FAIL: repl-form-complete? predicate"
echo " $(printf '%s' "$rr_out" | grep REPL-READER | tail -1)"
fails=$((fails + 1))
fi
# REPL must exit on :repl/quit / :exit — a reliable exit that works in any
# terminal, unlike ^D (which some terminals/editors don't deliver as EOF).
# Pipe: an evaluable form, the quit keyword, then a sentinel that must NOT run.
repl_out="$(printf '(+ 1000 23)\n:repl/quit\n(* 999 9)\n' | bin/joltc repl 2>/dev/null)"
if printf '%s' "$repl_out" | grep -q '1023' && ! printf '%s' "$repl_out" | grep -q '8991'; then
pass=$((pass + 1))
else
echo " FAIL: repl should exit on :repl/quit before later forms"
printf '%s\n' "$repl_out" | sed 's/^/ | /'
fails=$((fails + 1))
fi
repl_out="$(printf '(- 2024 1)\n:exit\n(* 999 9)\n' | bin/joltc repl 2>/dev/null)"
if printf '%s' "$repl_out" | grep -q '2023' && ! printf '%s' "$repl_out" | grep -q '8991'; then
pass=$((pass + 1))
else
echo " FAIL: repl should exit on :exit before later forms"
printf '%s\n' "$repl_out" | sed 's/^/ | /'
fails=$((fails + 1))
fi
# A form split across lines is accumulated and evaluated once complete, with a
# secondary continuation prompt before each continued line.
repl_out="$(printf '(+ 1\n2)\n:exit\n' | bin/joltc repl 2>/dev/null)"
if printf '%s' "$repl_out" | grep -q '3' && ! printf '%s' "$repl_out" | grep -q 'error'; then
pass=$((pass + 1))
else
echo " FAIL: repl should accumulate multi-line forms to 3"
printf '%s\n' "$repl_out" | sed 's/^/ | /'
fails=$((fails + 1))
fi
# A single-line regex literal is complete on its own — the #" opens a regex whose
# body (delimiters, quotes and all) must not be miscounted as unbalanced parens.
repl_out="$(printf '(re-find #"(a)(b)" "ab")\n:exit\n' | bin/joltc repl 2>/dev/null)"
if printf '%s' "$repl_out" | grep -q 'ab' && ! printf '%s' "$repl_out" | grep -q 'error'; then
pass=$((pass + 1))
else
echo " FAIL: repl should evaluate a one-line regex literal, not wait for more input"
printf '%s\n' "$repl_out" | sed 's/^/ | /'
fails=$((fails + 1))
fi
# REPL-driven development traces by default: an error in an evaluated form shows a
# tail-frame backtrace with no JOLT_TRACE set. rb tail-calls ra tail-calls +, all
# TCO-elided from the continuation — only the history recovers them.
repl_err="$(printf '(defn ra [x] (+ x 1))\n(defn rb [x] (ra x))\n(rb :nan)\n:exit\n' | bin/joltc repl 2>&1)"
if printf '%s' "$repl_err" | grep -q ' trace:' && printf '%s' "$repl_err" | grep -q 'rb'; then
pass=$((pass + 1))
else
echo " FAIL: a REPL error should show a tail-frame trace by default"
printf '%s\n' "$repl_err" | sed 's/^/ | /'
fails=$((fails + 1))
fi
# JOLT_TRACE=0 opts out — no trace in the REPL.
repl_off="$(printf '(defn ra [x] (+ x 1))\n(defn rb [x] (ra x))\n(rb :nan)\n:exit\n' | JOLT_TRACE=0 bin/joltc repl 2>&1)"
if printf '%s' "$repl_off" | grep -q ' trace:'; then
echo " FAIL: JOLT_TRACE=0 should suppress the REPL trace"
fails=$((fails + 1))
else
pass=$((pass + 1))
fi
echo "cli smoke: $pass passed, $fails failed"
[ "$fails" -eq 0 ]

View file

@ -0,0 +1,206 @@
;; source-registry.ss — map emitted procedures back to Clojure source for native
;; stack traces, and render an uncaught throwable.
;;
;; A direct-linked def compiles to (define jv$ns$name <fn>); the back end also
;; emits (jolt-register-source! "jv$ns$name" ns name file line) once per such def
;; — at definition time, so there is zero per-call cost. On an uncaught error we
;; walk Chez's native continuation frames, read each frame's procedure name, and
;; look it up here to print a Clojure backtrace.
;;
;; CAVEATS. Names map only for stable Chez procedure names — direct-link / AOT
;; closed-world builds. The open-world -e/repl/run path stores fns in var cells
;; as anonymous lambdas, so its frames don't map (the trace falls back to the
;; top-level location compile-eval.ss tracks). Pervasive tail-call optimization
;; also erases tail-called frames, so even a mapped trace shows only the non-tail
;; spine — the immediate error site is often a tail call and won't appear.
;; Keyed by the procedure name Chez actually reports for a frame — the SHORT
;; munged fn name (the letrec self-binding emit-fn uses), e.g. "deepest", not the
;; jv$ns$name global. Two vars in different namespaces can share a short name; an
;; 'ambiguous marker then keeps the frame name in the trace but drops the
;; (now-uncertain) ns/file:line, so a trace is never misattributed.
(define source-registry (make-hashtable string-hash string=?))
(define (jolt-register-source! procname ns nm file line)
(let ((existing (hashtable-ref source-registry procname #f)))
(cond
((not existing) (hashtable-set! source-registry procname (vector ns nm file line)))
((and (vector? existing)
(or (not (equal? (vector-ref existing 0) ns))
(not (equal? (vector-ref existing 1) nm))))
(hashtable-set! source-registry procname 'ambiguous))))
jolt-nil)
(def-var! "jolt.host" "register-source!" jolt-register-source!)
;; The continuation to walk for an uncaught value: the one jolt-throw captured for
;; THIS value (identity-tagged via jolt-throw-cont, so a stale entry from an
;; earlier caught throw is never reused), else a host condition's own
;; &continuation, else #f. raw may arrive as the &jolt-throw condition wrapping
;; the value (the built-binary launcher hands jolt-report-throwable the guard's
;; raw value) or already unwrapped (the cli unwraps first); unwrap here so the
;; identity match holds either way.
(define (jolt-error-continuation raw)
(let* ((v (jolt-unwrap-throw raw))
(tc (jolt-throw-cont)))
(cond
((and (pair? tc) (eq? (car tc) v)) (cdr tc))
((and (condition? v) (continuation-condition? v)) (condition-continuation v))
(else #f))))
;; A frame inspector's procedure name as a string, or #f for a non-frame / unnamed.
(define (srcreg-frame-name io)
(and (guard (e (#t #f)) (eq? (io 'type) 'continuation))
(let ((code (guard (e (#t #f)) (io 'code))))
(and code
(let ((nm (guard (e (#t #f)) (code 'name))))
(cond ((string? nm) nm)
((symbol? nm) (symbol->string nm))
(else #f)))))))
;; Frame names that are pure Chez / jolt-runtime plumbing — the eval boundary,
;; the var-cell trampoline, continuation/winder internals. They carry no Clojure
;; meaning, so an unmapped frame with one of these names is dropped from the trace
;; (a MAPPED frame is always kept — a jolt fn that happens to share the name still
;; resolves to its source). Any name Chez prefixes with `$` (system) or that jolt
;; prefixes with `jolt-` (host runtime) is plumbing too.
(define srcreg-plumbing-names
(let ((h (make-hashtable string-hash string=?)))
(for-each (lambda (s) (hashtable-set! h s #t))
'("dynamic-wind" "winder-dummy" "ksrc" "invoke" "apply"
"call-with-values" "call/cc" "call-with-current-continuation"
"raise" "raise-continuable" "with-exception-handler" "guard"
"eval" "compile" "interpret" "expand" "read" "load"
;; host dispatch/coercion helpers (not `jolt-` prefixed) that carry
;; no Clojure meaning in a trace
"record-method-dispatch" "protocol-resolve" "devirt-resolve"
"list->cseq" "host-static-call" "host-call"))
h))
(define (srcreg-plumbing-name? nm)
(or (hashtable-ref srcreg-plumbing-names nm #f)
(and (fx>? (string-length nm) 0) (char=? (string-ref nm 0) #\$))
(and (fx>=? (string-length nm) 5) (string=? (substring nm 0 5) "jolt-"))))
;; Walk a continuation, returning its frames (innermost first) as (frame-name .
;; record) pairs. record is a source vector #(ns name file line) for a frame that
;; maps to registered Clojure source, the symbol 'ambiguous for a short name shared
;; across namespaces, or #f for an unmapped-but-named frame (the common case on the
;; open-world eval path, where nothing is registered — the bare frame name is still
;; a useful trace line). Plumbing frames (host spine, eval boundary) and unnamed
;; frames are skipped; raw depth is capped.
(define (jolt-frame-records k)
;; read the env at call time, not load time: a built binary runs top-level forms
;; at heap-build time, where this would always be unset.
(let ((debug? (getenv "JOLT_DEBUG_FRAMES")))
(guard (e (#t '()))
(let loop ((io (inspect/object k)) (n 0) (acc '()))
(if (or (not io) (fx>=? n 400))
(reverse acc)
(let* ((nm (srcreg-frame-name io))
(src (and nm (hashtable-ref source-registry nm #f)))
;; keep a frame that maps, or any named frame that isn't plumbing
(keep? (and nm (or src (not (srcreg-plumbing-name? nm))))))
(when (and debug? nm)
(display (string-append " [frame] " nm (if src " *MAPPED*"
(if keep? "" " (skipped)")) "\n")
(current-error-port)))
(loop (guard (e (#t #f)) (io 'link)) (fx+ n 1)
(if keep? (cons (cons nm src) acc) acc))))))))
;; Render a list of (frame-name . record) pairs (innermost/deepest first) to a
;; backtrace string. record is a source vector #(ns name file line) -> "ns/name
;; (file:line)", or 'ambiguous / #f -> the bare frame name. A run of the same
;; frame-name collapses to one "name (xN)" line (deep recursion, or a hot fn a
;; loop re-enters), and the number of distinct lines is capped.
(define (jolt-render-recs recs)
(let ((port (open-output-string)))
(let loop ((rs recs) (shown 0))
(if (or (null? rs) (fx>=? shown 30))
(get-output-string port)
(let* ((p (car rs)) (frame-name (car p)) (r (cdr p)))
;; count a maximal run of the same frame-name
(let run ((tail (cdr rs)) (cnt 1))
(if (and (pair? tail) (string=? (car (car tail)) frame-name))
(run (cdr tail) (fx+ cnt 1))
(begin
(put-string port " ")
(if (vector? r)
(let ((ns (vector-ref r 0)) (nm (vector-ref r 1))
(file (vector-ref r 2)) (line (vector-ref r 3)))
(put-string port ns) (put-string port "/") (put-string port nm)
(when (string? file)
(put-string port " (") (put-string port file)
(put-string port ":") (put-string port (number->string line))
(put-string port ")")))
(put-string port frame-name)) ; 'ambiguous / unmapped: bare name
(when (fx>? cnt 1)
(put-string port " (x") (put-string port (number->string cnt)) (put-string port ")"))
(put-char port #\newline)
(loop tail (fx+ shown 1))))))))))
;; Multi-line backtrace for an uncaught value. Two sources, in preference order:
;; 1. The tail-frame history ring (rt.ss), when JOLT_TRACE enabled it — an
;; execution history of the runtime-compiled fns entered before the throw,
;; INCLUDING ones TCO erased from the live continuation. Most-recent first.
;; 2. Otherwise the live continuation (jolt-frame-records) — the accurate but
;; TCO-truncated non-tail spine.
;; Each frame maps to "ns/name (file:line)" when registered, else its bare name.
;; #f when neither source yields a frame (the caller then prints just the location).
;; The tail-frame history ring rendered as a backtrace, or #f when tracing is off /
;; empty. A mapped frame is kept; else drop plumbing (same rule as the continuation
;; path) so the two sources read consistently.
(define (jolt-history-backtrace)
(let* ((hist (jolt-trace-snapshot))
(recs (let loop ((ns hist) (acc '()))
(if (null? ns)
(reverse acc)
(let* ((nm (car ns)) (src (hashtable-ref source-registry nm #f)))
(loop (cdr ns)
(if (or src (not (srcreg-plumbing-name? nm)))
(cons (cons nm src) acc) acc)))))))
(and (pair? recs) (jolt-render-recs recs))))
(define (jolt-backtrace-string v)
(or (jolt-history-backtrace)
(let ((k (jolt-error-continuation v)))
(and k
(let ((recs (jolt-frame-records k)))
(and (pair? recs) (jolt-render-recs recs)))))))
;; Exposed for the REPL / nREPL error paths, which catch errors themselves instead
;; of going through the uncaught reporter. Returns the " trace:\n<frames>" block
;; from the tail-frame HISTORY only — the live continuation in a REPL is just the
;; REPL's own machinery — or nil when tracing is off (so a caller can when-let).
(def-var! "jolt.host" "backtrace-string"
(lambda ()
(let ((bt (jolt-history-backtrace)))
(if bt (string-append " trace:\n" bt) jolt-nil))))
;; Render an uncaught jolt throw (any value, not just a Chez condition) to a port:
;; an ex-info shows its message + ex-data (+ a host cause); anything else is
;; pr-str'd. Shared by the cli (cli.ss) and a built binary's launcher (build.ss).
(define (jolt-render-throwable raw port)
(let ((v (jolt-unwrap-throw raw)))
(if (jolt=2 (jolt-get v jolt-kw-ex-type jolt-nil) jolt-kw-ex-info)
(begin
(display "Unhandled exception: " port)
(display (jolt-str-render-one (jolt-get v jolt-kw-message jolt-nil)) port)
(newline port)
(let ((data (jolt-get v jolt-kw-data jolt-nil)))
(unless (jolt-nil? data)
(display " ex-data: " port) (display (jolt-pr-str data) port) (newline port)))
(let ((cause (jolt-get v jolt-kw-cause jolt-nil)))
(when (condition? cause)
(display " cause: " port)
(display (with-output-to-string (lambda () (display-condition cause))) port)
(newline port))))
(begin
(display "Unhandled exception: " port)
(display (if (condition? v) (with-output-to-string (lambda () (display-condition v))) (jolt-pr-str v)) port)
(newline port)))))
;; Render the throwable, then its Clojure backtrace when one maps. The caller adds
;; any top-level source location (the runtime cli does; a built binary has none).
(define (jolt-report-throwable v port)
(jolt-render-throwable v port)
(let ((bt (jolt-backtrace-string v)))
(when bt (display " trace:\n" port) (display bt port))))

Some files were not shown because too many files have changed in this diff Show more