Compare commits

..

No commits in common. "main" and "early-defn-recompile" have entirely different histories.

315 changed files with 18895 additions and 44544 deletions

View file

@ -1,236 +0,0 @@
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

@ -1,7 +1,6 @@
name: tests
# Run the gate (make test) on every push and pull request. Chez is the sole
# substrate; the JVM is used only as the conformance oracle (certify).
# Run the full test suite (jpm test) on every push and pull request.
on:
push:
pull_request:
@ -9,65 +8,50 @@ on:
jobs:
test:
runs-on: ubuntu-latest
env:
JANET_VERSION: v1.41.2 # bump to match the version Jolt is developed against
# Per-file deadline for the clojure-test-suite battery. Finite files finish
# in well under 1s; the genuinely-infinite ones get killed at any deadline.
# A generous value gives slow CI runners headroom so a sub-second file
# spiking doesn't time out and drop total-pass below the baseline.
JOLT_SUITE_TIMEOUT: "20"
steps:
- uses: actions/checkout@v5
with:
submodules: recursive # vendor/irregex, used by the Chez regex shim
# Submodules: vendor/sci (SCI bootstrap/runtime tests) and
# vendor/clojure-test-suite (the cross-dialect conformance battery,
# asserted against a baseline by clojure-test-suite-test.janet).
submodules: recursive
# Build Chez from source rather than the distro package: the apt
# chezscheme ships petite+scheme only, with no kernel dev files
# (libkernel.a, scheme.h), so `jolt build` (the buildsmoke gate) can't link
# a binary and would skip. The source build provides them, plus the libs the
# kernel links against.
- name: Install build dependencies
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
id: cache-chez
uses: actions/cache@v4
- name: Cache Janet build
id: cache-janet
uses: actions/cache@v5
with:
path: /opt/chez
key: chez-${{ runner.os }}-v10.4.1-x11off
path: /tmp/janet
key: janet-${{ env.JANET_VERSION }}-${{ runner.os }}
- name: Build Chez Scheme from source
if: steps.cache-chez.outputs.cache-hit != 'true'
- name: Build Janet
if: steps.cache-janet.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
# --disable-x11: the expression editor's X11 clipboard isn't needed and
# would pull an X11 build/link dep.
./configure --installprefix=/opt/chez --threads --disable-x11
make -j"$(nproc)"
sudo make install
sudo chown -R "$USER" /opt/chez
git clone --depth 1 --branch "$JANET_VERSION" https://github.com/janet-lang/janet.git /tmp/janet
make -C /tmp/janet
- name: Put chez on PATH
- name: Install Janet
run: sudo make -C /tmp/janet install
- name: Install jpm
run: |
# Installed as `scheme`; the gate invokes `chez`. A wrapper that execs
# scheme keeps argv0 so Chez finds its boot files. Placed 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"
/opt/chez/bin/chez --version
git clone --depth 1 https://github.com/janet-lang/jpm.git /tmp/jpm
# bootstrap.janet resolves jpm/cli.janet relative to the cwd, so it
# must run from inside the jpm checkout.
cd /tmp/jpm
sudo janet bootstrap.janet
- name: Install JDK + Clojure (certify oracle)
run: |
sudo apt-get install -y default-jdk rlwrap
# --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
- name: Janet version
run: janet -v
- name: Gate
# `make ci` runs the behavior gates (corpus/unit/smoke/buildsmoke/sci/
# certify). buildsmoke now links a real binary (the source-built Chez has
# the kernel dev files). The self-host byte-fixpoint (make selfhost) is a
# dev-machine check — it only holds on the Chez that minted the seed. See
# jolt-8479.
run: make ci
- name: Build executable
run: jpm build
- name: Run tests
run: jpm test

4
.gitignore vendored
View file

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

3
.gitmodules vendored
View file

@ -1,6 +1,3 @@
[submodule "vendor/irregex"]
path = vendor/irregex
url = https://github.com/ashinn/irregex.git
[submodule "vendor/sci"]
path = vendor/sci
url = https://github.com/borkdude/sci.git

96
AGENTS.md Normal file
View file

@ -0,0 +1,96 @@
# 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 -->

70
CLAUDE.md Normal file
View file

@ -0,0 +1,70 @@
# 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
_Add your build and test commands here_
```bash
# Example:
# npm install
# npm test
```
## Architecture Overview
_Add a brief overview of your project architecture_
## Conventions & Patterns
_Add your project-specific conventions here_

367
LICENSE
View file

@ -1,179 +1,143 @@
Eclipse Public License - v 2.0
Eclipse Public License - v 1.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 content
Distributed under this Agreement, and
a) in the case of the initial Contributor, the initial code and
documentation distributed under this Agreement, and
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.
b) in the case of each subsequent Contributor:
"Contributor" means any person or entity that Distributes the Program.
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.
"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
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.
"Recipient" means anyone who receives the Program under this Agreement,
including all Contributors.
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.
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.
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.
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.
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.
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).
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.
3. REQUIREMENTS
3.1 If a Contributor Distributes the Program in any form, then:
A Contributor may choose to distribute the Program in object code form
under its own license agreement, provided that:
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
a) it complies with the terms and conditions of this Agreement; and
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;
b) its license agreement:
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;
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;
iii) does not attempt to limit or alter the recipients' rights
in the Source Code under section 3.2; and
ii) effectively excludes on behalf of all Contributors all liability for
damages, including direct, indirect, special, incidental and
consequential damages, such as lost profits;
iv) requires any subsequent distribution of the Program by any
party to be under a license that satisfies the requirements
of this section 3.
iii) states that any provisions which differ from this Agreement are
offered by that Contributor alone and not by any other party; and
3.2 When the Program is Distributed as Source Code:
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.
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
When the Program is made available in source code form:
b) a copy of this Agreement must be included with each copy of
the Program.
a) it must be made available under this Agreement; and
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.
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.
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
@ -181,97 +145,80 @@ 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, 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.
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.
6. DISCLAIMER OF LIABILITY
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.
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.
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.
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.
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.
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.

172
Makefile
View file

@ -1,172 +0,0 @@
# jolt — Clojure on Chez Scheme. Single substrate, no Janet.
#
# bin/joltc runs jolt directly off the checked-in seed (host/chez/seed/); there is no
# 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 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: 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: 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.
selfhost:
@sh host/chez/selfcheck.sh
# Value-model unit tests (nil/truthiness/collections on Chez).
values:
@chez --script test/chez/values-test.ss
# Corpus conformance vs JVM-sourced expecteds (allowlist + floor).
corpus:
@chez --script host/chez/run-corpus.ss
# Host-specific unit cases.
unit:
@chez --script host/chez/run-unit.ss
# Real-CLI smoke over bin/joltc.
smoke:
@sh host/chez/smoke.sh
# `jolt build` produces a working standalone binary.
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:
@chez --script test/chez/ffi-binding-test.ss
# Transients: mutable backing, snapshot on persistent!, and linear-time builds.
transient:
@chez --script test/chez/transient-test.ss
# Inference / success-type checking: drive jolt.passes.types directly and assert
# diagnostic counts + collected calls/escapes (the optimization pass the other
# gates don't exercise).
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.
directlink:
@chez --script test/chez/directlink-test.ss
# Hint-directed fast arithmetic: ^double/^long param hints (and float literals)
# lower arithmetic to Chez fl*/fx* ops; un-hinted integer code stays generic.
numeric:
@chez --script test/chez/numeric-test.ss
# IR inlining: a small single-arity defn is spliced at call sites (under optimize),
# with ^double/^long entry/return coercions carried through via :coerce nodes.
inline:
@chez --script test/chez/inline-test.ss
# Tree-shake soundness: build example apps (incl. deps.edn git-lib apps) default vs
# --tree-shake and require identical output. Slow (two builds per app); not in the
# default gate. Skips without the examples repo / Chez kernel dev files.
shakesmoke:
@sh host/chez/tree-shake-smoke.sh
# JVM oracle: certify the corpus against reference Clojure. Skips if clojure absent.
certify:
@if command -v clojure >/dev/null 2>&1; then \
clojure -M test/conformance/certify.clj; \
else \
echo "certify: clojure not on PATH — skipped"; \
fi
# Re-mint the seed after changing a seed source (reader/analyzer/backend/core).
remint:
@sh host/chez/remint.sh

398
README.md
View file

@ -2,233 +2,255 @@
[![tests](https://github.com/jolt-lang/jolt/actions/workflows/tests.yml/badge.svg)](https://github.com/jolt-lang/jolt/actions/workflows/tests.yml)
A Clojure implementation on [Chez Scheme](https://cisco.github.io/ChezScheme/).
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
`chez`). The conformance gate additionally uses Clojure on the JVM as an oracle,
but running jolt does not.
A Clojure implementation on top of [Janet](https://janet-lang.org). Jolt reads Clojure source and, by default, compiles each form to native Janet bytecode — falling back to a tree-walking interpreter for forms the compiler doesn't handle, so results always match the interpreter. It ships a Clojure-compatible standard library. The goal is a Janet-hosted [SCI](https://github.com/borkdude/sci)-style runtime with a minimal bootstrap.
## Build
There is no build step. The bootstrap seed (`host/chez/seed/{prelude,image}.ss`)
is checked in, so a fresh clone runs immediately:
```bash
git clone --recurse-submodules https://github.com/jolt-lang/jolt.git
git clone https://github.com/jolt-lang/jolt.git
cd jolt
bin/joltc -e '(+ 1 2)' # => 3
git submodule update --init # pulls vendor/sci and vendor/clojure-test-suite
jpm build # builds build/jolt and build/jolt-deps
```
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:
```bash
make remint # iterates host/chez/bootstrap.ss to a byte-fixpoint
```
Requires `jpm` and a recent Janet (CI-tested against 1.41). See
[docs/building-and-deps.md](docs/building-and-deps.md) for build details, the
`jpm clean` caveat, how namespaces are resolved (`JOLT_PATH`), and pulling
Clojure libraries from a `deps.edn` with the `jolt-deps` tool.
## Run
```bash
bin/joltc -e EXPR # evaluate a Clojure expression and print the result
```
build/jolt # start a REPL
build/jolt file.clj [args] # run a file (binds *command-line-args* and *file*)
build/jolt -e EXPR [args] # evaluate EXPR and print the result
build/jolt -m NS [args] # require NS and call its -main
build/jolt nrepl-server [addr] # start an nREPL server ([host:]port, default 7888)
build/jolt --version # print the version
build/jolt -h | --help # help
```
```bash
$ bin/joltc -e '(->> (range 10) (filter even?) (map (fn [x] (* x x))) (reduce +))'
120
$ bin/joltc -e '(/ 1 2)'
1/2
The REPL accumulates multi-line forms until they balance:
```
user=> (defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
#'user/fib
user=> (map fib (range 10))
(0 1 1 2 3 5 8 13 21 34)
```
## REPL and editor integration
Running a file evaluates its top-level forms:
```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
```
$ echo '(println "hello" (* 6 7))' > hello.clj
$ build/jolt hello.clj
hello 42
```
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`.
## Use as a library
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`.
```janet
(use jolt/api)
(def ctx (init))
(eval-string ctx "(+ 1 2)") # → 3
(eval-string ctx "(map inc [1 2 3])") # → (2 3 4) ; a lazy seq, like Clojure
```
`(init)` returns a context with `clojure.core` loaded. Each context is isolated; use separate contexts for separate environments.
### Evaluation pipeline: interpreted and compiled
Every form passes through one router (`loader/eval-toplevel`) that decides *per
form* whether to tree-walk it or compile it to Janet bytecode. The shipped
runtime **compiles by default**; set `JOLT_INTERPRET=1` to force the interpreter.
**Hybrid, always correct.** The compiler is incomplete by design: a form it can't
compile correctly throws `jolt/uncompilable`, and the router falls back to the
tree-walking interpreter (`eval-form`) for that form. So the result *always*
matches the interpreter — compilation is a transparent speedup, never a semantic
change. Only the compile step is guarded; runtime errors in compiled code
propagate normally (no double-evaluation, no hidden errors).
What compiles: `def`/`defn`, multi-arity / named / variadic fns, `recur` (in
`loop` and directly in `fn`), `let`/`if`/`do`/`try`/`throw`/`quote`, map and
vector literals, and calls. What falls back to the interpreter: context-modifying
and definitional forms (`ns`, `defmacro`, `deftype`, `defprotocol`,
`defmulti`/`defmethod`, `reify`, `require`, `binding`, …), destructuring, regex
literals, and the handful of interpreter-only special forms.
**Live redefinition.** Compiled global references deref through Jolt **var cells**
(Janet early-binds plain symbols, which would freeze redefinition), so redefining
a `def`/`defn` at the REPL is visible to already-compiled callers — Clojure's var
model. Hot numeric primitives (`+ - * < > <= >=`) emit native Janet ops, and
calls compile to direct Janet calls.
```janet
(def ctx (init {:compile? true}))
(eval-string ctx "(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))")
(eval-string ctx "(fib 30)") ; → 832040, native Janet bytecode
```
For compute-heavy code the compiled path is dramatically faster than tree-walking,
at native Janet speed.
**Validated at parity.** The conformance suite passes 258/258 under *all three*
execution paths — interpreter, compiler, and the self-hosted compiler
(`conformance-test.janet` runs all three in CI) — and the full clojure-test-suite
matches its baseline across ~4.6k assertions — evidence the hybrid path doesn't
diverge.
**AOT.** `aot.janet` marshals a compiled namespace to a Janet bytecode image
(`save-ns`) and loads it back into a fresh context (`load-ns-image`), skipping
parse/analyze/emit/compile on reload. Core fns are referenced by name against the
baked-in runtime; only user bytecode and var cells are serialized.
## Host interop
Jolt exposes CLJS-style host interop through `.` on any Janet table or struct — a field holding a function is called with the receiver as the first argument:
```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!)
(def obj {:greet (fn [self name] (str "Hello " name))})
(. obj greet "Alice") ; → "Hello Alice"
(.-greet obj) ; field access (reader sugar for (. obj :greet))
```
## Compile a binary
### The `janet` interop bridge
`bin/joltc build` ahead-of-time compiles a project into a single self-contained
executable — the runtime, `clojure.core`, the standard library, the app, and its
`deps.edn` dependencies are linked in, so the result needs no Chez install, no
JVM, and no source on disk to run.
The whole Janet standard library is reachable from Clojure through an explicit
`janet` namespace segment, which marks every crossing into host code (where
Clojure semantics no longer hold):
```clojure
(janet.os/clock) ; → a Janet module fn: os/clock
(janet.string/join ["a" "b"] ",") ; → janet `string/join` (NB: takes a Janet
; tuple, not a Jolt vector — convert first)
(janet/slurp "deps.edn") ; → a Janet root builtin: slurp
(janet/type [1 2]) ; → :table
```
The rule is `janet/<name>` for a Janet root binding and `janet.<module>/<name>`
for a module binding. Because the boundary is explicit, you can tell at the call
site that a form drops into the host — and that values cross the boundary as
their Janet representations (a Jolt vector is a Janet table, etc.), so a Janet
function expecting a tuple needs an explicit conversion. The `jolt.interop`,
`jolt.shell`, and `jolt.http` namespaces are thin Clojure wrappers built on this.
This bridge is what makes networking (and everything else in Janet's stdlib)
available to ordinary Clojure — for example, `jolt.nrepl` (below) is plain
Clojure over `janet.net/*`.
```clojure
(require '[jolt.interop :as j])
(j/janet-type [1 2]) ; → :tuple
(j/janet-table-keys {:a 1 :b 2}) ; → [:b :a]
```
## nREPL
Jolt ships an [nREPL](https://nrepl.org) server and client (`jolt.nrepl`),
written in Clojure on top of the `janet.net/*` bridge. Start a server from the
CLI — it writes `.nrepl-port` so editors (CIDER, Calva, …) auto-connect:
```bash
bin/joltc build -m myapp.core -o myapp # compile myapp.core's -main into ./myapp
./myapp arg1 arg2 # runs anywhere; args reach -main
jolt nrepl-server # listen on 127.0.0.1:7888, write .nrepl-port
jolt nrepl-server 12345 # choose a port
jolt nrepl-server 0.0.0.0:12345 # choose host and port (alias: nrepl)
```
Modes trade dynamism for speed: the default (release) build uses the proven code
generator; `--opt` also runs the inference + inlining + scalar-replacement passes
over the closed-world program; `--dev` is unoptimized.
Supported ops: `clone`, `describe`, `eval`, `load-file`, `close`, `ls-sessions`,
`interrupt` (acknowledged; an in-flight eval can't actually be interrupted), and
`eldoc`. `eval` streams `out`, reports the current `ns`, evaluates each form in
the message, and returns an `eval-error` status (the session stays usable) on
failure. One Jolt runtime backs the server and sessions share it, so `def`s
persist across a connection like a normal dev REPL.
Two opt-in closed-world flags cut dispatch cost and binary size:
It's also usable as a library — embed a server, or drive another nREPL as a
client:
```bash
bin/joltc build -m myapp.core --direct-link # app->app calls bind directly (no var lookup)
bin/joltc build -m myapp.core --tree-shake # ship only code reachable from -main
```clojure
(require '[jolt.nrepl :as nrepl])
(def server (nrepl/start-server! {:port 7888}))
;; ... later ...
(nrepl/stop-server! server)
(def c (nrepl/connect {:port 7888}))
(def session (nrepl/client-clone c))
(nrepl/client-eval c "(+ 1 2)" session) ; → responses incl. {"value" "3"}
(nrepl/client-close c)
```
`--tree-shake` walks the call graph across your app, its libraries, and
`clojure.core`, drops everything unreachable from `-main` (and the compiler itself
when the app never `eval`s), and typically removes 12 MB. It stays sound by bailing
out — keeping everything, and reporting which library is responsible — when reachable
code resolves vars by name at runtime (`eval`/`resolve`/`ns-resolve`/…). See
[docs/tools-deps.md](docs/tools-deps.md) and `docs/rfc/0007`.
This needs Chez's kernel development files (`libkernel.a`, `scheme.h`) and a C
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,
vars/namespaces, host interop) hosts a portable Clojure overlay split across two
source roots by *when* they load:
- **`jolt-core/`** is baked into the seed — the compiler (`jolt-core/jolt/`:
reader/analyzer/IR/backend, plus `jolt.main`/`jolt.deps`) and `clojure.core` in
dependency-ordered tiers (`jolt-core/clojure/core/NN-*.clj`). Changing anything
here means re-minting the seed.
- **`stdlib/`** loads lazily at runtime off the source roots — the rest of the
standard library (`clojure.string`/`set`/`walk`/`edn`/`pprint`/…) plus the
`jolt.ffi` host library. Editing these needs no re-mint.
`bin/joltc` loads the checked-in seed and the spine, then compiles and evaluates 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).
## Differences from Clojure
Jolt targets Clojure semantics but runs on Chez, not the JVM. Most portable
Clojure runs unchanged — persistent collections (32-way-trie vectors, HAMT
maps/sets), the numeric tower (exact integers, bignums, ratios, doubles), lazy
and infinite sequences, transducers, destructuring, multimethods with
hierarchies, protocols/records (`deftype`/`defrecord`/`reify`/`extend-protocol`),
metadata, namespaces, atoms, `future`/`promise`/`agent`/`pmap`,
`clojure.core.async`, runtime `eval`/`load-string`/`defmacro`, and the full
reader (`#()`, `#_`, `#?`, tagged literals, `#"…"`) all behave as on the JVM.
`=` is category-aware (`(= 3 3.0)``false`) and `==` is value-equality, as in
Clojure. The genuine divergences:
Jolt targets Clojure semantics but runs on Janet, not the JVM. The notable divergences:
- **No JVM, no Java interop.** No reflection, no `gen-class`/`proxy`. Interop
syntax (`Class.`, `Class/static`, `.method`) resolves only against a shimmed
subset of the `java.*` standard library; a class token is a name, not a loaded
class. See [docs/host-interop.md](docs/host-interop.md). To call C libraries
directly, use the `jolt.ffi` foreign-function interface (how the db and
http-client libraries bind SQLite/libpq and sockets/OpenSSL/zlib).
- **No `BigDecimal`.** `decimal?` is always false and there is no `M` literal;
the rest of the numeric tower matches the JVM.
- **No STM.** No `ref`/`dosync`/`alter`/`commute` — coordinated shared state uses
atoms (per-atom mutex, JVM-style CAS). The concurrency primitives above are
otherwise present and run on a shared heap.
- **Regex engine.** Patterns compile through
[irregex](https://github.com/ashinn/irregex) (vendored), not
`java.util.regex`; common patterns work, Java-specific features can differ.
- **Coverage.** `clojure.core` is implemented function by function against the
JVM-sourced conformance corpus — broad but not total; a namespace can load with
most functions working and a few not yet implemented.
- **Host platform.** No JVM and no Java interop — `import`, `gen-class`, `proxy` of Java classes, and `java.*` are unavailable. `instance?` recognizes a small set of built-in types (`clojure.lang.Atom`, `Number`, `String`, …).
- **Numbers.** Janet integers and doubles. `(/ 1 3)` is `0.3333…` and large products lose precision. No ratios or `BigDecimal` (`ratio?` is always false, `bigdec` falls back to a double); `bigint`/`biginteger` use Janet's 64-bit `int/s64`, not arbitrary precision. The reader still accepts Clojure's numeric literal syntaxes — the BigInt/BigDecimal suffixes (`42N`, `1.5M`), ratios (`1/2`), radixed integers (`2r1010`, `16rFF`), and exponents (`1e3`) — but reads them as plain Janet numbers (a ratio becomes its double quotient). The auto-promoting `+'`/`-'`/`*'`/`inc'`/`dec'` are aliases for the plain ops, since Janet numbers don't overflow. `quot`/`rem`/`mod` follow Clojure's sign rules. The symbolic values `##Inf`/`##-Inf`/`##NaN` read, and `infinite?`/`NaN?` work. Janet represents an integer and an integer-valued double identically, so `1` and `1.0` are indistinguishable: `(float?/double? 1.0)` is `false` and `(int? 1.0)` is `true``float?`/`double?` are true only for values with a fractional part or `##Inf`/`##NaN`.
- **Collections.** By default Jolt uses immutable persistent data structures: vectors are 32-way branching tries (structural-sharing persistent vectors with O(log₃₂ n) `conj`/`assoc`/`nth`), lists are persistent singly-linked cons cells (O(1) `conj`/`cons` prepend with structural sharing), and maps/sets are persistent hash structures. Value equality and sequence operations are Clojure-compatible, but hash-map/hash-set iteration order is unspecified and differs from Clojure — use `sorted-map`/`sorted-set` when order matters.
- **Mutable build mode.** Jolt can be compiled to use fast Janet-native *mutable* collections instead, via a build-time flag: `JOLT_MUTABLE=1 jpm build` (default `jpm build` is immutable). In mutable mode vectors and lists share one mutable array representation (so `conj` mutates in place and appends, and `vector?`/`list?` no longer distinguish them) — a performance/looseness trade-off. The default immutable build has full Clojure value semantics.
- **Concurrency / STM.** No refs, `dosync`, agents, or `send`; `locking` evaluates its body without real locking. Atoms, volatiles, promises, and delays are supported.
- **Futures.** `future` runs its body on a *real* OS thread (Janet's `ev/thread`), so it can use a second core for CPU-bound work — unlike the cooperatively-scheduled `go` blocks. `deref`/`@` parks until the result is ready (with the optional `(deref f timeout-ms timeout-val)` arity); `future?`, `future-done?`, `realized?`, `future-cancel`, and `future-cancelled?` are supported. Two important divergences from the JVM: (1) **snapshot semantics** — Janet threads have separate heaps, so the body and the state it closes over are *copied* to the worker thread and only the return value is copied back; mutating a captured atom does not propagate to the parent (communicate via the return value). (2) **no thread interruption** — Janet OS threads can't be cancelled mid-run, so `future-cancel` marks the *future* cancelled (deref then throws and the predicates flip) but the underlying computation still runs to completion in the background. As on the JVM, a live future thread keeps the process alive until it finishes (the JVM's non-daemon future pool behaves the same).
- **core.async.** `clojure.core.async` runs on Janet fibers and channels (`chan`, `go`, `go-loop`, `<!`/`>!`/`<!!`/`>!!`, `close!`, `alts!`, `timeout`, `put!`/`take!`, `buffer`/`dropping-buffer`/`sliding-buffer`, and channel transducers via `(chan n xform)`). Because Janet fibers are stackful coroutines, a `go` block is just its body run in a fiber — no CPS/state-machine rewrite — so `<!`/`>!` work *anywhere*, including inside `try`, nested `fn`s, and loops (positions Clojure's `go` macro forbids). Go blocks are cooperatively scheduled on one OS thread, so parking (`<!`) and blocking (`<!!`) coincide; `thread` runs cooperatively too. Dynamic-var bindings are conveyed into `go` blocks (each go block sees the bindings in effect when it was spawned).
- **Regex.** Compiled to Janet's PEG engine (Janet has no regex). Supported: capturing groups (`[whole g1 …]`), greedy and lazy quantifiers with backtracking, `(?:…)`, lookahead `(?=…)`/`(?!…)`, alternation, anchors `^ $ \b \B`, character classes, and the `(?i)` flag. Not supported: lookbehind, backreferences (`\1`), named groups (`(?<name>…)`), and Unicode property classes (`\p{Lu}`).
- **Arrays.** Java-style arrays map onto Janet's native types: `byte-array` is a Janet buffer (contiguous, C-backed); `object-array`/`int-array`/`double-array`/etc. are Janet arrays. `aget`/`aset`/`alength`/`aclone` work over both.
- **Transients.** `transient`/`conj!`/`assoc!`/`dissoc!`/`disj!`/`pop!`/`persistent!` are real mutable scratch collections backed by Janet's native arrays and tables (vectors → arrays, maps/sets → tables), so building a collection with them avoids the per-step copying of the persistent path (notably for maps/sets). `persistent!` freezes back to a persistent value.
- **Not implemented.** JVM reflection, `proxy`, and the `clojure.repl`/`clojure.template` namespaces.
Supported and Clojure-compatible: chars as a distinct type, lazy/infinite sequences, transducers, destructuring, multimethods with hierarchies, protocols/records (`deftype`/`defrecord`/`reify`/`extend-protocol`), metadata, namespaces, and the reader (`#()`, `#_`, `#?`, tagged literals, `#"…"`).
## Test
```bash
make test # the full gate
make corpus # conformance corpus vs the JVM-sourced spec
make unit # host-specific unit cases
make selfhost # bootstrap fixpoint (rebuild == checked-in seed)
make smoke # bin/joltc CLI smoke
make sci # load borkdude/sci's source through joltc (compat stress)
make ffi # HTTP-server GC-safety + http-client temp paths
make transient # transient mutation + linear-time builds
make certify # JVM oracle (skips if clojure is absent)
```
jpm test # full suite (recurses test/)
janet test/spec/sequences-spec.janet # a single spec
janet test/integration/conformance-test.janet
```
The conformance corpus (`test/chez/corpus.edn`) is a host-neutral language spec
whose expected values are sourced from reference JVM Clojure. See
[test/conformance/SPEC.md](test/conformance/SPEC.md).
Tests are organized in three layers:
- **`test/spec/`** — the contract. Black-box, behavior-defining tables (one file
per public API area) that collectively pin down Jolt's defined behavior. This
is the authoritative description of what Jolt promises.
- **`test/integration/`** — cross-cutting and regression batteries: the Clojure
conformance suite (run in all three execution modes), SCI bootstrap/runtime
loading, jank conformance, the cross-dialect
[clojure-test-suite](https://github.com/jank-lang/clojure-test-suite) (a git
submodule at `vendor/clojure-test-suite`, run via a minimal `clojure.test` shim
and baseline-guarded), compile-mode tests, the library API, and a broad
systematic-coverage net.
- **`test/unit/`** — white-box tests for individual components (reader,
evaluator, types, persistent collections, regex, compiler).
`test/support/harness.janet` provides the shared `defspec` table runner (cases
are `["label" expected actual]`, compared with Jolt's own `=`) plus
`expect=`/`expect-throws` for unit tests.
The syntactic half of the contract — the surface syntax the reader accepts — is
specified as an EBNF grammar in [`docs/grammar.ebnf`](docs/grammar.ebnf), with
Jolt-vs-Clojure deviations noted inline. `test/spec/reader-syntax-spec.janet`
exercises it.
### clojure-test-suite conformance
The [clojure-test-suite](https://github.com/jank-lang/clojure-test-suite) battery
(vendored as a git submodule) runs ~3980 assertions green. Jolt validates its
arguments like Clojure — arithmetic on non-numbers, comparisons against `nil`,
out-of-range indices, malformed `conj!`/`assoc!`/`merge`, non-seqable
`first`/`seq`/`vec`, and lazy transformers (`map`/`filter`/…) realized over a
non-seqable all throw. The lazy seq fns return seqs (not vectors), so
`seq?`/`vector?`/`sequential?` of their results match Clojure. The assertions
that remain failing are accounted for by the platform/design differences above,
not by missing behavior:
- **No bignum/ratio/BigDecimal**`bigint`/`numerator`/`denominator`/`bigdec`,
the `big-int?`/auto-promotion checks, and the `2N`/`1/2`/`1.0M` literals read
but don't carry those exact types.
- **Integer/float identity** — Janet represents `1` and `1.0` identically, so
`quot`/`rem`/`mod`'s `double?`/`int?` result-type assertions and many
`float?`/`double?` cases can't distinguish them (`(str 0.0)` is `"0"`).
- **64-bit integers / Unicode**`bit-and` etc. on full-width 64-bit constants
lose precision (doubles), and `subs`/`count` work on bytes, not code points.
## License
[Eclipse Public License 2.0](https://www.eclipse.org/legal/epl-2.0/)
[Eclipse Public License 1.0](https://opensource.org/licenses/EPL-1.0)

1
bench/.gitignore vendored
View file

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

View file

@ -1,120 +0,0 @@
# jolt benchmark suite
Benchmarks that isolate the workload axes jolt's optimizing passes target. The
ray tracer (`examples/ray-tracer`) is **float-compute-bound** — its time is
irreducible algorithmic math (hit-testing + transcendentals), and devirt,
allocation removal, and type-proving all measured **flat** on it. So it can't
tell us whether those passes work. These benchmarks make each pass's target
workload the *dominant* cost.
Reference: the cross-language suites these draw from —
[Are We Fast Yet?](https://github.com/smarr/are-we-fast-yet) (Marr et al., DLS '16)
and the [Computer Language Benchmarks Game](https://benchmarksgame-team.pages.debian.net/benchmarksgame/).
The benchmarks are portable Clojure, so they also run on JVM Clojure for an
absolute reference.
## Benchmarks
| Benchmark | Axis | Pass it exercises | Source |
|---|---|---|---|
| `binary-trees` | allocation / GC pressure (escaping short-lived records) | scalar-replace, escape analysis | CLBG |
| `dispatch` | polymorphic (**megamorphic**) protocol dispatch | devirt, inline-cache | AWFY-style |
| `mono-dispatch` | **monomorphic** protocol dispatch (devirt/inline-cache *can* fire) | devirt, inline-cache | AWFY-style |
| `collections` | persistent map/vector churn (HAMT / 32-way tries) | persistent structures, transients | CLBG k-nucleotide-style |
| `mandelbrot` | pure float compute (tight arith loops, no alloc/dispatch) | native arith, loop codegen | CLBG |
| `fib` | recursion: function-call + integer-arith overhead | native arith, small-fn inlining | CLBG |
What the ray tracer does **not** capture and these do: allocation as the
bottleneck (~7% there), megamorphic *and* monomorphic dispatch (its dispatch is
monomorphic and cheap), persistent-collection throughput (it uses fixed records,
no collections in the hot loop), and isolated compute/call overhead.
Planned additions: Richards / DeltaBlue (heavier OO dispatch), NBody (float
control with record state), k-nucleotide proper.
## Holistic scorecard
`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.
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 # 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). 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

@ -1,53 +0,0 @@
;; binary-trees (Computer Language Benchmarks Game) — an ALLOCATION/GC stress
;; test. Builds and discards millions of short-lived `Node` records; the nodes
;; ESCAPE (stored in the tree, walked later), so this is the regime escape analysis
;; targets and the ray tracer never exercises (~7% alloc).
;;
;; Portable Clojure: runs on jolt and JVM Clojure for cross-impl comparison.
;; bench/run.sh binary-trees 14
(ns binary-trees)
(defrecord Node [left right])
(defn make-tree [depth]
(if (zero? depth)
(->Node nil nil)
(->Node (make-tree (dec depth)) (make-tree (dec depth)))))
(defn check-tree [node]
(let [l (:left node)]
(if (nil? l)
1
(+ (+ 1 (check-tree l)) (check-tree (:right node))))))
(defn run [max-depth]
(let [min-depth 4
stretch-depth (inc max-depth)
_ (check-tree (make-tree stretch-depth))
long-lived (make-tree max-depth)]
(loop [d min-depth acc 0]
(if (<= d max-depth)
(let [iterations (bit-shift-left 1 (+ (- max-depth d) min-depth))
sum (loop [i 0 s 0]
(if (< i iterations)
(recur (inc i) (+ s (check-tree (make-tree d))))
s))]
(recur (+ d 2) (+ acc sum)))
;; touch the long-lived tree so it isn't dead-code-eliminated
(+ acc (check-tree long-lived))))))
(defn -main [& args]
(let [max-depth (if (seq args) (Integer/parseInt (first args)) 14)]
(dotimes [_ 2] (run (min max-depth 10))) ; warmup
(let [runs 3
times (mapv (fn [_]
(let [t0 (System/nanoTime)
r (run max-depth)
ms (/ (- (System/nanoTime) t0) 1000000.0)]
[ms r]))
(range runs))
mss (mapv first times)
mean (/ (reduce + mss) runs)]
(println "binary-trees depth" max-depth "checksum" (second (first times)))
(println "runs:" (mapv (fn [t] (/ (Math/round (* t 10.0)) 10.0)) mss))
(println "mean:" (/ (Math/round (* mean 10.0)) 10.0) "ms"))))

View file

@ -1,46 +0,0 @@
;; collections — PERSISTENT-COLLECTION churn. Builds and reads persistent maps
;; and vectors (32-way hash/array tries) under heavy assoc/update/conj/lookup, a
;; word-count-style workload (cf. CLBG k-nucleotide). Exercises jolt's persistent
;; data structures and (eventually) transients — an axis the ray tracer (fixed
;; records, no collections in the hot loop) doesn't touch.
;;
;; Portable Clojure (jolt + JVM Clojure).
;; bench/run.sh collections 200000
(ns collections)
;; map churn: accumulate a frequency map over a stream of keys, then sum it back
(defn freq-map [n buckets]
(loop [i 0 m {}]
(if (< i n)
(recur (inc i)
(let [k (mod (* i 2654435761) buckets)]
(assoc m k (+ 1 (get m k 0)))))
m)))
(defn sum-vals [m]
(reduce (fn [acc k] (+ acc (get m k))) 0 (keys m)))
;; vector churn: conj many, then reduce
(defn vec-sum [n]
(let [v (loop [i 0 v []] (if (< i n) (recur (inc i) (conj v (mod i 1000))) v))]
(reduce + 0 v)))
(defn run [n]
(let [m (freq-map n 4096)]
(+ (sum-vals m) (vec-sum (quot n 4)))))
(defn -main [& args]
(let [n (if (seq args) (Integer/parseInt (first args)) 200000)]
(dotimes [_ 2] (run (quot n 4))) ; warmup
(let [runs 3
times (mapv (fn [_]
(let [t0 (System/nanoTime)
r (run n)
ms (/ (- (System/nanoTime) t0) 1000000.0)]
[ms r]))
(range runs))
mss (mapv first times)
mean (/ (reduce + mss) runs)]
(println "collections n" n "result" (second (first times)))
(println "runs:" (mapv (fn [t] (/ (Math/round (* t 10.0)) 10.0)) mss))
(println "mean:" (/ (Math/round (* mean 10.0)) 10.0) "ms"))))

View file

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

View file

@ -1,56 +0,0 @@
;; dispatch — a POLYMORPHIC-DISPATCH stress test. A protocol method is called in
;; a hot loop over a heterogeneous (megamorphic) collection of record types, with
;; minimal per-call work, so protocol dispatch dominates. This is the regime
;; devirtualization and the inline-cache target, and the one the ray
;; tracer can't reveal — its dispatch is monomorphic and a small fraction of the
;; float-math cost (devirt measured FLAT there).
;;
;; Portable Clojure (jolt + JVM Clojure).
;; bench/run.sh dispatch 20000
(ns dispatch)
(defprotocol Shape
(area [s])
(sides [s]))
(defrecord Circle [r] Shape (area [_] (* (* 3.14159 r) r)) (sides [_] 0))
(defrecord Square [s] Shape (area [_] (* s s)) (sides [_] 4))
(defrecord Triangle [b h] Shape (area [_] (* (* 0.5 b) h)) (sides [_] 3))
(defrecord Rect [w h] Shape (area [_] (* w h)) (sides [_] 4))
(defn build-shapes [n]
(mapv (fn [i]
(let [k (mod i 4)]
(cond
(= k 0) (->Circle (+ 1 (mod i 7)))
(= k 1) (->Square (+ 1 (mod i 5)))
(= k 2) (->Triangle (+ 1 (mod i 3)) (+ 2 (mod i 6)))
:else (->Rect (+ 1 (mod i 4)) (+ 1 (mod i 8))))))
(range n)))
;; megamorphic: every element may be a different type -> the call site sees all 4
(defn sum-area [shapes]
(reduce (fn [acc s] (+ (+ acc (area s)) (sides s))) 0.0 shapes))
(defn run [iters]
(let [shapes (build-shapes 1000)]
(loop [i 0 acc 0.0]
(if (< i iters)
(recur (inc i) (+ acc (sum-area shapes)))
acc))))
(defn -main [& args]
(let [iters (if (seq args) (Integer/parseInt (first args)) 20000)]
(dotimes [_ 2] (run (quot iters 4))) ; warmup
(let [runs 3
times (mapv (fn [_]
(let [t0 (System/nanoTime)
r (run iters)
ms (/ (- (System/nanoTime) t0) 1000000.0)]
[ms r]))
(range runs))
mss (mapv first times)
mean (/ (reduce + mss) runs)]
(println "dispatch iters" iters "result" (second (first times)))
(println "runs:" (mapv (fn [t] (/ (Math/round (* t 10.0)) 10.0)) mss))
(println "mean:" (/ (Math/round (* mean 10.0)) 10.0) "ms"))))

View file

@ -1,29 +0,0 @@
;; fib — naive recursive Fibonacci: pure function-call + integer-arithmetic
;; throughput, with no allocation, dispatch, or collections. Isolates call
;; overhead and native integer arith, and is the natural target for
;; single-call-site / small-fn inlining and self-call direct-linking.
;;
;; Portable Clojure (jolt + JVM Clojure).
;; bench/run.sh fib 32
(ns fib)
(defn fib [n]
(if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
(defn run [n] (fib n))
(defn -main [& args]
(let [n (if (seq args) (Integer/parseInt (first args)) 32)]
(dotimes [_ 2] (run (- n 6))) ; warmup
(let [runs 3
times (mapv (fn [_]
(let [t0 (System/nanoTime)
r (run n)
ms (/ (- (System/nanoTime) t0) 1000000.0)]
[ms r]))
(range runs))
mss (mapv first times)
mean (/ (reduce + mss) runs)]
(println "fib n" n "result" (second (first times)))
(println "runs:" (mapv (fn [t] (/ (Math/round (* t 10.0)) 10.0)) mss))
(println "mean:" (/ (Math/round (* mean 10.0)) 10.0) "ms"))))

View file

@ -1,52 +0,0 @@
;; mandelbrot — pure floating-point compute: for each point of an NxN grid,
;; iterate z = z^2 + c up to a cap and count iterations. No allocation, no
;; dispatch, no collections in the hot loop — just double arithmetic and tight
;; recur loops. This isolates the irreducible-math axis the ray tracer is bound
;; on (where devirt/alloc passes measured flat), so it tracks native-arith codegen
;; and loop quality directly.
;;
;; 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]
(if (or (>= i cap) (> (+ (* zr zr) (* zi zi)) 4.0))
i
(recur (inc i)
(+ (- (* zr zr) (* zi zi)) cr)
(+ (* 2.0 (* zr zi)) ci)))))
(defn run [n]
(let [cap 200
nd (* 1.0 n)]
(loop [y 0 acc 0]
(if (< y n)
(let [ci (- (/ (* 2.0 y) nd) 1.0)
row (loop [x 0 a 0]
(if (< x n)
(let [cr (- (/ (* 2.0 x) nd) 1.5)]
(recur (inc x) (+ a (count-point cr ci cap))))
a))]
(recur (inc y) (+ acc row)))
acc))))
(defn- run-bench [args]
(let [n (if (seq args) (Integer/parseInt (first args)) 1000)]
(dotimes [_ 2] (run (quot n 2))) ; warmup
(let [runs 3
times (mapv (fn [_]
(let [t0 (System/nanoTime)
r (run n)
ms (/ (- (System/nanoTime) t0) 1000000.0)]
[ms r]))
(range runs))
mss (mapv first times)
mean (/ (reduce + mss) runs)]
(println "mandelbrot n" n "result" (second (first times)))
(println "runs:" (mapv (fn [t] (/ (Math/round (* t 10.0)) 10.0)) mss))
(println "mean:" (/ (Math/round (* mean 10.0)) 10.0) "ms"))))
(defn -main [& args]
(run-bench args))

View file

@ -1,36 +0,0 @@
;; 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

@ -1,45 +0,0 @@
;; mono-dispatch — protocol dispatch where every call site sees ONE record type
;; (monomorphic). This is the regime where devirtualization and a
;; call-site inline cache CAN fire — the megamorphic `dispatch` bench deliberately
;; defeats them, so this is its complement: it measures how close a proven/cached
;; monomorphic dispatch gets to a direct call. Same per-call work as `dispatch`.
;;
;; Portable Clojure (jolt + JVM Clojure).
;; bench/run.sh mono-dispatch 20000
(ns mono-dispatch)
(defprotocol Shape
(area [s])
(sides [s]))
(defrecord Circle [r] Shape (area [_] (* (* 3.14159 r) r)) (sides [_] 0))
;; homogeneous: every element is a Circle -> the call site is monomorphic
(defn build-shapes [n]
(mapv (fn [i] (->Circle (+ 1 (mod i 7)))) (range n)))
(defn sum-area [shapes]
(reduce (fn [acc s] (+ (+ acc (area s)) (sides s))) 0.0 shapes))
(defn run [iters]
(let [shapes (build-shapes 1000)]
(loop [i 0 acc 0.0]
(if (< i iters)
(recur (inc i) (+ acc (sum-area shapes)))
acc))))
(defn -main [& args]
(let [iters (if (seq args) (Integer/parseInt (first args)) 20000)]
(dotimes [_ 2] (run (quot iters 4))) ; warmup
(let [runs 3
times (mapv (fn [_]
(let [t0 (System/nanoTime)
r (run iters)
ms (/ (- (System/nanoTime) t0) 1000000.0)]
[ms r]))
(range runs))
mss (mapv first times)
mean (/ (reduce + mss) runs)]
(println "mono-dispatch iters" iters "result" (second (first times)))
(println "runs:" (mapv (fn [t] (/ (Math/round (* t 10.0)) 10.0)) mss))
(println "mean:" (/ (Math/round (* mean 10.0)) 10.0) "ms"))))

View file

@ -1,70 +0,0 @@
#!/bin/sh
# Run the jolt benchmark suite against JVM Clojure and print a jolt/JVM scorecard.
#
# 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 # 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)
#
# 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"
# 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"
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"
run_one() {
ns="${1%%:*}"; arg="${2:-${1##*:}}"
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 jolt %9s ms\n' "$ns" "${jmean:--}"
fi
}
if [ -n "$1" ]; then
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 — optimized AOT binaries${NO_JVM:+ }${NO_JVM:-, vs JVM Clojure}"
for spec in $BENCHES; do run_one "$spec"; done
fi

View file

@ -1,41 +0,0 @@
#!/bin/sh
# joltc — the pure-Chez jolt runtime. NO Janet.
#
# Compiles and evaluates jolt (Clojure) on Chez using the checked-in bootstrap
# seed (host/chez/seed/). With only Chez installed it runs jolt end to end:
#
# joltc -e "(+ 1 2)" evaluate an expression
# joltc run -m app.core [args] resolve deps.edn, run a namespace's -main
# joltc -M:alias [args] run an alias's :main-opts
# joltc repl | path | <task> REPL, print roots, or a deps.edn task
#
# The launcher cd's to the jolt repo root so the runtime's relative loads work;
# the user's original cwd (the project dir, where deps.edn lives) is passed in
# JOLT_PWD.
root="$(CDPATH= cd -- "$(dirname -- "$0")/.." && 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 "$@"

View file

@ -1,97 +0,0 @@
# Module map
Where things live and what to read before changing them. Start here to answer
"where does feature X live?" and "what else do I need to touch?"
## Areas
| Area | Directory | Responsibility | Re-mint? |
| --- | --- | --- | --- |
| Chez runtime | `host/chez/*.ss` | The substrate: value model, persistent collections, seqs, vars/namespaces, host interop, native `clojure.core` shims, regex, FFI, IO, the **reader**. Composed by `rt.ss`. | only `reader.ss` |
| Compiler | `jolt-core/jolt/*.clj` | analyzer → IR → backend, the optimization passes, the CLI, the deps resolver, nREPL. Baked into the seed. | **yes** |
| `clojure.core` overlay | `jolt-core/clojure/core/NN-*.clj` | Portable `clojure.core` in dependency-ordered tiers (`00-syntax``50-io`); the `NN` prefix *is* the load order. | **yes** |
| Stdlib | `stdlib/clojure/*.clj` | Lazily-loaded portable namespaces (string/set/walk/edn/pprint/zip/test/data). | no |
| Build & tooling | `host/chez/build.ss`, `emit-image.ss`, `compile-eval.ss`, `loader.ss`, `cli.ss`, `bootstrap.ss` | AOT binary build, cross-compile, runtime eval/load, CLI spine, seed mint. | no (except via `reader.ss`) |
| Tests & gate | `test/chez/`, `test/conformance/`, `host/chez/run-*.ss`, `Makefile` | Corpus (JVM oracle), unit, per-feature tests. Every `make` target has a comment. | no |
**The reader is in `host/chez/reader.ss`** (Scheme, a seed source) — *not* in
`jolt-core/jolt/` with the rest of the compiler. Re-mint applies to it.
`rt.ss` is the runtime's load-order manifest: it `(load …)`s every shim in
dependency order with a per-file comment. Read it to see how the runtime is
composed and where a given `.ss` fits.
## `host/chez/*.ss` by family
- **Value model**: `values.ss` (nil/numbers/keywords/symbols), `collections.ss`
(persistent vec + HAMT map/set), `seq.ss` + `lazy-bridge.ss` (seqs, lazy-seqs),
`transients.ss`, `records.ss` + `records-interop.ss`.
- **Native `clojure.core` shims**: `natives-*.ss` (array/coll/format/meta/misc/num/
queue/reader/seq/str/transduce), plus `predicates.ss`, `converters.ss`, `printing.ss`.
- **Vars / namespaces / dynamics**: `vars.ss`, `ns.ss`, `dyn-binding.ss` (the
thread-local binding stack), `dynamic-var-defaults.ss` (a few `*…*` constant defaults),
`atoms.ss`, `multimethods.ss`.
- **Host interop**: `host-class.ss` (class tokens + method dispatch),
`host-static.ss` (interop registry core) + `host-static-methods.ss` (`Class/member`
statics) + `host-static-classes.ss` (instantiable object classes), `host-table.ss`,
`host-contract.ss` (the `jolt.host` seam the compiler resolves against),
`dot-forms.ss`, `records-interop.ss`.
- **Scalars / misc**: `regex.ss` (vendored irregex), `math.ss`, `inst-time.ss`,
`bigdec.ss`, `syntax-quote.ss`.
- **IO / system / concurrency / FFI**: `io.ss`, `png.ss`, `concurrency.ss`,
`async.ss`, `ffi.ss`.
- **Compiler entry on Chez**: `reader.ss`, `compile-eval.ss`, `emit-image.ss`,
`loader.ss`, `cli.ss`, `build.ss`, `bootstrap.ss`.
## Where is a `clojure.core` fn implemented?
Two homes, with a defined precedence:
1. **Native shim** — a `(def-var! "clojure.core" "name" …)` in a `host/chez/*.ss`
(hot/representation-coupled fns: `first`, `get`, `=`, the predicates).
2. **Overlay** — a `defn` in a `jolt-core/clojure/core/NN-*.clj` tier (most of
`clojure.core`, in portable Clojure).
3. **`post-prelude.ss`** re-asserts a handful of natives *after* the overlay loads,
so the native version wins (the overlay's value-reading versions are wrong for
Chez-native chars/atoms/etc.). Each entry there says why.
`grep 'def-var! "clojure.core" "frequencies"' host/chez` and
`grep -rn 'defn frequencies' jolt-core/clojure/core` to find a given fn. See
[seed-overlay-registry.md](seed-overlay-registry.md) for the shadowing mechanism.
## Cross-cutting features — touch points
A feature's *core* lives in one file; these are the other files you must keep in
sync when changing it.
- **Tree-shaking / DCE** (`--tree-shake`): `emit-image.ss` (the `dce-*` helpers +
record producers) and `build.ss` (`bld-shake-all` reachability + the manifest
splice in `bld-emit-runtime`); the flag in `main.clj`; validated by
`host/chez/tree-shake-smoke.sh` (`make shakesmoke`) and `build-smoke.sh`. See
[tools-deps.md](tools-deps.md#tree-shaking).
- **Direct-linking** (`--direct-link`): `backend_scheme.clj` (`direct-link?`,
`emit-top-form`, the `jv$<fqn>` bindings); `build.ss` turns it on; `main.clj` the
flag; `test/chez/directlink-test.ss`.
- **Numeric fl*/fx\*** (`^double`/`^long` hints): `jolt-core/jolt/passes/numeric.clj`
(the hint-directed pass + loop-counter + `:coerce`); `backend_scheme.clj`
(`dbl-ops`/`lng-ops` op strings, `emit-numeric`, entry/return coercion);
`analyzer.clj` (`nhint-of`, `:nhints`, `with-ret-nhint`); `host-contract.ss`
(`:num-ret` on resolve); `rt.ss` (`jolt->fx`); `test/chez/numeric-test.ss`.
- **IR inlining** (under `--opt`): `passes/inline.clj` (splice) + `passes.clj`
(stash) + `host-contract.ss` (`inline-ir`/`stash-inline!`); `test/chez/inline-test.ss`.
- **Multimethods**: `host/chez/multimethods.ss` (dispatch) + the overlay
`defmulti`/`defmethod` macros + `host-contract.ss` late-bind.
- **AOT namespace context** (`jolt build`): `build.ss` (`bld-ns-prelude`) emits
`(set-chez-ns! ns)` + `chez-register-alias!` per app namespace (both the normal
and tree-shake emit paths), matching the loader's per-file ns context;
`test/chez/build-app` (`make buildsmoke`).
- **Deps resolution**: `jolt-core/jolt/deps.clj` (the only file) + `main.clj`
(applies the roots) + `loader.ss` (the `require` path).
## Conventions you must preserve
See **CLAUDE.md → "Conventions & Patterns"** for the load-bearing rules: the
re-mint trigger, the tier macro-ordering rule, the `get`-on-your-own-wrapper trap,
`:jolt/type`-as-a-key parsing, the `var-deref` calling convention (the compiler is
reached from the `.ss` runtime by string lookup, so a public `defn` with no
in-Clojure callers can still be live), and the writing style.

View file

@ -1,32 +1,34 @@
# Building and dependencies
How to run Jolt from source and how to pull Clojure libraries into a project.
How to build Jolt from source and how to pull Clojure libraries into a project.
## Running
## Building
```bash
git clone https://github.com/jolt-lang/jolt.git
cd jolt
git submodule update --init # vendor/sci (used by the SCI bootstrap tests)
bin/joltc -e '(println "hello")'
jpm build
```
There is **no build step**. `bin/joltc` (`host/chez/cli.ss`) loads the
checked-in bootstrap seed (`host/chez/seed/{prelude,image}.ss`) plus the spine
and compiles+evals on Chez (read → analyze → IR → emit → eval), so a fresh
clone runs immediately. The whole `.clj` standard library
(`clojure.string`/`set`/`walk`/`edn`/`pprint`/…) and `clojure.core` are part of
the overlay, so they're always available.
This produces two executables under `build/`:
`bin/joltc` is both the runtime (REPL, file/expr runner) and the dependency
front-end (`deps.edn` resolution, see below). A run with no `deps.edn` never
touches the resolver.
- **`jolt`** — the runtime: REPL, file/expr runner, nREPL server. The whole `.clj`
standard library (`clojure.string`/`set`/`walk`/`edn`/`zip`, `jolt.http`/
`interop`/`shell`/`nrepl`) is baked into this binary at build time, so it loads
from any directory — the build artifact is self-contained. (`clojure.core` is
built into the runtime in Janet and auto-referred, so it's always available.)
- **`jolt-deps`** — a separate tool that resolves a `deps.edn` (see below). It
sits beside the runtime the way `jpm` sits beside `janet`; the runtime itself
knows nothing about deps.edn.
The bootstrap seed is **checked in**. 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`) — re-mint the seed with
`make remint` (it iterates `host/chez/bootstrap.ss` to a byte-fixpoint), or
`make selfhost` fails. Runtime-only `host/chez/*.ss` shims don't need a re-mint.
Needs `jpm` and a recent Janet — developed and CI-tested against **1.41**. The
futures and core.async layers use Janet's threaded `ev/` channels (`ev/thread`,
`ev/thread-chan`), so older Janets may not run the full suite.
`jpm build` doesn't always notice source changes; run `jpm clean && jpm build`
after editing `src/` to be sure the binaries are current. `jpm test` runs against
the source directly, so it never goes stale.
## How namespaces are found
@ -39,75 +41,77 @@ come from:
at runtime;
- the `:paths` option to `init` when embedding Jolt as a library.
If a namespace isn't found on any root, the loader falls back to the stdlib in
the overlay — that's how `clojure.string` and friends resolve when you run
outside the source tree.
If a namespace isn't found on any root, the loader falls back to the stdlib baked
into the binary — that's how `clojure.string` and friends resolve when you run
the binary outside the source tree.
So you can point Jolt at a directory of Clojure source with no deps machinery at
all:
```bash
JOLT_PATH=/path/to/lib/src bin/joltc run myfile.clj
JOLT_PATH=/path/to/lib/src build/jolt myfile.clj
```
## Dependencies via deps.edn
`bin/joltc` reads a `deps.edn` in the current directory, fetches its
dependencies, and prepends the resolved source directories to the source roots
for the run. The CLI commands (`jolt.deps` + `jolt.main`):
`jolt-deps` reads a `deps.edn` in the current directory, fetches its
dependencies, and runs `jolt` with the resolved source directories on
`JOLT_PATH`.
```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-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
jolt-deps path # print the resolved roots (':'-joined)
jolt-deps run FILE [args] # resolve, then run `jolt FILE …`
jolt-deps repl # resolve, then start a REPL
jolt-deps -e EXPR [args] # resolve, then evaluate EXPR
```
`jolt-deps` launches the `jolt` binary it finds on `PATH` (override with
`$JOLT_BIN`).
Example `deps.edn`:
```clojure
{:paths ["src"]
:deps {weavejester/medley {:git/url "https://github.com/weavejester/medley"
:git/sha "<full-sha>"}
:git/tag "1.0.0"}
my/helpers {:local/root "../helpers"}}}
```
```bash
bin/joltc run -m myapp.main
jolt-deps run -m myapp.main
```
### What's supported
- **git deps**`{:git/url … :git/sha …}` (use a full SHA; `git fetch` can't
resolve a short one), with an optional `:deps/root` for a subdirectory.
Transitive deps from each dependency's own `deps.edn` are resolved too.
- **git deps**`{:git/url … :git/tag …}` or `{:git/url … :git/sha …}` (use a
full SHA; `git fetch` can't resolve a short one). Transitive deps from each
dependency's own `deps.edn` are resolved too.
- **local deps**`{:local/root "../path"}`.
- The project's own `:paths` (default `["src"]`) are included.
- **aliases** — `:aliases {:dev {:extra-paths ["dev"] :extra-deps {…}
:main-opts ["-e" "…"]}}`, selected with `-A:dev` (or several: `-A:dev:test`).
`:extra-paths`/`:extra-deps` accumulate across selected aliases;
`:main-opts` is last-wins and runs via `-M:alias`.
- **tasks**`:tasks {clean "rm -rf target" test {:main-opts ["-m" "…"]}}`.
A string task is a shell command; a map task runs jolt with its `:main-opts`.
Run one with `bin/joltc <taskname>`.
Resolution is breadth-first, so a top-level coordinate always beats a transitive
one for the same lib.
Git clones land in a global, sha-immutable cache shared across projects —
`$JOLT_GITLIBS`, else `~/.jolt/gitlibs`.
Resolution reuses jpm's git fetch and cache (a dependency is cloned once into
`jpm_tree/.cache` and reused). Resolved roots are cached on a hash of `deps.edn`,
so an unchanged `deps.edn` doesn't re-fetch.
### What's not
- **No Maven.** `:mvn/version` deps are skipped with a warning — git and local
only.
- **No Maven.** `:mvn/version` deps are ignored — git and local only.
- **Pure `clj`/`cljc` only.** A library that needs the JVM (Java interop, host
classes) or a `clojure.core` feature Jolt doesn't implement will fail to load
or fail at a call. Coverage is per-function: a namespace can load with most
functions working and a few not.
### Bundling into one file
`jolt uberscript OUT.clj -m NS` (or `jolt-deps uberscript …`, which resolves deps
first) bundles `NS` and every namespace it requires — your code plus its
dependencies — into a single `.clj` in dependency order, ending with a call to
`NS/-main`. The result runs on a plain `jolt` with no `JOLT_PATH`, no deps
fetched, and no jpm:
```bash
jolt-deps uberscript app.clj -m myapp.main
jolt app.clj arg1 arg2
```
See [`tools-deps.md`](tools-deps.md) for the design rationale.

View file

@ -3,11 +3,10 @@
===========================================================================
This grammar specifies the surface syntax accepted by Jolt's reader
(host/chez/reader.ss, with the portable half in jolt-core/jolt/reader.clj)
the text that `read`/`read-string`/`load-string` turn into data/forms. It is
the syntactic half of Jolt's contract; the behavioural half lives in the
conformance corpus (test/chez/corpus.edn, see docs/spec/02-reader.md). Where
Jolt diverges from Clojure the difference is called out in a comment.
(src/jolt/reader.janet) the text that `read`/`parse-string`/`load-string`
turn into data/forms. It is the syntactic half of Jolt's contract; the
behavioural half lives in test/spec/. Where Jolt diverges from Clojure the
difference is called out in a comment.
Notation (ISO-ish EBNF):
= definition | alternation
@ -51,12 +50,11 @@ collection = list | vector | map ;
nil = "nil" ;
boolean = "true" | "false" ;
(* Numbers. Jolt carries a real numeric tower (JVM parity): an integer literal
reads as an exact integer (arbitrary precision), a ratio a/b as an exact
Ratio, a decimal/exponent literal as a double. The BigDecimal suffix M reads
as a real BigDecimal (unscaled x 10^-scale) 1.5M, 0.0M, 3M; class is
java.math.BigDecimal. The BigInt suffix N reads as an exact integer. Radixed
integers are computed by base; the symbolic floats ##Inf/##-Inf/##NaN are
(* Numbers. Jolt accepts Clojure's numeric literal syntaxes, but since Jolt
numbers are Janet ints/doubles it has no distinct bignum, ratio or
BigDecimal types: the BigInt suffix N and BigDecimal suffix M are read as the
plain number, a ratio a/b is read as its double quotient, and radixed
integers are computed by base. The symbolic floats ##Inf/##-Inf/##NaN are
also read. (No octal-with-leading-0 literal.) *)
number = symbolic-value
| [ sign ] , ( radix-int | ratio | hex-int | decimal ) ;
@ -64,10 +62,10 @@ sign = "+" | "-" ;
integer = digit , { digit } ;
hex-int = "0" , ( "x" | "X" ) , hex-digit , { hex-digit } , [ "N" ] ;
radix-int = integer , ( "r" | "R" ) , alnum , { alnum } ; (* base 2..36: 2r1010, 16rFF, 36rZ *)
ratio = integer , "/" , integer ; (* exact Ratio *)
ratio = integer , "/" , integer ; (* read as a double quotient *)
decimal = integer , [ "." , digit , { digit } ] , [ exponent ] , [ num-suffix ] ;
exponent = ( "e" | "E" ) , [ sign ] , digit , { digit } ;
num-suffix = "N" | "M" ; (* N = exact integer (BigInt); M = BigDecimal *)
num-suffix = "N" | "M" ; (* BigInt / BigDecimal in Clojure; plain number in Jolt *)
symbolic-value = "##Inf" | "##-Inf" | "##NaN" ;
digit = "0".."9" ;
hex-digit = digit | "a".."f" | "A".."F" ;
@ -111,7 +109,7 @@ map-entry = form , ws , form ; (* an even number of forms *)
(* --------------------------------------------------------------------------
Reader macros (prefix sugar). Each expands to a 2-element form
(op operand), e.g. 'x -> (quote x), @a -> (clojure.core/deref a).
(op operand), e.g. 'x -> (quote x), @a -> (deref a).
-------------------------------------------------------------------------- *)
reader-macro = quote | syntax-quote | unquote | unquote-splice
@ -121,17 +119,13 @@ quote = "'" , form ; (* (quote form) *)
syntax-quote = "`" , form ; (* (syntax-quote form) *)
unquote-splice = "~@" , form ; (* (unquote-splicing form) *)
unquote = "~" , form ; (* (unquote form) *)
deref = "@" , form ; (* (clojure.core/deref form) qualified, *)
(* so it derefs even where deref is shadowed *)
deref = "@" , form ; (* (deref form) *)
metadata = "^" , meta-form , ws , form ; (* attach metadata to form *)
meta-form = map | keyword | symbol | string ;
(* Normalized like Clojure: a symbol or string is a type hint -> {:tag ...};
a keyword -> {keyword true}; a map is used as-is. A keyword/symbol/string
meta-form on a symbol rides ON the symbol (it stays a bare symbol, so a hint
like ^String is transparent in params/lets/bodies). A MAP meta-form routes
through a runtime (with-meta form ...) even on a symbol, so a name
with ^{:map} metadata reads as a form, not a bare symbol def/defn/defmacro/ns
unwrap that to the bare name (and attach the metadata). *)
a keyword -> {keyword true}; a map is used as-is. On a symbol the metadata
rides on the symbol (it stays a bare symbol, so a hint like ^String is
transparent in params/lets/bodies); other targets use a runtime with-meta. *)
(* --------------------------------------------------------------------------
Dispatch forms introduced by "#".
@ -153,7 +147,7 @@ anon-arg = "%" | "%" , digit , { digit } | "%&" ;
var-quote = "#'" , symbol ; (* (var symbol) *)
(* Regex literal -> an irregex-backed regex value.
(* Regex literal -> a Janet PEG-backed regex value.
Supported: groups, greedy/lazy quantifiers, (?:..), lookahead (?=..)/(?!..),
alternation, anchors ^ $ \b \B, classes, (?i). NOT: lookbehind,
backreferences, named groups. *)

View file

@ -1,271 +0,0 @@
# Host interop and JVM standard-library shims
Jolt runs on Chez Scheme, not the JVM, so there are no real Java classes behind
interop forms. Instead the runtime ships shims for the slice of the JVM standard
library that portable Clojure code reaches for, so libraries written against
`clojure.core` and common `java.*` classes run unchanged. The Clojure interop
syntax works against these shims:
```clojure
(Math/sqrt 2) ; static call
Math/PI ; static field
(StringBuilder.) ; constructor
(.append sb "x") ; instance method
(instance? String "hi") ; class token
```
A class token (`String`, `java.util.UUID`, …) resolves to a name; there is no
reflection and no class hierarchy. `(class x)` returns the JVM class name for the
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
aren't implemented; a few are accepted but no-ops (noted inline).
### Numbers and language
- **`java.lang.Math`** — `sqrt` `cbrt` `pow` `exp` `log` `log10` `floor` `ceil`
`round` `abs` `max` `min` `sin` `cos` `tan` `asin` `acos` `atan` `signum`
`random`; fields `PI`, `E`. (`clojure.math` mirrors these as functions.)
- **`Long` / `Integer`** — `parseLong`/`parseInt`/`valueOf` (optional radix),
`MAX_VALUE`, `MIN_VALUE`; `(Integer. x)`.
- **`Double` / `Float`** — `parseDouble`, `valueOf`, `toString`, `isNaN`,
`isInfinite`, the `*_VALUE`/`*_INFINITY`/`NaN` fields; `(Double. s)`.
- **`Boolean`** — `parseBoolean`, `TRUE`, `FALSE`.
- **`Character`** — `isUpperCase` `isLowerCase` `isDigit` `isWhitespace` (ASCII).
- **Boxed-number methods** — every number answers `.intValue` `.longValue`
`.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` `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` (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
- **`java.lang.String`** statics — `valueOf`, `format` (the `clojure.core/format`
engine; `String/format` with a leading locale is accepted). Instance methods
go through `clojure.string` / the native string ops.
- **`StringBuilder`** — `append` `toString` `length` `charAt` `setLength`.
- **`java.text.NumberFormat`** — `getInstance` `getNumberInstance`
`getIntegerInstance`; `.format`, `.setGroupingUsed`,
`.setMinimum/MaximumFractionDigits`.
- **`java.util.StringTokenizer`** — `hasMoreTokens` `countTokens` `nextToken`.
- **`java.util.regex.Pattern`** — `compile` (with `Pattern/MULTILINE`), `quote`;
`.split`, `.pattern`. (`#"…"` literals and `clojure.string` regex fns are the
usual entry points.)
### Collections (mutable)
- **`java.util.ArrayList`** — `add` `get` `set` `size` `isEmpty` `remove` `clear`
`contains` `toArray` `iterator`.
- **`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)`. 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).
### Time and date
- **`java.util.Date`** — `(Date.)` / `(Date. ms)`; `getTime` `toInstant`
`toLocalDate(Time)` `before` `after` `equals` `toString` (RFC 3339).
- **`java.time`** — `Instant` (`now`, `ofEpochMilli`, `toEpochMilli`, `atZone`),
`LocalDateTime`, `ZoneId`, `DateTimeFormatter` (`ofPattern`, `ISO_LOCAL_*`,
localized styles), `FormatStyle`.
- **`java.text.SimpleDateFormat`** — `(SimpleDateFormat. pattern)`; `parse`
`format` `toPattern` `applyPattern` (`setTimeZone`/`setLenient` accepted but
ignored — formatting is UTC).
- **`java.util.TimeZone`** / **`java.util.Locale`** — constructed and passed
through; only UTC is honored for formatting.
### Net, encoding, misc
- **`java.net.URL`** — `(URL. spec)`; `toString` `toExternalForm` `getProtocol`
`getPath` `getFile`.
- **`java.net.URI`** — full component accessors (`getScheme` `getHost` `getPort`
`getPath` `getQuery` `getFragment`, raw variants, `isAbsolute`).
- **`java.util.Base64`** — `getEncoder`/`getDecoder` with `encode`,
`encodeToString`, `decode`.
- **`java.nio.charset.Charset`** — `forName`.
- **`java.util.UUID`** — `randomUUID`, `fromString`; `(UUID. s)`.
- **Exceptions**`Throwable` `Exception` `RuntimeException`
`IllegalArgumentException` `IllegalStateException` `IOException`
`NumberFormatException` `ArithmeticException` `NullPointerException`
`ClassCastException` `IndexOutOfBoundsException` `FileNotFoundException`
`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
`BigDecimal`.
## Adding your own shim from a library
The built-in shims above are baked into the seed. A library or project can
register its **own** host classes at load time — no seed re-mint, no host edits.
Put the registration calls at the top level of a namespace your code requires.
Four functions (in `clojure.core`) plus the tagged-table seam (in `jolt.host`)
cover it.
`__register-class-ctor!` makes `(Name. …)` work; `__register-class-statics!`
makes `Name/field` and `(Name/method …)` work; `__register-class-methods!`
attaches instance methods to a tagged value; `__register-instance-check!` teaches
`instance?` about your class. **Method and static names are strings** (they match
the literal name in the interop form).
A stateful object is a *tagged table*`jolt.host/tagged-table` creates one,
`ref-put!`/`ref-get` set and read its fields. Read the tag back with
`jolt.host/ref-get` (or test it with `jolt.host/table?`); a plain `get` /
keyword lookup deliberately can't see a wrapper's own `:jolt/type`.
```clojure
(ns mylib.greeter
(:require [jolt.host :as host]))
;; (Greeter. name) -> a tagged value carrying its name
(__register-class-ctor! "Greeter"
(fn [name] (-> (host/tagged-table :greeter)
(host/ref-put! :name name))))
;; (.hello g) -> instance method, keyed by the literal method name
(__register-class-methods! :greeter
{"hello" (fn [self] (str "hi " (host/ref-get self :name)))})
;; Greeter/VERSION (field) and (Greeter/make x) (static method)
(__register-class-statics! "Greeter"
{"VERSION" "1.0"
"make" (fn [name] (Greeter. name))})
;; (instance? Greeter x)
(__register-instance-check!
(fn [class-name v]
(when (= class-name "Greeter")
(and (host/table? v) (= :greeter (host/ref-get v :jolt/type))))))
```
```clojure
(.hello (Greeter. "ada")) ;=> "hi ada"
Greeter/VERSION ;=> "1.0"
(.hello (Greeter/make "bob")) ;=> "hi bob"
(instance? Greeter (Greeter. "x")) ;=> true
```
An instance-check predicate returns `true`/`false` to decide, or `nil` to defer
to the next registered check and the built-ins — so several libraries can
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,80 +0,0 @@
# Clojure libraries known to work with Jolt
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).
* [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
* [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 by
[jolt-lang/router](https://github.com/jolt-lang/router).
* [integrant](https://github.com/weavejester/integrant) — data-driven system
configuration (`#ig/ref`), with its
[dependency](https://github.com/weavejester/dependency) and
[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.
* [markdown-clj](https://github.com/yogthos/markdown-clj) — Markdown → HTML, on the
markdown-app example
* [hiccup](https://github.com/weavejester/hiccup) — HTML from Clojure data, on the
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

@ -170,9 +170,9 @@ Signature(s), since-version
## Open questions
1. Numerics: the reference has longs/doubles/ratios/BigInt with promotion
rules; CLJS has JS numbers. Resolved: jolt carries the Scheme numeric tower
(exact integers/bignums, exact ratios, flonum doubles), matching the
reference's tower — see the numerics note in §4.
rules; CLJS has JS numbers; jolt has Janet numbers. Likely answer: specify
an integer/float core with a host-numeric-tower extension point — needs
its own design note in §4.
2. Where do `*print-length*`-style dynamic vars land — host-dependent
interface or portable with defaults?
3. License/venue if the spec outgrows this repo (likely CC-BY; separate repo

View file

@ -1,22 +1,9 @@
# RFC 0002 — Reader-Conditional Feature Set
- **Status**: Superseded (2026-06-25) — jolt now includes `:clj` in the default
set; see the note below.
- **Status**: Accepted (implemented; measured)
- **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
@ -90,6 +77,6 @@ per-context opt-in, exactly how the SCI bootstrap now loads
- Loading clj-ecosystem libraries via deps requires deciding their feature
set; the deps loader currently inherits the process default — a future
refinement is per-dependency feature configuration (filed with the deps
work).
work, jolt-dw4).
- `.cljc` authors targeting jolt can write `:jolt` branches and rely on
`:default` fallbacks.

View file

@ -1,49 +1,45 @@
# RFC 0003: Transients — semantics and the Chez mutable backing
# RFC 0003: Transients — semantics and why they live in the Janet seed
Status: accepted (design note)
This note pins down what transients *are* in Jolt, where their behavior
deviates from JVM Clojure and why, and how the transient machinery is
represented in the Chez runtime. It exists so the design doesn't revisit
deviates from JVM Clojure and why, and why the transient machinery is part of
the irreducible Janet seed rather than a candidate for the core-in-Clojure
migration (jolt-tzo). It exists so the kernel-shrink ladder doesn't revisit
transients every round.
## What a transient is in Jolt
A transient is a Chez record (`jolt-transient`, `host/chez/transients.ss`)
wrapping *true mutable* host backing, snapshotted to the immutable collection on
`persistent!`. The backing is per kind:
A transient is a tagged Janet table wrapping a *native* mutable host value
(`core.janet`, "Transients" section):
- transient vector — a growable Scheme vector (a capacity buffer plus a fill
count `n`). `conj!`/`pop!` are in-place, amortized O(1); the buffer doubles on
growth.
- transient map — a Chez hashtable keyed by `key-hash` / `jolt=`
(value-equality, nil-safe). Hashing by value keeps collection keys comparing
across representations.
- transient set — a Chez hashtable of elements.
- `cow` — a copy-on-write fallback for anything else (e.g. a sorted coll).
- transient vector — `@{:jolt/type :jolt/transient :kind :vector :arr ARRAY}`,
a Janet array.
- transient map — `:kind :map :tbl TABLE`, a Janet table mapping
`canon-key(k)``@[k v]`. Keying by canonical key keeps collection keys
comparing by value across representations (`[1 2]` the pvec and `[1 2]` the
tuple are one key), and storing the `@[k v]` pair preserves the *original*
key for the rebuilt persistent map.
- transient set — `:kind :set :tbl TABLE` mapping `canon-key(x)``x`.
`transient` accepts pvecs, pmaps, psets, and the exotic colls handled by the
`cow` path. Each kind copies its source into the matching mutable backing once.
The bang ops (`conj!`, `assoc!`, `dissoc!`, `disj!`, `pop!`) mutate that backing
in place and return the transient — O(1) per op (amortized for the vector push).
`persistent!` snapshots a persistent value from the backing (folding the
hashtable into a pmap/pset, handing off the buffer as a pvec) and invalidates the
transient (the record's active flag clears; any further bang op or a second
`persistent!` throws "transient used after persistent!", matching Clojure's
invalidation contract).
The bang ops (`conj!`, `assoc!`, `dissoc!`, `disj!`, `pop!`) mutate that host
value in place and return the transient — O(1) per op (amortized for array
push). `persistent!` rebuilds a persistent value from the host value and
invalidates the transient (`:jolt/persistent` flag; any further bang op or a
second `persistent!` throws "Transient used after persistent! call", matching
Clojure's invalidation contract).
Read ops work on an active transient where Clojure supports them: `get`,
`contains?`, `count`, and `nth` (vector kind) see through the transient.
`contains?`, `count`, and `nth` (vector kind) branch on the transient tag.
`seq` on a transient is not supported, as in Clojure.
## Deviations from JVM Clojure (deliberate)
**O(n) edges, O(1) middle.** Clojure's `(transient v)` is O(1) — the transient
*shares* the persistent trie and marks nodes editable; `persistent!` is O(1)
too. Jolt's `transient` copies the source into a mutable buffer/hashtable (O(n))
and `persistent!` snapshots back (O(n)). The bang ops in between are host-mutable
O(1), which is *faster* per-op than trie editing. So the asymptotics of the usual
too. Jolt's `transient` copies the source into a native array/table (O(n)) and
`persistent!` rebuilds (O(n)). The bang ops in between are native-host O(1),
which is *faster* per-op than trie editing. So the asymptotics of the usual
pattern
(persistent! (reduce conj! (transient []) coll))
@ -52,12 +48,13 @@ are identical (O(n) total either way) with a better constant in the loop and a
worse constant at the two edges. The pattern transients exist for — batch
construction — is fully served. What is NOT served is transient-editing a
*large* collection to change a few keys: that's O(n) in Jolt vs O(log n) in
Clojure, because `transient` copies the source into a growable Scheme vector /
Chez hashtable and `persistent!` snapshots it back.
Clojure, because `transient` flattens the pvec trie / phm buckets into a
native array/table and `persistent!` rebuilds them.
**No thread-ownership check.** JVM Clojure ≥1.7 also dropped the owner-thread
assertion (for fork/join), keeping only "don't use after persistent!", which
Jolt enforces. A transient handed across threads is a data race exactly as in
Jolt enforces. Jolt code is fiber-concurrent; when real OS-thread futures land
(jolt-ejx), a transient handed across threads is a data race exactly as in
Clojure — documented, not checked, same as the JVM.
**`(conj!)` / `(conj! t)` arities** follow Clojure's transducer-era contract:
@ -66,43 +63,49 @@ zero args makes a fresh `(transient [])`, one arg returns it untouched.
lenient kvs walk of Jolt's `assoc`.
**No transient sorted variants** — same as Clojure. One leniency: Clojure
throws on `(transient '(1))`, but Jolt routes a list through the `cow` fallback
path, yielding a transient. Harmless but non-Clojure; tighten if it ever
bites.
throws on `(transient '(1))`, but Jolt's lists are Janet arrays underneath and
fall into the mutable-build branch, yielding a transient *vector*. Harmless
(the result of `persistent!` is a vector, never silently a list) but
non-Clojure; tighten if it ever bites.
## Why transients live in the host
## Why transients stay in the Janet seed
Transients are part of the value/representation layer in the Chez runtime
(`host/chez/transients.ss`), not the portable `clojure.core` overlay, on three
The migration ladder (jolt-tzo) moves anything expressible as *pure Clojure
over existing primitives* out of the seed. Transients fail that test on three
grounds:
1. **They are the mutation kernel.** A transient's entire value is direct
mutation of a host buffer/hashtable. The overlay has no mutation seam of its
own. Re-expressing the bang ops in Clojure would mean either growing the host
surface one-for-one (a host-vector-push, a host-hashtable-put, …, i.e. moving
the same code behind more indirection) or simulating mutation over persistent
values (defeating the point of transients).
mutation of a host array/table. The overlay's only mutation seam is
`jolt.host/ref-put!` (a single table-put). Re-expressing `tr-conj!` etc. in
Clojure would mean either growing the host surface one-for-one
(`host-array-push!`, `host-table-put!`, …, i.e. moving the same code behind
more indirection) or simulating mutation over persistent values (defeating
the point of transients). Either way the Janet line count moves, it doesn't
shrink.
2. **They sit under the collection dispatch.** `conj`/`assoc`/`get`/`count`/
`contains?` see through a transient. Hoisting the transient ops above that
dispatch would put a compiled-Clojure call inside the hottest paths for no
semantic gain — transients have no semantics to *fix*.
2. **They sit under the seed's own dispatch.** `conj`/`assoc`/`get`/`count`/
`contains?` in the seed branch on the transient tag. Hoisting the transient
ops above that dispatch (the hierarchy-port pattern of lazily-resolved
overlay vars) would put an interpreted/compiled-Clojure call inside the
hottest native paths for no semantic gain — transients have no semantics to
*fix* (unlike hierarchy, which had real correctness gaps).
3. **The value layer is the host's job.** The persistent collections and, with
them, their mutable scratch counterparts, live in the Chez runtime alongside
the value model. Transients are representation, not library.
3. **The value layer is declared irreducible.** The self-hosting design doc
(docs/self-hosting-compiler.md, "The kernel") keeps the value/representation
layer — persistent collections and, with them, their mutable scratch
counterparts — in the host. Transients are representation, not library.
What lives in the overlay: anything *derived* — e.g. `into`'s transient-using
fast path, or `update!`-style conveniences — is plain Clojure over
`transient`/bang-ops/`persistent!`.
What CAN move (and mostly has): anything *derived* — e.g. `into`'s
transient-using fast path, or future `update!`-style conveniences — is plain
Clojure over `transient`/bang-ops/`persistent!` and belongs in the overlay
tiers as ordinary migration batches.
## Future work
- The persistent map/set are a bitmap HAMT with structural sharing
(`host/chez/collections.ss`), so Clojure-style O(1) `transient`/`persistent!`
via editable nodes is a real option there — an internal change behind the same
surface, not a semantics change. The persistent vector is a flat
copy-on-write Scheme vector rather than a trie, so the transient surface for
it stays the copy-to-growable-vector path.
- pvec is already a 32-way trie with structural sharing (pv.janet), so
Clojure-style O(1) `transient`/`persistent!` via editable nodes is a real
option for vectors — an internal change behind the same surface, not a
semantics change. phm is bucket-based copy-on-write; the same trick applies
if it ever becomes a HAMT.
- `transient?` (Jolt extension, useful in tests) stays; Clojure has no public
predicate, so it must not leak into portability-sensitive code.

View file

@ -1,147 +0,0 @@
# RFC 0004: Type hints and keyword-lookup specialization
Status: accepted (design note)
This note describes how Jolt treats Clojure type hints, and the one place it
uses them: a `^:struct` or `^Record` hint on a local lets a constant-keyword
lookup skip its runtime representation guard. It records the rationale, the
soundness contract, the checked mode for catching inaccurate hints, and the
measured effect, so later work does not relitigate it.
## Background: why the lookup carries a guard
A Jolt map value has several runtime representations (see RFC on collections and
`host/chez/collections.ss`): a persistent hash map (a bitmap HAMT) for the
general case, plus sorted maps, transients, and record/deftype instances. A
record instance is a Chez record (`jrec`) whose fields are read directly off the
record's storage, while a HAMT lookup runs the full `jolt=`/`jolt-hash`-keyed
collection path.
A constant-keyword lookup `(:k m)` compiles to a guarded form: it inspects the
subject's representation and routes a HAMT/sorted/transient/lazy-seq value to the
full `jolt-get` semantics, while a record/raw-get-safe value takes the direct
field read, which matches `jolt-get` for keyword keys. The guard is correct and
cheap, but on a raw-get-safe value it is wasted work: profiling the ray tracer (a
naive all-maps program) found keyword lookups are about half of a render, and the
guard is the only avoidable part of each one.
Dropping the guard is only safe when the subject is known to be a plain
struct/record rather than a tagged collection. Jolt does not infer that
inter-procedurally (it would be unsound across a dynamic language's call
boundaries). A type hint supplies the same fact soundly, as a programmer
assertion.
## What the hints mean
Two hints on a local resolve to the "plain struct/record" assertion, which we
call the `:struct` hint internally:
- `^:struct` — the value is a plain struct or record map. There is no Clojure
keyword with this meaning (Clojure's type hints are class names), so this is a
Jolt-specific metadata flag, analogous to `^:dynamic`.
- `^Name` where `Name` is a `defrecord`/`deftype`. Both forms define a `->Name`
positional constructor, so the analyzer treats a tag whose `->Name` resolves
as a record type. Record instances are raw-get-safe, so the lookup drops the
guard. A `^String`, `^long`, or any other non-record tag is not a record and
is ignored, exactly as before.
Every other hint parses and is inert, matching Clojure (S12b in the reader
spec). A hint never changes a program's result; it only permits an
optimization.
## How it flows
The reader already keeps `^hint` metadata on the binding symbol and is otherwise
transparent (`host/chez/reader.ss`). The change threads that fact to the lookup
site:
1. The analyzer (`jolt-core/jolt/analyzer.clj`) records a `:struct` hint per
local in its env when a param or `let` binding carries `^:struct` or a
record-type tag, and attaches `:hint :struct` to that local's `:local` IR
node. Resolving a record-type tag uses the host contract function
`record-type?` (`jolt.host`, backed by `host/chez/host-contract.ss`), which
checks for the `->Name` constructor.
2. The back end (`jolt-core/jolt/backend_scheme.clj`) emits the direct field read
when the lookup subject is a `:local` carrying the hint, and the guarded form
otherwise. The unhinted path is identical to before.
3. The inline pass (`jolt-core/jolt/passes.clj`) propagates the hint: when it
binds a non-trivial call argument to a fresh local, it carries the called
function's parameter hint onto that local, so lookups inside the spliced body
keep the direct path. Without this, inlining a hinted function would erase the
benefit, because the hinted parameter is replaced by an unhinted temporary.
The same machinery covers both `(:k m)` and `(get m :k [default])` when the key
is a constant keyword. A `get` with a variable, numeric, or string key falls
through to `jolt-get` unchanged.
## Record hints across namespaces, and as inference seeds
A `^RecordType` hint does two things beyond dropping the lookup guard.
**It carries the specific type, not just "a struct".** The guard-skip only needs
to know the value is raw-get-safe (`:struct`), but the structural inference (RFC
0005) wants the actual record type so a field read gets the field's type —
`(:origin ray)` on a `^Ray ray` is a `Vec3`, not `:any`. A record hint on a
parameter is resolved to the record's constructor key and used to **seed the
inference's parameter type**. That is what keeps a record parameter's reads typed
across a namespace boundary *without* whole-program inference (RFC 0005,
"Cross-namespace inference") — the open-world counterpart to the whole-program
pass. Hinting only the public entry point is not enough; the hint has to be on
the function where the hot reads actually happen.
**It resolves across namespaces.** A hint may name a record defined in another
namespace, in either spelling — `^Vec3` where the type is `:refer`-ed, or
`^v/Vec3` where the namespace is `:as`-aliased. Resolution (`record-ctor-key`,
a `jolt.host` contract function backed by `host/chez/host-contract.ss`) runs
against the *compile* namespace and maps the type to its home constructor key
through a constructor-value index — keyed by the constructor value, not a var's
namespace, so a `:refer`-interned var (whose namespace is the referring one)
still resolves home. The reader keeps a tag's namespace qualifier (`^v/Vec3`
`"v/Vec3"`, not `"Vec3"`) so the aliased spelling has something to resolve. Both
`defrecord` field hints and function parameter hints use this resolution.
## Soundness and the checked mode
An accurate hint is correctness-preserving by construction: for a struct or
record the bare get equals the guarded result. An inaccurate hint (asserting
`^:struct` for a value that is actually a phm) makes the raw get return the wrong
thing. This is the same contract as a wrong Clojure `^String`, except that a
wrong Jolt hint fails silently rather than throwing.
To make a lie visible without taxing the fast path, `JOLT_CHECK_HINTS=1` keeps
the guard but throws on the tagged arm with a message naming the local and key:
```
type hint violated on `m`: (:a m) — value is a
phm/sorted/transient/lazy-seq, not the plain struct/record the
^:struct/^Record hint asserts
```
This is a development aid, off by default, with zero cost to normal builds (the
flag is read when the lookup is compiled, and the bare get is emitted when it is
off). The flag is part of the image-cache fingerprint.
## Coverage
Type hints parse in every position Clojure accepts them and are inert except for
the optimization above. This matches Clojure's "parse and otherwise do nothing"
model, with the difference that Clojure additionally uses hints to avoid
reflection and select primitive arithmetic, which do not apply to the Chez host.
## Measured effect
On the ray tracer (`~/src/examples/ray-tracer`, all values are `{:r :g :b}`-style
maps), with inlining on and the hot parameters hinted, a render goes from 13.3s
to 10.9s, about 1.22x, taking it to roughly 7.8x the JVM from 9.4x after the
inline pass. A seeded render produces an identical pixel checksum hinted and
unhinted, confirming the hints are correctness-preserving on the full pipeline.
## Status and non-goals
Implemented. Not pursued: inter-procedural shape inference (unsound in a dynamic
language without a guard, which costs as much as the one being removed) and a
shape-based "hidden class" representation (profiling showed allocation is about
1% of the workload, so a cheaper allocation would not help, and an escaping-map
lookup through a runtime shape check costs about the same as the guard it would
replace). The hint is the sound, opt-in lever on the part of the cost that can
move.

View file

@ -1,303 +0,0 @@
# RFC 0005 — Structural collection-type inference
- **Status**: Implemented. Ray tracer 12.8s to 11.0s hint-free,
matching the explicit `^:struct` version; render checksum unchanged.
- **Champions**: jolt maintainers
- **Created**: 2026-06-13
## Summary
Replace jolt's ad-hoc inference lattice with a single recursive **structural
type**, so that the type of a value mirrors the tree shape of the data it
describes. A struct-map carries its field types, a vector its element type, a
function its parameter and return types, recursively. A keyword lookup returns
the looked-up field's type, so nested access like `(:r (:direction ray))` is
typed end to end. This unifies the two facts the current inference tracks
inconsistently (a vector's element type, but not a map's field types), subsumes
the existing inference passes as special cases, and
closes the remaining ray-tracer gap without a hint. The system is a
soft-typing-style inference: it never rejects a program, it assigns a concrete
type only when it can prove one, and it falls back to `:any` (and the existing
runtime guard) everywhere else.
## Motivation
The existing inference specializes a collection access (drops the
`:jolt/type` guard, emits `pv-count`, and so on) when it can prove the
collection's type. It works, it is sound, and it is fully dynamic-fallback
safe. But its type lattice grew ad hoc:
- `:struct-map` means "a raw-get-safe map" but carries **no field types**.
- `{:vec ELEM}` carries its **element type**.
These are the same idea applied to two kinds of child in the data tree, but
only one is tracked. The cost is concrete: in the ray tracer a lookup result
like `(:direction ray)` is typed `:any`, so `(:r (:direction ray))` keeps its
guard, and the `vec3` functions (called all day with such values) cannot be
typed, so the inference reaches only about 3% where the explicit `^:struct`
hint reaches 22%. The hint wins precisely because it asserts the field/param
shape the inference fails to derive.
The fix is to make the type a structural tree, tagged as precisely as provable.
Then `:struct` tracking and field tracking are one mechanism, the special cases
collapse into one signature table, and nested access is typed by construction.
## The type lattice
A type `T` is one of:
- A scalar tag: `:num`, `:str`, `:kw`, `:bool`, `:char`. (Optionally a coarser
`:nonnil` for "provably not nil and not false", which is what the struct-vs-phm
decision needs; see below.)
- `:nil`.
- `{:struct {field -> T}}` — a raw-get-safe map (a record) whose
field `k` has type `(fields k)` or `:any` if absent. The degenerate
`{:struct {}}` is "a struct, fields unknown" and replaces today's
`:struct-map`.
- `{:vec T}` — a vector whose elements have type `T`.
- `{:set T}` — a set of `T`.
- `:phm` — a persistent hash map (NOT raw-get-safe; distinct from `:struct`).
- `{:fn {:params [T...] :ret T}}` — a function (optional precision; the current
flat param/return inference is the zero-arity-detail version of this).
- `:any` — the top. Anything not provably more specific.
- `:bottom` (represented as the absence of a type / `nil` internally) — the
identity for join, used to seed the fixpoint.
Types are immutable values comparable by structural equality, exactly like the
current `{:vec ELEM}` representation, so they flow across the portable
inference and the host unchanged.
### Join (least upper bound)
```
join(T, T) = T
join(bottom, T) = T
join({:struct a}, {:struct b}) = {:struct {k -> join(a[k]?:any, b[k]?:any) for k in keys(a) keys(b)}}
join({:vec a}, {:vec b}) = {:vec join(a, b)}
join({:set a}, {:set b}) = {:set join(a, b)}
join(_, _) = :any ; different constructors
```
Two struct types join field-wise; a field present in only one side becomes
`:any` in the result (it might be absent, so a lookup of it is not provably
typed). This is the standard record lattice.
### Termination: depth cap
Structural types of recursive data (a tree node that contains a tree node, a
cons cell) would be infinite. To keep types finite and the inter-procedural
fixpoint terminating, structural types are **depth-capped**: beyond a small
depth `D` (proposed `D = 4`) a child type is `:any`. Construction and join both
truncate at `D`. With the cap the lattice has finite height, so the monotone
fixpoint converges. The ray tracer's shapes (vec3 inside ray inside hit-info)
are depth 2 to 3, well inside the cap.
## Inference rules
Inference is a forward pass producing `[type node']` for each IR node (the
existing shape), threaded with a local type environment and the
inter-procedural state. The rules are uniform over the structural
type:
- **Literals.** `{:k v ...}` with constant scalar keys and struct-safe values
builds `{:struct {:k type(v) ...}}`; otherwise `:phm`. `[a b ...]` builds
`{:vec (join type(a) type(b) ...)}`. `#{...}` builds `{:set ...}`. Scalars
build their scalar tag. (The struct-vs-phm condition is the same as the back
end's: scalar keys, and every value provably non-nil and non-false.)
- **Lookup returns the field type.** `(:k m)` / `(get m :k)` where
`m : {:struct fs}` returns `(fs :k)` or `:any`. This is the single rule that
makes nesting work and that unifies field tracking with `:struct` tracking.
- **Indexing returns the element type.** `(nth v i)` / `(v i)` where
`v : {:vec T}` returns `T`. `(first v)` / `(peek v)` likewise.
- **Flow.** `let`/`loop` bind init types; `if` joins the branch types; `do`
takes the tail type. (As today.)
- **Calls use signatures.** Every call result type comes from the callee's
signature: core fns from a fixed signature table (below), user fns from the
inter-procedural fixpoint's inferred signature.
The inter-procedural fixpoint, recompile, escape gate, and closed-world
assumption are unchanged. They now propagate structural types instead of flat
tags.
## Core function signatures
The current special cases (`truthy-ret-fns`, `vector-ret-fns`, `elem-fns`,
`hof-table`, and the `conj`/`range`/`reduce`/`mapv` branches) collapse into one
table of **type schemes**, possibly parametric:
```
inc, dec, +, -, *, /, mod, ... : (... :num) -> :num
count : (Coll) -> :num
nth : ∀T. ({:vec T}, :num) -> T (3-arg adds a default: -> join(T, default))
get : ∀T. ({:struct fs}, :k) -> (fs :k) ; const key
first,peek : ∀T. ({:vec T}) -> T
conj : ∀T. ({:vec T}, x) -> {:vec join(T, type(x))}
assoc : ({:struct fs}, :k, v) -> {:struct (assoc fs :k type(v))} ; const key
vec, mapv : ... -> {:vec ...}
range : (...) -> {:vec :num}
rand-nth : ∀T. ({:vec T}) -> T
map, filter, mapv, filterv, reduce, ... ; see HOFs
```
Parametric schemes (the `∀T`) are where polymorphism actually matters, and they
give the element/field propagation for free. **Higher-order functions are just
schemes whose parameter is itself a function type**: `reduce`'s scheme says its
function argument is `(Acc, Elem) -> Acc` applied to the collection's element
type, so the closure's element parameter is typed by applying the scheme,
replacing the hand-written `hof-table`.
## Hints as seeds
`^:struct x` seeds `x : {:struct {}}` (a struct, fields unknown) at a unit
boundary the inference cannot see across. A future extension could allow a shape
hint `^{:r :num :g :num :b :num}` to seed field types, but once inference is
structural this is rarely needed; the hint stays the escape hatch for genuinely
dynamic boundaries, exactly as today.
## Soundness
Unchanged in spirit from the current system: a concrete type is assigned only
when proven (a literal genuinely has those fields; a fn provably returns that
shape), and everything unprovable is `:any`, which keeps the dynamic guard. A
wrong specialization is therefore impossible. The inter-procedural part keeps
the closed-world (optimization-mode) assumption already adopted, which is sound
under whole-program / source-distribution compilation.
## Compilation modes and defaults
Direct-linking — and the inference and specialization it enables — is the
**default for running a program** and stays **off for interactive work**, chosen
by the CLI run mode rather than a global opt-in flag:
| mode | linking | whole-program |
|---|---|---|
| `-m` / `-M NS` (program entry) | direct (default) | **auto** (closed world) |
| `FILE` / `-f` / stdin (`-`) | direct (default) | no (per-namespace) |
| `repl`, `-e`, `nrepl-server` | indirect / open | no |
A program run is a closed world — every namespace is required, then the code
runs to completion — so it direct-links: user code gets inlining, record shapes,
and the inference's specialization. A `-m` / `-M` entry is the exact point where
all requires are done and `-main` is about to run, so the whole-program
cross-namespace pass (below) runs there automatically. Interactive modes stay
open: a REPL, `-e`, and the nREPL server must let you redefine vars — which
direct-linking seals against — so they keep the indirect, live-deref path.
Env overrides, all winning over the mode default:
- `JOLT_NO_DIRECT_LINK=1` — force the open/indirect path even for a program run
(runtime redefinition, hot-reload, self-modifying code).
- `JOLT_NO_WHOLE_PROGRAM=1` — keep direct-linking but skip the whole-program
pass (per-namespace inference only).
- `JOLT_DIRECT_LINK=1` — force direct-linking on even in an interactive mode.
- `JOLT_WHOLE_PROGRAM=1` — force the whole-program pass on in any direct-linked
mode.
- `JOLT_NO_SHAPE=1` — disable the record/shape representation under direct-linking.
What direct-linking gives up is what Clojure's `:direct-linking` and jank's
`-Odirect-call` give up: a direct call embeds its callee, so redefining the
callee is not seen by already-compiled callers. Whole-program additionally
const-links stable vars (data defs, record types, `^:redef`), extending the same
trade. That is why the interactive modes stay open and the opt-outs exist.
### Cross-namespace inference
Per-namespace inference (a `FILE` run, or any namespace under
`JOLT_NO_WHOLE_PROGRAM`) types a function's parameters from the call sites it can
see **within that namespace**. A function whose record parameter is supplied by a
caller in *another* namespace is left `:any`, its field reads keep the guard, and
the values derived from it widen — so a decomposed program is markedly slower
than the same code in one namespace (measured at ~3.7× on the ray tracer split
across five namespaces). The information exists in the program; per-namespace
compilation just can't see a caller in a not-yet-loaded namespace. Two ways to
supply it:
1. **Whole-program** (auto for `-m` / `-M`) runs one closed-world inference
fixpoint over every loaded namespace before `-main`, typing each parameter
from its call sites wherever they live. Namespaces required later (inside
`-main`) fall back to per-namespace inference.
2. **Parameter type hints** (`^RecordType`, RFC 0004) declare the type directly,
so it also works in the open world — REPL, library code that must be fast for
any caller, and hot-reloading servers — where the world cannot be closed.
## Relationship to Hindley-Milner and soft typing
This is HM-shaped with two deliberate departures, which is the textbook
definition of **soft typing** (Wright and Cartwright, "A Practical Soft Type
System for Scheme", 1997 — HM extended with union types and a dynamic type).
Taken from HM:
- The **structural type language** (records, vectors, functions as type
constructors). This is the "tree of types".
- **Constraint propagation** and **type schemes** for the core library (the
`∀T` signatures). That parametric polymorphism is exactly what HM provides,
and it is where it matters (generic collection functions like `nth`,
`reduce`, `map`).
Changed, on purpose:
- Replace "unify or **fail**" with "**join over a lattice whose top is `:any`**".
The inference never rejects a program; an unprovable spot becomes `:any` and
keeps the runtime guard. This is the "fall back to dynamic when in doubt"
policy made principled.
- **Monovariant** for user functions (the inter-procedural fixpoint plus
inlining cover the practical polymorphism); parametric schemes are kept only
for core functions.
So: HM structural types and constraint propagation and core-fn schemes, solved
by lattice join with a dynamic top instead of unification-or-fail. Other AOT
inferencers for dynamic languages do the whole-program version of the same
thing (RPython's annotator, Crystal's global inference, Shed Skin), all with a
union/dynamic fallback.
## Implementation and migration
This is a refactor that **simplifies** the current code: it deletes the ad-hoc
tag soup and the per-op special cases and replaces them with one recursive type
plus a signature table.
1. Define the structural type, `join`, the depth cap, and the predicates
(`struct-safe?`, `field-type`, `elem-type`) in `jolt.passes`.
2. Rewrite `infer` so each op produces/consumes structural types: literals
build shapes; `(:k m)` returns the field type; calls consult the signature
table.
3. Move the core-fn knowledge into a signature table (subsumes the existing
tables and HOF handling).
4. The back end keeps reading the use-site type to specialize (guard drop for
`{:struct}`, `pv-count`/`pv-nth` for `{:vec}`), now uniformly.
5. Keep the inter-procedural fixpoint, recompile, escape gate, and triggering as
is; they propagate structural types.
The phases land incrementally behind the same optimization-mode gate, each
verified against conformance (three modes), the full test gate, and the
ray-tracer benchmark, exactly as the current phases were.
## Design problems and open questions
- **Recursion / termination.** Handled by the depth cap (`D = 4`). Open
question: is a fixed cap better than proper recursive (mu) types? A cap is
simpler and sound; mu-types are more precise but add complexity. Proposed:
start with the cap.
- **Compile-time cost.** Structural types are larger and the fixpoint does more
work. Mitigations: the depth cap bounds type size; inference runs only in
optimization mode; the fixpoint iteration count stays bounded. Needs
measurement on a large namespace (clojure.core itself) to confirm acceptable.
- **Heterogeneous data.** `[1 "a"]` joins to `{:vec :any}`; a map whose field
varies across branches joins that field to `:any`. Correct degradation, not a
problem, but worth stating.
- **Non-constant keys.** `(assoc m k v)` / `(:k m)` with a non-constant `k`
cannot track a specific field; the result degrades to `{:struct {}}` or
`:phm` as appropriate. Field tracking only applies to constant scalar keys.
- **`false`/`nil` field values.** A map literal is `{:struct ...}` only when
every value is provably non-nil and non-false (the back end stores such maps
as a phm). The `:nonnil` tag (or a per-type "provably truthy" predicate) is
what the literal rule needs; this must be carried correctly or struct
inference is unsound.
- **Function-type precision.** `{:fn ...}` is optional. The current flat
param/return inference is enough for the collection-specialization goal;
full function types matter more for the type-checker (RFC 0006) and could be
deferred.
- **Closed-world boundary.** Inherited from the inter-procedural pass:
param/return inference assumes the compiled unit is the whole program.
Documented there; unchanged.

View file

@ -1,232 +0,0 @@
# RFC 0006 — Compile-time detection of provably-wrong code (success typing)
- **Status**: Implemented. Core-fn error domains (arithmetic on non-numbers,
count/first/rest/next/seq/nth on non-seqable scalars), `JOLT_TYPE_CHECK=
off|warn|error`. Follow-ups landed: bounded scalar **unions** so a
use is reported only when every member is in the error domain; **user-fn
error domains** behind `JOLT_TYPE_CHECK_USER` (closed-world);
precise **file:line:col** locations. The checker is now one
inference walk (folded into `infer`), and is **on by default in direct-link
builds** — where it piggybacks on the specialization inference for ~free —
and opt-in (`JOLT_TYPE_CHECK`) in plain builds.
- **Champions**: jolt maintainers
- **Created**: 2026-06-13
- **Depends on**: RFC 0005 (structural collection-type inference)
## Summary
Reuse the structural type inference of RFC 0005 as a **loose type checker**: at
compile time, flag code that is *provably* wrong, accept everything that is
merely ambiguous, and never produce a false positive. Concretely, when an
expression's inferred type is concrete and the operation applied to it would
throw at runtime for that type (for example passing a string where a function
only ever operates on numbers), report a clear compile-time error pointing at
the offending form, with the inferred type and what was expected. When the type
is `:any`, a union that includes a valid case, or beyond the inference's depth
cap, accept it silently. This is **success typing** (the discipline behind
Erlang's Dialyzer), applied to jolt for free on top of the inference we already
need for optimization.
## Motivation
Once the compiler tracks concrete types for many values (RFC 0005), it can see
some programs that cannot possibly be correct: `(inc "x")`, `(first 5)`,
`(count :k)`, `(/ 1 "two")`. Today these compile and fail at runtime, often far
from the cause. Reporting them at compile time, with a precise location and
message, turns a class of runtime crashes into immediate, actionable feedback,
at no extra inference cost.
The design constraint the user set is the right one and is exactly success
typing's contract: **accept ambiguous cases, reject only provably-wrong ones.**
A checker that never lies about errors is one developers trust and that does not
get in the way of correct-but-untypeable dynamic code.
## Principle: success typing, never a false positive
Success typing (Lindahl and Sagonas, "Practical Type Inference Based on Success
Typings", 2006; the basis of Dialyzer) inverts the usual type-checker stance.
A normal checker accepts only what it can prove correct and rejects the rest
(false positives on dynamic code). A success typer accepts everything that
*could* be correct and rejects only what *cannot* be correct under any
execution. It is sound for **rejection**: if it reports an error, the code is
genuinely wrong. It is intentionally incomplete: it misses errors it cannot
prove. That is the correct trade for a dynamic language, and it matches the
user's "accept ambiguous, reject provably wrong".
Mapped onto jolt:
- The inference assigns a value a concrete type only when it can prove it
(RFC 0005). Unprovable is `:any`.
- A use site is reported **iff** the argument's inferred type is concrete and
lies entirely outside the operation's accepted domain, where the operation
*throws* on that domain (not merely returns a benign default).
- `:any`, a depth-capped child, or a union that includes an accepted type is
**never** reported.
## What "provably wrong" means
The checker needs, per operation it understands, an **error domain**: the set
of argument types for which the operation throws at runtime. This is narrower
than "the types it is documented to accept", because Clojure is lenient in many
places and flagging a benign case would be a false positive:
- `(get 5 :k)` returns `nil`, it does not throw. NOT reported.
- `(:k 5)` returns `nil`. NOT reported.
- `(count 5)` throws ("count not supported on number"). Reported when the
argument is provably a non-countable scalar.
- `(first 5)` throws (not seqable). Reported for a provably non-seqable scalar.
- `(inc "x")`, `(+ 1 "x")` throw. Reported when an argument is provably a
non-number (`:str`, `:kw`, `:struct`, `:vec`, ...).
- `(nth 5 0)` throws. Reported for a provably non-indexable scalar.
So the checker ships a curated table of the clearest throwing operations with
their error domains. It starts small (arithmetic on non-numbers, seq/`count`/
`nth`/`first` on non-seqables) and grows conservatively. Anything not in the
table is not checked, which is safe (no false positive).
A use site is reported only when:
1. the argument's inferred type `T` is concrete (not `:any`, not a union that
includes an accepted type, not truncated by the depth cap), and
2. `T` is in the operation's error domain (the operation provably throws on `T`).
## Examples
```clojure
(inc "x") ; ERROR: inc expects a number, got a string
(let [n "x"] (inc n)) ; ERROR: same, n inferred :str
(count :foo) ; ERROR: count not supported on :kw
(first 42) ; ERROR: 42 is not seqable
(:k 5) ; accepted (returns nil, not an error)
(inc (rand-nth coll)) ; accepted if the element type is :any/unknown
(inc (if c 1 "x")) ; accepted: union {:num, :str} includes :num (ambiguous)
(defn f [n] (inc n)) ... ; if f is ALWAYS called with strings in-unit, ERROR at the call;
; if its callers are unknown/varied, accepted
```
## Error reporting
A reported error includes:
- the source location (`file:line:col`) of the offending form;
- the operation and the parameter position;
- the inferred type of the argument, rendered readably (`:str`,
`{:struct {:r :num}}`, `{:vec :any}`);
- what the operation requires (`a number`, `a seqable`).
Example:
```
type error scene.clj:42:18: `inc` requires a number, but argument 1 is a string
```
Errors are attributed to the form the user wrote. For macro-expanded code, the
checker reports at the original form's recorded position (the loader already
tracks `:error-pos`), never at synthesized internals.
## Strictness levels
`JOLT_TYPE_CHECK` controls behavior:
- **off** — no checking.
- **warn** — report to stderr, do not fail compilation. **The default in
direct-link builds**, where checking rides the specialization inference for
~free; opt-in elsewhere.
- **error** — fail compilation on a provable type error. Opt-in for CI / strict
builds.
When `JOLT_TYPE_CHECK` is unset, checking is **on (`warn`) in direct-link
builds** and **off in plain REPL/dev builds** (where it would cost a standalone
inference pass, ~2.6× compile). `JOLT_TYPE_CHECK_USER` additionally enables
reporting against inferred user-function domains (closed-world; see below).
Because the checker only fires on provable errors, even `error` mode cannot
break a correct program: a correct program has no provable type errors to
report. (A correct-but-untypeable program is simply not reported, since its
types degrade to `:any`.)
## Soundness of rejection (no false positives)
The whole value of this feature is that a reported error is real. The
guarantees:
- The inference assigns concrete types only when provable (RFC 0005). So a
concrete `T` at a use site is a genuine lower bound on what flows there in the
analyzed world.
- The error-domain table lists only operations that genuinely throw on the
listed types, verified against the runtime.
- Ambiguity is always accepted: `:any`, unions containing an accepted type, and
depth-capped children are never reported.
Two boundaries need care and bound where the checker is allowed to fire:
- **Closed-world / redefinition.** Inter-procedural argument types assume the
compiled unit is the whole program (inherited from RFC 0005). For the checker,
this means a reported error on a *user* function's parameter is only as sound
as that assumption. The conservative initial policy: only report against
**core-function** error domains (stable, not redefinable) and against types
derived without crossing an open boundary. Reporting against inferred user-fn
signatures is a later, opt-in escalation.
- **Macros / generated code.** Check post-expansion IR but report at the user's
source location, and suppress reports inside expansions the user did not
write (or attribute them to the macro call site).
## Relationship to other systems
- **Dialyzer / success typing** (Erlang): the direct model — sound for
rejection, no false positives, accepts the ambiguous.
- **Typed Clojure / core.typed**: opt-in *sound* gradual typing that rejects
what it cannot prove correct; the opposite trade (false positives on dynamic
code), which is why we do not follow it.
- **clj-kondo**: a popular Clojure linter that flags some obvious type misuses
syntactically; this RFC subsumes the type-driven subset with inference-backed
precision and no false positives.
## Implementation
The checker is a thin pass over the same inference results:
1. After (or during) inference, walk the IR. At each call to an operation in
the error-domain table, look at the inferred type of each checked argument.
2. If concrete and in the error domain, record a diagnostic with location, the
inferred type, and the expected domain.
3. Emit diagnostics per the strictness level.
It adds no new inference; it consumes RFC 0005's types and a small curated
table. It can ship after RFC 0005 lands, starting in `warn` mode with the
smallest high-confidence table (arithmetic and seq/count/nth/first), and grow.
## Design problems and open questions
- **Curating the error domain.** The table must list only genuinely-throwing
cases. Getting it wrong (listing a lenient op) yields false positives, which
destroys trust. Mitigation: start tiny, test each entry against the runtime,
grow slowly. Open question: derive the table from the same machinery the
runtime uses, to avoid drift?
- **Unions.** *Resolved.* The lattice has a bounded scalar union
`{:union #{T...}}` (cap 4); differing if-branches form a union instead of
collapsing to `:any`, and a use is reported only when *every* member is in the
error domain. Unions are opaque to structural specialization, so codegen is
unchanged.
- **User-function signatures.** *Resolved, opt-in.* Behind
`JOLT_TYPE_CHECK_USER`: the checker re-checks a registered non-redefinable
user fn's body with one parameter bound to its concrete argument type; a
diagnostic the all-`:any` body did not have means that argument is provably
wrong. Monotonic, so still no false positives; closed-world, hence opt-in.
- **Negative/never types.** *Resolved.* Calling a provably
non-callable value (`:num`/`:str` — keywords/maps/vectors/sets are IFn) is
reported at the default level; wrong-arity to a registered single-fixed-arity
user fn is reported under the `JOLT_TYPE_CHECK_USER` opt-in. A union callee is
flagged only when every member is non-callable.
- **Position vs intent.** *Resolved.* The reader records each list
form's absolute offset (identity-keyed, so positions survive macroexpansion
exactly when the user's sub-form is spliced through); the analyzer stamps it
onto `:invoke` nodes, the checker carries it into each diagnostic, and the
back end renders `file:line:col`. Inlining/scalar-replace preserve it via
`assoc`.
- **Interaction with the optimization gate.** *Resolved (jolt audit).* The
checker is one inference walk folded into `infer`. In direct-link builds it
piggybacks on the specialization inference that already runs (~free, default
on); in plain builds it runs as a standalone pass only when `JOLT_TYPE_CHECK`
is set. "Run inference for checking" and "specialize from inference" are the
same walk now, gated by a `checking?` flag.

View file

@ -1,186 +0,0 @@
# RFC 0007 — Compilation modes and binary output
- **Status**: Draft. No code yet; this fixes the design before Phase 4 work
(beads `jolt-cf1q.5`) starts.
- **Champions**: jolt maintainers
- **Created**: 2026-06-22
## Summary
Give jolt a `jolt build` command that emits a standalone executable, and a
three-mode model that trades dynamism for speed:
- **dev** — open/indirect linking, redefinition works, no perf focus. What
`repl`/`-e`/`nrepl` already are.
- **release** (default for a built program) — direct-linked, closed-world,
per-namespace inference. Fast, still a recognizable Clojure runtime.
- **optimized** — whole-program inference, `fl*`/`fx*` typed emission, Chez
whole-program optimization. Fastest, sacrifices dynamic redefinition.
All three already have their machinery in the tree — the inference and inline
passes were ported into `jolt-core/jolt/passes/`. What is missing is (a) a code
path that writes emitted Scheme to disk and AOT-compiles it instead of
eval'ing it in process, and (b) a switch that turns the dormant passes on. This
RFC specifies both.
## Motivation
The Janet host could produce binaries (`jolt uberscript` with dead-code
elimination, `jolt cgen-build` for a single native binary). The Chez rehost
dropped that machinery with the Janet host — it was Janet-specific (IR→C made
sense when the host was Janet). On Chez the natural target is Chez's own native
compiler, so the old emitters were deleted rather than re-pointed.
The result today: `bin/joltc` only ever loads the checked-in seed and
compile-evals in process. `jolt.main/-main` dispatches `run / -M / -A / repl /
nrepl / task` and nothing else. There is no way to ship an app as a binary, and
the optimization passes are inert — `jolt.host/inline-enabled?` is a stub
returning `#f` (`host/chez/host-contract.ss:283`), so every call links
indirectly and nothing inlines. Jolt on Chez runs only in what this RFC calls
dev mode.
The passes themselves survived intact:
- `jolt/passes/types.clj` — structural collection-type inference (RFC 0005) +
success-type checking (RFC 0006).
- `jolt/passes/inline.clj` — inline + flatten-lets + scalar-replace, already
gated "direct-link only".
- `jolt/passes/fold.clj` — const-fold, including predicate folding.
So this is not a port of lost code. It is wiring: a build front-end, a
file-emitting back-end path, and a mode switch over passes that already exist.
## The three modes
| Mode | Linking | Inference | Redefinition | Driver |
|---|---|---|---|---|
| **dev** | indirect (var-deref per call) | off | yes | `repl`, `-e`, `nrepl`, `run` of a file by default |
| **release** | direct, closed-world | per-namespace | no (closed world) | `jolt build` default |
| **optimized** | direct + whole-program | whole-program fixpoint, `fl*`/`fx*` | no | `jolt build --opt` / `-M`-style entry |
The modes are points on one axis (how much the back end may assume is fixed),
not three code paths. Each mode is a setting of two independent knobs the passes
already understand:
- **direct-link?** — may a call to a var compile to a direct procedure
reference instead of a `var-deref`? Enables inlining and call-site folding.
Opt-out is per-target: a `^:redef` or `^:dynamic` var always links indirect.
- **whole-program?** — does inference see the whole reachable program at once
(closed world), so a record param's callers in other namespaces are visible
and its field reads specialize? Without it, inference is per-namespace and a
cross-ns param de-specializes to `:any` (the cross-ns penalty documented in
the `cross-ns-param-penalty` memory; declared `^RecordType` hints are the
open-world escape hatch).
```
dev: direct-link? = false whole-program? = false
release: direct-link? = true whole-program? = false
optimized: direct-link? = true whole-program? = true
```
`fl*`/`fx*` typed emission (unchecked flonum/fixnum Scheme ops) rides on
optimized: only whole-program inference proves the types that make dropping the
numeric-tower dispatch sound. Release keeps the tower.
## CLI surface
```
jolt build [-m NS | FILE] [-o OUT] [--opt] [--dev]
```
- Resolves `deps.edn` exactly as `run` does (reuse `jolt.deps`).
- Default mode is **release**. `--opt` selects optimized; `--dev` builds an
unoptimized binary (useful to ship a debuggable build, not for the REPL).
- `-o` names the output (default the entry ns / file stem).
- Output is a single executable: a Chez boot file plus the compiled program,
launched by a thin wrapper, or a fully linked image where the platform allows.
App libraries are baked in — no source roots needed at runtime.
Env opt-outs for the build (mirrors the Janet knobs, now keyed off the mode
rather than the run): `JOLT_NO_DIRECT_LINK` forces open linking even in a build,
`JOLT_NO_WHOLE_PROGRAM` keeps direct-link but per-namespace, `JOLT_WHOLE_PROGRAM=1`
forces whole-program. These already name the two knobs above.
## Emission pipeline
The in-process spine today (`host/chez/compile-eval.ss`) is, per form:
```
source → read → analyze (→ IR) → emit (→ Scheme string) → (eval (read …))
```
`jolt build` keeps everything up to `emit` and replaces the per-form `eval` with
accumulate-then-compile:
1. **Assemble the program.** Starting from the entry ns's `-main`, load the
transitive `require` graph (the loader already does this) and collect every
reachable top-level form, in dependency order, with its compile namespace.
2. **Dead-code elimination.** Re-target the uberscript DCE idea: compute
reachability from `-main` plus non-prunable forms, drop dead `defn`/`defn-`.
Bail to keep-all on `resolve`/`ns-resolve`/`requiring-resolve`/`find-var`/
`intern`/`eval`/`load-string` (anything that defeats static reachability);
keep and scan `defmethod`/`defrecord`/`extend` bodies so dispatch targets
stay live.
3. **Emit to a file.** Run `analyze → emit` for each surviving form under the
mode's knobs, concatenating the Scheme strings into one program source (the
core overlay prelude first, exactly as the seed image is built today).
4. **Compile.** Feed that source to Chez `compile-program` (release) or
`compile-whole-program` (optimized, which also lets Chez cross-module
inline), producing a compiled object, then link a boot file / wrapper into
the final executable.
Steps 34 are the only genuinely new back-end code. Step 2 is a re-port of a
deleted pass. Steps before them already run on every `joltc` invocation.
## Turning the passes on
`inline-enabled?` is the existing gate. Today `host-contract.ss` hardwires it to
`#f`. Under this RFC the build sets it (and a parallel `whole-program?` flag)
from the chosen mode before compiling, so:
- release: `inline-enabled?` → true, whole-program off. Per-ns inference and
inlining light up; `fl*`/`fx*` stays off.
- optimized: both on; the types pass runs its whole-program fixpoint and the
back end may emit unchecked numeric ops where a flonum/fixnum is proven.
No new pass is required to reach release — it is the ported passes, ungated.
## Staging
1. **Spike (de-risk Chez AOT).** Emit a trivial whole program to disk and prove
`compile-program` + boot/static link yields a standalone binary that runs.
This is the only real unknown.
2. **`jolt build` release.** Front-end + file-emitting back-end path + flip
`inline-enabled?` from the mode. Gate against the bench/corpus suites; binary
output must pass the corpus a `run` passes.
3. **DCE.** Re-port the reachability pass; gate with a test like the old
`uberscript-dce` case.
4. **Optimized.** Whole-program flag, `compile-whole-program`, `fl*`/`fx*`
emission. Gate on the bench suite (ray tracer, binary-trees) for size and
speed vs the spike baseline.
Each stage is TDD against the existing gates (`make test`, `make corpus`, the
`bench/` programs). Modes land behind the build command, so dev — the only mode
today — is unaffected until a stage proves out.
## Open questions
- **Static vs. boot-file linking.** A fully static Chez image is the smallest,
most portable artifact but the most work to link; a boot file plus a stub
launcher is the easy first cut. Spike decides which step 1 targets.
- **FFI in a built binary.** `jolt.ffi` loads native libraries at runtime; a
closed-world build still needs that to work. The build must bake the FFI
Clojure side and keep dynamic `dlopen` at run time.
- **Macro and `eval` at runtime.** Release/optimized are closed-world, but an
app that calls `eval`/`load-string` needs the compiler present. Either ship
the compiler image in the binary (larger) or reject those builds (the DCE
bail-out already detects the calls).
## Prior art in this repo
The optimization design these modes turn on is RFC 0004 (type hints), RFC 0005
(structural inference), RFC 0006 (success checking). The linking model — direct
linking as a per-unit property, `^:redef`/`^:dynamic` as the only opt-out — and
the cross-ns specialization penalty are recorded in beads memories
(`jolt-linking-model`, `cross-ns-param-penalty`). Phase 4 (`jolt-cf1q.5`) is the
tracking issue.

View file

@ -1,21 +0,0 @@
# RFCs
Design notes for non-obvious language and compiler decisions. An RFC records *why*
a thing is built the way it is; the code is the source of truth for *how*.
| # | Title | Status | Governs |
| --- | --- | --- | --- |
| [0001](0001-language-specification.md) | A Specification for the Clojure Language | Draft | The conformance target — what "is Clojure" means for jolt. |
| [0002](0002-reader-conditional-features.md) | Reader-Conditional Feature Set | Accepted | `#?(...)` feature keys (`:jolt`, `:clj`, `:default`). |
| [0003](0003-transients.md) | Transients | Accepted | `transient`/`persistent!` semantics + the Chez mutable backing. |
| [0004](0004-type-hints.md) | Type hints + keyword-lookup specialization | Accepted | `^Type`/`^:struct` hints → the bare-`get` fast path. |
| [0005](0005-structural-type-inference.md) | Structural collection-type inference | Implemented | The `:struct`/`:vec`/`:set` lattice in `passes/types`. |
| [0006](0006-success-type-checking.md) | Success typing (provably-wrong-code detection) | Implemented | The error-domain checker in `passes/types`. |
| [0007](0007-compilation-modes-and-binary-output.md) | Compilation modes + binary output | Implemented (doc lags) | `release`/`--opt`/`--dev`, `--direct-link`, `--tree-shake`. |
RFC 0007's own status line still says "Draft, no code yet" — that is stale:
direct-linking and tree-shaking shipped (see [tools-deps.md](../tools-deps.md) and
`backend_scheme.clj` / `build.ss`). Two compiler features that grew alongside it —
**IR inlining** (`passes/inline.clj`, under `--opt`) and **numeric `fl*`/`fx*`
lowering** from `^double`/`^long` hints (`passes/numeric.clj`) — are not yet written
up as RFCs; their touch points are in [../MODULES.md](../MODULES.md).

View file

@ -1,45 +0,0 @@
# Seed ↔ Overlay Registry
Jolt is Clojure on Chez Scheme. `clojure.core` is built from two tiers that both
define `clojure.core`-facing vars, and for a handful of names *both* tiers carry
a definition. This document records how the two tiers relate and which copy is
authoritative.
## The two tiers
- **Native shims** (`host/chez/natives-*.ss`) bind a set of `clojure.core` vars
directly to Scheme runtime values via `def-var!` — collection constructors,
seq fns, numeric/string ops, and so on. These cover names the overlay assumes
exist as bare `clojure.core` vars but does not define itself.
- **The Clojure overlay** (`jolt-core/clojure/core/NN-*.clj`) defines the rest of
`clojure.core` in dependency-ordered tiers, loaded in order: `00-syntax`,
`00-kernel`, `10-seq`, `20-coll`, `25-sorted`, `30-macros`, `40-lazy`, `50-io`.
The overlay loads after the native shims. When an overlay tier `(defn X …)` for a
name a native shim already bound, the **overlay def shadows the native binding**
user code sees the overlay copy. The native binding then survives only if some
other native/runtime code still calls the Scheme value directly.
So a name's *home* is determined by two facts:
1. is it bound by a native shim? (the Scheme value is reachable from the runtime)
2. does an overlay tier `(defn X …)`? (the overlay copy is what user code sees)
## The compiled seed
`clojure.core` is compiled ahead of time into the checked-in seed
(`host/chez/seed/{prelude,image}.ss`) as Scheme `def-var!` forms. The seed's
source twin is the overlay (`jolt-core/clojure/core/*.clj` plus the stdlib
namespaces under `stdlib/clojure/`); `host/chez/emit-image.ss` re-emits the
prelude from those sources on Chez. The build is a byte-fixpoint: rebuilding from
an up-to-date seed reproduces it exactly.
## Consistency guard
There is no separate drift-check test for the registry. The self-hosting
fixpoint is the guard: after changing a seed source (a core tier, the compiler
namespaces, the host contract, the reader, or `emit-image.ss`) you must re-mint
the seed (`make remint`), and `make selfhost` fails if the checked-in seed and
its sources have drifted. So if the overlay's shadowing relationship changes, the
re-minted prelude changes with it, and the fixpoint check keeps source and seed
in agreement.

View file

@ -0,0 +1,138 @@
# Self-hosting architecture: portable jolt-core over a host runtime
Design for splitting Jolt into a **portable Clojure-in-Clojure core** and a
**host runtime** (Janet today, another runtime tomorrow), so the language is
truly self-hosted and `jolt-core` can be lifted out and re-hosted.
This is the design that must be right *before* writing the compiler in Clojure —
see [[self-hosting-compiler]] for the staged plan it plugs into.
## What "truly self-hosted + portable" requires
Two independent properties:
1. **Self-hosted** — the compiler and most of `clojure.core` are written in
Clojure and compiled by Jolt itself.
2. **Portable** — that Clojure code (`jolt-core`) depends only on a small,
explicit **host contract**, never on Janet directly. Re-hosting means
implementing the contract for a new runtime; `jolt-core` is reused verbatim.
The enemy is `jolt-core` calling `janet/tuple`, `make-vec`, `ns-find`, etc.
directly — that welds it to Janet. Every host dependency must go through the
contract.
## Prior art (the seam everyone uses)
- **Clojure (JVM).** `clojure.lang.*` (Java) is the host: `RT`/`Numbers` runtime
helpers, the `Compiler` (form → JVM bytecode), persistent data structures,
`Var`/`Namespace`, the reader. `clojure/core.clj` is the language, in Clojure.
Seam: ~20 primitive special forms + `RT` static methods. Everything else is
Clojure.
- **ClojureScript (self-hosted).** Two portable passes — `cljs.analyzer`
(form → AST **as data**, reading a **compiler-state map** of
namespaces/defs/macros, *not* host objects) and `cljs.compiler` (AST → JS, the
host-specific back end). `cljs.core` is Clojure compiled to JS. Platform splits
live in `.cljc` reader conditionals. This is the closest model to what we want:
**the analyzer is host-agnostic; only the back end and the runtime are
host-specific.**
- **Nanopass / Guile Tree-IL.** A high-level IR is the portability seam; multiple
back ends consume it.
- **ClojureCLR / ClojureDart / jank.** Same shape every time: portable analyzer +
host back end + host runtime.
The invariant across all of them: **the IR (analyzer output) and a small runtime
protocol are the contract; the front end is portable, the back end and runtime
are per-host.**
## Decisions (locked)
- **Seam = a minimal host protocol.** `jolt-core` calls a small documented set of
host fns (in ns `jolt.host`): `resolve-sym`, `macro?`, `macroexpand-1`,
`current-ns`, `intern!`, plus the `RT` primitives. Each host provides `jolt.host`
(+ RT). Re-hosting = reimplement that handful of fns. The protocol *is* the
boundary; `jolt-core` never touches Janet directly.
- **Physical split now.** Portable Clojure lives under `jolt-core/` (a new source
root, embedded into the binary like the rest of the stdlib); host Janet code for
the new pipeline under `host/janet/`. Legacy host modules under `src/jolt/*.janet`
are the existing Janet host and get relocated under `host/janet/` in a later
mechanical pass (tracked) — not moved big-bang now, to keep the suite green.
## The Jolt split
```
jolt-core/ PORTABLE Clojure — no Janet. Depends only on the contract.
ir the IR spec (data shapes the analyzer emits)
analyzer form -> IR (macroexpands; resolves via host protocol)
macros when/cond/->/defn/... (the macro library, in Clojure)
core clojure.core fns expressible in Clojure, over RT primitives
host/janet/ THE HOST — Janet. Implements the contract.
reader text -> jolt forms
rt data structures + RT primitive fns (cons/first/+/get/apply…)
backend IR -> Janet forms -> Janet compile -> bytecode (the emitter)
cenv the compile-time host protocol impl (resolve/macro?/intern)
bootstrap load jolt-core, wire analyzer+backend into the loader
interop janet.* bridge
```
Two contracts cross the seam:
### 1. The IR (analyzer → back end)
The existing `:op`-tagged AST, made **host-neutral**:
- `{:op :const :val v}`, `:if`, `:do`, `:let`, `:fn` (arities), `:invoke`,
`:vector`/`:map`/`:set`, `:quote`, `:throw`/`:try`, `:loop`/`:recur`.
- **Globals reference vars by NAME, not by host cell:**
`{:op :var :ns "clojure.core" :name "map"}`. (compiler.janet today embeds the
Janet var cell as a constant — that's a host leak and breaks AOT. Name-based
refs are both portable and AOT-friendly; the back end resolves the cell.)
- No embedded host function values. Calls to runtime primitives are
`{:op :rt :name "cons"}` resolved by the back end to the host's RT fn.
### 2. The host contract (two protocols)
- **Compile-time (`cenv`)** — what the analyzer needs from the host while
analyzing: `(current-ns)`, `(resolve-sym sym) -> {:kind :var|:macro|:local|:special|:host, :ns, :name}`,
`(macroexpand-1 form)`, `(intern! ns sym meta)`. The analyzer calls only these;
it never touches Janet ns/var tables. (CLJS keeps this as pure data; we use a
small protocol — a minimal, documented boundary — because Jolt already has live
ns/var objects. The protocol *is* the seam.)
- **Runtime (`RT`)** — the primitive fns emitted code and `jolt-core` call by
stable name: arithmetic/compare, `cons/first/rest/seq/conj/get/assoc/count`,
`apply`, `=`, vector/map/set constructors, var deref/bind, keyword/symbol
construction. The back end maps each to the host (on Janet, mostly the existing
`core-*`). To re-host, implement this set.
## Why name-based vars (not embedded cells)
`compiler.janet` compiles a global ref to a closure over the Janet var cell. That
(a) is a Janet value baked into the IR — not portable, and (b) can't be marshaled
for AOT without the runtime-dict trick. Compiling instead to *resolve var by
(ns,name) at call time* through an RT primitive keeps redefinition live, makes the
IR host-neutral, and makes images trivially portable. The per-call lookup is the
cost; it can be cached/direct-linked later as an opt-in optimization.
## Bootstrap & staging (keeps the suite green throughout)
`compiler.janet` stays as the **bootstrap back end** until the Clojure pipeline is
proven. Order:
1. **Freeze the IR** spec and refactor `compiler.janet`'s emit to consume
name-based `:var` (no behavior change; bootstrap still works).
2. **Define the host contract** (`cenv` + `RT`) and implement it on Janet,
exposed under a stable namespace the Clojure core can call.
3. **Write `jolt.analyzer` in Clojure** producing IR, against `cenv`. Diff its IR
against the Janet analyzer on the conformance corpus until identical.
4. **Janet back end consumes IR** from the Clojure analyzer; wire into the loader
behind a flag. Validate at parity (dual-mode conformance + clojure-test-suite).
5. **Flip** the loader to the Clojure analyzer + Janet back end; `compiler.janet`
shrinks to the back end only.
6. **Move `clojure.core`** macros then fns into `jolt-core` incrementally, each
compiled by the prior stage, isolating host bits behind `RT`.
Guards at every step: the dual-mode conformance harness (interpret vs compile)
and the clojure-test-suite baseline.
## The portability test
When done, re-hosting Jolt to runtime X means writing only: `host/X/{reader, rt,
backend, cenv, bootstrap}`. `jolt-core/{ir, analyzer, macros, core}` is reused
unchanged. That is the concrete bar for "truly self-hosted and portable."

View file

@ -0,0 +1,172 @@
# Toward a self-hosting Jolt compiler
Research and design notes for evolving Jolt from "interpreter + opt-in ad-hoc
compiler" toward a self-hosting Clojure-in-Clojure compiler that emits Janet
bytecode, keeps full REPL live-redefinition, and rests on a minimal Janet
bootstrap. This is a design doc, not a changelog — it describes where we are, the
prior art, the constraints we verified, and a recommended path.
## The goal
- **Self-hosting, Clojure-in-Clojure.** A small kernel in the host (Janet) is
enough to start; the rest of Clojure — including the compiler — is written in
Clojure and compiled by Jolt itself, growing the language as it compiles more
of itself.
- **Janet bytecode out.** Compiled code runs as native Janet bytecode (fast),
not tree-walking.
- **Full runtime flexibility.** `def`/`defn` redefinition, vars, protocols,
multimethods, and everything else stay live and redefinable at the REPL even
for compiled code.
- **Minimal host requirement.** Shrink what must exist in Janet to the
irreducible base.
## Where Jolt is today
- ~5,500 lines of **Janet** implement `clojure.core` (`core.janet`) and a
tree-walking interpreter (`evaluator.janet`); ~1k lines of **Clojure** are the
stdlib (`clojure.string/set/walk/…`, `jolt.*`). So the language is mostly in
the host, inverted from the Clojure-in-Clojure ideal.
- The interpreter (`eval-form`) is the complete reference path.
- The compiler (`compiler.janet`) — `analyze-form` (reader form → `:op` AST) →
`emit` (AST → Janet form) → Janet `compile`/`eval` — is now **on by default**
in the shipped runtime (`JOLT_INTERPRET=1` opts out). It is a *hybrid*: forms
it can't compile correctly throw `jolt/uncompilable` and fall back to the
interpreter (`loader/eval-toplevel`), so results always match the interpreter.
Validated at parity — conformance 218/218 under both interpret and compile, and
the clojure-test-suite under compile passes 3932 (vs the 3913 interpreter
baseline) across ~4.6k assertions.
- Done so far: var-indirection (globals deref through var cells, so compiled code
is REPL-redefinable); hybrid fallback; compilation of multi-arity / named /
variadic fns and `recur` inside `fn`; map and vector literal compilation
(mode-correct via `make-vec` / `build-map-literal`); resolution that mirrors
the interpreter (current ns → `clojure.core` → Janet-env fallback); and AOT
(`aot.janet`) that marshals a compiled namespace to a Janet bytecode image
against the baked-in runtime dictionary and loads it back.
- Still open — the actual self-hosting: the compiler and most of `clojure.core`
are still Janet. Rewriting them in Clojure (compiled by Jolt) is the remaining
Clojure-in-Clojure work.
## What the host gives us (verified)
Janet already is the backend and the AOT story — we don't need a custom bytecode
emitter:
- `(compile form env source)` → a **function** (compiled bytecode). Jolt's job is
Clojure form → correct Janet form → `compile`.
- `marshal`/`unmarshal`, `make-image`/`load-image` → serialize a compiled
environment to a **bytecode image** and load it back: this is Phase 4 AOT.
- `asm`/`disasm` → bytecode assembler/disassembler if we ever want to bypass the
form layer (we shouldn't need to).
**The catch we verified:** Janet *early-binds* top-level references. Compile
`(defn caller [] foo)`, then redefine `foo` — the compiled `caller` still returns
the old value. So emitting Jolt globals as plain Janet symbols (what the current
compiler largely does) is fundamentally incompatible with REPL redefinition. This
is the single most important design constraint below.
## Prior art
- **Clojure (JVM).** A Java runtime + compiler bootstraps `clojure.core`, which is
written in Clojure; thereafter Clojure compiles Clojure to JVM bytecode. Only
~20 special forms are primitive; everything else is macros/functions. Crucially,
compiled call sites go **through Var objects** (a deref), so redefining a var is
visible to existing compiled callers — that's how speed and live redefinition
coexist. Clojure 1.8 added opt-in **direct linking** (inline the call, drop the
var indirection) for speed where you don't need redefinition (used for core in
production). AOT compiles namespaces to `.class` files.
- **ClojureScript self-hosting.** Two stages: an **analyzer** (source → AST plus
a "compiler state" map of namespaces/defs/macros) and a **compiler** (AST → JS).
`cljs.js` exposes compile/eval at runtime; bootstrapped CLJS compiles CLJS at
~2× the JVM compiler. The host VM (JS engine) is the backend — the same shape we
want with Janet as the backend.
- **Nanopass (Chez Scheme).** A compiler as *many small passes* over *formally
specified* intermediate languages, with autogenerated boilerplate to recur
through unchanged forms and checks that each pass's output matches its grammar.
The lesson for "grow the language as it compiles itself": keep passes small and
IRs explicit so adding a form is local and verifiable.
- **Guile.** A Lisp on a bytecode VM: source → Tree-IL (high-level IR) → CPS
(optimization IR) → VM bytecode, with several front-end languages targeting
Tree-IL. The closest analog to "Lisp → bytecode on a VM."
## Assessment: is the current approach the right one?
The overall *shape* is right and matches ClojureScript: front-end (analyze →
emit) with the host VM as the backend, emitting host forms that the host compiles
to bytecode. Two things need to change to reach the goal:
1. **Late binding for globals.** Compile a reference to a Jolt var as a **deref
through the var cell**, not as a Janet symbol. Jolt vars are already cells
(`{:jolt/type :jolt/var :root …}`); a compiled global call becomes roughly
`((var-root cell) args…)` instead of `(janet-symbol args…)`. Redefinition
updates the cell's root, so compiled callers see it — exactly Clojure's model.
One indirection per global call; locals and control flow stay direct and fast.
Offer opt-in **direct linking** for hot/AOT code that doesn't need redefinition.
2. **Move the compiler and core into Clojure.** Today both are Janet. Self-hosting
means the compiler is Clojure compiled by Jolt, and most of `clojure.core` is
Clojure. That's the bulk of the work and where the "language builds itself"
payoff lives.
So: keep the emit-to-Janet target (it's correct and gives us bytecode + AOT for
free), fix global binding, and progressively self-host.
## Recommended architecture
**Pipeline (nanopass-lite).** Keep the data-driven `:op` AST and grow it as small,
named passes rather than one big walker:
1. *read* — reader → forms (already have it).
2. *macroexpand* — fully expand to special forms + calls (the interpreter already
expands; share one expander).
3. *analyze* — forms → AST, resolving locals vs vars and tagging ops.
4. *(optional) optimize* — constant-fold, direct-link hot calls, etc.
5. *emit* — AST → Janet form, with globals as var-cell derefs.
6. *compile* — Janet `compile` → bytecode; `make-image` for AOT.
Make each pass total over the IR so an unhandled node is an explicit gap, not a
silent miss.
**The kernel (minimal Janet bootstrap).** The irreducible base that must exist in
the host before any Clojure can run: the reader; the value/representation layer
(vars, namespaces, symbols, keywords, persistent collections, chars); host
interop (the `janet.*` bridge); `fn`/`if`/`do`/`let`/`quote`/`def`/`loop`/`recur`
evaluation; and `compile`/`eval`. Everything else — the rest of `clojure.core`,
the macros, and the compiler — is Clojure loaded and (eventually) compiled by the
kernel. Today the kernel is far larger than this; shrinking it is a long game.
**Hybrid interpret/compile (Phase 3, and a bootstrap safety net).** When a pass
can't yet compile a sub-form, emit a call back into the interpreter (`eval-form`)
for that sub-form instead of erroring. This lets the compiler be incomplete and
still correct (hot paths compile, cold/unsupported paths interpret), lets us grow
coverage incrementally, and de-risks the self-hosting bootstrap.
**Live flexibility.** Vars stay first-class cells; compiled code derefs them;
`def` updates the root; protocol/multimethod dispatch stays dynamic. Direct
linking is opt-in, never the default, so the REPL is always live.
## A staged path
1. **Var-indirection in the emitter***done*. Global refs compile as var-cell
derefs, so a compiled `defn` is redefinable at the REPL.
2. **Hybrid fallback + coverage** (`jolt-1bj`) — *done*. Forms the compiler can't
compile throw `jolt/uncompilable` and fall back to the interpreter, so compile
mode is always correct. Covered: multi-arity/named/variadic fns, `recur` in
`fn`, map/vector literals, and resolution matching the interpreter.
Destructuring compiles via the shared `destructure` expander: the `fn`/`let`/
`loop`/`defn` macros desugar to plain-symbol `fn*`/`let*`/`loop*`, so it no
longer falls back — and the primitives reject patterns outright, matching
Clojure (`jolt-f79`).
5. **Compile-by-default + AOT** (`jolt-7j9`) — *done, done out of order*. Once the
hybrid path was validated at parity, compilation was flipped on by default and
AOT images (`aot.janet`) landed. Done before 34 because it's the runtime
payoff and only needed the hybrid path to be correct, not self-hosting.
3. **Self-host the compiler** (`jolt-lcn`) — *open*. Rewrite `compiler.janet` as
Clojure (`jolt.compiler`) that Jolt compiles. Now the compiler is part of the
language it compiles.
4. **Shrink the kernel / core-in-Clojure** (`jolt-uqi`) — *open*. Move
`clojure.core` from Janet to Clojure incrementally, each piece compiled by the
previous stage — the language building itself — leaving a minimal Janet kernel.
What remains (3 and 4) is the actual Clojure-in-Clojure rewrite: the largest part
of the work and where the "language builds itself" payoff lives. The correctness
and runtime foundations it needs — redefinable compiled code, an always-correct
hybrid path, compile-by-default, and AOT — are now in place.

View file

@ -68,9 +68,8 @@ Behavioral questions are settled in this order: differential testing against
the reference implementation → cross-dialect agreement in clojure-test-suite
→ ClojureDocs community examples (verified before inclusion) → reference
source (for intent). Conformance tests live in this repository
(the corpus `test/chez/corpus.edn`, run on Chez via `host/chez/run-corpus.ss`
and certified against reference JVM Clojure by `test/conformance/certify.clj`)
and in the cross-dialect clojure-test-suite.
(`test/integration/conformance-test.janet` runs each assertion through three
independent execution paths) and in the cross-dialect clojure-test-suite.
## 5. Chapter plan

View file

@ -43,10 +43,7 @@ exponent := [eE] ['+'|'-'] digits
- S5. Trailing `N` (BigInt) and `M` (BigDecimal) suffixes are part of the
grammar; their value semantics are the §4 numeric-tower question.
Implementations without those towers SHOULD read them as the nearest
numeric type and MUST document the choice. The Chez host carries the full
tower: `N` reads as an exact integer (arbitrary precision) and `M` as a real
BigDecimal — `1.5M`, `0.0M`, `3M` — with value equality ignoring scale
(`1.0M = 1.00M`), `(class 1.5M)``java.math.BigDecimal`, and `decimal?` true.
numeric type and MUST document the choice.
### Symbols and keywords
@ -59,9 +56,8 @@ keyword := ':' name | ':' ns '/' name | '::' name | '::' alias '/' name
. $ & %` (with `%` and `&` further constrained inside `#()`); a symbol
MUST NOT begin with a digit; `.` and `/` have positional restrictions.
- S7. `::kw` MUST resolve to the current namespace at *read* time
(`::k` in ns `user` reads as `:user/k`); `::alias/k` resolves `alias` through
the current namespace's aliases. (Clojure raises a read error for an unknown
alias; jolt reads it as `:alias/k`.)
(`::k` in ns `user` reads as `:user/k`); `::alias/k` resolves the alias or
MUST be a read error if the alias does not exist.
### Strings and characters
@ -78,29 +74,15 @@ checks → UNVERIFIED (rows to add).
| Sugar | Reads as | |
|---|---|---|
| `'form` | `(quote form)` | S10 |
| `@form` | `(clojure.core/deref form)` | S11 |
| `@form` | `(deref form)` | S11 |
| `^meta form` | form with metadata attached (see below) | S12 |
| `#'sym` | `(var sym)` | S13 |
| `` `form `` | syntax-quote (§2.4) | |
| `~form`, `~@form` | unquote / unquote-splicing — only within syntax-quote (S14: MUST error outside) | |
- S11. `@form` reads as `(clojure.core/deref form)` — the operator is the
fully-qualified `clojure.core/deref`, not a bare `deref`, so `@x` still
dereferences in a namespace that excludes and rebinds `deref`
(`(ns … (:refer-clojure :exclude [deref]))`), matching Clojure.
- S12a. `^:kw form``^{:kw true} form`; `^Sym form``^{:tag Sym} form`;
`^"str"``^{:tag "str"} form`. Multiple `^` stack, rightmost innermost,
merged left-over-right.
- S12b. Type hints are semantically transparent: a hint MUST NOT change a
program's result. Hints parse in every position they do in Clojure (params,
`let` bindings, `def` names, return position, arbitrary forms) and are
otherwise inert. As a non-normative optimization, jolt recognizes two hints
on a local as an assertion that a constant-keyword lookup may skip its
runtime representation guard: `^:struct` (a plain struct/record map) and
`^Name` where `Name` is a `defrecord`/`deftype`. The assertion is the
programmer's (an inaccurate hint yields a wrong lookup, like a wrong Clojure
`^String`); `JOLT_CHECK_HINTS=1` turns a violated hint into an error at no
cost to unchecked builds. See RFC 0004.
- S13a. `#'ns/sym` MUST denote the same var as `(var ns/sym)`:
`(= (var clojure.core/str) #'clojure.core/str)` is true.
@ -125,15 +107,6 @@ checks → UNVERIFIED (rows to add).
- `#(body)` reads as `(fn [args…] (body))` with parameters derived from the
`%`-symbols appearing in body: `%``%1`, `%n` positional, `%&` the rest
parameter. Arity = highest `%n` mentioned (plus rest if `%&`).
- The `%`-symbols are collected from the WHOLE body, recursing through every
nested form including vector, map and set literals — `#(assoc {} :k %)`,
`#(hash-set % %2)` and `#(get {:t %} :t)` all see their `%`s. (A reader that
scanned only call forms would miscompile `#(identity {:text %})` as a 0-arg fn.)
- The synthesized parameters are auto-gensyms (their names carry the `#` suffix,
like Clojure's `p1__N#`), so an `#()` written inside a syntax-quote survives:
the params are mapped consistently and left unqualified rather than being
qualified to the current namespace (a qualified symbol is not a valid
parameter). E.g. `` `(map #(inc %) xs) `` expands correctly inside a macro.
- `#()` literals MUST NOT nest.
```clojure
@ -159,10 +132,9 @@ 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 :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.)
`#{: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.)
- Reader conditionals MUST be an error outside `.cljc`-style reading unless
the implementation documents otherwise.
@ -225,31 +197,3 @@ 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

@ -17,17 +17,7 @@ syntax is specified here, their behavior is host-defined.
Special-form head symbols are not shadowable: a binding named `if` does not
change the meaning of `(if ...)` in operator position. ⚠ This matches the
reference; it differs from Scheme. A local *may* legally be named like a special
form and used in value position (`(let [if 5] if)``5`); only operator
position is reserved. **Macros, unlike special forms, ARE shadowable** by a local
(`(let [when (fn ...)] (when 1 2))` calls the local).
A list form in operator position is resolved in this order (the canonical
read → **macroexpand** → analyze pipeline): a local binding shadows everything;
otherwise a macro head is expanded and the result re-analyzed; otherwise a
special-form head is parsed by rule; otherwise the form is a function
application. Macroexpansion therefore happens *before* special-form dispatch, so
a macro is never mistaken for a special form (and vice versa).
reference; it differs from Scheme.
---
@ -76,8 +66,7 @@ a macro is never mistaken for a special form (and vice versa).
S1S3, E1E2 → jolt `forms-spec` "if/do/def" group; truthiness group in
`truthiness-spec`; clojure-test-suite `core_test/if.cljc`. S4 → `forms-spec`
fn/loop recur cases. X1 → `forms-spec` "if arity (X1)" (0/1/4-arg forms throw
in both the analyzer and the interpreter).
fn/loop recur cases. X1 → UNVERIFIED (arity-error case to add).
---
@ -145,11 +134,10 @@ S1S3, E1 → jolt `forms-spec` let group; clojure-test-suite
| `do` | empty `(do)` → nil; top-level `do` splices for compilation units (important and under-documented) |
| `fn*` | arities, variadic `&`, closure capture, self-name, simple-symbol params only, recur target |
| `loop*` | recur arity must match bindings; recur rebinds in place |
| `letfn` | mutually-recursive local fns (`letrec*` semantics — a fn body sees every binding, not only earlier ones). jolt treats `letfn` as a primitive special, not the reference's `letfn` macro → `letfn*` indirection; behavior is identical |
| `recur` | tail-position rule (normative definition of tail position needed), across `if`/`do`/`let*`/`try` interactions |
| `quote` | self-evaluation table: which literals are self-evaluating unquoted |
| `var` | `#'` reader sugar; resolution at compile time |
| `throw` | any value vs Throwable — host question; jolt/cljs allow data, reference requires Throwable → classification needed |
| `try/catch/finally` | catch dispatch order, `:default`-style catch-all is a dialect extension (⚠ divergence note), finally evaluation guarantees, value of try |
| `set!` | three targets, all implemented: `(set! *var* val)` sets the var's innermost thread binding (else root); `(set! field val)` inside a `deftype` method mutates a `^:unsynchronized-mutable`/`^:volatile-mutable` field in place; `(set! (.-field obj) val)` does the same via interop syntax. Returns val |
| `set!` | host-dependent (dynamic vars + host fields) |
| `.` / `new` | syntax only; behavior host-defined |

View file

@ -10,40 +10,6 @@ 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
```
@ -196,164 +162,6 @@ 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

@ -12,39 +12,36 @@ sources, and process: [`../rfc/0001-language-specification.md`](../rfc/0001-lang
| Doc | Content | Status |
|---|---|---|
| [`00-front-matter.md`](00-front-matter.md) | conformance terms, entry format, host classification | drafted |
| [`02-reader.md`](02-reader.md) | token grammar + reader-macro catalog | drafted |
| `01`, `04``08` | see chapter plan in front matter | planned |
| `01-evaluation.md``08-macros.md` | see chapter plan in front matter | planned |
| [`03-special-forms.md`](03-special-forms.md) | special-form catalog + normative exemplars (`if`, `let*`) | exemplars |
| [`09-core-library.md`](09-core-library.md) | per-var entry format + exemplars (`first`, `reduce`, `parse-uuid`) | exemplars |
| [`coverage.md`](coverage.md) | generated dashboard over the 694-var surface | generated |
| [`../grammar.ebnf`](../grammar.ebnf) | reader surface syntax (EBNF), companion to `02-reader.md` | reference |
Regenerate the dashboard after surface changes:
`python3 tools/spec_coverage.py` (reads `tools/clojuredocs-export.json` and
probes a working jolt checkout via `bin/joltc`).
`python3 tools/spec_coverage.py` (requires `clojuredocs-export.json` in the
repo root and a working jolt checkout).
## Current numbers (2026-06-22)
## Current numbers (2026-06-10)
Of the 694 `clojure.core` vars in the ClojureDocs inventory, jolt interns 574.
Broadly:
Of the 694 `clojure.core` vars in the ClojureDocs inventory:
- **568** implemented in jolt *and* exercised by the behavioral suites
- **6** implemented but not directly tested — each gets a test with its spec entry
- **6** portable but absent from jolt's resolvable surface (the REPL history
vars `*1`/`*2`/`*3`/`*e`, plus `letfn`/`re-groups`, which work but aren't
interned where `resolve` can see them) — tracked as gaps
- the rest classified host/JVM/concurrency (see the dashboard for the full
per-var breakdown — it is the source of truth)
- **380** implemented in jolt *and* exercised by the behavioral suites
- **154** implemented but not directly tested — each gets a test with its spec entry
- **35** portable but missing from jolt (`parse-long`/`parse-double`/
`parse-boolean`, `update-keys`/`update-vals`, `macroexpand`, `time`,
`partitionv`/`partitionv-all`/`splitv-at`, `with-redefs`, `with-open`,
reader fns, ns-introspection stragglers, …) — tracked as implementation gaps
- **22** resolvable in code but invisible to ns introspection
(`resolve`/`ns-publics` can't see seed-fallback names like `compare`,
`gensym`, `type`) — a conformance finding in its own right
- the rest classified host/JVM/concurrency (see dashboard)
## How this connects to the test suites
- `test/chez/corpus.edn` — the host-neutral behavioral corpus, one row per
case (`{:suite :label :expected :actual}`). The Chez compiler evaluates each
case via `host/chez/run-corpus.ss` (run with `make corpus`), and
`test/conformance/certify.clj` certifies every `:expected` against reference
JVM Clojure (run with `make certify`). Spec entries cite these cases.
- `test/conformance/` — the certification tooling and classified divergences
(`certify.clj`, `known-divergences.edn`); see its `README.md` and `SPEC.md`.
- `test/integration/conformance-test.janet` — 302 assertions, each run
through three independent execution paths (interpreter, bootstrap
compiler, self-hosted compiler) that must agree. Spec entries cite these.
- `test/spec/*.janet` — ~1,500 behavioral cases organized by topic.
- `vendor/clojure-test-suite` — the cross-dialect suite (≥4081 assertions
passing); dialect splits there are classification evidence.
- jank's per-construct corpus (`~/src/jank/compiler+runtime/test/jank`) is

View file

@ -1,21 +1,21 @@
# Appendix A — Coverage Dashboard (generated)
Generated 2026-06-26 by `tools/spec_coverage.py` — do not edit by hand.
Generated 2026-06-10 by `tools/spec_coverage.py` — do not edit by hand.
Surface: **694** clojure.core vars (ClojureDocs export; 648 with
community examples). jolt interns 594 of them.
community examples). jolt interns 553 of them.
| Status | Count | Meaning |
|---|---|---|
| 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 | 0 | portable semantics, jolt lacks it — implementation gap |
| special-form | 16 | specified in §3, not a library var |
| dynamic-var | 11 | classification needed: portable default vs host-dependent |
| agents-taps | 16 | out of scope pending concurrency design note |
| implemented+tested | 415 | in jolt and exercised by spec/conformance |
| implemented-untested | 138 | in jolt, no direct test — spec entries will add them |
| resolvable-not-interned | 2 | works in code but invisible to ns introspection (conformance finding) |
| missing-portable | 10 | portable semantics, jolt lacks it — implementation gap |
| special-form | 15 | specified in §3, not a library var |
| dynamic-var | 30 | classification needed: portable default vs host-dependent |
| agents-taps | 22 | out of scope pending concurrency design note |
| stm-refs | 11 | out of scope pending concurrency design note |
| jvm-specific | 46 | catalogued, not specified |
| jvm-specific | 53 | 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
@ -26,60 +26,60 @@ UNVERIFIED field; that column will be added as entries land.
| Var | Status | ClojureDocs examples |
|---|---|---|
| `*` | implemented+tested | ✓ |
| `*'` | implemented+tested | ✓ |
| `*1` | implemented+tested | ✓ |
| `*2` | implemented+tested | ✓ |
| `*3` | implemented+tested | ✓ |
| `*'` | implemented-untested | ✓ |
| `*1` | implemented-untested | ✓ |
| `*2` | implemented-untested | ✓ |
| `*3` | implemented-untested | ✓ |
| `*agent*` | dynamic-var | ✓ |
| `*allow-unresolved-vars*` | dynamic-var | ✓ |
| `*assert*` | implemented+tested | ✓ |
| `*clojure-version*` | implemented+tested | ✓ |
| `*command-line-args*` | implemented-untested | ✓ |
| `*compile-files*` | implemented+tested | ✓ |
| `*assert*` | dynamic-var | ✓ |
| `*clojure-version*` | implemented-untested | ✓ |
| `*command-line-args*` | dynamic-var | ✓ |
| `*compile-files*` | dynamic-var | ✓ |
| `*compile-path*` | dynamic-var | ✓ |
| `*compiler-options*` | 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 | |
| `*data-readers*` | dynamic-var | ✓ |
| `*default-data-reader-fn*` | dynamic-var | ✓ |
| `*e` | implemented-untested | ✓ |
| `*err*` | dynamic-var | ✓ |
| `*file*` | dynamic-var | ✓ |
| `*flush-on-newline*` | dynamic-var | |
| `*fn-loader*` | dynamic-var | |
| `*in*` | implemented+tested | |
| `*math-context*` | implemented+tested | |
| `*ns*` | implemented+tested | ✓ |
| `*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*` | implemented+tested | ✓ |
| `*in*` | dynamic-var | |
| `*math-context*` | dynamic-var | |
| `*ns*` | implemented-untested | ✓ |
| `*out*` | dynamic-var | ✓ |
| `*print-dup*` | dynamic-var | ✓ |
| `*print-length*` | dynamic-var | ✓ |
| `*print-level*` | dynamic-var | ✓ |
| `*print-meta*` | dynamic-var | ✓ |
| `*print-namespace-maps*` | dynamic-var | ✓ |
| `*print-readably*` | dynamic-var | ✓ |
| `*read-eval*` | dynamic-var | ✓ |
| `*reader-resolver*` | dynamic-var | |
| `*repl*` | dynamic-var | |
| `*source-path*` | dynamic-var | ✓ |
| `*suppress-read*` | dynamic-var | |
| `*unchecked-math*` | implemented+tested | ✓ |
| `*unchecked-math*` | implemented-untested | ✓ |
| `*use-context-classloader*` | dynamic-var | ✓ |
| `*verbose-defrecords*` | dynamic-var | |
| `*warn-on-reflection*` | implemented+tested | ✓ |
| `*warn-on-reflection*` | dynamic-var | ✓ |
| `+` | implemented+tested | ✓ |
| `+'` | implemented+tested | ✓ |
| `+'` | implemented-untested | ✓ |
| `-` | implemented+tested | ✓ |
| `-'` | implemented+tested | ✓ |
| `-'` | implemented-untested | ✓ |
| `->` | implemented+tested | ✓ |
| `->>` | implemented+tested | ✓ |
| `->ArrayChunk` | jvm-specific | |
| `->Eduction` | implemented+tested | |
| `->Eduction` | implemented-untested | |
| `->Vec` | jvm-specific | |
| `->VecNode` | jvm-specific | |
| `->VecSeq` | jvm-specific | |
| `-cache-protocol-fn` | jvm-specific | |
| `-reset-methods` | jvm-specific | |
| `.` | special-form | ✓ |
| `..` | implemented+tested | ✓ |
| `/` | implemented+tested | ✓ |
| `.` | implemented-untested | ✓ |
| `..` | implemented-untested | ✓ |
| `/` | implemented-untested | ✓ |
| `<` | implemented+tested | ✓ |
| `<=` | implemented+tested | ✓ |
| `=` | implemented+tested | ✓ |
@ -94,17 +94,17 @@ UNVERIFIED field; that column will be added as entries land.
| `Throwable->map` | jvm-specific | ✓ |
| `abs` | implemented+tested | ✓ |
| `accessor` | jvm-specific | ✓ |
| `aclone` | implemented+tested | ✓ |
| `aclone` | implemented-untested | ✓ |
| `add-classpath` | jvm-specific | ✓ |
| `add-tap` | agents-taps | ✓ |
| `add-watch` | implemented+tested | ✓ |
| `agent` | implemented+tested | ✓ |
| `agent-error` | implemented+tested | ✓ |
| `agent` | agents-taps | ✓ |
| `agent-error` | agents-taps | ✓ |
| `agent-errors` | agents-taps | |
| `aget` | implemented+tested | ✓ |
| `alength` | implemented+tested | ✓ |
| `alias` | implemented+tested | ✓ |
| `all-ns` | implemented+tested | ✓ |
| `all-ns` | implemented-untested | ✓ |
| `alter` | stm-refs | ✓ |
| `alter-meta!` | implemented+tested | ✓ |
| `alter-var-root` | implemented+tested | ✓ |
@ -117,34 +117,34 @@ UNVERIFIED field; that column will be added as entries land.
| `array-map` | implemented+tested | ✓ |
| `as->` | implemented+tested | ✓ |
| `aset` | implemented+tested | ✓ |
| `aset-boolean` | implemented+tested | ✓ |
| `aset-byte` | implemented+tested | ✓ |
| `aset-char` | implemented+tested | ✓ |
| `aset-double` | implemented+tested | ✓ |
| `aset-float` | implemented+tested | ✓ |
| `aset-int` | implemented+tested | ✓ |
| `aset-long` | implemented+tested | ✓ |
| `aset-short` | implemented+tested | ✓ |
| `aset-boolean` | implemented-untested | ✓ |
| `aset-byte` | implemented-untested | ✓ |
| `aset-char` | implemented-untested | ✓ |
| `aset-double` | implemented-untested | ✓ |
| `aset-float` | implemented-untested | ✓ |
| `aset-int` | implemented-untested | ✓ |
| `aset-long` | implemented-untested | ✓ |
| `aset-short` | implemented-untested | ✓ |
| `assert` | implemented+tested | ✓ |
| `assoc` | implemented+tested | ✓ |
| `assoc!` | implemented+tested | ✓ |
| `assoc-in` | implemented+tested | ✓ |
| `associative?` | implemented+tested | ✓ |
| `atom` | implemented+tested | ✓ |
| `await` | implemented+tested | ✓ |
| `await` | agents-taps | ✓ |
| `await-for` | agents-taps | ✓ |
| `await1` | agents-taps | |
| `bases` | jvm-specific | ✓ |
| `bean` | implemented+tested | ✓ |
| `bean` | implemented-untested | ✓ |
| `bigdec` | implemented+tested | ✓ |
| `bigint` | implemented+tested | ✓ |
| `biginteger` | implemented+tested | ✓ |
| `biginteger` | implemented-untested | ✓ |
| `binding` | implemented+tested | ✓ |
| `bit-and` | implemented+tested | ✓ |
| `bit-and-not` | implemented+tested | ✓ |
| `bit-and-not` | implemented-untested | ✓ |
| `bit-clear` | implemented+tested | ✓ |
| `bit-flip` | implemented+tested | ✓ |
| `bit-not` | implemented+tested | ✓ |
| `bit-flip` | implemented-untested | ✓ |
| `bit-not` | implemented-untested | ✓ |
| `bit-or` | implemented+tested | ✓ |
| `bit-set` | implemented+tested | ✓ |
| `bit-shift-left` | implemented+tested | ✓ |
@ -152,40 +152,40 @@ UNVERIFIED field; that column will be added as entries land.
| `bit-test` | implemented+tested | ✓ |
| `bit-xor` | implemented+tested | ✓ |
| `boolean` | implemented+tested | ✓ |
| `boolean-array` | implemented+tested | ✓ |
| `boolean-array` | implemented-untested | ✓ |
| `boolean?` | implemented+tested | ✓ |
| `booleans` | implemented+tested | ✓ |
| `bound-fn` | implemented+tested | ✓ |
| `booleans` | implemented-untested | ✓ |
| `bound-fn` | implemented-untested | ✓ |
| `bound-fn*` | implemented+tested | ✓ |
| `bound?` | implemented+tested | ✓ |
| `bounded-count` | implemented+tested | ✓ |
| `butlast` | implemented+tested | ✓ |
| `byte` | implemented+tested | ✓ |
| `byte-array` | implemented+tested | ✓ |
| `bytes` | implemented+tested | ✓ |
| `bytes?` | implemented+tested | ✓ |
| `byte` | implemented-untested | ✓ |
| `byte-array` | implemented-untested | ✓ |
| `bytes` | implemented-untested | ✓ |
| `bytes?` | implemented-untested | ✓ |
| `case` | implemented+tested | ✓ |
| `cast` | jvm-specific | ✓ |
| `cat` | implemented+tested | ✓ |
| `cat` | implemented-untested | ✓ |
| `catch` | special-form | ✓ |
| `char` | implemented+tested | ✓ |
| `char-array` | implemented+tested | ✓ |
| `char-escape-string` | implemented+tested | ✓ |
| `char-name-string` | implemented+tested | ✓ |
| `char-array` | implemented-untested | ✓ |
| `char-escape-string` | implemented-untested | ✓ |
| `char-name-string` | implemented-untested | ✓ |
| `char?` | implemented+tested | ✓ |
| `chars` | implemented+tested | ✓ |
| `chunk` | implemented+tested | ✓ |
| `chunk-append` | implemented+tested | ✓ |
| `chunk-buffer` | implemented+tested | ✓ |
| `chunk-cons` | implemented+tested | ✓ |
| `chunk-first` | implemented+tested | ✓ |
| `chunk-next` | implemented+tested | ✓ |
| `chunk-rest` | implemented+tested | ✓ |
| `chars` | implemented-untested | ✓ |
| `chunk` | implemented-untested | ✓ |
| `chunk-append` | implemented-untested | ✓ |
| `chunk-buffer` | implemented-untested | ✓ |
| `chunk-cons` | implemented-untested | ✓ |
| `chunk-first` | implemented-untested | ✓ |
| `chunk-next` | implemented-untested | ✓ |
| `chunk-rest` | implemented-untested | ✓ |
| `chunked-seq?` | implemented+tested | ✓ |
| `class` | implemented+tested | ✓ |
| `class?` | implemented+tested | ✓ |
| `class` | implemented-untested | ✓ |
| `class?` | jvm-specific | ✓ |
| `clear-agent-errors` | agents-taps | |
| `clojure-version` | implemented+tested | ✓ |
| `clojure-version` | implemented-untested | ✓ |
| `coll?` | implemented+tested | ✓ |
| `comment` | implemented+tested | ✓ |
| `commute` | stm-refs | ✓ |
@ -205,7 +205,7 @@ UNVERIFIED field; that column will be added as entries land.
| `conj!` | implemented+tested | ✓ |
| `cons` | implemented+tested | ✓ |
| `constantly` | implemented+tested | ✓ |
| `construct-proxy` | implemented+tested | ✓ |
| `construct-proxy` | implemented-untested | ✓ |
| `contains?` | implemented+tested | ✓ |
| `count` | implemented+tested | ✓ |
| `counted?` | implemented+tested | ✓ |
@ -213,14 +213,14 @@ UNVERIFIED field; that column will be added as entries land.
| `create-struct` | jvm-specific | ✓ |
| `cycle` | implemented+tested | ✓ |
| `dec` | implemented+tested | ✓ |
| `dec'` | implemented+tested | ✓ |
| `dec'` | implemented-untested | ✓ |
| `decimal?` | implemented+tested | ✓ |
| `declare` | implemented+tested | ✓ |
| `dedupe` | implemented+tested | ✓ |
| `def` | special-form | ✓ |
| `default-data-readers` | implemented+tested | ✓ |
| `default-data-readers` | jvm-specific | ✓ |
| `definline` | jvm-specific | |
| `definterface` | implemented+tested | ✓ |
| `definterface` | implemented-untested | ✓ |
| `defmacro` | special-form | ✓ |
| `defmethod` | implemented+tested | ✓ |
| `defmulti` | implemented+tested | ✓ |
@ -232,13 +232,13 @@ UNVERIFIED field; that column will be added as entries land.
| `defstruct` | jvm-specific | ✓ |
| `deftype` | implemented+tested | ✓ |
| `delay` | implemented+tested | ✓ |
| `delay?` | implemented+tested | ✓ |
| `delay?` | implemented-untested | ✓ |
| `deliver` | implemented+tested | ✓ |
| `denominator` | implemented+tested | ✓ |
| `deref` | implemented+tested | ✓ |
| `derive` | implemented+tested | ✓ |
| `descendants` | implemented+tested | ✓ |
| `destructure` | implemented+tested | ✓ |
| `destructure` | implemented-untested | ✓ |
| `disj` | implemented+tested | ✓ |
| `disj!` | implemented+tested | ✓ |
| `dissoc` | implemented+tested | ✓ |
@ -252,10 +252,10 @@ UNVERIFIED field; that column will be added as entries land.
| `dosync` | stm-refs | ✓ |
| `dotimes` | implemented+tested | ✓ |
| `doto` | implemented+tested | ✓ |
| `double` | implemented+tested | ✓ |
| `double-array` | implemented+tested | ✓ |
| `double` | implemented-untested | ✓ |
| `double-array` | implemented-untested | ✓ |
| `double?` | implemented+tested | ✓ |
| `doubles` | implemented+tested | ✓ |
| `doubles` | implemented-untested | ✓ |
| `drop` | implemented+tested | ✓ |
| `drop-last` | implemented+tested | ✓ |
| `drop-while` | implemented+tested | ✓ |
@ -263,8 +263,8 @@ UNVERIFIED field; that column will be added as entries land.
| `empty` | implemented+tested | ✓ |
| `empty?` | implemented+tested | ✓ |
| `ensure` | stm-refs | ✓ |
| `ensure-reduced` | implemented+tested | ✓ |
| `enumeration-seq` | implemented+tested | ✓ |
| `ensure-reduced` | implemented-untested | ✓ |
| `enumeration-seq` | implemented-untested | ✓ |
| `error-handler` | agents-taps | ✓ |
| `error-mode` | agents-taps | ✓ |
| `eval` | implemented+tested | ✓ |
@ -275,11 +275,11 @@ UNVERIFIED field; that column will be added as entries land.
| `ex-data` | implemented+tested | ✓ |
| `ex-info` | implemented+tested | ✓ |
| `ex-message` | implemented+tested | ✓ |
| `extend` | implemented+tested | ✓ |
| `extend` | implemented-untested | ✓ |
| `extend-protocol` | implemented+tested | ✓ |
| `extend-type` | implemented+tested | ✓ |
| `extenders` | implemented+tested | ✓ |
| `extends?` | implemented+tested | ✓ |
| `extenders` | missing-portable | ✓ |
| `extends?` | implemented-untested | ✓ |
| `false?` | implemented+tested | ✓ |
| `ffirst` | implemented+tested | ✓ |
| `file-seq` | implemented+tested | ✓ |
@ -287,17 +287,17 @@ UNVERIFIED field; that column will be added as entries land.
| `filterv` | implemented+tested | ✓ |
| `finally` | special-form | ✓ |
| `find` | implemented+tested | ✓ |
| `find-keyword` | implemented+tested | ✓ |
| `find-keyword` | missing-portable | ✓ |
| `find-ns` | implemented+tested | ✓ |
| `find-protocol-impl` | jvm-specific | |
| `find-protocol-method` | jvm-specific | |
| `find-var` | implemented+tested | ✓ |
| `first` | implemented+tested | ✓ |
| `flatten` | implemented+tested | ✓ |
| `float` | implemented+tested | ✓ |
| `float-array` | implemented+tested | ✓ |
| `float` | implemented-untested | ✓ |
| `float-array` | implemented-untested | ✓ |
| `float?` | implemented+tested | ✓ |
| `floats` | implemented+tested | ✓ |
| `floats` | implemented-untested | ✓ |
| `flush` | implemented+tested | ✓ |
| `fn` | implemented+tested | ✓ |
| `fn?` | implemented+tested | ✓ |
@ -308,7 +308,7 @@ UNVERIFIED field; that column will be added as entries land.
| `format` | implemented+tested | ✓ |
| `frequencies` | implemented+tested | ✓ |
| `future` | implemented+tested | ✓ |
| `future-call` | implemented+tested | ✓ |
| `future-call` | implemented-untested | ✓ |
| `future-cancel` | implemented+tested | ✓ |
| `future-cancelled?` | implemented+tested | ✓ |
| `future-done?` | implemented+tested | ✓ |
@ -319,17 +319,17 @@ UNVERIFIED field; that column will be added as entries land.
| `get` | implemented+tested | ✓ |
| `get-in` | implemented+tested | ✓ |
| `get-method` | implemented+tested | ✓ |
| `get-proxy-class` | implemented+tested | ✓ |
| `get-proxy-class` | implemented-untested | ✓ |
| `get-thread-bindings` | implemented+tested | ✓ |
| `get-validator` | implemented+tested | ✓ |
| `group-by` | implemented+tested | ✓ |
| `halt-when` | implemented+tested | ✓ |
| `hash` | implemented+tested | ✓ |
| `hash-combine` | implemented+tested | ✓ |
| `halt-when` | implemented-untested | ✓ |
| `hash` | implemented-untested | ✓ |
| `hash-combine` | implemented-untested | ✓ |
| `hash-map` | implemented+tested | ✓ |
| `hash-ordered-coll` | implemented+tested | ✓ |
| `hash-ordered-coll` | implemented-untested | ✓ |
| `hash-set` | implemented+tested | ✓ |
| `hash-unordered-coll` | implemented+tested | ✓ |
| `hash-unordered-coll` | implemented-untested | ✓ |
| `ident?` | implemented+tested | ✓ |
| `identical?` | implemented+tested | ✓ |
| `identity` | implemented+tested | ✓ |
@ -341,29 +341,29 @@ UNVERIFIED field; that column will be added as entries land.
| `import` | implemented+tested | ✓ |
| `in-ns` | implemented+tested | ✓ |
| `inc` | implemented+tested | ✓ |
| `inc'` | implemented+tested | ✓ |
| `inc'` | implemented-untested | ✓ |
| `indexed?` | implemented+tested | ✓ |
| `infinite?` | implemented+tested | ✓ |
| `init-proxy` | implemented+tested | ✓ |
| `init-proxy` | implemented-untested | ✓ |
| `inst-ms` | implemented+tested | ✓ |
| `inst-ms*` | implemented+tested | |
| `inst-ms*` | missing-portable | |
| `inst?` | implemented+tested | ✓ |
| `instance?` | implemented+tested | ✓ |
| `int` | implemented+tested | ✓ |
| `int-array` | implemented+tested | ✓ |
| `int-array` | implemented-untested | ✓ |
| `int?` | implemented+tested | ✓ |
| `integer?` | implemented+tested | ✓ |
| `interleave` | implemented+tested | ✓ |
| `intern` | implemented+tested | ✓ |
| `interpose` | implemented+tested | ✓ |
| `into` | implemented+tested | ✓ |
| `into-array` | implemented+tested | ✓ |
| `ints` | implemented+tested | ✓ |
| `into-array` | implemented-untested | ✓ |
| `ints` | implemented-untested | ✓ |
| `io!` | stm-refs | ✓ |
| `isa?` | implemented+tested | ✓ |
| `iterate` | implemented+tested | ✓ |
| `iteration` | jvm-specific | ✓ |
| `iterator-seq` | implemented+tested | ✓ |
| `iterator-seq` | implemented-untested | ✓ |
| `juxt` | implemented+tested | ✓ |
| `keep` | implemented+tested | ✓ |
| `keep-indexed` | implemented+tested | ✓ |
@ -376,23 +376,23 @@ UNVERIFIED field; that column will be added as entries land.
| `lazy-seq` | implemented+tested | ✓ |
| `let` | implemented+tested | ✓ |
| `letfn` | implemented+tested | ✓ |
| `line-seq` | implemented+tested | ✓ |
| `line-seq` | implemented-untested | ✓ |
| `list` | implemented+tested | ✓ |
| `list*` | implemented+tested | ✓ |
| `list?` | implemented+tested | ✓ |
| `load` | implemented+tested | ✓ |
| `load-file` | implemented-untested | ✓ |
| `load` | jvm-specific | ✓ |
| `load-file` | jvm-specific | ✓ |
| `load-reader` | jvm-specific | ✓ |
| `load-string` | implemented+tested | ✓ |
| `loaded-libs` | jvm-specific | ✓ |
| `locking` | implemented+tested | ✓ |
| `long` | implemented+tested | ✓ |
| `long-array` | implemented+tested | ✓ |
| `longs` | implemented+tested | ✓ |
| `long` | implemented-untested | ✓ |
| `long-array` | implemented-untested | ✓ |
| `longs` | implemented-untested | ✓ |
| `loop` | implemented+tested | ✓ |
| `macroexpand` | implemented+tested | ✓ |
| `macroexpand-1` | implemented+tested | ✓ |
| `make-array` | implemented+tested | ✓ |
| `make-array` | implemented-untested | ✓ |
| `make-hierarchy` | implemented+tested | ✓ |
| `map` | implemented+tested | ✓ |
| `map-entry?` | implemented+tested | ✓ |
@ -402,7 +402,7 @@ UNVERIFIED field; that column will be added as entries land.
| `mapv` | implemented+tested | ✓ |
| `max` | implemented+tested | ✓ |
| `max-key` | implemented+tested | ✓ |
| `memfn` | implemented+tested | ✓ |
| `memfn` | implemented-untested | ✓ |
| `memoize` | implemented+tested | ✓ |
| `merge` | implemented+tested | ✓ |
| `merge-with` | implemented+tested | ✓ |
@ -415,7 +415,7 @@ UNVERIFIED field; that column will be added as entries land.
| `mod` | implemented+tested | ✓ |
| `monitor-enter` | special-form | |
| `monitor-exit` | special-form | |
| `munge` | implemented+tested | ✓ |
| `munge` | implemented-untested | ✓ |
| `name` | implemented+tested | ✓ |
| `namespace` | implemented+tested | ✓ |
| `namespace-munge` | implemented+tested | ✓ |
@ -425,7 +425,7 @@ UNVERIFIED field; that column will be added as entries land.
| `new` | special-form | ✓ |
| `newline` | implemented+tested | ✓ |
| `next` | implemented+tested | ✓ |
| `nfirst` | implemented+tested | ✓ |
| `nfirst` | implemented-untested | ✓ |
| `nil?` | implemented+tested | ✓ |
| `nnext` | implemented+tested | ✓ |
| `not` | implemented+tested | ✓ |
@ -435,8 +435,8 @@ UNVERIFIED field; that column will be added as entries land.
| `not=` | implemented+tested | ✓ |
| `ns` | implemented+tested | ✓ |
| `ns-aliases` | implemented+tested | ✓ |
| `ns-imports` | implemented+tested | ✓ |
| `ns-interns` | implemented+tested | ✓ |
| `ns-imports` | implemented-untested | ✓ |
| `ns-interns` | implemented-untested | ✓ |
| `ns-map` | implemented+tested | ✓ |
| `ns-name` | implemented+tested | ✓ |
| `ns-publics` | implemented+tested | ✓ |
@ -464,24 +464,24 @@ UNVERIFIED field; that column will be added as entries land.
| `partition-by` | implemented+tested | ✓ |
| `partitionv` | implemented+tested | |
| `partitionv-all` | implemented+tested | |
| `pcalls` | implemented+tested | ✓ |
| `pcalls` | jvm-specific | ✓ |
| `peek` | implemented+tested | ✓ |
| `persistent!` | implemented+tested | ✓ |
| `pmap` | implemented+tested | ✓ |
| `pmap` | jvm-specific | ✓ |
| `pop` | implemented+tested | ✓ |
| `pop!` | implemented+tested | ✓ |
| `pop-thread-bindings` | implemented+tested | |
| `pop-thread-bindings` | implemented-untested | |
| `pos-int?` | implemented+tested | ✓ |
| `pos?` | implemented+tested | ✓ |
| `pr` | implemented+tested | ✓ |
| `pr-str` | implemented+tested | ✓ |
| `prefer-method` | implemented+tested | ✓ |
| `prefers` | implemented+tested | ✓ |
| `prefers` | implemented-untested | ✓ |
| `primitives-classnames` | jvm-specific | ✓ |
| `print` | implemented+tested | ✓ |
| `print-ctor` | jvm-specific | ✓ |
| `print-dup` | implemented+tested | ✓ |
| `print-method` | implemented+tested | ✓ |
| `print-dup` | implemented-untested | ✓ |
| `print-method` | implemented-untested | ✓ |
| `print-simple` | jvm-specific | ✓ |
| `print-str` | implemented+tested | ✓ |
| `printf` | implemented+tested | ✓ |
@ -490,13 +490,13 @@ UNVERIFIED field; that column will be added as entries land.
| `prn` | implemented+tested | ✓ |
| `prn-str` | implemented+tested | ✓ |
| `promise` | implemented+tested | ✓ |
| `proxy` | implemented+tested | ✓ |
| `proxy-call-with-super` | implemented+tested | |
| `proxy-mappings` | implemented+tested | ✓ |
| `proxy` | implemented-untested | ✓ |
| `proxy-call-with-super` | implemented-untested | |
| `proxy-mappings` | implemented-untested | ✓ |
| `proxy-name` | jvm-specific | |
| `proxy-super` | implemented+tested | ✓ |
| `push-thread-bindings` | implemented+tested | |
| `pvalues` | implemented+tested | ✓ |
| `proxy-super` | implemented-untested | ✓ |
| `push-thread-bindings` | implemented-untested | |
| `pvalues` | jvm-specific | ✓ |
| `qualified-ident?` | implemented+tested | ✓ |
| `qualified-keyword?` | implemented+tested | ✓ |
| `qualified-symbol?` | implemented+tested | ✓ |
@ -505,23 +505,23 @@ UNVERIFIED field; that column will be added as entries land.
| `rand` | implemented+tested | ✓ |
| `rand-int` | implemented+tested | ✓ |
| `rand-nth` | implemented+tested | ✓ |
| `random-sample` | implemented+tested | ✓ |
| `random-sample` | implemented-untested | ✓ |
| `random-uuid` | implemented+tested | ✓ |
| `range` | implemented+tested | ✓ |
| `ratio?` | implemented+tested | ✓ |
| `rational?` | implemented+tested | ✓ |
| `rationalize` | implemented+tested | ✓ |
| `re-find` | implemented+tested | ✓ |
| `re-groups` | implemented+tested | ✓ |
| `re-matcher` | implemented+tested | ✓ |
| `re-groups` | implemented-untested | ✓ |
| `re-matcher` | implemented-untested | ✓ |
| `re-matches` | implemented+tested | ✓ |
| `re-pattern` | implemented+tested | ✓ |
| `re-seq` | implemented+tested | ✓ |
| `read` | implemented+tested | ✓ |
| `read+string` | implemented+tested | ✓ |
| `read-line` | implemented+tested | ✓ |
| `read` | missing-portable | ✓ |
| `read+string` | missing-portable | ✓ |
| `read-line` | missing-portable | ✓ |
| `read-string` | implemented+tested | ✓ |
| `reader-conditional` | implemented+tested | ✓ |
| `reader-conditional` | implemented-untested | ✓ |
| `reader-conditional?` | implemented+tested | ✓ |
| `realized?` | implemented+tested | ✓ |
| `record?` | implemented+tested | ✓ |
@ -537,7 +537,7 @@ UNVERIFIED field; that column will be added as entries land.
| `ref-min-history` | stm-refs | ✓ |
| `ref-set` | stm-refs | ✓ |
| `refer` | implemented+tested | ✓ |
| `refer-clojure` | implemented+tested | ✓ |
| `refer-clojure` | implemented-untested | ✓ |
| `reify` | implemented+tested | ✓ |
| `release-pending-sends` | agents-taps | ✓ |
| `rem` | implemented+tested | ✓ |
@ -554,11 +554,11 @@ UNVERIFIED field; that column will be added as entries land.
| `require` | implemented+tested | ✓ |
| `requiring-resolve` | jvm-specific | ✓ |
| `reset!` | implemented+tested | ✓ |
| `reset-meta!` | implemented+tested | ✓ |
| `reset-meta!` | implemented-untested | ✓ |
| `reset-vals!` | implemented+tested | ✓ |
| `resolve` | implemented+tested | ✓ |
| `rest` | implemented+tested | ✓ |
| `restart-agent` | implemented+tested | ✓ |
| `restart-agent` | agents-taps | ✓ |
| `resultset-seq` | jvm-specific | ✓ |
| `reverse` | implemented+tested | ✓ |
| `reversible?` | implemented+tested | ✓ |
@ -568,14 +568,14 @@ UNVERIFIED field; that column will be added as entries land.
| `satisfies?` | implemented+tested | ✓ |
| `second` | implemented+tested | ✓ |
| `select-keys` | implemented+tested | ✓ |
| `send` | implemented+tested | ✓ |
| `send-off` | implemented+tested | ✓ |
| `send` | agents-taps | ✓ |
| `send-off` | agents-taps | ✓ |
| `send-via` | agents-taps | ✓ |
| `seq` | implemented+tested | ✓ |
| `seq-to-map-for-destructuring` | implemented+tested | ✓ |
| `seq-to-map-for-destructuring` | implemented-untested | ✓ |
| `seq?` | implemented+tested | ✓ |
| `seqable?` | implemented+tested | ✓ |
| `seque` | implemented+tested | ✓ |
| `seque` | implemented-untested | ✓ |
| `sequence` | implemented+tested | ✓ |
| `sequential?` | implemented+tested | ✓ |
| `set` | implemented+tested | ✓ |
@ -586,9 +586,9 @@ UNVERIFIED field; that column will be added as entries land.
| `set-error-mode!` | agents-taps | ✓ |
| `set-validator!` | implemented+tested | ✓ |
| `set?` | implemented+tested | ✓ |
| `short` | implemented+tested | ✓ |
| `short-array` | implemented+tested | ✓ |
| `shorts` | implemented+tested | ✓ |
| `short` | implemented-untested | ✓ |
| `short-array` | implemented-untested | ✓ |
| `shorts` | implemented-untested | ✓ |
| `shuffle` | implemented+tested | ✓ |
| `shutdown-agents` | agents-taps | ✓ |
| `simple-ident?` | implemented+tested | ✓ |
@ -607,7 +607,7 @@ UNVERIFIED field; that column will be added as entries land.
| `sorted-set` | implemented+tested | ✓ |
| `sorted-set-by` | implemented+tested | ✓ |
| `sorted?` | implemented+tested | ✓ |
| `special-symbol?` | implemented+tested | ✓ |
| `special-symbol?` | implemented-untested | ✓ |
| `spit` | implemented+tested | ✓ |
| `split-at` | implemented+tested | ✓ |
| `split-with` | implemented+tested | ✓ |
@ -623,7 +623,7 @@ UNVERIFIED field; that column will be added as entries land.
| `subs` | implemented+tested | ✓ |
| `subseq` | implemented+tested | ✓ |
| `subvec` | implemented+tested | ✓ |
| `supers` | implemented+tested | ✓ |
| `supers` | implemented-untested | ✓ |
| `swap!` | implemented+tested | ✓ |
| `swap-vals!` | implemented+tested | ✓ |
| `symbol` | implemented+tested | ✓ |
@ -636,12 +636,12 @@ UNVERIFIED field; that column will be added as entries land.
| `take-nth` | implemented+tested | ✓ |
| `take-while` | implemented+tested | ✓ |
| `tap>` | agents-taps | ✓ |
| `test` | implemented+tested | ✓ |
| `test` | implemented-untested | ✓ |
| `the-ns` | implemented+tested | ✓ |
| `thread-bound?` | implemented+tested | ✓ |
| `throw` | special-form | ✓ |
| `time` | implemented+tested | ✓ |
| `to-array` | implemented+tested | ✓ |
| `to-array` | implemented-untested | ✓ |
| `to-array-2d` | implemented+tested | ✓ |
| `trampoline` | implemented+tested | ✓ |
| `transduce` | implemented+tested | ✓ |
@ -650,38 +650,38 @@ UNVERIFIED field; that column will be added as entries land.
| `true?` | implemented+tested | ✓ |
| `try` | special-form | ✓ |
| `type` | implemented+tested | ✓ |
| `unchecked-add` | implemented+tested | ✓ |
| `unchecked-add-int` | implemented+tested | ✓ |
| `unchecked-byte` | implemented+tested | ✓ |
| `unchecked-char` | implemented+tested | |
| `unchecked-dec` | implemented+tested | ✓ |
| `unchecked-dec-int` | implemented+tested | ✓ |
| `unchecked-divide-int` | implemented+tested | ✓ |
| `unchecked-double` | implemented+tested | ✓ |
| `unchecked-float` | implemented+tested | ✓ |
| `unchecked-inc` | implemented+tested | ✓ |
| `unchecked-inc-int` | implemented+tested | ✓ |
| `unchecked-int` | implemented+tested | ✓ |
| `unchecked-long` | implemented+tested | ✓ |
| `unchecked-multiply` | implemented+tested | ✓ |
| `unchecked-multiply-int` | implemented+tested | |
| `unchecked-negate` | implemented+tested | ✓ |
| `unchecked-negate-int` | implemented+tested | ✓ |
| `unchecked-remainder-int` | implemented+tested | |
| `unchecked-short` | implemented+tested | ✓ |
| `unchecked-subtract` | implemented+tested | ✓ |
| `unchecked-subtract-int` | implemented+tested | ✓ |
| `underive` | implemented+tested | ✓ |
| `unchecked-add` | implemented-untested | ✓ |
| `unchecked-add-int` | implemented-untested | ✓ |
| `unchecked-byte` | implemented-untested | ✓ |
| `unchecked-char` | implemented-untested | |
| `unchecked-dec` | implemented-untested | ✓ |
| `unchecked-dec-int` | implemented-untested | ✓ |
| `unchecked-divide-int` | implemented-untested | ✓ |
| `unchecked-double` | implemented-untested | ✓ |
| `unchecked-float` | implemented-untested | ✓ |
| `unchecked-inc` | implemented-untested | ✓ |
| `unchecked-inc-int` | implemented-untested | ✓ |
| `unchecked-int` | implemented-untested | ✓ |
| `unchecked-long` | implemented-untested | ✓ |
| `unchecked-multiply` | implemented-untested | ✓ |
| `unchecked-multiply-int` | implemented-untested | |
| `unchecked-negate` | implemented-untested | ✓ |
| `unchecked-negate-int` | implemented-untested | ✓ |
| `unchecked-remainder-int` | implemented-untested | |
| `unchecked-short` | implemented-untested | ✓ |
| `unchecked-subtract` | implemented-untested | ✓ |
| `unchecked-subtract-int` | implemented-untested | ✓ |
| `underive` | implemented-untested | ✓ |
| `unquote` | jvm-specific | ✓ |
| `unquote-splicing` | jvm-specific | ✓ |
| `unreduced` | implemented+tested | ✓ |
| `unsigned-bit-shift-right` | implemented+tested | ✓ |
| `unsigned-bit-shift-right` | implemented-untested | ✓ |
| `update` | implemented+tested | ✓ |
| `update-in` | implemented+tested | ✓ |
| `update-keys` | implemented+tested | ✓ |
| `update-proxy` | implemented+tested | ✓ |
| `update-proxy` | implemented-untested | ✓ |
| `update-vals` | implemented+tested | ✓ |
| `uri?` | implemented+tested | ✓ |
| `uri?` | implemented-untested | ✓ |
| `use` | implemented+tested | ✓ |
| `uuid?` | implemented+tested | ✓ |
| `val` | implemented+tested | ✓ |
@ -707,15 +707,15 @@ UNVERIFIED field; that column will be added as entries land.
| `while` | implemented+tested | ✓ |
| `with-bindings` | implemented+tested | ✓ |
| `with-bindings*` | implemented+tested | ✓ |
| `with-in-str` | implemented+tested | ✓ |
| `with-in-str` | missing-portable | ✓ |
| `with-loading-context` | jvm-specific | |
| `with-local-vars` | implemented+tested | ✓ |
| `with-local-vars` | missing-portable | ✓ |
| `with-meta` | implemented+tested | ✓ |
| `with-open` | implemented+tested | ✓ |
| `with-open` | missing-portable | ✓ |
| `with-out-str` | implemented+tested | ✓ |
| `with-precision` | implemented+tested | ✓ |
| `with-precision` | missing-portable | ✓ |
| `with-redefs` | implemented+tested | ✓ |
| `with-redefs-fn` | implemented+tested | ✓ |
| `xml-seq` | implemented+tested | ✓ |
| `xml-seq` | implemented-untested | ✓ |
| `zero?` | implemented+tested | ✓ |
| `zipmap` | implemented+tested | ✓ |

View file

@ -9,170 +9,62 @@ Scope, decided up front:
- **pure `clj`/`cljc`** — anything needing the JVM won't load or run; expected.
- **no classpath abstraction**`require` just needs to find a dep's namespaces;
"the classpath" is an ordered list of source directories.
- **own resolver, own reader**`deps.edn` is read by jolt's own reader, and git
fetch/cache is a thin shell-out to `git`; no external package manager.
- **deps-agnostic runtime core** — resolution is a CLI front-end concern, not a
runtime one. The runtime knows nothing about `deps.edn`; it only consumes a
list of source roots. The CLI resolves a `deps.edn` into those roots before
running.
- **piggyback on jpm** — reuse jpm's git fetch + cache; don't write a package
manager.
- **separate tool** — resolution lives in `jolt-deps`, beside the runtime, the
way `jpm` sits beside `janet`. The `jolt` runtime knows nothing about deps.edn.
## How resolution works
## How jpm handles dependencies
`jolt.deps` (`jolt-core/jolt/deps.clj`) reads `deps.edn` (jolt's own reader
parses the EDN), then walks `:deps`:
jpm's package code (`jpm/pm.janet`) splits into a fetch half and a build half,
and we use only the first:
- `:git/url` + `:git/sha` (+ optional `:deps/root`) → clone the sha into the git
cache and contribute the checkout (or its `:deps/root` subdir);
- **`resolve-bundle`** normalizes a dep spec to `{:url :tag :type :shallow}`,
accepting `:url`/`:repo` + `:tag`/`:sha`/`:commit`/`:ref`. A deps.edn
`{:git/url … :git/sha …}` maps straight onto it.
- **`download-bundle url :git tag shallow`** clones into a content-addressed cache
(`<modpath>/.cache/git_<tag>_<sanitized-url>`) and returns the path —
`git init` + `remote add` + fetch + reset, plus submodules. No build step.
- **`bundle-install`** is the half we skip: it then runs `project.janet` build
rules, which a Clojure lib doesn't have. It's cleanly separable from the clone.
So jpm gives us git resolution and a cache for free; calling `download-bundle`
needs `jpm/config/load-default` first (it sets `gitpath` and the cache dyns).
## How it works
`src/jolt/deps.janet` reads `deps.edn` (Janet parses it directly — EDN and Janet
syntax overlap for the `:deps`/`:paths` subset), then walks `:deps`:
- `:git/url` (+ `:git/sha` or `:git/tag`) → `resolve-bundle` + `download-bundle`
into `jpm_tree/.cache`;
- `:local/root` → the path as-is;
- `:mvn/*` → skipped with a warning;
- anything else → ignored.
git resolution shells out to `git` through `jolt.host/sh``git init` + remote
add + fetch + reset at the requested sha. Clones land in a global, sha-immutable
cache (`$JOLT_GITLIBS`, else `~/.jolt/gitlibs`) shared across projects, the
`tools.gitlibs` `~/.gitlibs` model.
- `:mvn/*` and anything else → ignored.
Each resolved dependency contributes its own `:paths` (default `["src"]`) as
source roots; the walk is **breadth-first** so every top-level coordinate
registers before any transitive one — a top-level pin always wins, matching
tools.deps. The result is a de-duplicated, ordered list of directories.
source roots, and we recurse into its `deps.edn` for transitive deps. The result
is a de-duplicated, ordered list of directories. `resolve-deps-cached` memoizes
that list in the tree keyed on a hash of `deps.edn`, so an unchanged file doesn't
re-fetch. jpm is loaded lazily (`require`, not `import`) so it's pulled in only
when resolving — never embedded in a built binary.
Two tools.deps features are mirrored in reduced form. **Aliases**: `:aliases`
entries supply `:extra-paths`/`:extra-deps` (accumulate across the aliases
selected with `-A:a:b`) and `:main-opts` (last-wins, run with `-M:alias`).
**Tasks**: the honest subset of babashka's — a string task is a shell command, a
map task is `{:main-opts […]}`; bare Clojure expressions aren't a separate task
form.
The loader (`evaluator.janet/find-ns-file`) resolves a namespace by searching the
context's `:source-paths` in order (the stdlib `src/jolt` first), trying `<ns>.clj`
then `<ns>.cljc`. Extra roots come from `JOLT_PATH` or `init`'s `:paths` option.
## How the CLI ties it together
`jolt-deps` (`src/jolt/deps_cli.janet`, its own `declare-executable`) ties it
together: it resolves the roots and runs the `jolt` binary with them on
`JOLT_PATH`. The runtime's only dependency interface is that env var.
`jolt.main` (`jolt-core/jolt/main.clj`) is the CLI dispatch. Driven by `cli.ss`,
it resolves the project (`jolt.deps/resolve-project`), prepends the resolved
roots, and de-sugars the argv into a run:
`jolt uberscript` bundles a namespace and everything it requires into one
standalone `.clj`. It requires the entry namespace and uses the order in which
the loader finishes loading files — a dependency finishes before the file that
required it, so the order is topological — then concatenates that source. The
baked-in stdlib is excluded (it's part of the runtime, not bundled).
- `run -m NS args` → load `NS`, call its `-main`;
- `run FILE` → load the file;
- `-M:alias` → run the alias's `:main-opts`;
- `-A:alias` → add the alias's paths/deps, then run the rest;
- `repl` → a line REPL;
- `path` → print the resolved roots;
- `build -m NS [-o OUT] [--opt|--dev]` → AOT-compile the app into a standalone binary;
- `<task>` → run a `deps.edn` `:tasks` entry.
The resolver lives in the overlay alongside the runtime, but the runtime's only
dependency interface is the list of source roots it's handed.
## Native libraries
A library that binds C declares the shared objects it needs under `:jolt/native`,
so `jolt.main` loads them before the namespace is required and its `foreign-fn`
bindings resolve. Each entry is a map — `{:name "sqlite3" :darwin
["libsqlite3.0.dylib" …] :linux ["libsqlite3.so.0" …]}` — with optional
`:optional true` (absence is fine, a feature-gated dep) and `:process true` (use
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). 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
`<name>.build` scratch dir sits beside it). `-o PATH` overrides — absolute as-is,
relative against the project dir. Paths resolve against the project (`JOLT_PWD`),
not the CLI's cwd, since `bin/joltc` runs from the jolt repo.
`:jolt/build {:embed ["resources" …]}` bakes those directories' files into the
binary; `io/resource` serves them from the image with no files on disk. Resources
not embedded resolve at runtime against `JOLT_PWD` (or the cwd), so the
ship-the-binary-with-its-`resources/`-dir model also works. Files read through
`io/file` (e.g. a `config.edn` a config library loads) stay external by design —
edit them without rebuilding.
A standalone build needs Chez's kernel dev files (`libkernel.a`, `scheme.h`) and
a C compiler; `JOLT_CHEZ_CSV` overrides the auto-detected `csv<ver>/<machine>`
dir. `--opt` turns on the inference/flatten/scalar-replace passes; the default
`release` mode is const-fold only.
`--direct-link` (or `:jolt/build {:direct-link true}`) opts into a closed world: a
call between the app's own functions binds to its target directly, skipping the var
lookup and generic dispatch a runtime call pays — at the cost of runtime
redefinition of those vars and `eval`/`load-string`. It's off by default, so
ordinary builds (including `release` and `--opt`) stay dynamically linked. A var
marked `^:redef` or `^:dynamic` stays indirect even under `--direct-link`, and calls
into `clojure.core` stay indirect in every mode.
## Tree-shaking
`--tree-shake` (or `:jolt/build {:tree-shake true}`) ships only the code reachable
from `-main`. The build constructs one call graph spanning the app, every resolved
library, and the `clojure.core`/stdlib prelude, then keeps `-main`, every
side-effecting top-level form (so a `defmethod`/`defrecord`/protocol registration
keeps its targets live), and everything reachable from those — dropping the rest. A
reference counts whether it's a call or a value (`#'x`, a fn passed to `map`, a fn
stored in a map): any reference keeps its target live, so nothing reachable is ever
dropped. An app that never compiles at runtime (no reachable `eval`/`load-string`)
also drops the analyzer and back end from the binary. Typical savings are 12 MB;
behaviour is unchanged.
**It bails — keeps everything — when reachable code resolves a var by name at
runtime** (`eval`, `resolve`, `ns-resolve`, `requiring-resolve`, `find-var`,
`intern`, `load-string`, `load-file`). A static call graph can't follow a runtime
`resolve`, so dropping anything would be unsound. The build prints which definitions
forced the bail:
```
jolt build: tree-shake skipped (reachable code resolves vars at runtime):
selmer.filters/generate-json -> clojure.core/resolve
clojure.tools.logging/call-str -> clojure.core/ns-resolve
```
These are almost always libraries, not your code — `resolve` is how mature Clojure
libraries implement plugin systems and optional integrations (a logging backend
chosen at runtime, a template filter that lazily loads an optional dependency). On
the JVM that costs nothing; in a closed-world binary it defeats reachability. To make
an app tree-shakeable, keep runtime resolution off the *reachable* path: a backend
that's fixed on jolt can be referenced directly rather than resolved (the jolt
`tools.logging` port dropped the JVM's dynamic factory selection for exactly this),
and an optional integration you don't use can be dropped or hard-wired. Unreached
`resolve`-using code is shaken away like anything else — only resolution on the live
path triggers the bail.
The closed-world soundness model follows Stalin's dead-code analysis: in a program
with no `eval`, a definition is live iff it is referenced (called or as a value) from
a root, transitively.
Gotcha worth remembering: the `jolt` CLI's context is built into its image at
build time, so `JOLT_PATH` is applied at runtime in `main`, not in `init` (whose
env read would be frozen at build).
## Limitations
@ -182,35 +74,18 @@ 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
[examples](https://github.com/jolt-lang/examples) exercise real pure-`cljc` git
libraries end to end — resolving them from git, loading their namespaces, and
running sample calls. A library fails when it relies on something Jolt doesn't
provide — JVM interop, or a regex feature like Unicode property classes
(`\p{…}`).
`test/integration/deps-conformance-test.janet` resolves a few real pure-`cljc`
git libraries and reports whether their namespaces load and a sample call works.
It's network-gated behind `JOLT_CONFORMANCE=1` so CI stays offline. Use it to
check a library against the current interpreter, and to drive fixes for whatever
gap a failure points at (the same loop as the clojure-test-suite battery). A
library fails when it relies on something Jolt doesn't provide — JVM interop, or
a regex feature like Unicode property classes (`\p{…}`).
## Not yet
- **Compiling deps into a binary image.** `uberscript` already produces a
standalone `.clj`; baking a project's dependencies directly into a custom
executable image is a heavier variant that isn't implemented.

View file

@ -1,221 +0,0 @@
;; atoms — host-coupled mutable reference cells for the Chez host.
;;
;; atom/deref/swap!/reset! are host primitives (not the clojure.core overlay),
;; so the runtime provides native shims, def-var!'d into clojure.core. They
;; lower to var-deref in prelude mode. The hierarchy machinery
;; (global-hierarchy = (atom (make-hierarchy))) calls `atom` at the prelude's
;; LOAD time, so without this shim the whole prelude fails to load.
;;
;; compare-and-set!/swap-vals!/reset-vals! are overlay fns over the native kernel
;; in the live system; provided here natively too so the host is self-sufficient
;; for atoms without the full prelude (the overlay versions, when the full prelude
;; loads, override these but compose the same native kernel).
;; watches is an alist of (key . watch-fn); validator is a jolt fn or jolt-nil.
;; The peripheral ops + the notify/validate behaviour live natively here, and
;; post-prelude.ss re-asserts them over the overlay's def-var!.
;; `lock` is a per-atom mutex guarding the read-modify-write critical sections,
;; so swap!/reset!/compare-and-set! are atomic under real OS threads
;; (futures/go blocks share the heap). The user fn in swap! runs OUTSIDE the lock
;; (a CAS retry loop, like the JVM) so it never deadlocks on re-entrant access and
;; a watch/validator can deref the same atom.
(define-record-type jolt-atom
(fields (mutable val) (mutable watches) (mutable validator) lock)
(nongenerative jolt-atom-v3))
;; 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) (m #f))
(cond
((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) 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)))
(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).
(define (jolt-atom-notify a old new)
(for-each (lambda (kv) (jolt-invoke (cdr kv) (car kv) a old new))
(reverse (jolt-atom-watches a))))
;; deref reads an atom; it also unwraps a `reduced` (Clojure @(reduced x) => x,
;; which the overlay's `unreduced` relies on). The reduced record is in seq.ss.
(define (jolt-deref x)
(cond
((jolt-atom? x) (jolt-atom-val x))
((jolt-reduced? x) (jolt-reduced-val x))
(else (error #f "deref: unsupported reference type" x))))
;; CAS the val from `old` to `nv` by identity (eq?), atomically. Returns #t on
;; success. The compute step (f) runs outside this, so we re-check under the lock.
(define (jolt-atom-cas! a old nv)
(with-mutex (jolt-atom-lock a)
(if (eq? (jolt-atom-val a) old)
(begin (jolt-atom-val-set! a nv) #t)
#f)))
;; (swap! a f arg*): JVM-style CAS loop — read, compute f OUTSIDE the lock, then
;; atomically compare-and-set; retry if another thread changed it. Validate the
;; new value before storing, notify watches after.
(define (jolt-swap! a f . args)
(let retry ()
(let* ((old (jolt-atom-val a))
(nv (apply jolt-invoke f old args)))
(jolt-atom-validate a nv)
(if (jolt-atom-cas! a old nv)
(begin (jolt-atom-notify a old nv) nv)
(retry)))))
(define (jolt-reset! a v)
(jolt-atom-validate a v)
(let ((old (with-mutex (jolt-atom-lock a)
(let ((o (jolt-atom-val a))) (jolt-atom-val-set! a v) o))))
(jolt-atom-notify a old v)
v))
;; compare-and-set! keeps jolt= (value) semantics, done atomically under the lock.
(define (jolt-compare-and-set! a oldv newv)
(jolt-atom-validate a newv)
(let ((swapped (with-mutex (jolt-atom-lock a)
(if (jolt= (jolt-atom-val a) oldv)
(begin (jolt-atom-val-set! a newv) #t)
#f))))
(when swapped (jolt-atom-notify a oldv newv))
swapped))
(define (jolt-swap-vals! a f . args)
(let retry ()
(let* ((old (jolt-atom-val a))
(nv (apply jolt-invoke f old args)))
(jolt-atom-validate a nv)
(if (jolt-atom-cas! a old nv)
(begin (jolt-atom-notify a old nv) (jolt-vector old nv))
(retry)))))
(define (jolt-reset-vals! a v)
(jolt-atom-validate a v)
(let ((old (with-mutex (jolt-atom-lock a)
(let ((o (jolt-atom-val a))) (jolt-atom-val-set! a v) o))))
(jolt-atom-notify a old v)
(jolt-vector old v)))
;; --- 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 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)
(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)
(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)))
(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)
(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)
(def-var! "clojure.core" "swap!" jolt-swap!)
(def-var! "clojure.core" "reset!" jolt-reset!)
(def-var! "clojure.core" "compare-and-set!" jolt-compare-and-set!)
(def-var! "clojure.core" "swap-vals!" jolt-swap-vals!)
(def-var! "clojure.core" "reset-vals!" jolt-reset-vals!)
(def-var! "clojure.core" "atom?" jolt-atom?)
;; peripheral ops: the overlay (20-coll) re-defs these over jolt.host/ref-put!,
;; which fails on an atom record — post-prelude.ss re-asserts the natives.
(def-var! "clojure.core" "add-watch" jolt-add-watch)
(def-var! "clojure.core" "remove-watch" jolt-remove-watch)
(def-var! "clojure.core" "set-validator!" jolt-set-validator!)
(def-var! "clojure.core" "get-validator" jolt-get-validator)

View file

@ -1,41 +0,0 @@
;; bootstrap.ss — the pure-Chez self-build.
;;
;; Given a SEED (prelude, image) pair — the bootstrap compiler, checked in under
;; host/chez/seed/ — it loads them, then rebuilds the clojure.core prelude AND the
;; compiler image from the .clj/.ss sources using the on-Chez compiler
;; (emit-image.ss), writing fresh artifacts: read -> analyze -> emit all run on
;; Chez. The seed is a JOINT fixpoint, so a rebuild from an up-to-date seed
;; reproduces it byte-for-byte (`make selfhost` checks this); when the sources
;; change, run it twice to reconverge and re-mint the seed.
;;
;; Run from the repo root:
;; chez --script host/chez/bootstrap.ss SEED-PRELUDE SEED-IMAGE OUT-PRELUDE OUT-IMAGE
(import (chezscheme))
(define bs-args (cdr (command-line))) ; drop the script name
(when (< (length bs-args) 4)
(display "usage: bootstrap.ss SEED-PRELUDE SEED-IMAGE OUT-PRELUDE OUT-IMAGE\n")
(exit 2))
(define bs-seed-prelude (list-ref bs-args 0))
(define bs-seed-image (list-ref bs-args 1))
(define bs-out-prelude (list-ref bs-args 2))
(define bs-out-image (list-ref bs-args 3))
;; Load the runtime + the SEED compiler (prelude for macros, image for the
;; analyzer/emitter), exactly as the spine assembles a program.
(load "host/chez/rt.ss")
(set-chez-ns! "clojure.core")
(load bs-seed-prelude)
(load "host/chez/post-prelude.ss")
(set-chez-ns! "user")
(load "host/chez/host-contract.ss")
(load bs-seed-image)
(load "host/chez/compile-eval.ss")
(load "host/chez/emit-image.ss")
;; Rebuild both artifacts from source ON CHEZ and write them out.
(let ((p (open-output-file bs-out-prelude 'replace)))
(put-string p (jolt-emit-prelude)) (close-port p))
(let ((p (open-output-file bs-out-image 'replace)))
(put-string p (jolt-emit-image)) (close-port p))
(display "bootstrap: rebuilt prelude + compiler image on Chez\n")

View file

@ -1,264 +0,0 @@
;; 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

@ -1,170 +0,0 @@
#!/bin/sh
# build smoke: `jolt build` compiles a multi-namespace app (macro + cross-ns +
# clojure.string) into a standalone binary, which then runs with no jolt source
# or Chez install on the path — args reach -main, output matches.
root="$(CDPATH= cd -- "$(dirname -- "$0")/../.." && pwd)"
cd "$root"
# Preflight: a standalone build needs Chez's kernel dev files (libkernel.a +
# scheme.h) and a C compiler. A distro chezscheme package ships neither, so on
# such hosts (CI included) skip — like `certify` skips without Clojure. Pin the
# csv dir we validate so the build uses exactly it.
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 "build smoke: skipped (Chez kernel dev files or C compiler not available)"
exit 0
fi
export JOLT_CHEZ_CSV="$csv"
app="$root/test/chez/build-app"
out="$(mktemp -d)/app-bin"
trap 'rm -rf "$(dirname "$out")"' EXIT
echo "build smoke: compiling app.core -> $out"
if ! JOLT_PWD="$app" bin/joltc build -m app.core -o "$out" >/dev/null 2>&1; then
echo " FAIL: jolt build exited non-zero"
exit 1
fi
[ -x "$out" ] || { echo " FAIL: no executable produced"; exit 1; }
# Run from a neutral cwd with args. The first line is an embedded resource
# (deps.edn :jolt/build :embed), proving io/resource resolves from the binary with
# no resources/ dir on disk; the rest exercise a macro, cross-ns, and args.
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'
if [ "$got" != "$want" ]; then
echo " FAIL: binary output mismatch"
echo "--- want ---"; echo "$want"
echo "--- got ----"; echo "$got"
exit 1
fi
# Optimized mode (inference + flatten + scalar-replace) must produce the same
# result — a sanity check that the passes don't miscompile this app.
if ! JOLT_PWD="$app" bin/joltc build -m app.core -o "$out" --opt >/dev/null 2>&1; then
echo " FAIL: jolt build --opt exited non-zero"; exit 1
fi
got_opt="$(cd / && "$out" alpha bb ccc 2>&1)"
if [ "$got_opt" != "$want" ]; then
echo " FAIL: --opt binary output mismatch"
echo "--- got ----"; echo "$got_opt"
exit 1
fi
# Closed-world direct-linking (opt-in): same result, and the cross-namespace call
# (app.core -> app.util/shout) must lower to a direct jv$ binding, not var-deref.
if ! JOLT_PWD="$app" bin/joltc build -m app.core -o "$out" --direct-link >/dev/null 2>&1; then
echo " FAIL: jolt build --direct-link exited non-zero"; exit 1
fi
got_dl="$(cd / && "$out" alpha bb ccc 2>&1)"
if [ "$got_dl" != "$want" ]; then
echo " FAIL: --direct-link binary output mismatch"
echo "--- got ----"; echo "$got_dl"
exit 1
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
echo " FAIL: jolt build --tree-shake exited non-zero"; exit 1
fi
got_ts="$(cd / && "$out" alpha bb ccc 2>&1)"
if [ "$got_ts" != "$want" ]; then
echo " FAIL: --tree-shake binary output mismatch"
echo "--- got ----"; echo "$got_ts"
exit 1
fi
if grep -q 'def-var! "app.util" "twice"' "$out.build/flat.ss"; then
echo " FAIL: --tree-shake did not drop the unreachable twice macro"; exit 1
fi
# The app never evals, so the compiler image (analyzer/back end) is dropped.
if grep -q 'def-var! "jolt.analyzer"' "$out.build/flat.ss"; then
echo " FAIL: --tree-shake kept the compiler image in a no-eval app"; exit 1
fi
# Core is shaken: a clojure.core overlay fn this app never uses is dropped.
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
# 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

@ -1,751 +0,0 @@
;; build.ss — `jolt build`: AOT-compile an app into a standalone executable.
;;
;; Loaded on demand by cli.ss when the command is `build`. Defines the host
;; primitive jolt.host/build-binary, which jolt.main's build command calls after
;; resolving the project's deps + source roots.
;;
;; The pipeline (Phase 4 stage 2):
;; 1. load the entry namespace — registers its macros/vars and follows requires,
;; recording the app namespaces in dependency order (loader's ns-loaded-hook).
;; 2. re-emit each app namespace to Scheme (the emit-image cross-compile path),
;; now that its macros are registered.
;; 3. textually inline the cli.ss runtime load sequence into one flat source,
;; append the app emission + a launcher that calls the entry's -main.
;; 4. compile-file -> make-boot-file -> embed the boot as C bytes -> cc-link
;; against libkernel.a into a single self-contained binary.
;;
;; emit-image.ss supplies the cross-compiler (ei-* helpers); it's loaded here so a
;; normal run never pays for it.
(load "host/chez/emit-image.ss")
(load "host/chez/dce.ss")
;; --- shell helpers ----------------------------------------------------------
;; Run a command, return its stdout as one trimmed string ("" on no output).
(define (bld-sh-capture cmd)
(let* ((p (process (bld-sh-wrap cmd))) (in (car p)))
(let loop ((acc '()))
(let ((l (get-line in)))
(if (eof-object? l)
(begin (close-port in)
;; rejoin with newlines (get-line stripped them). Callers use
;; single-line output; this just avoids silently concatenating
;; two lines into one corrupt token if a command emits more.
(let ((ls (reverse acc)))
(if (null? ls) ""
(fold-left (lambda (s x) (string-append s "\n" x)) (car ls) (cdr ls)))))
(loop (cons l acc)))))))
(define (bld-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))
(cond ((> (+ i nsub) ns) #f)
((string=? (substring s i (+ i nsub)) sub) #t)
(else (loop (+ i 1)))))))
;; --- 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
(let ((p (bld-sh-capture "command -v chez || command -v scheme || command -v petite")))
(if (> (string-length p) 0) p "chez")))
;; Chez version off (scheme-version) "Chez Scheme Version X.Y.Z" — last token.
(define bld-version
(let* ((s (scheme-version)) (n (string-length s)))
(let loop ((i n))
(if (or (= i 0) (char=? (string-ref s (- i 1)) #\space))
(substring s i n)
(loop (- i 1))))))
;; The csv<ver>/<machine> dir holding scheme.h, libkernel.a, *.boot. Derived from
;; the chez executable's location; JOLT_CHEZ_CSV overrides.
(define bld-csv-dir
(let ((env (getenv "JOLT_CHEZ_CSV")))
(or (and env (> (string-length env) 0) env)
(let* ((bindir (bld-sh-capture "dirname \"$(command -v chez || command -v scheme || command -v petite)\""))
(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)
(let ((p (string-append bld-csv-dir "/" f)))
(unless (file-exists? p)
(error 'jolt-build (string-append "Chez build file missing: " p
"\nSet JOLT_CHEZ_CSV to the csv<ver>/<machine> dir.")))))
'("scheme.h" "libkernel.a" "petite.boot" "scheme.boot")))
;; Link flags. macOS Homebrew layout for the kernel's lz4/zlib/ncurses deps.
(define (bld-link-libs)
(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
;; controls: 'prelude (the clojure.core blob, replaced by the shaken core under
;; tree-shake), 'image + 'compile-eval (the compiler, dropped for a no-eval app).
;; Tagging keeps the splice/drop decisions off fragile substring matching.
(define bld-runtime-manifest
(list
"(load \"host/chez/rt.ss\")"
"(set-chez-ns! \"clojure.core\")"
'prelude
"(load \"host/chez/post-prelude.ss\")"
"(set-chez-ns! \"user\")"
"(load \"host/chez/host-contract.ss\")"
'image
'compile-eval
"(load \"host/chez/png.ss\")"
"(load \"host/chez/loader.ss\")"
"(load \"host/chez/java/ffi.ss\")"
"(set-source-roots! (list \"jolt-core\" \"stdlib\"))"))
(define bld-tagged-loads
'((prelude . "(load \"host/chez/seed/prelude.ss\")")
(image . "(load \"host/chez/seed/image.ss\")")
(compile-eval . "(load \"host/chez/compile-eval.ss\")")))
;; A single-line top-level `(load "PATH")` -> PATH, else #f.
(define (bld-load-path line)
(let ((s (let trim ((i 0))
(if (and (< i (string-length line))
(memv (string-ref line i) '(#\space #\tab)))
(trim (+ i 1))
(substring line i (string-length line))))))
(and (>= (string-length s) 7)
(string=? (substring s 0 6) "(load ")
(let* ((q1 (let scan ((i 6)) (if (char=? (string-ref s i) #\") i (scan (+ i 1)))))
(q2 (let scan ((i (+ q1 1))) (if (char=? (string-ref s i) #\") i (scan (+ i 1))))))
(substring s (+ q1 1) q2)))))
;; 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)
(when (> depth 50) (error 'jolt-build "load nesting too deep"))
(let ((p (bld-load-path line)))
(if p
(for-each (lambda (l) (bld-inline-line l out (+ depth 1))) (bld-file-lines p))
(begin (put-string out line) (put-string out "\n")))))
;; Inline the runtime manifest, dispatching on the manifest tags. core-strs (the
;; shaken clojure.core defs, or #f) replaces the 'prelude blob; drop-compiler? (a
;; closed AOT app that never compiles from source) omits 'image + 'compile-eval —
;; the analyzer/back end are dead weight in the binary (~0.8MB).
(define (bld-emit-runtime out drop-compiler? core-strs)
(for-each
(lambda (entry)
(cond
((eq? entry 'prelude)
(if core-strs
(for-each (lambda (s) (put-string out s) (put-string out "\n")) core-strs)
(bld-inline-line (cdr (assq 'prelude bld-tagged-loads)) out 0)))
((memq entry '(image compile-eval))
(unless drop-compiler? (bld-inline-line (cdr (assq entry bld-tagged-loads)) out 0)))
(else (bld-inline-line entry out 0))))
bld-runtime-manifest))
;; --- app emission -----------------------------------------------------------
;; Re-emit one app namespace to a list of Scheme strings: optimize (run-passes)
;; and stay strict — a form that fails to emit must fail the build, not vanish.
;; 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;
;; (2) register the ns's :as aliases so a quoted alias resolves at runtime — a
;; (defmethod ig/foo …) passes 'ig/foo to defmethod-setup, which needs ig -> the
;; real ns, but the build strips the (ns …) form that would register it.
(define (bld-scan-spec! ns-name spec emit!)
(let ((items (cond ((pvec? spec) (seq->list spec))
((and (cseq? spec) (cseq-list? spec)) (seq->list spec))
(else '()))))
(when (and (pair? items) (symbol-t? (car items)))
(let ((target (symbol-t-name (car items))))
(let loop ((xs (cdr items)))
(when (and (pair? xs) (pair? (cdr xs)))
(let ((k (car xs)) (v (cadr xs)))
(when (keyword? k)
(cond
((and (string=? (keyword-t-name k) "as") (symbol-t? v))
(emit! (string-append "(chez-register-alias! " (ei-str-lit ns-name)
" " (ei-str-lit (symbol-t-name v))
" " (ei-str-lit target) ")")))
;; :refer [a b] / :refer :all — a defmethod on a referred multifn
;; resolves the bare name through the refer table at runtime.
((or (string=? (keyword-t-name k) "refer") (string=? (keyword-t-name k) "only"))
(cond
((and (keyword? v) (string=? (keyword-t-name v) "all"))
(emit! (string-append "(chez-register-refer-all! " (ei-str-lit ns-name)
" " (ei-str-lit target) ")")))
((or (pvec? v) (and (cseq? v) (cseq-list? v)))
(for-each (lambda (n)
(when (symbol-t? n)
(emit! (string-append "(chez-register-refer! " (ei-str-lit ns-name)
" " (ei-str-lit (symbol-t-name n))
" " (ei-str-lit target) ")"))))
(seq->list v))))))))
(loop (cddr xs))))))))
(define (bld-ns-prelude ns-name src)
(let ((acc (list (string-append "(set-chez-ns! " (ei-str-lit ns-name) ")")))
(nsf (let loop ((fs (ei-read-all src)))
(cond ((null? fs) #f)
((ei-ns-form? (car fs)) (car fs))
(else (loop (cdr fs)))))))
(when nsf
(for-each
(lambda (clause)
(when (and (cseq? clause) (cseq-list? clause))
(let ((citems (seq->list clause)))
(when (and (pair? citems) (keyword? (car citems))
(let ((kn (keyword-t-name (car citems))))
(or (string=? kn "require") (string=? kn "use"))))
(for-each (lambda (spec)
(bld-scan-spec! ns-name spec
(lambda (s) (set! acc (cons s acc)))))
(cdr citems))))))
(seq->list nsf)))
(reverse acc)))
;; --- bundling: native libs + resources --------------------------------------
;; A jolt seq of jolt strings -> a Scheme list of Scheme strings.
(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"] | ["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) (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")))
((and (eq? which 'optional) (string=? kind "opt"))
(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)
(let ((dir (if (string=? rel "") root (string-append root "/" rel))))
(fold-left
(lambda (acc name)
(let* ((relpath (if (string=? rel "") name (string-append rel "/" name)))
(full (string-append root "/" relpath)))
(if (file-directory? full)
(bld-walk-files root relpath acc)
(cons (cons relpath full) acc))))
acc
(directory-list dir))))
;; Emit register-embedded-resource! per file under each embed dir. Emitted BEFORE
;; the app forms so the (read-file-string ABSPATH) runs at heap build — the file's
;; contents bake into the boot image and io/resource serves them with no file on
;; disk. ABSPATH only has to exist at build time.
(define (bld-emit-embeds out embed-dirs)
(for-each
(lambda (root)
(when (file-directory? root)
(for-each
(lambda (rp)
(put-string out (string-append
"(register-embedded-resource! " (ei-str-lit (car rp))
" (read-file-string " (ei-str-lit (cdr rp)) "))\n")))
(bld-walk-files root "" '()))))
(bld-strs embed-dirs)))
;; --- the build --------------------------------------------------------------
;; entry-ns: the app's main namespace (a string). out-path: the binary to write.
;; mode: "dev" | "release" | "optimized". Every form runs through jolt.passes/
;; run-passes (const-fold always; inline + type inference when optimized turns on
;; direct-linking). Deps + source roots are already applied by the caller.
;; natives: encoded :jolt/native libs to load at startup. embed-dirs: dirs whose
;; files bake into the binary (single-file). ext-roots: project-relative io/resource
;; roots resolved at runtime against JOLT_PWD (ship-alongside resources).
;; 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?)
;; 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!
(lambda (name file) (set! app-order (cons (cons name file) app-order))))
(load-namespace entry-ns)
(set-ns-loaded-hook! (lambda (name file) #f))
(let ((ordered (reverse app-order))) ; deps first, entry last
(when (null? ordered)
(error 'jolt-build (string-append "no source namespace loaded for " entry-ns
" — is it on the source roots?")))
;; 2. emit each app namespace. `optimized` turns on the inference + flatten
;; + scalar-replace passes; release/dev get const-fold only.
;; direct-link? (opt-in) commits to a closed world: app->app calls bind
;; directly, giving up runtime redefinition of those vars. Off by default in
;; every mode. The defined-set accumulates across the dependency-ordered
;; namespaces, so a dep's defs are direct-linkable by the time the entry that
;; calls them is emitted.
;; set-optimize!/set-direct-link! are process-global flags in the back end;
;; dynamic-wind guarantees they revert even if a strict form errors mid-emit
;; (a failing form errors the build by design), so the compiler isn't left in
;; optimize/direct-link mode for a later caller.
(let*-values
(((core-strs app-strs drop-compiler?)
(dynamic-wind
(lambda ()
(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!")))
;; 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")
(apply append
(map (lambda (nf)
;; ns-prelude forms (always kept, no fqn/refs) set the
;; ns + register aliases before this ns's forms; dce
;; keeps original order.
(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 (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))))
(lambda ()
(set-optimize! #f)
((var-deref "jolt.backend-scheme" "set-direct-link!") #f)))))
(when drop-compiler? (display "jolt build: dropping compiler image (no runtime eval)\n"))
(let* ((builddir (string-append out-path ".build"))
(flat-ss (string-append builddir "/flat.ss"))
(flat-so (string-append builddir "/flat.so"))
(boot (string-append builddir "/jolt.boot"))
(boot-h (string-append builddir "/boot_data.h"))
(main-c (string-append builddir "/main.c")))
(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)
;; Load native libs, bake embedded resources, and point source roots at
;; the build-time app roots — all BEFORE the app forms. The app's
;; top-level forms run at binary startup (Sbuild_heap), and they include
;; foreign-procedure evals (a library's defcfn) and (slurp (io/resource …))
;; reads. So the libraries must be loaded and resources resolvable by the
;; time those forms run, not later in the scheme-start launcher.
(put-string out "\n;; === native libraries (required) ===\n")
(bld-emit-natives out natives 'required)
(put-string out "\n;; === embedded resources ===\n")
(bld-emit-embeds out embed-dirs)
(put-string out (string-append
"(set-source-roots! (list "
(fold-left (lambda (s r) (string-append s (ei-str-lit r) " ")) ""
(get-source-roots))
"))\n"))
(put-string out "\n;; === app ===\n")
(for-each (lambda (s) (put-string out s) (put-string out "\n")) app-strs)
;; The launcher runs as Chez's scheme-start (so argv reaches -main —
;; top-level boot forms run during heap build, before args are set), and
;; suppresses the interactive greeting. It resets source roots to the
;; app's resource dirs resolved against JOLT_PWD (or cwd) so a runtime
;; io/resource that wasn't embedded still resolves next to the binary.
(put-string out "\n;; === launcher ===\n")
(put-string out "(suppress-greeting #t)\n")
(put-string out "(scheme-start\n (lambda args\n")
(bld-emit-natives out natives 'optional)
(put-string out (string-append
" (let ((base (or (getenv \"JOLT_PWD\") \".\")))\n"
" (set-source-roots!\n"
" (append (map (lambda (r) (string-append base \"/\" r)) (list "
(fold-left (lambda (s r) (string-append s (ei-str-lit r) " ")) "" (bld-strs ext-roots))
"))\n"
" (list \"jolt-core\" \"stdlib\"))))\n"))
(put-string out (string-append
;; 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 -> 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?)
(build-binary (jolt-str-render-one entry)
(jolt-str-render-one out)
(jolt-str-render-one mode)
natives embed-dirs ext-roots (jolt-truthy? direct-link?) (jolt-truthy? tree-shake?))
jolt-nil))

View file

@ -1,90 +0,0 @@
;; cli.ss — the jolt runtime.
;;
;; Loads the checked-in seed (host/chez/seed/{prelude,image}.ss — the bootstrap
;; compiler) and the spine, then either evaluates a -e expression or dispatches a
;; CLI command (run/-M/repl/path/task) through jolt.main. The loader
;; (loader.ss) turns `require` into real file loading off the source roots, so a
;; multi-file project with deps.edn dependencies runs end to end.
;;
;; Run from the repo root (bin/joltc cd's there); the project dir is JOLT_PWD.
(import (chezscheme))
(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")
(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") ; jolt.png — a baked namespace before the snapshot
(load "host/chez/loader.ss")
;; 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/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.
;; A project's resolved deps roots are prepended to these by jolt.main.
(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. 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
;; (do …) so a multi-form string evaluates every form and returns the last.
((and (= (length cli-args) 2) (string=? (car cli-args) "-e"))
(let ((result (jolt-final-str
(jolt-compile-eval (string-append "(do " (cadr cli-args) ")") "user"))))
(unless (string=? result "")
(display result) (newline))))
;; otherwise dispatch the argv through jolt.main/-main
(else
;; `build` AOT-compiles an app to a standalone binary — load the build
;; driver (the cross-compiler emitter) on demand so a normal run never pays
;; for it. It defines jolt.host/build-binary, which jolt.main's build cmd calls.
(when (and (pair? cli-args) (string=? (car cli-args) "build"))
(load "host/chez/build.ss"))
(load-namespace "jolt.main")
(let ((mainv (var-deref "jolt.main" "-main")))
(apply jolt-invoke mainv cli-args)))))

View file

@ -1,606 +0,0 @@
;; persistent collections on the Chez RT.
;;
;; The vector / map / set the emitted programs construct from literals and
;; operate on via the lowered leaf ops (conj/get/nth/count/assoc/...). Loaded by
;; rt.ss after values.ss; jolt=2 / jolt-hash (values.ss) call into the
;; jolt-coll? / jolt-coll=? / jolt-coll-hash hooks defined here (forward refs,
;; resolved at run time — nothing is CALLED during load).
;;
;; The persistent vector is a copy-on-write Scheme vector and the map/set are a
;; bitmap HAMT. They live in Scheme; correctness, not perf, is the gate.
;; ============================================================================
;; small immutable-vector helpers (manual; avoid stdlib arg-order ambiguity)
;; ============================================================================
(define (vec-copy-range v start end)
(let ((out (make-vector (fx- end start))))
(let loop ((i start))
(when (fx<? i end) (vector-set! out (fx- i start) (vector-ref v i)) (loop (fx+ i 1))))
out))
(define (vec-insert v i x) ; copy of v with x spliced in at index i
(let* ((n (vector-length v)) (out (make-vector (fx+ n 1))))
(let loop ((j 0)) (when (fx<? j i) (vector-set! out j (vector-ref v j)) (loop (fx+ j 1))))
(vector-set! out i x)
(let loop ((j i)) (when (fx<? j n) (vector-set! out (fx+ j 1) (vector-ref v j)) (loop (fx+ j 1))))
out))
(define (vec-set v i x) ; functional update at index i
(let ((out (vec-copy-range v 0 (vector-length v)))) (vector-set! out i x) out))
(define (vec-remove v i) ; copy of v with index i dropped
(let* ((n (vector-length v)) (out (make-vector (fx- n 1))))
(let loop ((j 0)) (when (fx<? j i) (vector-set! out j (vector-ref v j)) (loop (fx+ j 1))))
(let loop ((j (fx+ i 1))) (when (fx<? j n) (vector-set! out (fx- j 1) (vector-ref v j)) (loop (fx+ j 1))))
out))
;; ============================================================================
;; persistent vector — 32-way trie + tail (Clojure's PersistentVector)
;; ============================================================================
;; 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 ((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 ((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 ((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-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 ((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=
;; arr slot is one of: leaf (cons k v) | hnode (branch) | hcoll (hash bucket)
;; ============================================================================
(define-record-type hnode (fields bm arr) (nongenerative chez-hnode-v1))
(define-record-type hcoll (fields hash alist) (nongenerative chez-hcoll-v1))
(define empty-hnode (make-hnode 0 (vector)))
(define hmask #x3FFFFFFFFFFFFFF) ; 58-bit non-negative hash window
(define max-shift 55)
;; bitwise-and (not fxand): jolt-hash is set!-decorated per type (records/inst/
;; sorted return their own hash) and Chez's equal-hash can yield a BIGNUM, so a
;; key's hash isn't guaranteed to be a fixnum. Masking with the 58-bit window via
;; the generic bitwise-and always lands in fixnum range for the HAMT's fx slicing.
(define (key-hash k) (bitwise-and (jolt-hash k) hmask))
(define (chunk h shift) (fxand (fxsra h shift) 31))
(define (bitpos h shift) (fxsll 1 (chunk h shift)))
(define (popcount n) (let loop ((n n) (c 0)) (if (fx=? n 0) c (loop (fxand n (fx- n 1)) (fx+ c 1)))))
(define (arr-index bm bit) (popcount (fxand bm (fx- bit 1))))
;; jolt= alist ops (for hash-collision buckets)
(define (assoc-jolt k al) (cond ((null? al) #f) ((jolt= (caar al) k) (car al)) (else (assoc-jolt k (cdr al)))))
(define (alist-replace k v al) (if (jolt= (caar al) k) (cons (cons k v) (cdr al)) (cons (car al) (alist-replace k v (cdr al)))))
(define (alist-remove k al) (cond ((null? al) '()) ((jolt= (caar al) k) (cdr al)) (else (cons (car al) (alist-remove k (cdr al))))))
;; split two leaves that collided at `shift` into a subtree (or hcoll if the
;; full hashes are equal / the hash is exhausted).
(define (split-leaf shift ek ev h k v)
(let ((eh (key-hash ek)))
(if (or (fx>? shift max-shift) (fx=? eh h))
(make-hcoll h (list (cons ek ev) (cons k v)))
(let ((ei (chunk eh shift)) (ni (chunk h shift)))
(if (fx=? ei ni)
(make-hnode (fxsll 1 ei) (vector (split-leaf (fx+ shift 5) ek ev h k v)))
(let ((eb (fxsll 1 ei)) (nb (fxsll 1 ni)))
(if (fx<? ei ni)
(make-hnode (fxior eb nb) (vector (cons ek ev) (cons k v)))
(make-hnode (fxior eb nb) (vector (cons k v) (cons ek ev))))))))))
(define (node-assoc node shift h k v added)
(let* ((bit (bitpos h shift)) (bm (hnode-bm node)) (arr (hnode-arr node)))
(if (fx=? 0 (fxand bm bit))
(begin (set-box! added #t)
(make-hnode (fxior bm bit) (vec-insert arr (arr-index bm bit) (cons k v))))
(let* ((i (arr-index bm bit)) (child (vector-ref arr i)))
(cond
((hnode? child) (make-hnode bm (vec-set arr i (node-assoc child (fx+ shift 5) h k v added))))
((hcoll? child)
(let ((al (hcoll-alist child)))
(if (assoc-jolt k al)
(make-hnode bm (vec-set arr i (make-hcoll (hcoll-hash child) (alist-replace k v al))))
(begin (set-box! added #t)
(make-hnode bm (vec-set arr i (make-hcoll (hcoll-hash child) (cons (cons k v) al))))))))
((jolt= (car child) k) (make-hnode bm (vec-set arr i (cons k v)))) ; replace
(else (set-box! added #t)
(make-hnode bm (vec-set arr i (split-leaf (fx+ shift 5) (car child) (cdr child) h k v)))))))))
(define (node-get node shift h k default)
(let* ((bit (bitpos h shift)) (bm (hnode-bm node)))
(if (fx=? 0 (fxand bm bit)) default
(let ((child (vector-ref (hnode-arr node) (arr-index bm bit))))
(cond ((hnode? child) (node-get child (fx+ shift 5) h k default))
((hcoll? child) (let ((p (assoc-jolt k (hcoll-alist child)))) (if p (cdr p) default)))
((jolt= (car child) k) (cdr child))
(else default))))))
(define (node-dissoc node shift h k removed)
(let* ((bit (bitpos h shift)) (bm (hnode-bm node)) (arr (hnode-arr node)))
(if (fx=? 0 (fxand bm bit)) node
(let* ((i (arr-index bm bit)) (child (vector-ref arr i)))
(cond
((hnode? child) (make-hnode bm (vec-set arr i (node-dissoc child (fx+ shift 5) h k removed))))
((hcoll? child)
(if (assoc-jolt k (hcoll-alist child))
(begin (set-box! removed #t)
(let ((nal (alist-remove k (hcoll-alist child))))
(cond ((null? nal) (make-hnode (fxand bm (fxnot bit)) (vec-remove arr i)))
((null? (cdr nal)) (make-hnode bm (vec-set arr i (car nal)))) ; collapse to leaf
(else (make-hnode bm (vec-set arr i (make-hcoll (hcoll-hash child) nal)))))))
node))
((jolt= (car child) k)
(set-box! removed #t) (make-hnode (fxand bm (fxnot bit)) (vec-remove arr i)))
(else node))))))
(define (node-fold node proc acc) ; (proc k v acc) over every leaf
(let ((arr (hnode-arr node)))
(let loop ((i 0) (acc acc))
(if (fx<? i (vector-length arr))
(let ((child (vector-ref arr i)))
(loop (fx+ i 1)
(cond ((hnode? child) (node-fold child proc acc))
((hcoll? child)
(let cl ((al (hcoll-alist child)) (a acc))
(if (null? al) a (cl (cdr al) (proc (caar al) (cdar al) a)))))
(else (proc (car child) (cdr child) acc)))))
acc))))
;; ============================================================================
;; persistent map / set over the HAMT
;; ============================================================================
;; 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)))
(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))
(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))))
;; 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)
(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-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-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))
(define (pset-count s) (pmap-cnt (pset-m s)))
(define (pset-fold s proc acc) (pmap-fold (pset-m s) (lambda (k v a) (proc k a)) acc))
(define (jolt-hash-set . xs) (let loop ((s empty-pset) (xs xs)) (if (null? xs) s (loop (pset-conj s (car xs)) (cdr xs)))))
;; ============================================================================
;; leaf ops the emitter lowers core/clojure fns to (mirrors native-ops)
;; ============================================================================
(define (jolt-conj1 coll x)
(cond ((pvec? coll) (pvec-conj coll x)) ; nil is a valid vector/set element
((pset? coll) (pset-conj coll x))
;; a list/seq conjs by PREPENDING (seq.ss: cseq / empty-list). conj onto a
;; list stays a list, conj onto a lazy/realized seq yields a seq cell (a
;; Cons) — list?-preserving.
((cseq? coll) (if (cseq-list? coll) (cseq-list x coll) (cseq-realized x coll)))
((empty-list-t? coll) (cseq-list x jolt-nil))
((pmap? coll)
(cond ((jolt-nil? x) coll) ; (conj m nil) = m
((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)))
(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
;; base map/set/vec/string cases (cf. register-hash-arm!).
(define jolt-get-arms '())
(define (register-get-arm! pred handler)
(set! jolt-get-arms (cons (cons pred handler) jolt-get-arms)))
(define (jolt-get-base coll k d)
(cond ((pmap? coll) (pmap-get coll k d))
((pset? coll) (if (pset-contains? coll k) k d))
((pvec? coll) (pvec-nth-d coll k d))
((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)
(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 ((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)
(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)
(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 ((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
;; exactness-aware, so this must be exact to match an exact integer literal:
;; (= 2 (count m)) -> 2 vs exact 2 -> true.
(define (jolt-count coll)
(begin
(cond ((pvec? coll) (pvec-count coll))
((pmap? coll) (pmap-cnt coll))
((pset? coll) (pset-count coll))
((string? coll) (string-length coll))
((jolt-nil? coll) 0)
((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
(let loop ((coll coll) (kvs kvs))
(cond ((null? kvs) coll)
((null? (cdr kvs)) (error 'assoc "assoc expects an even number of key/vals"))
(else (loop (jolt-assoc1 coll (car kvs) (cadr kvs)) (cddr kvs)))))))
(define (jolt-dissoc coll . ks)
(cond ((jolt-nil? coll) jolt-nil)
((pmap? coll) (meta-carry coll (fold-left pmap-dissoc coll ks)))
(else (error 'dissoc "unsupported collection"))))
(define (jolt-contains? coll k)
(cond ((pmap? coll) (pmap-contains? coll k))
((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)
(cond ((jolt-nil? coll) #t)
((pvec? coll) (fx=? 0 (pvec-count coll)))
((pmap? coll) (fx=? 0 (pmap-cnt coll)))
((pset? coll) (fx=? 0 (pset-count coll)))
((string? coll) (fx=? 0 (string-length coll)))
((empty-list-t? coll) #t)
((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))
;; 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 ((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 (jolt-stack-throw coll))))
;; ============================================================================
;; equality / hash hooks called from values.ss (jolt=2 / jolt-hash)
;; ============================================================================
(define (jolt-coll? x) (or (pvec? x) (pmap? x) (pset? x)))
(define (jolt-coll=? a b)
(cond
((and (pvec? a) (pvec? b))
(let ((va (pvec-v a)) (vb (pvec-v b)))
(and (fx=? (vector-length va) (vector-length vb))
(let loop ((i 0))
(or (fx=? i (vector-length va))
(and (jolt= (vector-ref va i) (vector-ref vb i)) (loop (fx+ i 1))))))))
((and (pmap? a) (pmap? b))
(and (fx=? (pmap-cnt a) (pmap-cnt b))
(pmap-fold a (lambda (k v ok) (and ok (jolt= (pmap-get b k pmap-absent) v))) #t)))
((and (pset? a) (pset? b))
(and (fx=? (pset-count a) (pset-count b))
(pset-fold a (lambda (e ok) (and ok (pset-contains? b e))) #t)))
(else #f)))
(define (jolt-coll-hash x)
(cond
((pvec? x)
(let ((v (pvec-v x)))
(let loop ((i 0) (h 1))
(if (fx=? i (vector-length v)) (bitwise-and h hmask)
(loop (fx+ i 1) (bitwise-and (+ (* 31 h) (key-hash (vector-ref v i))) hmask))))))
;; maps/sets hash order-independently (sum), consistent with unordered =
((pmap? x) (bitwise-and (pmap-fold x (lambda (k v a) (+ a (fxxor (key-hash k) (key-hash v)))) 0) hmask))
((pset? x) (bitwise-and (pset-fold x (lambda (e a) (+ a (key-hash e))) 0) hmask))))

View file

@ -1,297 +0,0 @@
;; compile-eval.ss — the compile spine.
;;
;; Ties together the cross-compiled compiler image (jolt.ir + jolt.analyzer +
;; jolt.backend-scheme, loaded as def-var! forms) and the host contract
;; (host-contract.ss) into a runtime entry: a Clojure source string is read by the
;; Chez data reader, analyzed by the analyzer to IR, emitted to Scheme by the
;; emitter, and eval'd. This is the spine the stage2==stage3 bootstrap fixpoint
;; closes over.
;;
;; Loaded after host-contract.ss + the compiler image.
(define jolt-ce-analyze (var-deref "jolt.analyzer" "analyze"))
(define jolt-ce-emit (var-deref "jolt.backend-scheme" "emit"))
;; jolt.passes/run-passes: const-fold every analyzed form, plus inline + type
;; inference when the unit opted into direct-linking (jolt build --opt). Off that
;; path it is a pure const-fold. Loaded from the compiler image (jolt.passes).
(define jolt-ce-run-passes (var-deref "jolt.passes" "run-passes"))
;; The compiler reads source as FORMS (set literals stay {:jolt/type :jolt/set},
;; which the analyzer lowers) — the raw reader, not clojure.core/read-string,
;; 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)
(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)) "quote") (pair? (cdr items)))
(cadr items) x))
x))
;; Pre-register any (require ...)/(use ...) :as aliases under `ns` BEFORE analysis,
;; so a qualified s/foo resolves while compiling (analysis precedes the runtime
;; require). Walks the whole form (a require may be nested in a do/let).
(define (ce-clause-require? cl) ; (:require ...) / (:use ...) ns clause
(and (pair? cl) (keyword? (car cl))
(let ((kn (keyword-t-name (car cl)))) (or (string=? kn "require") (string=? kn "use")))))
(define (ce-scan-requires! form ns)
(when (and (cseq? form) (cseq-list? form))
(let ((items (seq->list form)))
(when (pair? items)
(let* ((h (car items)) (hn (and (symbol-t? h) (symbol-t-name h))))
(cond
;; (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. 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"))
(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).
;; `ns` is the compile namespace unqualified symbols resolve against.
(define (jolt-analyze-emit-form form ns)
(ce-scan-requires! form ns)
(let* ((ctx (make-analyze-ctx ns))
(ir (jolt-ce-run-passes (jolt-ce-analyze ctx form) ctx)))
(jolt-ce-emit ir)))
;; --- runtime defmacro -------------------------------------------------------
;; Shared with emit-image.ss (loaded after this). A defmacro lowers to a def of
;; its expander fn + a macro flag, exactly as the prelude emits build-time macros.
;; Is `f` a (defmacro ...) / (definline ...) form?
(define (ce-macro-form? f)
(and (cseq? f) (cseq-list? f)
(let ((items (seq->list f)))
(and (pair? items) (symbol-t? (car items))
(let ((h (symbol-t-name (car items))))
(or (string=? h "defmacro") (string=? h "definline")))))))
;; (defmacro NAME [docstring] [attr-map] params body...) -> (values "NAME" (fn ...)).
;; Strips a leading docstring (native string) + attr-map (a non-symbol pmap), then
;; re-heads the rest with `fn` so a destructured macro arglist desugars. Emits the
;; BARE fn (the caller wraps it in def-var! + mark-macro!), never a (def NAME ...) —
;; interning NAME would make require skip the real macro.
(define (ce-defmacro->fn f)
(let* ((items (seq->list f))
(name-sym (cadr items))
(after-name (cddr items))
(a1 (if (and (pair? after-name) (string? (car after-name)))
(cdr after-name) after-name))
(after-meta (if (and (pair? a1) (pmap? (car a1)))
(cdr a1) a1))
(fn-sym (jolt-symbol #f "fn")))
(values (symbol-t-name name-sym)
(apply jolt-list (cons fn-sym after-meta)))))
;; A bare top-level (do ...) form — head is the unqualified `do` symbol.
(define (ce-top-do? form)
(and (cseq? form) (cseq-list? form)
(let ((h (seq-first form)))
(and (symbol-t? h) (jolt-nil? (hc-sym-ns h))
(string=? (symbol-t-name h) "do")))))
;; Compile + eval ONE already-read form in compile ns `ns`; returns the value.
;; 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
;; land there and its refs resolve (cross-ns def/require in one program).
((ce-top-do? form)
(let loop ((fs (cdr (seq->list form))) (result jolt-nil) (cur ns))
(if (null? fs)
result
(let ((r (jolt-compile-eval-form (car fs) cur)))
(loop (cdr fs) r (chez-current-ns))))))
;; defmacro is compiled like any other form — the analyzer lowers it to a def
;; 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)))))
;; Source string -> value (read one form, compile + eval on Chez, in the
;; top-level environment where rt.ss's runtime procedures live).
(define (jolt-compile-eval src ns)
(jolt-compile-eval-form (jolt-ce-read src) ns))
;; clojure.core/load-string: read every form from the source string and compile+
;; eval each in the current ns, returning the last value (nil for blank input).
(define (jolt-load-string s)
(let loop ((src s) (result jolt-nil))
(let ((pn (jolt-parse-next src)))
(if (jolt-nil? pn)
result
(loop (jolt-nth pn 1)
(jolt-compile-eval-form (jolt-nth pn 0) (chez-current-ns)))))))
;; eval / load-string are FUNCTIONS on the spine (the compiler image is resident
;; at runtime). eval takes an already-read FORM (e.g. from quote / list); it and
;; load-string compile+eval in the current ns. eval is removed from the analyzer's
;; special-symbol lists (host-contract.ss) so it resolves as an ordinary core var.
(def-var! "clojure.core" "eval"
(lambda (form) (jolt-compile-eval-form form (chez-current-ns))))
(def-var! "clojure.core" "load-string" jolt-load-string)

View file

@ -1,288 +0,0 @@
;; converters + string ops — host-coupled natives def-var!'d into clojure.core,
;; resolved in prelude mode. Loaded last (after jolt-pr-str), since `str` reuses
;; the printer. int/long truncate toward zero to an exact integer; compare returns
;; an exact -1/0/1; double yields a flonum.
;; str rendering for the value types not handled by the fast arms below. A host
;; shim loaded later (records, host-table, inst-time, …) registers an arm with
;; register-str-render! instead of set!-wrapping jolt-str-render-one — the arms
;; are type-disjoint, so the full behavior is the base arms here plus the
;; registry, gathered in one place rather than scattered across a set! chain.
;; Newest registration is checked first (matches the old outermost-wins order).
(define str-render-registry '()) ; list of (pred . render), checked front-to-back
(define (register-str-render! pred render)
(set! str-render-registry (cons (cons pred render) str-render-registry)))
;; str: nil -> "", string raw, char bare (not \c), regex -> raw source, a
;; registered host type via its arm, else the printer (which renders collections
;; with readable elements).
(define (jolt-str-render-one v)
(cond
((jolt-nil? v) "")
((string? v) v)
((char? v) (string v))
((regex-t? v) (regex-t-source v))
;; str/print render the infinities and NaN long-form (Clojure .toString),
;; unlike the -e printer's inf/-inf/nan.
((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)
(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)))
(define (jolt-subs s start . end)
(substring s (jolt->idx start)
(if (null? end) (string-length s) (jolt->idx (car end)))))
;; vec: a pvec from any seqable (already-pvec returns itself).
(define (jolt-vec coll)
(cond
((jolt-nil? coll) (jolt-vector))
((pvec? coll) coll)
((string? coll) (apply jolt-vector (string->list coll)))
(else (apply jolt-vector (seq->list coll)))))
(define (jolt-keyword . args)
(cond
((= (length args) 1)
(let ((a (car args)))
(cond
((jolt-nil? a) jolt-nil)
((keyword? a) a)
;; a 1-arg string splits on the FIRST "/" into ns/name:
;; (keyword "x/y") => :x/y with ns "x" — destructure's {:keys [x/y]} builds
;; the key this way, so without the split the namespaced key never matches.
((string? a)
(let ((si (let loop ((i 0))
(cond ((>= i (string-length a)) #f)
((char=? (string-ref a i) #\/) i)
(else (loop (+ i 1)))))))
(if (and si (> si 0) (< si (- (string-length a) 1)))
(keyword (substring a 0 si) (substring a (+ si 1) (string-length a)))
(keyword #f a))))
((jolt-symbol? a)
(let ((ns (symbol-t-ns a)))
(keyword (if (or (jolt-nil? ns) (not ns) (eq? ns '())) #f ns) (symbol-t-name a))))
(else (error #f "keyword: requires string/symbol/keyword" a)))))
((= (length args) 2)
(keyword (let ((ns (car args))) (if (jolt-nil? ns) #f ns)) (cadr args)))
(else (error #f "keyword: wrong arity"))))
(define (jolt-symbol-new . args)
(cond
((= (length args) 1)
(let ((a (car args)))
(cond
((jolt-symbol? a) a)
;; (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 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))))))))
((keyword? a) (jolt-symbol (keyword-t-ns a) (keyword-t-name a)))
;; (symbol a-var) -> the var's qualified symbol (clojure.spec.alpha/->sym).
((var-cell? a) (jolt-symbol (var-cell-ns a) (var-cell-name a)))
(else (error #f "symbol: requires string/symbol" a)))))
;; (symbol ns name): a nil namespace is the no-ns sentinel #f (NOT jolt-nil),
;; so (symbol nil "x") equals (symbol "x") and the reader literal 'x — jolt=
;; 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.
(define jolt-gensym-counter 0)
(define (jolt-gensym . prefix)
(let ((p (if (null? prefix) "G__" (car prefix))))
(set! jolt-gensym-counter (+ jolt-gensym-counter 1))
(jolt-symbol #f
(string-append (if (string? p) p (jolt-str-render-one p))
(number->string jolt-gensym-counter)))))
;; 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))))
;; 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)))
(define (jolt-strcmp a b) (cond ((string<? a b) -1) ((string>? a b) 1) (else 0)))
(define (jolt-kw->string k)
(let ((ns (keyword-t-ns k))) (if ns (string-append ns "/" (keyword-t-name k)) (keyword-t-name k))))
(define (jolt-sym-ns-string s)
(let ((n (symbol-t-ns s))) (if (or (jolt-nil? n) (not n) (eq? n '())) "" n)))
;; compare returns an EXACT integer -1/0/1 (= JVM compare -> int).
(define (jolt-compare a b)
(cond
((and (jolt-nil? a) (jolt-nil? b)) 0)
((jolt-nil? a) -1)
((jolt-nil? b) 1)
((and (number? a) (number? b)) (jolt-cmp3 a b))
((and (string? a) (string? b)) (jolt-strcmp a 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)))
((and (boolean? a) (boolean? b)) (cond ((eq? a b) 0) ((eq? a #f) -1) (else 1)))
((and (char? a) (char? b)) (jolt-cmp3 (char->integer a) (char->integer b)))
((and (pvec? a) (pvec? b))
(let ((la (pvec-count a)) (lb (pvec-count b)))
(if (not (= la lb))
(jolt-cmp3 la lb)
(let loop ((i 0))
(if (>= i la)
0
(let ((r (jolt-compare (pvec-nth-d a i jolt-nil) (pvec-nth-d b i jolt-nil))))
(if (= r 0) (loop (+ i 1)) r)))))))
(else (error #f "compare: cannot compare these types" a b))))
(def-var! "clojure.core" "str" jolt-str)
(def-var! "clojure.core" "subs" jolt-subs)
(def-var! "clojure.core" "vec" jolt-vec)
(def-var! "clojure.core" "keyword" jolt-keyword)
(def-var! "clojure.core" "symbol" jolt-symbol-new)
(def-var! "clojure.core" "gensym" jolt-gensym)
;; --- 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)
;; 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 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)

View file

@ -1,120 +0,0 @@
#!/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

@ -1,186 +0,0 @@
;; dce.ss — tree-shaking (jolt build --tree-shake): whole-program reachability DCE.
;;
;; Build one call graph over the re-emitted app + libraries AND the clojure.core
;; prelude, keep -main + every side-effecting top-level form + everything reachable
;; from those, drop the rest. Bails (keeps everything) if reachable code resolves a
;; var by name at runtime (eval/resolve/...), which a static graph can't follow. Per
;; Stalin's rule, ANY reference — a call OR a value/#'x — keeps its target live, so a
;; fn passed to map or referenced as #'x is never dropped.
;;
;; Loaded by build.ss after the compiler image (needs jolt.ir/reduce-ir-children).
;; The records it consumes come from ei-emit-ns-records (app/libs) + dce-blob-records
;; (the prelude); both build the (dce-rec …) shape below.
;; --- the DCE record ---------------------------------------------------------
;; keep?: #t = a non-def form (side effect / registration) — always emitted, and its
;; refs are reachability roots. #f = a prunable def emitted only if fqn is reached.
;; fqn: "ns/name" of a prunable def, else #f. refs: "ns/name" strings it references.
;; str: the Scheme source to emit.
(define (dce-rec keep? fqn refs str) (vector keep? fqn refs str))
(define (dce-rec-keep? r) (vector-ref r 0))
(define (dce-rec-fqn r) (vector-ref r 1))
(define (dce-rec-refs r) (vector-ref r 2))
(define (dce-rec-str r) (vector-ref r 3))
;; --- reference extraction from IR -------------------------------------------
(define dce-kw-op (keyword #f "op"))
(define dce-kw-var (keyword #f "var"))
(define dce-kw-the-var (keyword #f "the-var"))
(define dce-kw-def (keyword #f "def"))
(define dce-kw-ns (keyword #f "ns"))
(define dce-kw-name (keyword #f "name"))
(define dce-reduce-children (var-deref "jolt.ir" "reduce-ir-children"))
;; "ns/name" of every var reference anywhere in an IR node, prepended to acc. Counts
;; a :var (call head or value) and a :the-var (#'x). Arg order (acc node) matches
;; reduce-ir-children's fold fn so it nests directly.
(define (dce-collect-refs acc node)
(let ((op (jolt-get node dce-kw-op)))
(if (or (eq? op dce-kw-var) (eq? op dce-kw-the-var))
(cons (string-append (jolt-get node dce-kw-ns) "/" (jolt-get node dce-kw-name)) acc)
(dce-reduce-children dce-collect-refs acc node))))
;; The fqn of a bare top-level def (the only prunable IR form), else #f.
(define (dce-def-fqn node)
(and (eq? (jolt-get node dce-kw-op) dce-kw-def)
(string-append (jolt-get node dce-kw-ns) "/" (jolt-get node dce-kw-name))))
;; --- reference sets that gate the analysis ----------------------------------
;; A reference whose presence in reachable code forces keep-everything (the static
;; graph can't follow runtime name resolution).
(define dce-bail-refs
'("clojure.core/eval" "clojure.core/resolve" "clojure.core/ns-resolve"
"clojure.core/requiring-resolve" "clojure.core/find-var" "clojure.core/intern"
"clojure.core/load-string" "clojure.core/load-file" "clojure.core/load-reader"
"clojure.core/load"))
;; A reference that needs the analyzer/back end at runtime (compile-from-source). If
;; reachable code uses none of these, the compiler image is dropped from the binary —
;; an AOT app is fully compiled. (resolve/require don't need it: resolve is a
;; var-table lookup; a require of a baked ns no-ops.)
(define dce-compile-refs
'("clojure.core/eval" "clojure.core/load-string" "clojure.core/load-file"
"clojure.core/load-reader" "clojure.core/load"))
;; clojure.core fns the runtime .ss shims reference by name (via var-deref) — they
;; aren't visible in the IR call graph, so seed them as roots. (Found by grepping the
;; runtime shims; the smoke harness catches a miss as a diff/crash.)
(define dce-runtime-core-roots
'("clojure.core/identity" "clojure.core/isa?" "clojure.core/line-seq"
"clojure.core/make-hierarchy" "clojure.core/read" "clojure.core/read-string"
"clojure.core/read+string" "clojure.core/realized?" "clojure.core/reset!"))
;; --- reading a minted blob (prelude.ss) into records ------------------------
;; The prelude is a flat list of (guard CLAUSE (def-var! "ns" "name" V)) forms (+ the
;; occasional side-effecting init). Read each with Chez `read` so it joins the graph
;; instead of being baked wholesale: a def-var! is a prunable node whose core->core
;; edges are the (var-deref/jolt-var "ns" "name") calls in V; any other form is
;; non-prunable (kept, refs are roots).
(define (dce-unwrap form)
(if (and (pair? form) (eq? (car form) 'guard) (pair? (cddr form))) (caddr form) form))
(define (dce-sexp-refs form acc)
(cond
((and (pair? form) (memq (car form) '(var-deref jolt-var))
(pair? (cdr form)) (string? (cadr form)) (pair? (cddr form)) (string? (caddr form)))
(cons (string-append (cadr form) "/" (caddr form)) acc))
((pair? form) (dce-sexp-refs (cdr form) (dce-sexp-refs (car form) acc)))
(else acc)))
;; str re-serializes the read form (compiled identically; comments/whitespace are
;; irrelevant).
(define (dce-blob-records 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)))
(if (eof-object? form)
(reverse acc)
(let ((b (dce-unwrap form))
(str (with-output-to-string (lambda () (write form))))
(refs (dce-sexp-refs form '())))
(loop (cons
(if (and (pair? b) (eq? (car b) 'def-var!) (pair? (cdr b)) (string? (cadr b))
(pair? (cddr b)) (string? (caddr b)))
(dce-rec #f (string-append (cadr b) "/" (caddr b)) refs str)
(dce-rec #t #f refs str))
acc)))))))))
;; --- the shake: graph -> reachable -> bail check -> partition ----------------
;; edges: fqn -> refs (prunable defs only). roots: -main + the runtime-core roots +
;; every non-def form's refs.
(define (dce-build-graph records entry-main)
(let ((edges (make-hashtable string-hash string=?))
(roots (cons entry-main dce-runtime-core-roots)))
(for-each (lambda (r)
(if (dce-rec-keep? r)
(set! roots (append (dce-rec-refs r) roots))
(hashtable-set! edges (dce-rec-fqn r) (dce-rec-refs r))))
records)
(values edges roots)))
;; Closure of roots over edges -> a reached set (hashtable fqn -> #t).
(define (dce-reachable edges roots)
(let ((reached (make-hashtable string-hash string=?)))
(let bfs ((work roots))
(unless (null? work)
(let ((fq (car work)))
(if (hashtable-ref reached fq #f)
(bfs (cdr work))
(begin (hashtable-set! reached fq #t)
(bfs (append (or (hashtable-ref edges fq #f) '()) (cdr work))))))))
reached))
(define (dce-rec-reached? r reached)
(or (dce-rec-keep? r) (hashtable-ref reached (dce-rec-fqn r) #f)))
;; Scan the KEPT records: does any resolve a var at runtime (bail), and does any need
;; the compiler? Returns (values bail? bail-why needs-compiler?). bail-why is up to 6
;; (def . bail-ref) pairs for the diagnostic.
(define (dce-bail-scan records reached)
(let ((bail #f) (why '()) (needs-compiler #f))
(for-each
(lambda (r)
(when (dce-rec-reached? r reached)
(for-each (lambda (b)
(when (member b (dce-rec-refs r))
(set! bail #t)
(when (< (length why) 6)
(set! why (cons (cons (or (dce-rec-fqn r) "<form>") b) why)))))
dce-bail-refs)
(when (ormap (lambda (c) (and (member c (dce-rec-refs r)) #t)) dce-compile-refs)
(set! needs-compiler #t))))
records)
(values bail (reverse why) needs-compiler)))
;; Kept records -> (values kept-strings n-defs n-kept-defs).
(define (dce-partition records reached)
(let loop ((rs records) (acc '()) (n 0) (k 0))
(if (null? rs)
(values (reverse acc) n k)
(let* ((r (car rs)) (isdef (and (dce-rec-fqn r) #t)))
(if (dce-rec-reached? r reached)
(loop (cdr rs) (cons (dce-rec-str r) acc) (if isdef (+ n 1) n) (if isdef (+ k 1) k))
(loop (cdr rs) acc (if isdef (+ n 1) n) k))))))
;; Returns (values core-strs app-strs drop-compiler?). core-strs is #f on a bail,
;; signalling "inline prelude.ss unshaken" + keep the compiler.
(define (dce-shake core-records app-records entry-main)
(let-values (((edges roots) (dce-build-graph (append core-records app-records) entry-main)))
(let* ((reached (dce-reachable edges roots)))
(let-values (((bail why needs-compiler) (dce-bail-scan (append core-records app-records) reached)))
(let ((drop-compiler? (and (not bail) (not needs-compiler))))
(if bail
(begin
(display "jolt build: tree-shake skipped (reachable code resolves vars at runtime):\n")
(for-each (lambda (w) (display (string-append " " (car w) " -> " (cdr w) "\n"))) why)
(values #f (map dce-rec-str app-records) drop-compiler?))
(let-values (((core-strs cn ck) (dce-partition core-records reached))
((app-strs an ak) (dce-partition app-records reached)))
(display (string-append "jolt build: tree-shake kept " (number->string (+ ck ak))
" of " (number->string (+ cn an)) " defs (core "
(number->string ck) "/" (number->string cn) ")\n"))
(values core-strs app-strs drop-compiler?))))))))

View file

@ -1,167 +0,0 @@
;; dynamic var binding — binding / with-bindings* / var-set / thread-bound? /
;; with-local-vars / with-redefs / bound-fn* / get-thread-bindings.
;;
;; A per-thread dynamic-binding stack: a list of frames, innermost (most recently
;; pushed) at the HEAD. Each frame is an alist of (var-cell . value) MUTABLE pairs
;; — so var-set can update the innermost binding in place (set-cdr!), matching
;; Clojure where var-set targets the current binding, not the root.
;;
;; The binding macro builds a frame as a jolt map (array-map of (var x) -> value);
;; push-thread-bindings folds it into the alist. Lookups walk frames by cell
;; IDENTITY (eq?) — vars are interned, so (var x) always yields the same cell, and
;; this sidesteps a persistent-hash-map-can't-find-a-var-key quirk.
;;
;; var reads (var-deref in compiled code, jolt-var-get / deref on a cell) consult
;; the stack before falling back to the cell root. Loaded LAST (after vars.ss and
;; ns.ss) so it chains the fully-extended jolt-var-get and overrides rt.ss var-deref.
;; THREAD-LOCAL: a Chez thread parameter, so each OS thread (a future / go block)
;; has its own binding stack. Chez initializes a new thread's parameter
;; to the spawning thread's value at fork time, giving Clojure binding conveyance
;; for free (the future shim also installs an explicit snapshot, belt-and-suspenders).
(define dyn-binding-stack (make-thread-parameter '()))
;; find the innermost (cell . value) pair binding CELL, or #f.
(define (dyn-find-binding cell)
(let loop ((frames (dyn-binding-stack)))
(and (pair? frames)
(or (assq cell (car frames))
(loop (cdr frames))))))
;; a unique sentinel: distinguishes "no thread binding" from a binding whose
;; value happens to be jolt-nil.
(define dyn-no-binding (list 'no-binding))
(define (dyn-binding-value cell)
(if (pair? (dyn-binding-stack))
(let ((p (dyn-find-binding cell)))
(if p
(let ((val (cdr p)))
(if (var-cell? val) (jolt-var-get val) val)) ; nested var deref (Clojure)
dyn-no-binding))
dyn-no-binding))
;; push-thread-bindings: frame is a jolt map of var-cell -> value. Fold it into an
;; identity-keyed alist of mutable pairs and push.
(define (jolt-push-thread-bindings frame)
(dyn-binding-stack
(cons (pmap-fold frame (lambda (k v acc) (cons (cons k v) acc)) '())
(dyn-binding-stack)))
jolt-nil)
(define (jolt-pop-thread-bindings)
(when (pair? (dyn-binding-stack))
(dyn-binding-stack (cdr (dyn-binding-stack))))
jolt-nil)
;; get-thread-bindings: a jolt map of every currently-bound cell -> value,
;; innermost wins. Merge oldest-frame-first (the stack head is innermost). The
;; result can be re-pushed by with-bindings* / bound-fn*.
(define (jolt-get-thread-bindings)
(let loop ((frames (reverse (dyn-binding-stack))) (m (jolt-hash-map)))
(if (null? frames)
m
(loop (cdr frames)
(let frame-loop ((alist (car frames)) (m m))
(if (null? alist)
m
(frame-loop (cdr alist)
(pmap-assoc m (caar alist) (cdar alist)))))))))
;; __thread-bound? — single var; true iff it has a thread binding.
(define (jolt-thread-bound? v)
(and (var-cell? v) (dyn-find-binding v) #t))
;; var-set: update the innermost frame that binds v (in place); else set the root.
(define (jolt-var-set v val)
(if (var-cell? v)
(let ((p (dyn-find-binding v)))
(if p
(begin (set-cdr! p val) 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* ((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
;; binds these as lexical locals; var-get/var-set read/write the root. Each gets a
;; unique name so two locals never compare/hash equal as map keys.
(define local-var-counter 0)
(define (jolt-local-var . args)
(set! local-var-counter (fx+ local-var-counter 1))
(make-var-cell "" (string-append "local-" (number->string local-var-counter))
(if (pair? args) (car args) jolt-nil)
#t))
;; --- chain the var-read paths onto the binding stack -------------------------
;; var-deref (rt.ss): the compiled-code read path for every clojure.core var
;; reference. Consult the stack first; fall straight back to the root (NOT through
;; jolt-var-get's unbound-error path) so undefined-var reads keep prior behaviour.
;; The *ns* var cell — its reads are thread-local: with no thread-binding they
;; derive from chez-current-ns (a thread-parameter), so *ns* tracks in-ns per
;; thread and a (binding [*ns* ..]) drives resolution. Captured now that *ns* is
;; defined (ns.ss loaded earlier); chez-current-ns consults it too.
(set! star-ns-cell (jolt-var "clojure.core" "*ns*"))
(define %dyn-rt-var-deref var-deref)
(set! var-deref
(lambda (ns name)
(let ((cell (jolt-var ns name)))
(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)))))))
;; 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)
(set! jolt-var-get
(lambda (v)
(if (var-cell? v)
(let ((bv (dyn-binding-value v)))
(cond ((not (eq? bv dyn-no-binding)) bv)
((eq? v star-ns-cell) (intern-ns! (chez-current-ns)))
(else (%dyn-var-get v))))
(%dyn-var-get v))))
;; var-cell keys hash/compare by ns/name (jolt=2 in vars.ss already compares
;; ns/name) — stable under root mutation, so a var works as a map key (with-redefs
;; builds (hash-map (var f) v); get-thread-bindings returns a var-keyed map).
(register-hash-arm! var-cell? (lambda (x) (equal-hash (cons (var-cell-ns x) (var-cell-name x)))))
;; --- bind the host seams the overlay references -----------------------------
(def-var! "clojure.core" "push-thread-bindings" jolt-push-thread-bindings)
(def-var! "clojure.core" "pop-thread-bindings" jolt-pop-thread-bindings)
(def-var! "clojure.core" "get-thread-bindings" jolt-get-thread-bindings)
(def-var! "clojure.core" "__thread-bound?" jolt-thread-bound?)
(def-var! "clojure.core" "var-set" jolt-var-set)
(def-var! "clojure.core" "alter-var-root" jolt-alter-var-root)
(def-var! "clojure.core" "__local-var" jolt-local-var)
;; re-assert var-get / deref to the new (stack-aware) closures (vars.ss captured
;; the pre-chain values).
(def-var! "clojure.core" "var-get" jolt-var-get)
(def-var! "clojure.core" "deref" jolt-deref)

View file

@ -1,70 +0,0 @@
;; dynamic-var-defaults.ss — default values for the handful of clojure.core dynamic
;; vars that aren't emitted into the prelude (*clojure-version*, *assert*, …). Plain
;; constant def-var!s; *ns* (a namespace object) needs a value type with
;; get-see-through and map?=false and is tracked separately. The binding-stack
;; machinery (binding / var-set / thread-bound?) lives in dyn-binding.ss. Loaded
;; from rt.ss after the value model + def-var!.
;; *clojure-version* — a map {:major 1 :minor 11 :incremental 0 :qualifier nil}.
(def-var! "clojure.core" "*clojure-version*"
(jolt-hash-map (keyword #f "major") 1
(keyword #f "minor") 11
(keyword #f "incremental") 0
(keyword #f "qualifier") jolt-nil))
;; *unchecked-math* — jolt does no unchecked-math elision; the var reads false.
(def-var! "clojure.core" "*unchecked-math*" #f)
;; *warn-on-reflection* — jolt has no reflection, so the var reads false; (set!
;; *warn-on-reflection* …) resolves and updates it (a no-op effect).
(def-var! "clojure.core" "*warn-on-reflection*" #f)
;; *assert* — gates `assert`; settable/bindable (malli.assert toggles it). Default
;; true, like the JVM.
(def-var! "clojure.core" "*assert*" #t)
;; *print-readably* — bound by pr-family / with-out-str-style code; default true.
(def-var! "clojure.core" "*print-readably*" #t)
;; *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

@ -1,191 +0,0 @@
;; emit-image.ss — the on-Chez compiler-image emitter.
;;
;; This is the stage2/stage3 half of the self-hosting fixpoint. The
;; analyze->emit runs ON CHEZ (jolt-ce-analyze / jolt-ce-emit, loaded from a
;; previously-built image): feed it stage1's image and it produces stage2; feed it
;; stage2 and it produces stage3. stage2 == stage3 byte-for-byte proves the
;; on-Chez compiler reproduces itself (self-hosting-bootstrap-research §4).
;;
;; Loaded after compile-eval.ss (needs jolt-ce-analyze/jolt-ce-emit/ce-scan-requires!,
;; make-analyze-ctx) and rt.ss (read-file-string, the reader's rdr-read-form).
;; Read every top-level form from a source string (a Chez read-all).
;; Uses the same reader the spine reads single forms with.
(define (ei-read-all src)
(let ((end (string-length src)))
(let loop ((i 0) (acc '()))
(let-values (((form j) (rdr-read-form src i end)))
(if (rdr-eof? form)
(reverse acc)
(loop j (cons form acc)))))))
;; Is `f` an (ns ...) form? (Its only role in the image is alias registration; we
;; never emit it — the def-var!s carry explicit ns names.)
(define (ei-ns-form? f)
(and (cseq? f) (cseq-list? f)
(let ((items (seq->list f)))
(and (pair? items) (symbol-t? (car items))
(string=? (symbol-t-name (car items)) "ns")))))
;; ei-macro-form? / ei-defmacro->fn moved to compile-eval.ss (ce-macro-form? /
;; ce-defmacro->fn, loaded before this) — shared with the runtime defmacro spine.
;; Cross-compile one namespace's source to a list of guard-wrapped Scheme strings.
;; Each form is analyzed with a fresh ctx — resolution is via the runtime var-table
;; + alias tables, not ctx-accumulated state, so this matches the spine's per-form
;; analyze. A defmacro emits its expander fn as (def-var! ns name <fn>) +
;; (mark-macro! ns name) so the on-Chez analyzer can expand it.
;; Analyze -> (optionally run passes) -> emit one form. optimize? runs
;; jolt.passes/run-passes (build optimizes; the seed minter stays un-optimized so
;; the self-host fixpoint is independent of the passes). emit-top-form is the
;; 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))))
;; The emitted `(def-var! …)(mark-macro! …)` pair for a defmacro, guard-wrapped
;; (tolerant) or bare (strict) to match guard?.
(define (ei-macro-string ns-name nm scm guard?)
(if guard?
(string-append "(guard (e (#t #f))\n (def-var! " (ei-str-lit ns-name) " " (ei-str-lit nm)
"\n " scm ")\n (mark-macro! " (ei-str-lit ns-name) " " (ei-str-lit nm) "))")
(string-append "(def-var! " (ei-str-lit ns-name) " " (ei-str-lit nm) "\n " scm
")\n(mark-macro! " (ei-str-lit ns-name) " " (ei-str-lit nm) ")")))
;; Cross-compile one namespace's source to a list of Scheme strings — shared by
;; 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 ((hook (ei-emit-form-hook)))
(let loop ((forms (ei-read-all src)) (acc '()))
(if (null? forms)
(reverse acc)
(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))
((ce-macro-form? f)
(let-values (((nm fn-form) (ce-defmacro->fn f)))
(let ((scm (if guard?
(guard (e (#t #f)) (ei-compile-form (make-analyze-ctx ns-name) fn-form optimize?))
(ei-compile-form (make-analyze-ctx ns-name) fn-form optimize?))))
(loop (cdr forms)
(if (and guard? (not scm)) acc
(cons (ei-macro-string ns-name nm scm guard?) acc))))))
(else
(let ((scm (if guard?
(guard (e (#t #f)) (ei-compile-form (make-analyze-ctx ns-name) f optimize?))
(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)))))))))))
(define (ei-emit-ns ns-name src) (ei-emit-ns* ns-name src #f #t))
;; --- DCE record producer ----------------------------------------------------
;; Cross-compile a namespace's source to tree-shaking records — the app/library
;; counterpart to dce-blob-records (the prelude). The shake itself and all dce-*
;; helpers live in dce.ss; this stays here because it drives the ei-* compiler. A
;; top-level def becomes a prunable record; any other form a kept (side-effecting)
;; record whose refs are roots. A macro is prunable — its expander isn't called at
;; runtime in an AOT build.
(define (ei-emit-ns-records ns-name src)
(set-chez-ns! ns-name) ; ::kw resolves against this ns (see ei-emit-ns*)
(let loop ((forms (ei-read-all src)) (acc '()))
(if (null? forms)
(reverse acc)
(let ((f (car forms)))
(ce-scan-requires! f ns-name)
(cond
((ei-ns-form? f) (loop (cdr forms) acc))
((ce-macro-form? f)
(let-values (((nm fn-form) (ce-defmacro->fn f)))
(let* ((ctx (make-analyze-ctx ns-name))
(ir (jolt-ce-run-passes (jolt-ce-analyze ctx fn-form) ctx))
(str (ei-macro-string ns-name nm (jolt-ce-emit-top ir) #f))
(refs (dce-collect-refs '() ir)))
(loop (cdr forms) (cons (dce-rec #f (string-append ns-name "/" nm) refs str) acc)))))
(else
(let* ((ctx (make-analyze-ctx ns-name))
(ir (jolt-ce-run-passes (jolt-ce-analyze ctx f) ctx))
(str (jolt-ce-emit-top ir))
(fqn (dce-def-fqn ir))
(refs (dce-collect-refs '() ir)))
(loop (cdr forms)
(cons (if fqn (dce-rec #f fqn refs str) (dce-rec #t #f refs str)) acc)))))))))
;; Scheme string literal for a ns/name — uses the runtime's own writer
;; (printable ASCII identifiers only here).
(define (ei-str-lit s) (with-output-to-string (lambda () (write s))))
;; The compiler namespaces, in load order. The passes (fold/inline/types + the
;; jolt.passes façade) load after ir so run-passes is available to the back end;
;; fold/inline/types come before the façade that :refers them.
(define ei-compiler-ns-files
(list (cons "jolt.ir" "jolt-core/jolt/ir.clj")
(cons "jolt.analyzer" "jolt-core/jolt/analyzer.clj")
(cons "jolt.backend-scheme" "jolt-core/jolt/backend_scheme.clj")
(cons "jolt.passes.fold" "jolt-core/jolt/passes/fold.clj")
(cons "jolt.passes.numeric" "jolt-core/jolt/passes/numeric.clj")
(cons "jolt.passes.inline" "jolt-core/jolt/passes/inline.clj")
(cons "jolt.passes.types.lattice" "jolt-core/jolt/passes/types/lattice.clj")
(cons "jolt.passes.types.check" "jolt-core/jolt/passes/types/check.clj")
(cons "jolt.passes.types" "jolt-core/jolt/passes/types.clj")
(cons "jolt.passes" "jolt-core/jolt/passes.clj")))
;; The clojure.core tiers + stdlib namespaces, in load order.
;; Re-emitting these on Chez is the
;; prelude half of the fixpoint (the whole emitted system reproducing itself).
(define ei-prelude-ns-files
(append
(map (lambda (tf) (cons "clojure.core" (string-append "jolt-core/clojure/core/" tf ".clj")))
'("00-syntax" "00-kernel" "10-seq" "20-coll" "21-coll" "22-coll" "25-sorted" "30-macros" "40-lazy" "50-io"))
(list (cons "clojure.string" "stdlib/clojure/string.clj")
(cons "clojure.walk" "stdlib/clojure/walk.clj")
(cons "clojure.template" "stdlib/clojure/template.clj")
(cons "clojure.edn" "stdlib/clojure/edn.clj")
(cons "clojure.set" "stdlib/clojure/set.clj")
(cons "clojure.pprint" "stdlib/clojure/pprint.clj"))))
;; Join a list of form strings with "\n", no trailing newline.
(define (ei-join forms)
(let join ((fs forms) (out ""))
(cond
((null? fs) out)
((string=? out "") (join (cdr fs) (car fs)))
(else (join (cdr fs) (string-append out "\n" (car fs)))))))
;; Re-emit the whole list of (ns . file) pairs ON CHEZ as one Scheme string.
(define (ei-emit-ns-files nfs)
(ei-join (apply append
(map (lambda (nf) (ei-emit-ns (car nf) (read-file-string (cdr nf)))) nfs))))
;; Emit the compiler image (jolt.ir + jolt.analyzer + jolt.backend-scheme) on Chez.
(define (jolt-emit-image) (ei-emit-ns-files ei-compiler-ns-files))
;; Emit the clojure.core prelude (all tiers + stdlib) on Chez — the prelude half of
;; the self-hosting fixpoint.
(define (jolt-emit-prelude) (ei-emit-ns-files ei-prelude-ns-files))

View file

@ -1,528 +0,0 @@
;; host-contract.ss — the jolt.host contract on Chez.
;;
;; The portable seam between jolt-core (analyzer/IR/emitter, cross-compiled to
;; Scheme) and the host. Every
;; contract fn is def-var!'d into the "jolt.host" namespace so the cross-compiled
;; jolt.analyzer / jolt.backend-scheme — whose unqualified form-*/resolve-global/
;; ... refs lower to (var-deref "jolt.host" ...) — resolve here at runtime.
;;
;; This is what puts analyze->IR->emit ON CHEZ. It runs
;; over the Chez data reader's forms (reader.ss): symbols are symbol-t, lists are
;; cseq (list?), () is empty-list-t, vectors/maps are pvec/pmap, sets and #tag/
;; regex/inst/uuid are pmaps tagged :jolt/type, chars are NATIVE Chez chars.
;;
;; Loaded after rt.ss + reader.ss + the core prelude; before the compiler image.
;; --- the analyze ctx --------------------------------------------------------
;; ctx is opaque to the analyzer (only ever threaded to these contract fns); we
;; make it a box carrying the compile namespace. The var/ns registry it consults
;; is the global var-table (rt.ss).
(define-record-type chez-actx (fields (mutable cns)) (nongenerative chez-actx-v1))
(define (make-analyze-ctx ns) (make-chez-actx ns))
;; Interned keywords reused for form tags + resolve-global's result map.
(define hc-kw-jolt-type (keyword "jolt" "type"))
(define hc-kw-jolt-set (keyword "jolt" "set"))
(define hc-kw-jolt-tagged (keyword "jolt" "tagged"))
(define hc-kw-value (keyword #f "value"))
(define hc-kw-tag (keyword #f "tag"))
(define hc-kw-form (keyword #f "form"))
(define hc-kw-kind (keyword #f "kind"))
(define hc-kw-ns (keyword #f "ns"))
(define hc-kw-name (keyword #f "name"))
(define hc-kw-var (keyword #f "var"))
(define hc-kw-unresolved (keyword #f "unresolved"))
(define hc-kw-class (keyword #f "class"))
(define hc-kw-num-ret (keyword #f "num-ret"))
(define hc-kw-double (keyword #f "double"))
(define hc-kw-long (keyword #f "long"))
(define hc-kw-regex (keyword #f "regex"))
(define hc-kw-inst (keyword #f "#inst"))
(define hc-kw-uuid (keyword #f "#uuid"))
(define hc-kw-bigdec (keyword #f "bigdec"))
;; --- form predicates --------------------------------------------------------
(define (hc-sym? x) (symbol-t? x))
;; 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.
;; 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
;; real pset value — a macro template's #{...} expansion (syntax-quote.ss jolt-sqset)
;; produces a pset, which the analyzer must still read as a set literal.
(define (hc-set? x)
(or (pset? x)
(and (pmap? x) (eq? (jolt-get x hc-kw-jolt-type) hc-kw-jolt-set))))
(define (hc-char? x) (char? x))
(define (hc-keyword? x) (keyword? x))
(define (hc-literal? x)
(or (jolt-nil? x) (boolean? x) (number? x) (string? x) (keyword-t? x) (char? x)))
(define (hc-tagged-of x tag)
(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) (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))
(define (hc-bigdec-source x) (jolt-get x hc-kw-form))
;; A live namespace value spliced into a form (e.g. `(str ~*ns*) in a macro):
;; the analyzer can't carry an opaque runtime value, so recognize a jns and
;; 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
(define (hc-sym-name x) (symbol-t-name x))
;; The reader stores an unqualified symbol's ns inconsistently (#f, '(), or
;; jolt-nil — see converters.ss). The contract is jolt-nil for unqualified (the
;; analyzer tests (nil? ns)), so normalize; a real ns string passes through.
(define (hc-sym-ns x)
(let ((ns (symbol-t-ns x)))
(if (and ns (not (jolt-nil? ns)) (not (null? ns))) ns jolt-nil)))
(define (hc-sym-meta x)
(let ((m (symbol-t-meta x)))
(if (and m (not (jolt-nil? m)) (not (null? m))) m jolt-nil)))
;; Metadata the reader attached to a collection literal (vec/map/set/list), or
;; jolt-nil. The analyzer re-emits a runtime (with-meta ..) for a meta-carrying
;; vector/map/set so the value keeps its metadata.
(define (hc-coll-meta x) (jolt-meta x))
;; list items -> jolt vector (pvec); the analyzer mapv's over the result.
(define (hc-elements x)
(cond ((empty-list-t? x) empty-pvec)
((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)
(if (pset? x)
(apply jolt-vector (pset-fold x cons '()))
(jolt-get x hc-kw-value)))
(define (hc-map-pairs x)
(let ((kv (hashtable-ref rdr-map-order x #f)))
(if kv
;; reader-built map literal: emit pairs in SOURCE order (kv = k1 v1 k2 v2 …)
;; so the analyzer evaluates the values left-to-right.
(let loop ((kv kv) (acc '()))
(if (null? kv) (apply jolt-vector (reverse acc))
(loop (cddr kv) (cons (jolt-vector (car kv) (cadr kv)) acc))))
;; a runtime/non-reader map: pmap iteration order
(let loop ((ks (if (jolt-nil? (jolt-seq (jolt-keys x))) '()
(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) (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))
;; 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
;; uncompilable (the handled specials are dispatched in analyze-list BEFORE this).
;; `eval` is NOT here: it is a clojure.core FUNCTION on the spine (compile-eval.ss
;; def-var!s it), so it must resolve as an ordinary var, not punt.
;; `defmacro` stays special — the spine intercepts it before analysis.
(define hc-special-names
'("quote" "syntax-quote" "unquote" "unquote-splicing" "do" "if" "def"
"defmacro" "fn*" "let*" "loop*" "recur" "throw" "try" "set!" "new"
"." "gen-class" "monitor-enter" "monitor-exit" "letfn"))
(define (hc-interop-head? name)
(let ((n (string-length name)))
(and (> n 1)
(not (string=? name "..")) ; the .. threading macro, not an interop form
(or (char=? (string-ref name 0) #\.)
(char=? (string-ref name (- n 1)) #\.)))))
(define (hc-special? name)
(if (or (member name hc-special-names) (hc-interop-head? name)) #t #f))
;; --- compile-time environment -----------------------------------------------
(define (hc-current-ns ctx) (chez-actx-cns ctx))
(define (hc-late-bind? ctx) #t) ; Chez has no interpreter to punt to
;; Resolve a global symbol to its var cell against the compile ns then clojure.core
;; (a qualified ns wins). Shared by resolve-global / form-macro? / form-expand-1.
;; Normalizes the reader's unqualified-ns sentinel (#f / '() / jolt-nil) like
;; hc-sym-ns, so an unqualified symbol never looks up a bogus "#f" namespace.
(define (hc-resolve-cell ctx sym)
(let* ((nm (symbol-t-name sym))
(sns (symbol-t-ns sym))
(qualified (and sns (not (jolt-nil? sns)) (not (null? sns)) sns)))
(if qualified
;; 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 (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)))
(var-cell-lookup "clojure.core" nm)))))
;; Runtime macros: a defmacro is emitted into the prelude as a
;; def-var! of its cross-compiled expander fn plus (mark-macro! ns name), so the
;; var cell is flagged a macro (rt.ss var-macro-table). form-macro? checks the
;; flag; form-expand-1 applies the expander to the unevaluated arg forms (the rest
;; of the list), and the analyzer re-analyzes the returned form.
(define (hc-macro? ctx sym)
(macro-var? (hc-resolve-cell ctx sym)))
;; 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 (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)
;; {:kind :unresolved :name NAME} — not found (late-bind -> var-ref @ compile ns;
;; a qualified one -> host-static in the analyzer)
;; No :host branch: there is no separate native-op env — the hot
;; clojure.core primitives (+,-,map,...) are declared in clojure.core below so
;; they classify as :var and the emitter's native-op path lowers them.
;; A var's declared numeric return (^double/^long on its name) -> :double/:long,
;; 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)) ; ^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
;; reference (java.util.Map, clojure.lang.Named) — Clojure has no such vars. With
;; no JVM classes, jolt models a class as its name string, so the symbol
;; self-evaluates to that string (the analyzer emits a :const). This lets a lib
;; extend a protocol to / instance?-check a host class jolt has no shim for.
(define (hc-fq-class-name? nm)
(let ((n (string-length nm)))
(let loop ((i (fx- n 1)))
(cond ((fx<? i 0) #f)
((char=? (string-ref nm i) #\.)
(and (fx<? (fx+ i 1) n) (char-upper-case? (string-ref nm (fx+ i 1)))))
(else (loop (fx- i 1)))))))
(define (hc-resolve-global ctx sym)
(let* ((nm (symbol-t-name sym))
(cell (hc-resolve-cell ctx sym)))
(if (and cell (var-cell-defined? cell))
(let ((base (jolt-hash-map hc-kw-kind hc-kw-var
hc-kw-ns (var-cell-ns cell)
hc-kw-name (var-cell-name cell)))
(nr (hc-cell-num-ret cell)))
(if nr (jolt-assoc base hc-kw-num-ret nr) base))
(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)
;; --- syntax-quote lowering ---------------------------------------------------
;; Lowers a `form
;; to CONSTRUCTION CODE — Chez reader forms calling __sqcat/__sqvec/__sqmap/
;; __sqset/__sq1 + quote — that the analyzer re-analyzes, so a backtick compiles
;; with zero runtime cost (read -> macroexpand -> compile). Symbols resolve to
;; clojure.core / the compile ns; a foo# auto-gensym is stable within one `.
(define hc-special-symbols
'("quote" "syntax-quote" "unquote" "unquote-splicing" "do" "if" "def"
"defmacro" "fn*" "let*" "loop*" "recur" "throw" "try" "set!" "var"
"new" "."))
(define (hc-special-symbol? nm) (and (member nm hc-special-symbols) #t))
(define hc-sq-gensym-counter 0)
(define (hc-sq-gensym base)
(set! hc-sq-gensym-counter (+ hc-sq-gensym-counter 1))
(jolt-symbol #f (string-append base "__" (number->string hc-sq-gensym-counter) "__auto")))
(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)
(let ((h (seq-first x)))
(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)
(let ((sns (hc-sym-ns form)) (nm (symbol-t-name form)))
(if (jolt-nil? sns)
(cond
;; foo# -> a stable per-` auto-gensym
((and (> (string-length nm) 0)
(char=? (string-ref nm (- (string-length nm) 1)) #\#))
(or (hashtable-ref gsmap nm #f)
(let ((g (hc-sq-gensym (substring nm 0 (- (string-length nm) 1)))))
(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
;; syntax-quotes a referred var (e.g. clojure.tools.logging/spy using
;; clojure.pprint's pprint) expands to the real var.
((chez-resolve-refer (chez-actx-cns ctx) nm)
=> (lambda (target) (jolt-symbol target nm)))
(else (jolt-symbol (chez-actx-cns ctx) nm))) ; else: qualify to compile ns
;; qualified: if the ns part is an :as alias in the compile ns, resolve it
;; to the target namespace — Clojure resolves the alias part of a qualified
;; symbol in syntax-quote, so a macro's `impl/foo` expands to its real
;; (clojure.tools.logging.impl/foo) name and stays unambiguous even when
;; another loaded ns shares the alias's short name. Otherwise
;; leave it as written (a real ns or an interop class token).
(let ((target (chez-resolve-alias (chez-actx-cns ctx) sns)))
(if target (jolt-symbol target nm) form)))))
(define (hc-sq-lower ctx form gsmap)
(cond
((hc-head-is? form "unquote") (hc-second form))
((hc-head-is? form "unquote-splicing")
(jolt-throw (jolt-ex-info "~@ used outside of a list or vector in syntax-quote"
(jolt-hash-map))))
((hc-literal? form) form)
((symbol-t? form) (jolt-list (hc-sym "quote") (hc-sq-symbol ctx form gsmap)))
((hc-list? form)
(apply jolt-list (hc-sym "__sqcat")
(map (lambda (it) (hc-sq-lower-part ctx it gsmap)) (seq->list form))))
((hc-vec? form)
(apply jolt-list (hc-sym "__sqvec")
(map (lambda (it) (hc-sq-lower-part ctx it gsmap)) (seq->list form))))
((hc-set? form)
(apply jolt-list (hc-sym "__sqset")
(map (lambda (it) (hc-sq-lower-part ctx it gsmap)) (seq->list (hc-set-items form)))))
((hc-map? form)
(apply jolt-list (hc-sym "__sqmap")
(let loop ((pairs (seq->list (hc-map-pairs form))) (acc '()))
(if (null? pairs) (reverse acc)
(let ((p (seq->list (car pairs))))
(loop (cdr pairs)
(cons (hc-sq-lower ctx (cadr p) gsmap)
(cons (hc-sq-lower ctx (car p) gsmap) acc))))))))
(else (jolt-list (hc-sym "quote") form)))) ; tagged (char/regex/...) etc.
;; a list/vector/set element: a ~@ splice passes through (its seq is spliced by
;; __sqcat), any other item is wrapped (__sq1 <lowered>) so __sqcat flattens it.
(define (hc-sq-lower-part ctx item gsmap)
(if (hc-head-is? item "unquote-splicing")
(hc-second item)
(jolt-list (hc-sym "__sq1") (hc-sq-lower ctx item gsmap))))
(define (hc-syntax-quote-lower ctx inner)
(hc-sq-lower ctx inner (make-hashtable string-hash string=?)))
;; 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.
(define hc-optimize? #f)
(define (set-optimize! on) (set! hc-optimize? on))
(define (hc-inline-enabled? ctx) hc-optimize?)
;; Inline-body registry: jolt.passes stashes an inline-eligible defn's
;; {:params :body :nhints :ret} here (keyed ns/name) as its form is optimized;
;; jolt.passes.inline fetches it to splice the body at a call site. The stash is an
;; opaque jolt value to the host — IR maps round-tripping through the table.
(define inline-stash-table (make-hashtable string-hash string=?))
(define (hc-stash-inline! ctx ns-name nm m)
(hashtable-set! inline-stash-table (string-append ns-name "/" nm) m) jolt-nil)
(define (hc-inline-ir ctx ns-name nm)
(or (hashtable-ref inline-stash-table (string-append ns-name "/" nm) #f) jolt-nil))
;; --- declare the hot clojure.core primitives so resolve-global sees them ------
;; (mirrors backend_scheme.clj native-ops keys — the emitter lowers these inline,
;; so the declared cell's unbound root is never deref'd.)
(for-each (lambda (nm) (declare-var! "clojure.core" nm))
'("+" "-" "*" "/" "<" ">" "<=" ">=" "=" "inc" "dec" "not" "min" "max"
"mod" "rem" "quot" "vector" "hash-map" "hash-set" "conj" "get" "nth" "count"
"assoc" "dissoc" "contains?" "empty?" "peek" "pop" "first" "rest" "next" "seq"
"cons" "list" "reverse" "last" "map" "filter" "remove" "reduce" "into" "concat"
"apply" "range" "take" "drop" "keys" "vals" "even?" "odd?" "pos?" "neg?"
"zero?" "identity" "ex-info"))
;; --- install: bind the contract into the jolt.host namespace -----------------
(define (hc-install!)
(def-var! "jolt.host" "form-sym?" hc-sym?)
(def-var! "jolt.host" "form-sym-name" hc-sym-name)
(def-var! "jolt.host" "form-sym-ns" hc-sym-ns)
(def-var! "jolt.host" "form-sym-meta" hc-sym-meta)
(def-var! "jolt.host" "form-coll-meta" hc-coll-meta)
(def-var! "jolt.host" "form-list?" hc-list?)
(def-var! "jolt.host" "form-vec?" hc-vec?)
(def-var! "jolt.host" "form-map?" hc-map?)
(def-var! "jolt.host" "form-set?" hc-set?)
(def-var! "jolt.host" "form-char?" hc-char?)
(def-var! "jolt.host" "form-char-code" hc-char-code)
(def-var! "jolt.host" "form-literal?" hc-literal?)
(def-var! "jolt.host" "form-keyword?" hc-keyword?)
(def-var! "jolt.host" "form-regex?" hc-regex?)
(def-var! "jolt.host" "form-inst?" hc-inst?)
(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)
(def-var! "jolt.host" "form-vec-items" hc-vec-items)
(def-var! "jolt.host" "form-set-items" hc-set-items)
(def-var! "jolt.host" "form-map-pairs" hc-map-pairs)
(def-var! "jolt.host" "form-regex-source" hc-regex-source)
(def-var! "jolt.host" "form-inst-source" hc-inst-source)
(def-var! "jolt.host" "form-uuid-source" hc-uuid-source)
(def-var! "jolt.host" "form-position" hc-form-position)
(def-var! "jolt.host" "form-special?" hc-special?)
(def-var! "jolt.host" "compile-ns" hc-current-ns)
(def-var! "jolt.host" "late-bind?" hc-late-bind?)
(def-var! "jolt.host" "form-macro?" hc-macro?)
(def-var! "jolt.host" "form-expand-1" hc-expand-1)
(def-var! "jolt.host" "resolve-global" hc-resolve-global)
(def-var! "jolt.host" "host-intern!" hc-intern!)
(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!))
(hc-install!)

View file

@ -1,178 +0,0 @@
;; host tables + sorted collections — the jolt.host value primitives and the
;; 25-sorted tier's runtime.
;;
;; jolt.host/tagged-table + ref-put! + ref-get back the whole sorted tier
;; (sorted-map/sorted-set/subseq/rsubseq) AND every overlay fn that calls
;; (sorted? x) — empty, ifn?, reversible?, map?, set?, coll?. This provides:
;; 1. tagged-table / ref-put! / ref-get over a Chez mutable tagged-table type
;; (a string-keyed hashtable wrapped in an `htable` record), def-var!'d into
;; the jolt.host ns. The sorted tier (25-sorted.clj) mints its wrapper with
;; these — a red-black tree + :ops table travel inside the htable.
;; 2. a sorted-coll arm on the collection dispatchers, set!-extended the same
;; way records.ss extends them for jrec: each op routes through the value's
;; own :ops table (the dispatch pattern). first/rest/
;; next/last fall out free once jolt-seq has a sorted arm (they seq first).
;;
;; Loaded LAST (after records.ss / transients.ss / natives-meta.ss): it wraps the
;; jrec-extended dispatchers + value-host-tags, delegating to the captured prior.
;; --- jolt.host primitives ----------------------------------------------------
;; A tagged-table: a string-keyed hashtable (keyword field -> value). Keyword
;; keys collapse to their ns/name string so interning isn't relied on.
(define-record-type htable (fields (immutable h)) (nongenerative chez-htable-v1))
(define (kw->key k)
(let ((ns (keyword-t-ns k)))
(if (and ns (not (jolt-nil? ns))) (string-append ns "/" (keyword-t-name k)) (keyword-t-name k))))
(define (jolt-tagged-table tag)
(let ((h (make-hashtable string-hash string=?)))
(hashtable-set! h "jolt/type" tag)
(make-htable h)))
;; ref-put! threads the table back; a nil value REMOVES the key. Errors on a
;; non-htable so the atom-watch / volatile uses (which pass a different ref type
;; and have no table yet) stay a crash rather than silently diverging.
(define (jolt-ref-put! t k v)
(unless (htable? t) (error #f "ref-put!: not a host table" t))
(if (jolt-nil? v)
(hashtable-delete! (htable-h t) (kw->key k))
(hashtable-set! (htable-h t) (kw->key k) v))
t)
(define (jolt-ref-get t k)
(if (htable? t) (hashtable-ref (htable-h t) (kw->key k) jolt-nil) jolt-nil))
(def-var! "jolt.host" "tagged-table" jolt-tagged-table)
(def-var! "jolt.host" "ref-put!" jolt-ref-put!)
(def-var! "jolt.host" "ref-get" jolt-ref-get)
;; map-entry constructor: a 2-elem entry-flagged pvec (map-entry? true, vector?
;; false), so sorted-map seq/first produce real map entries that key/val accept.
(def-var! "jolt.host" "map-entry" make-map-entry)
;; --- sorted-coll recognition + ops access ------------------------------------
(define kw-jtype (keyword "jolt" "type"))
(define kw-sorted-map (keyword "jolt" "sorted-map"))
(define kw-sorted-set (keyword "jolt" "sorted-set"))
(define kw-ops (keyword #f "ops"))
(define kw-op-count (keyword #f "count"))
(define kw-op-seq (keyword #f "seq"))
(define kw-op-get (keyword #f "get"))
(define kw-op-contains (keyword #f "contains"))
(define kw-op-assoc (keyword #f "assoc"))
(define kw-op-dissoc (keyword #f "dissoc"))
(define kw-op-conj (keyword #f "conj"))
(define kw-op-disj (keyword #f "disj"))
(define (htable-sorted-map? x) (and (htable? x) (jolt=2 (jolt-ref-get x kw-jtype) kw-sorted-map)))
(define (htable-sorted-set? x) (and (htable? x) (jolt=2 (jolt-ref-get x kw-jtype) kw-sorted-set)))
(define (htable-sorted? x) (or (htable-sorted-map? x) (htable-sorted-set? x)))
;; the op fn for `op-kw` from the value's attached :ops map, then invoke it on sc.
(define (sc-op sc op-kw) (jolt-get (jolt-ref-get sc kw-ops) op-kw jolt-nil))
(define (sc-call sc op-kw . args) (apply jolt-invoke (sc-op sc op-kw) sc args))
;; --- extend the collection dispatchers with a sorted arm ---------------------
(define %h-seq jolt-seq)
(set! jolt-seq (lambda (x) (if (htable-sorted? x) (sc-call x kw-op-seq) (%h-seq x))))
(define %h-count jolt-count)
(set! jolt-count (lambda (coll) (if (htable-sorted? coll) (sc-call coll kw-op-count) (%h-count coll))))
(register-get-arm! htable-sorted? (lambda (coll k d) (sc-call coll kw-op-get k d)))
(define %h-contains? jolt-contains?)
(set! jolt-contains? (lambda (coll k)
(if (htable-sorted? coll) (if (jolt-truthy? (sc-call coll kw-op-contains k)) #t #f) (%h-contains? coll k))))
(define %h-assoc1 jolt-assoc1)
(set! jolt-assoc1 (lambda (coll k v)
(if (htable-sorted-map? coll) (sc-call coll kw-op-assoc (jolt-vector k v)) (%h-assoc1 coll k v))))
(define %h-dissoc jolt-dissoc)
(set! jolt-dissoc (lambda (coll . ks)
(if (htable-sorted-map? coll) (sc-call coll kw-op-dissoc (apply jolt-vector ks)) (apply %h-dissoc coll ks))))
(define %h-conj1 jolt-conj1)
(set! jolt-conj1 (lambda (coll x)
(if (htable-sorted? coll) (sc-call coll kw-op-conj (jolt-vector x)) (%h-conj1 coll x))))
(define %h-disj jolt-disj)
(set! jolt-disj (lambda (s . xs)
(if (htable-sorted-set? s) (sc-call s kw-op-disj (apply jolt-vector xs)) (apply %h-disj s xs))))
(def-var! "clojure.core" "disj" jolt-disj)
(define %h-empty? jolt-empty?)
(set! jolt-empty? (lambda (coll) (if (htable-sorted? coll) (zero? (sc-call coll kw-op-count)) (%h-empty? coll))))
(define %h-keys jolt-keys)
(set! jolt-keys (lambda (m)
(if (htable-sorted-map? m)
(list->cseq (map (lambda (e) (jolt-nth e 0)) (seq->list (sc-call m kw-op-seq))))
(%h-keys m))))
(define %h-vals jolt-vals)
(set! jolt-vals (lambda (m)
(if (htable-sorted-map? m)
(list->cseq (map (lambda (e) (jolt-nth e 1)) (seq->list (sc-call m kw-op-seq))))
(%h-vals m))))
;; sorted colls are collections (callable as fns via jolt-invoke, conj-able).
(define %h-coll? jolt-coll?)
(set! jolt-coll? (lambda (x) (or (htable-sorted? x) (%h-coll? x))))
;; public predicates: a sorted-map is map?, a sorted-set is set?, both coll?.
;; predicates.ss/records.ss def-var!'d a snapshot, so re-def-var! after set!.
(define %h-map? jolt-map?)
(set! jolt-map? (lambda (x) (or (htable-sorted-map? x) (%h-map? x))))
(def-var! "clojure.core" "map?" jolt-map?)
(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-collection? x) (jolt-coll-pred? x))))
;; --- equality / hash ---------------------------------------------------------
;; A sorted coll canonicalizes like its unordered counterpart:
;; a sorted-map equals ANY map (hash or sorted) with the same entries, a
;; sorted-set ANY set with the same elements — the comparator is irrelevant to =.
;; Convert to the plain persistent coll and delegate to the prior jolt=2 / hash.
;; (htable-sorted? short-circuits on a non-htable BEFORE any jolt=2, so extending
;; jolt=2 here doesn't recurse: the inner tag compare gets two keywords.)
(define (sorted-map->pmap sc)
(fold-left (lambda (m e) (pmap-assoc m (jolt-nth e 0) (jolt-nth e 1)))
empty-pmap (seq->list (sc-call sc kw-op-seq))))
(define (sorted-set->pset sc)
(fold-left (lambda (s x) (pset-conj s x)) empty-pset (seq->list (sc-call sc kw-op-seq))))
(define (sorted->plain x) (if (htable-sorted-map? x) (sorted-map->pmap x) (sorted-set->pset x)))
;; a sorted coll compares as its plain equivalent: normalize and re-dispatch (the
;; normalized values aren't sorted, so this arm won't re-match — the base compares).
(register-eq-arm! (lambda (a b) (or (htable-sorted? a) (htable-sorted? b)))
(lambda (a b) (jolt=2 (if (htable-sorted? a) (sorted->plain a) a)
(if (htable-sorted? b) (sorted->plain b) b))))
;; a sorted coll hashes as its plain equivalent (jolt-hash recurses through the base).
(register-hash-arm! htable-sorted? (lambda (x) (jolt-hash (sorted->plain x))))
;; --- printing ----------------------------------------------------------------
;; sorted colls render in SORTED order (the value's :seq), not HAMT order — and
;; a sorted-map prints "{k v, k v}" (", " between pairs),
;; NOT the space-only form the unordered pmap arm uses.
(define (sorted-map-render sc render)
(string-append "{"
(let loop ((es (seq->list (sc-call sc kw-op-seq))) (first #t) (acc ""))
(if (null? es) acc
(loop (cdr es) #f
(string-append acc (if first "" ", ")
(render (jolt-nth (car es) 0)) " " (render (jolt-nth (car es) 1))))))
"}"))
(define (sorted-set-render sc render)
(string-append "#{" (jolt-str-join (map render (seq->list (sc-call sc kw-op-seq)))) "}"))
(define (sorted-render x render)
(if (htable-sorted-map? x) (sorted-map-render x render) (sorted-set-render x render)))
;; sorted colls render in :seq order via the calling printer (str vs readable).
(register-pr-readable-arm! htable-sorted? (lambda (x) (sorted-render x jolt-pr-readable)))
(register-pr-str-arm! htable-sorted? (lambda (x) (sorted-render x jolt-pr-str)))
(register-str-render! htable-sorted? (lambda (x) (sorted-render x jolt-str-render-one)))
;; --- protocol dispatch over builtins (extend-protocol Map/Set on sorted) ------
;; value-host-tags (records.ss) drives extend-protocol on host values; a
;; sorted-map must answer to "Map", a sorted-set to "Set"/"Collection".
(define %h-value-host-tags value-host-tags)
(set! value-host-tags (lambda (obj)
(cond
((htable-sorted-map? obj) '("PersistentTreeMap" "Sorted" "IPersistentMap" "Associative"
"Map" "java.util.Map" "IPersistentCollection" "Object"))
((htable-sorted-set? obj) '("PersistentTreeSet" "Sorted" "IPersistentSet"
"Set" "java.util.Set" "Collection" "IPersistentCollection" "Object"))
(else (%h-value-host-tags obj)))))
;; (class e) on a throwable tagged-table (a library's ex-info envelope carrying a
;; JVM :class, e.g. jolt-lang/http-client's UnknownHostException) reads that
;; class name, so clojure.test's (thrown? Class …) / (= Class (class e)) match.
;; an htable carrying a string "class" entry reports it (a host-object class mirror).
(register-class-arm! (lambda (x) (and (htable? x) (string? (hashtable-ref (htable-h x) "class" #f))))
(lambda (x) (hashtable-ref (htable-h x) "class" #f)))

View file

@ -1,315 +0,0 @@
;; async.ss — clojure.core.async channel primitives on real OS threads.
;;
;; 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; an
;; optional ex-handler catches a throw from the transducer step.
;;
;; 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 ----------------------------------------------------------------
(define-record-type async-buffer (fields n kind) (nongenerative async-buffer-v1))
(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
;; front (pop from its head), `in` holds pushed entries reversed onto it, `len` is
;; the count (an append-to-a-list FIFO is O(n) per push and O(n) to measure).
;; 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) (mutable takew) exh)
(nongenerative async-chan-v2))
(define (ac-qnew) (vector '() '() 0))
(define (ac-qlen ch) (vector-ref (async-chan-items ch) 2))
(define (ac-qempty? ch) (fx=? 0 (vector-ref (async-chan-items ch) 2)))
(define (ac-qpush! ch entry)
(let ((q (async-chan-items ch)))
(vector-set! q 1 (cons entry (vector-ref q 1)))
(vector-set! q 2 (fx+ 1 (vector-ref q 2)))))
(define (ac-qfront! q) ; ensure `out` is non-empty: out := reverse in
(when (null? (vector-ref q 0))
(vector-set! q 0 (reverse (vector-ref q 1)))
(vector-set! q 1 '())))
(define (ac-qpop! ch)
(let ((q (async-chan-items ch)))
(ac-qfront! q)
(let ((out (vector-ref q 0)))
(vector-set! q 0 (cdr out))
(vector-set! q 2 (fx- (vector-ref q 2) 1))
(car out))))
(define (ac-qdrop-oldest! ch)
(let ((q (async-chan-items ch)))
(ac-qfront! q)
(vector-set! q 0 (cdr (vector-ref q 0)))
(vector-set! q 2 (fx- (vector-ref q 2) 1))))
;; enqueue honoring the buffer kind (used by the transducer step + buffered puts).
(define (ac-buf-give! ch v)
(case (async-chan-kind ch)
((dropping) (when (< (ac-qlen ch) (async-chan-cap ch)) (ac-qpush! ch (cons v #f))))
((sliding) (when (>= (ac-qlen ch) (async-chan-cap ch)) (ac-qdrop-oldest! ch))
(ac-qpush! ch (cons v #f)))
(else (ac-qpush! ch (cons v #f)))) ; fixed: caller ensured room
(condition-broadcast (async-chan-cv ch)))
;; A transducer is a jolt fn (xform); (xform add-rf) yields the channel's reducing
;; fn. add-rf: 0-arg init, 1-arg completion, 2-arg step (enqueue the output). A
;; `reduced` step result closes the channel.
(define (ac-make-add-rf ch)
(lambda args
(cond ((null? args) ch) ; init
((null? (cdr args)) (car args)) ; completion
(else (ac-buf-give! ch (cadr args)) (car args))))) ; step
;; 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))))
(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))
(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/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))))
;; close! (idempotent): mark closed, flush a stateful transducer's completion, and
;; wake everyone. ac-close! assumes the lock is held; the public form takes it.
(define (ac-close! ch)
(unless (async-chan-closed? ch)
(async-chan-closed?-set! ch #t)
(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)))
;; >! / >!! — put, blocking. false if closed; nil may not be put. With a
;; 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-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 (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
(cond ((async-chan-closed? ch) #f)
((< (ac-qlen ch) (async-chan-cap ch))
(ac-qpush! ch (cons v #f)) (condition-broadcast (async-chan-cv ch)) #t)
(else (condition-wait (async-chan-cv ch) (async-chan-mu ch)) (loop))))
(let ((box (vector #f))) ; unbuffered: rendezvous
(ac-qpush! ch (cons v box))
(condition-broadcast (async-chan-cv ch))
(let loop ()
(cond ((vector-ref box 0) #t)
((async-chan-closed? ch) #f)
(else (condition-wait (async-chan-cv ch) (async-chan-mu ch)) (loop))))))))))))
;; remove + return the head value, waking a parked rendezvous putter.
(define (ac-take-head! ch)
(let* ((entry (ac-qpop! ch)) (v (car entry)) (box (cdr entry)))
(when box (vector-set! box 0 #t))
(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 ((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 (ac-take-wait ch) (loop))))))
;; 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 ((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))))
;; 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)
(let ((w (ac-make 0 'unbuffered #f)))
(fork-thread (lambda () (sleep (ms->duration ms)) (jolt-async-close! w)))
w))
;; (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
;; are conveyed (Chez inherits the thread-parameter at fork; we install explicitly).
(define (async-go-spawn thunk)
(let ((w (ac-make 1 'fixed #f)) (snap (dyn-binding-stack)))
(fork-thread
(lambda ()
(dyn-binding-stack snap)
(let ((r (guard (e (#t (cons #f e))) (cons #t (jolt-invoke thunk)))))
(when (and (car r) (not (jolt-nil? (cdr r)))) (jolt-async-give w (cdr r)))
(jolt-async-close! w))))
w))
;; --- macros (expander fns over the reader forms) ----------------------------
(define cca-go-spawn-sym (jolt-symbol "clojure.core.async" "go-spawn"))
(define cca-go-sym (jolt-symbol "clojure.core.async" "go"))
(define cca-fn*-sym (jolt-symbol #f "fn*"))
(define cca-loop-sym (jolt-symbol #f "loop"))
;; (go body...) -> (clojure.core.async/go-spawn (fn* [] body...))
(define (cca-go-macro . body)
(jolt-list cca-go-spawn-sym (apply jolt-list cca-fn*-sym empty-pvec body)))
;; (go-loop bindings body...) -> (go (loop bindings body...))
(define (cca-go-loop-macro bindings . body)
(jolt-list cca-go-sym (apply jolt-list cca-loop-sym bindings body)))
;; (thread body...) — a real OS thread (same shape as go here).
(define (cca-thread-macro . body)
(jolt-list cca-go-spawn-sym (apply jolt-list cca-fn*-sym empty-pvec body)))
;; --- 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! "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")

View file

@ -1,402 +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 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

@ -1,85 +0,0 @@
;; 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

@ -1,261 +0,0 @@
;; 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

@ -1,611 +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 :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

@ -1,149 +0,0 @@
;; dot-forms.ss — generic dispatch for the `.` special-form / `.-field` desugar.
;; The analyzer lowers (. target member arg*) and (.-field target)
;; to a :host-call; the Chez emit routes a non-shimmed :host-call through
;; record-method-dispatch. This file extends that dispatcher with the collection
;; arms the interpreter's dispatch-member covers but the record/string base does
;; not, with this precedence:
;;
;; * collection interop wins first — count/seq/nth/get/valAt/containsKey on a
;; vector/map/set/seq/record (so (. {:count 9} count) is the entry count, 1,
;; NOT the :count field).
;; * field access — a "-name" member reads the field (records and maps).
;; * map member — a stored fn is a method (called with self + args); any
;; other value is returned as a field.
;;
;; Anything not recognized falls through to the previous dispatcher (jhost /
;; number / regex / jrec protocol / string). Loaded LAST (after host-static.ss).
;; 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.
;; 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
;; inconsistency Chez's normalized cseq can't mirror — so a raw seq target falls
;; through to the base dispatcher rather than risk a divergence the corpus would
;; never exercise but a future case might.
(define (dot-coll? obj)
(or (jolt-vector? obj) (jolt-map? obj) (pset? obj)))
;; Mirror coll-interop: return a one-element list boxing the result (so a jolt-nil
;; result is still distinguishable from "not a collection method"), or #f.
(define (dot-coll-method obj name args)
(cond
((string=? name "count") (list (jolt-count obj)))
((string=? name "seq") (list (jolt-seq obj)))
((string=? name "nth") (list (apply jolt-nth obj args)))
((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
;; non-record map these win OVER a field lookup, like dispatch-member. getMessage
;; on an ex-info reads its :message (the one the corpus exercises); getCause reads
;; :cause; toString/hashCode/equals round out the set. Returns a boxed result or
;; #f. Strings/numbers/records/jhost keep the base dispatcher (it shims them).
(define (dot-object-method obj name args)
(cond
((string=? name "getMessage")
(list (if (jolt=2 (jolt-get obj jolt-kw-ex-type jolt-nil) jolt-kw-ex-info)
(jolt-get obj jolt-kw-message jolt-nil)
(jolt-str-render-one obj))))
((string=? name "getCause") (list (jolt-get obj jolt-kw-cause jolt-nil)))
;; java.sql.SQLException chaining — ex-info / host throwables don't chain.
((string=? name "getNextException") (list jolt-nil))
((string=? name "getStackTrace") (list (jolt-vector)))
((string=? name "toString") (list (jolt-str-render-one obj)))
((string=? name "hashCode") (list (jolt-hash obj)))
((string=? name "equals") (list (if (jolt= obj (car args)) #t #f)))
(else #f)))
(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)
(char=? (string-ref method-name 0) #\-)))
(mname (if field?
(substring method-name 1 (string-length method-name))
method-name)))
(cond
;; 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,
;; then a stored procedure is a method (call with self), else the field.
((and (jolt-map? obj) (not (jrec? obj)))
(cond
((dot-object-method obj mname rest) => car)
(else
(let ((v (jolt-get obj (keyword #f mname) jolt-nil)))
(if (procedure? v) (apply jolt-invoke v obj rest) v)))))
(else 'pass)))))

View file

@ -1,167 +0,0 @@
;; ffi.ss — the runtime side of jolt's foreign-function interface (jolt.ffi).
;;
;; A jolt LIBRARY binds native code itself: it loads a shared object and declares
;; typed foreign functions, then exposes a Clojure API. The TYPED CALL is lowered
;; at compile time to a Chez `foreign-procedure` by the backend (the
;; `jolt.ffi/foreign-fn` special form) — this file provides everything that does
;; NOT need compile-time types: loading libraries, allocating/reading/writing
;; foreign memory, and string/pointer marshaling. All exposed under `jolt.ffi`.
;;
;; A foreign pointer is a Chez machine address (an exact integer / uptr), the same
;; representation `void*` arguments and results use, so pointers flow between
;; foreign-fn calls and these helpers transparently.
;; --- loading shared objects --------------------------------------------------
;; (jolt.ffi/load-library name) loads a .so/.dylib by name (resolved by the OS
;; loader against the standard search paths). A library typically calls this once
;; at load with a platform-specific name. (load-library) with no name (or #f)
;; loads the running process's own symbols (libc, sockets).
(define (ffi-load-library . args)
(if (or (null? args) (jolt-nil? (car args)))
(begin (load-shared-object #f) jolt-nil)
(begin (load-shared-object (jolt-str-render-one (car args))) jolt-nil)))
(define (ffi-loaded? name)
(guard (e (#t #f)) (load-shared-object (jolt-str-render-one name)) #t))
;; --- foreign type keywords ---------------------------------------------------
;; The keyword type names jolt.ffi accepts (in foreign-fn signatures and the
;; memory accessors) map to Chez foreign types. Kept in one place so the backend
;; (compile-time, for foreign-procedure) and these accessors (runtime, for
;; foreign-ref/set!) agree.
(define (ffi-type->chez kw)
(let ((n (if (keyword-t? kw) (keyword-t-name kw) (jolt-str-render-one kw))))
(cond
((string=? n "int") 'int)
((string=? n "uint") 'unsigned-int)
((string=? n "long") 'long)
((string=? n "ulong") 'unsigned-long)
((string=? n "int64") 'integer-64)
((string=? n "uint64") 'unsigned-64)
((string=? n "size_t") 'size_t)
((string=? n "ssize_t") 'ssize_t)
((string=? n "iptr") 'iptr)
((string=? n "uptr") 'uptr)
((string=? n "double") 'double)
((string=? n "float") 'float)
((or (string=? n "pointer") (string=? n "void*")) 'void*)
((string=? n "string") 'string)
((string=? n "void") 'void)
((or (string=? n "uint8") (string=? n "u8") (string=? n "byte")) 'unsigned-8)
((string=? n "char") 'char)
(else (error #f (string-append "jolt.ffi: unknown foreign type :" n))))))
;; --- foreign memory ----------------------------------------------------------
;; alloc returns a pointer (integer address). The caller frees it. read/write take
;; a type keyword and an optional byte offset.
(define (ffi-alloc nbytes) (foreign-alloc (jnum->exact nbytes)))
(define (ffi-free ptr) (foreign-free (jnum->exact ptr)) jolt-nil)
(define (ffi-read ptr ty . off)
(foreign-ref (ffi-type->chez ty) (jnum->exact ptr) (if (pair? off) (jnum->exact (car off)) 0)))
(define (ffi-write ptr ty off val)
(foreign-set! (ffi-type->chez ty) (jnum->exact ptr) (jnum->exact off) val) jolt-nil)
;; sizeof a foreign type (for laying out structs / arrays).
(define (ffi-sizeof ty) (foreign-sizeof (ffi-type->chez ty)))
(define (ffi-null? ptr) (and (number? ptr) (= (jnum->exact ptr) 0)))
(define ffi-null 0)
;; --- buffer I/O (known length) ----------------------------------------------
;; read n bytes at ptr as a string (UTF-8, falling back to latin1 for invalid
;; sequences) — for a socket recv buffer and similar fixed-length reads.
(define (ffi-read-bytes ptr n)
(let* ((n (jnum->exact n)) (p (jnum->exact ptr)) (bv (make-bytevector n)))
(do ((i 0 (+ i 1))) ((= i n)) (bytevector-u8-set! bv i (foreign-ref 'unsigned-8 p i)))
(guard (e (#t (list->string (map integer->char (bytevector->u8-list bv))))) (utf8->string bv))))
;; write a string's UTF-8 bytes into ptr (no NUL terminator); return the count.
(define (ffi-write-bytes ptr s)
(let* ((bv (string->utf8 (jolt-str-render-one s))) (n (bytevector-length bv)) (p (jnum->exact ptr)))
(do ((i 0 (+ i 1))) ((= i n)) (foreign-set! 'unsigned-8 p i (bytevector-u8-ref bv i)))
n))
(def-var! "jolt.ffi" "read-bytes" ffi-read-bytes)
(def-var! "jolt.ffi" "write-bytes" ffi-write-bytes)
;; --- byte-array buffer I/O (binary-faithful) --------------------------------
;; Move raw bytes between a jolt byte-array (jolt-array kind 'byte) and foreign
;; memory, byte-exact (no UTF-8 / latin1 decode) — for socket recv/send and the
;; zlib / OpenSSL buffers an HTTP client passes through. read-array returns a
;; fresh byte-array of n bytes; write-array copies a byte-array's bytes into ptr
;; and returns the count.
(define (ffi-read-array ptr n)
(let* ((n (jnum->exact n)) (p (jnum->exact ptr)) (v (make-vector n 0)))
(do ((i 0 (+ i 1))) ((= i n)) (vector-set! v i (foreign-ref 'unsigned-8 p i)))
(make-jolt-array v 'byte)))
(define (ffi-write-array ptr arr)
(let* ((v (jolt-array-vec arr)) (n (vector-length v)) (p (jnum->exact ptr)))
(do ((i 0 (+ i 1))) ((= i n)) (foreign-set! 'unsigned-8 p i (bitwise-and (exact (vector-ref v i)) #xff)))
n))
(def-var! "jolt.ffi" "read-array" ffi-read-array)
(def-var! "jolt.ffi" "write-array" ffi-write-array)
;; --- string / bytevector marshaling ------------------------------------------
;; A C string result already comes back as a jolt string (the `string` foreign
;; type). For a `void*` that points at a NUL-terminated C string, read it here.
(define (ffi-ptr->string ptr)
(if (ffi-null? ptr) jolt-nil
(let ((p (jnum->exact ptr)))
(let loop ((i 0) (acc '()))
(let ((b (foreign-ref 'unsigned-8 p i)))
(if (= b 0) (utf8->string (u8-list->bytevector (reverse acc)))
(loop (+ i 1) (cons b acc))))))))
;; Copy a jolt string's UTF-8 bytes into a freshly alloc'd NUL-terminated buffer;
;; the caller frees it. Returns the pointer.
(define (ffi-string->ptr s)
(let* ((bv (string->utf8 (jolt-str-render-one s))) (n (bytevector-length bv))
(p (foreign-alloc (+ n 1))))
(do ((i 0 (+ i 1))) ((= i n)) (foreign-set! 'unsigned-8 p i (bytevector-u8-ref bv i)))
(foreign-set! 'unsigned-8 p n 0)
p))
;; --- callbacks: receive calls FROM C ----------------------------------------
;; jolt.ffi/foreign-callable lowers to (jolt-ffi-register-callable! (foreign-callable …)).
;; A foreign-callable code object must be LOCKED (so the collector neither moves
;; nor reclaims it) and RETAINED while C may still call through its entry point.
;; Register it keyed by that entry-point address (a jolt pointer integer) — which
;; is what the caller hands to C; free-callable unlocks and drops it. A callback
;; left registered lives for the process (the GTK-signal-handler common case).
(define ffi-callable-table (make-eqv-hashtable)) ; entry-point addr -> code object
(define (jolt-ffi-register-callable! co)
(lock-object co)
(let ((addr (foreign-callable-entry-point co)))
(hashtable-set! ffi-callable-table addr co)
addr))
(define (ffi-free-callable addr)
(let* ((a (jnum->exact addr)) (co (hashtable-ref ffi-callable-table a #f)))
(when co (unlock-object co) (hashtable-delete! ffi-callable-table a))
jolt-nil))
;; --- native libraries for a standalone binary -------------------------------
;; `jolt build` bakes a project's deps.edn :jolt/native declarations into the
;; launcher, which loads them at startup (load-shared-object isn't part of the
;; saved heap, so it must run in the built process, not at heap build). process?
;; loads the running binary's own symbols (libc sockets); otherwise try each
;; platform candidate in turn and fail unless the spec is optional.
(define (jolt-build-load-native cands optional? process?)
(if process?
(begin (load-shared-object #f) #t)
(let loop ((cs cands))
(cond
((null? cs)
(unless optional?
(error 'jolt-build "required native library not found" cands))
#f)
((guard (e (#t #f)) (load-shared-object (car cs)) #t) #t)
(else (loop (cdr cs)))))))
;; --- expose under jolt.ffi ---------------------------------------------------
(def-var! "jolt.ffi" "free-callable" ffi-free-callable)
(def-var! "jolt.ffi" "load-library" ffi-load-library)
(def-var! "jolt.ffi" "loaded?" (lambda (n) (if (ffi-loaded? n) #t #f)))
(def-var! "jolt.ffi" "alloc" ffi-alloc)
(def-var! "jolt.ffi" "free" ffi-free)
(def-var! "jolt.ffi" "read" ffi-read)
(def-var! "jolt.ffi" "write" ffi-write)
(def-var! "jolt.ffi" "sizeof" ffi-sizeof)
(def-var! "jolt.ffi" "null?" (lambda (p) (if (ffi-null? p) #t #f)))
(def-var! "jolt.ffi" "null" ffi-null)
(def-var! "jolt.ffi" "ptr->string" ffi-ptr->string)
(def-var! "jolt.ffi" "string->ptr" ffi-string->ptr)

View file

@ -1,205 +0,0 @@
;; host class tokens — a bare class name (String, Keyword, File...)
;; evaluates to its JVM canonical-name STRING, the same value (class instance)
;; returns, so (= String (class "x")) holds and a (defmethod m String ...) keys
;; against a (class …) dispatch (ring.util.request does this).
;; The analyzer resolves these names to clojure.core vars, so the back end emits
;; (var-deref "clojure.core" "String") — def-var!'ing the canonical strings here is
;; all that's needed at runtime.
;;
;; Loaded after natives-meta.ss (jolt-type) + the printer (jolt-str-render-one).
;; (class x) — Clojure's class of a value. Scalars map to their JVM class name,
;; matching core-class. Collections/seqs have no JVM class on this host;
;; (str (type x)) is the clean host taxonomy and
;; is never compared against a class token in the corpus. Records yield their
;; ns-qualified class name (= (str (type x))). Total — never crashes.
;; A host shim (bigdec, queue, host-table) registers its type's class name via
;; register-class-arm! instead of set!-wrapping jolt-class (cf. register-hash-arm!).
;; The entry is stable, so the var cell bound below stays current as arms register.
(define jolt-class-arms '())
(define (register-class-arm! pred handler)
(set! jolt-class-arms (cons (cons pred handler) jolt-class-arms)))
(define (jolt-class-base x)
(cond
((jolt-nil? x) jolt-nil)
((boolean? x) "java.lang.Boolean")
;; per-type number classes, like the JVM: integer -> Long, flonum -> Double,
;; exact non-integer -> Ratio.
((and (number? x) (flonum? x)) "java.lang.Double")
((and (number? x) (exact? x) (integer? x)) "java.lang.Long")
((and (number? x) (exact? x) (rational? x)) "clojure.lang.Ratio")
((number? x) "java.lang.Number")
((string? x) "java.lang.String")
((keyword? x) "clojure.lang.Keyword")
((symbol-t? x) "clojure.lang.Symbol")
((jolt-atom? x) "clojure.lang.Atom")
((char? x) "java.lang.Character")
((regex-t? x) "java.util.regex.Pattern")
;; 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)))))
;; 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")
("ISeq" . "clojure.lang.ISeq") ("Keyword" . "clojure.lang.Keyword")
("Symbol" . "clojure.lang.Symbol") ("MapEntry" . "clojure.lang.MapEntry")
("StringReader" . "java.io.StringReader") ("StringWriter" . "java.io.StringWriter")
("StringBuilder" . "java.lang.StringBuilder")
("StringTokenizer" . "java.util.StringTokenizer")
("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")
("InterruptedException" . "java.lang.InterruptedException")
("IOException" . "java.io.IOException")
("UnknownHostException" . "java.net.UnknownHostException")
("ConnectException" . "java.net.ConnectException")
("SocketTimeoutException" . "java.net.SocketTimeoutException")
("MalformedURLException" . "java.net.MalformedURLException")
("SSLException" . "javax.net.ssl.SSLException")
("ExceptionInfo" . "clojure.lang.ExceptionInfo")
("IExceptionInfo" . "clojure.lang.IExceptionInfo")
("Pattern" . "java.util.regex.Pattern")
("URI" . "java.net.URI") ("UUID" . "java.util.UUID")
("ArrayList" . "java.util.ArrayList") ("PersistentQueue" . "clojure.lang.PersistentQueue")
("NumberFormatException" . "java.lang.NumberFormatException")
("ArithmeticException" . "java.lang.ArithmeticException")
("NullPointerException" . "java.lang.NullPointerException")
("ClassCastException" . "java.lang.ClassCastException")
("IndexOutOfBoundsException" . "java.lang.IndexOutOfBoundsException")
("UnsupportedEncodingException" . "java.io.UnsupportedEncodingException")
("FileNotFoundException" . "java.io.FileNotFoundException")
("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)
;; resolve a ^Type hint symbol-name to its canonical class name at def time:
;; "String" -> "java.lang.String", matching the JVM compiler. An
;; already-canonical name maps to itself; an unknown name yields #f (left as-is).
(define class-hint-table (make-hashtable string-hash string=?))
(for-each (lambda (p) (hashtable-set! class-hint-table (car p) (cdr p))) class-token-alist)
(for-each (lambda (p) (hashtable-set! class-hint-table (cdr p) (cdr p))) class-token-alist)
(define (resolve-class-hint name) (hashtable-ref class-hint-table name #f))
(def-var! "jolt.host" "resolve-class-hint" resolve-class-hint)
;; fully-qualified canonical class names self-evaluate to their own name string,
;; so (= (class 1) java.lang.Long) and (instance? clojure.lang.Atom x) resolve the
;; class token (= what jolt-class / instance-check key on).
;; Value classes only — NOT the collection interfaces (ISeq/IPersistentMap/...),
;; which downstream code (e.g. SCI) references as protocols/interfaces.
(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))
"java.lang.Exception" "java.lang.Throwable" "java.lang.RuntimeException"
"java.lang.IllegalArgumentException" "java.lang.IllegalStateException"
"java.lang.UnsupportedOperationException" "java.io.IOException"
"java.net.UnknownHostException" "java.net.ConnectException"
"java.net.SocketTimeoutException" "java.net.MalformedURLException"
"javax.net.ssl.SSLException"
"java.lang.NumberFormatException" "java.lang.ArithmeticException"
"java.lang.NullPointerException" "java.lang.ClassCastException"
"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.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"))

File diff suppressed because it is too large Load diff

View file

@ -1,443 +0,0 @@
;; host-static-methods.ss — the `Class/member` static surface: java.lang.Math,
;; System (properties/env), Thread, the Long/Integer/Double/Character/String static
;; methods, java.text.NumberFormat, and the Class registry. Registers into
;; host-static.ss's class-statics table (loaded just before this); instantiable host
;; object classes (ArrayList, StringBuilder, …) live in host-static-classes.ss.
;; ---- java.lang statics ------------------------------------------------------
;; java.lang.Math: sqrt/pow/floor/ceil/trig/log/exp always return a DOUBLE on the
;; JVM (Chez's sqrt/expt return EXACT for exact args, e.g. (sqrt 9) -> 3), so coerce
;; to flonum. round -> long (exact); abs/max/min preserve the argument's type.
(define (->dbl x) (exact->inexact x))
(register-class-statics! "Math"
(list (cons "sqrt" (lambda (x) (->dbl (sqrt x))))
(cons "pow" (lambda (a b) (->dbl (expt a b))))
(cons "floor" (lambda (x) (->dbl (floor x))))
(cons "ceil" (lambda (x) (->dbl (ceiling x))))
(cons "round" (lambda (x) (exact (floor (+ x 1/2))))) ; JVM round-half-up -> long
(cons "abs" (lambda (x) (abs x)))
(cons "sin" (lambda (x) (->dbl (sin x)))) (cons "cos" (lambda (x) (->dbl (cos x))))
(cons "tan" (lambda (x) (->dbl (tan x)))) (cons "asin" (lambda (x) (->dbl (asin x))))
(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)))
(cons "random" (lambda args (random 1.0)))))
;; Thread: real OS threads back futures/promises.
;; - sleep parks the calling thread for `ms` ms (a worker sleeping doesn't block
;; the parent).
;; - yield hands the CPU to another runnable thread (libc sched_yield).
;; - each thread carries an interrupt flag; interrupted (static) reads AND clears
;; the current thread's flag, matching the JVM. currentThread / .interrupt /
;; .isInterrupted are wired in io.ss, where the thread handle is built.
;; Per-thread interrupt flag, lazily allocated so each OS thread gets its own box.
;; A thread handle (from currentThread) captures this box, so .interrupt from
;; another thread sets the target thread's flag.
(define thread-interrupt-box (make-thread-parameter #f))
(define (current-interrupt-box)
(or (thread-interrupt-box)
(let ((b (box #f))) (thread-interrupt-box b) b)))
(define (clear-thread-interrupt!) (set-box! (current-interrupt-box) #f))
;; libc sched_yield, resolved once; fall back to a zero-length park if the symbol
;; isn't available.
(define thread-yield!
(let ((fp #f) (tried? #f))
(lambda ()
(unless tried?
(set! tried? #t)
(set! fp (jolt-foreign-proc-safe "sched_yield" '() 'int)))
(if fp (fp) (sleep (make-time 'time-duration 0 0)))
jolt-nil)))
(define thread-statics
(list (cons "sleep" (lambda (ms . _)
(let* ((ms* (exact (floor ms)))
(secs (quotient ms* 1000))
(nanos (* (remainder ms* 1000) 1000000)))
(sleep (make-time 'time-duration nanos secs)))
jolt-nil))
(cons "yield" (lambda _ (thread-yield!)))
(cons "interrupted" (lambda _ (let* ((b (current-interrupt-box)) (v (unbox b)))
(set-box! b #f) (and v #t))))))
(register-class-statics! "Thread" thread-statics)
(register-class-statics! "java.lang.Thread" thread-statics)
;; clojure.lang.LockingTransaction: jolt has no STM (no refs/dosync), so a
;; transaction is never running. isRunning -> false.
(register-class-statics! "LockingTransaction" (list (cons "isRunning" (lambda () #f))))
(register-class-statics! "clojure.lang.LockingTransaction" (list (cons "isRunning" (lambda () #f))))
;; clojure.lang.LazilyPersistentVector/createOwning: build a vector from an array
;; (malli's -vmap fills an object-array then hands it over). jolt has no array
;; ownership transfer, so copy the array's elements into a persistent vector.
(define (lpv-create-owning arr) (apply jolt-vector (seq->list (jolt-seq arr))))
(register-class-statics! "LazilyPersistentVector" (list (cons "createOwning" lpv-create-owning)))
(register-class-statics! "clojure.lang.LazilyPersistentVector" (list (cons "createOwning" lpv-create-owning)))
;; clojure.lang.PersistentArrayMap/createWithCheck: build a map from a [k v k v…]
;; array, throwing on a duplicate key. malli's eager entry parser relies on the
;; throw to report ::duplicate-keys, so a missing class would mis-fire on every
;; map. Build the map and signal if a key collapsed (count*2 < array length).
(define (pam-create-with-check arr)
(let ((items (seq->list (jolt-seq arr))))
(let loop ((xs items) (m (jolt-hash-map)))
(if (null? xs) m
(if (null? (cdr xs)) (error #f "PersistentArrayMap: odd key/value count")
(let ((k (car xs)))
(if (jolt-contains? m k) (error #f "Duplicate key")
(loop (cddr xs) (jolt-assoc m k (cadr xs))))))))))
(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))))
;; clojure.core/current-time-ms — epoch milliseconds; backs the `time` macro.
(def-var! "clojure.core" "current-time-ms" (lambda () (->num (now-millis))))
(register-class-statics! "System"
(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)))
(cons "clearProperty" (lambda (k) (sys-clear-property k)))
(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 "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")))))
;; JVM Integer.toHexString/etc. treat the int as 32-bit unsigned.
(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"))))
(cons "parseInt" (lambda (x . r) (parse-int-or-throw x (if (null? r) 10 (jnum->exact (car r))) "parseInt")))
;; lowercase, like the JVM; a negative int is the 32-bit unsigned form.
(cons "toHexString" (lambda (x) (string-downcase (number->string (int->u32 (jnum->exact x)) 16))))
(cons "toOctalString" (lambda (x) (number->string (int->u32 (jnum->exact x)) 8)))
(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 "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 "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))))
(cons "isInfinite" (lambda (x) (and (flonum? x) (infinite? x))))
(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 "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 "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)))))
;; 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.
(register-class-statics! "String"
(list (cons "valueOf" (lambda (x . _) (if (jolt-nil? x) "null" (jolt-str-render-one x))))
(cons "format" (lambda (a . rest)
(if (and (jhost? a) (string=? (jhost-tag a) "locale"))
(apply jolt-format (car rest) (cdr rest))
(apply jolt-format a rest))))))
;; ---- java.text.NumberFormat -------------------------------------------------
;; A grouping decimal formatter (selmer number-format / cuerdas). state:
;; #(grouping? min-frac max-frac). .format groups the integer part with commas.
(define (nf-make grouping? minf maxf) (make-jhost "numberformat" (vector grouping? minf maxf)))
(define (group-int-str s) ; "1234567" -> "1,234,567"
(let* ((neg (and (> (string-length s) 0) (char=? (string-ref s 0) #\-)))
(digs (if neg (substring s 1 (string-length s)) s))
(n (string-length digs)) (out '()))
(let loop ((i 0))
(when (< i n)
(when (and (> i 0) (= 0 (modulo (- n i) 3))) (set! out (cons #\, out)))
(set! out (cons (string-ref digs i) out)) (loop (+ i 1))))
(string-append (if neg "-" "") (list->string (reverse out)))))
(define (nf-format self x)
(let* ((grouping? (vector-ref (jhost-state self) 0))
(minf (vector-ref (jhost-state self) 1)) (maxf (vector-ref (jhost-state self) 2))
(neg (< x 0)) (ax (abs (exact->inexact x)))
(scale (expt 10 maxf))
(scaled (exact (round (* ax scale))))
(ipart (quotient scaled scale)) (fpart (remainder scaled scale))
(istr (number->string ipart))
(fstr0 (if (> maxf 0) (let ((s (number->string fpart)))
(string-append (make-string (max 0 (- maxf (string-length s))) #\0) s)) ""))
;; trim trailing zeros down to minf
(fstr (let loop ((s fstr0)) (if (and (> (string-length s) minf)
(char=? (string-ref s (- (string-length s) 1)) #\0))
(loop (substring s 0 (- (string-length s) 1))) s))))
(string-append (if neg "-" "") (if grouping? (group-int-str istr) istr)
(if (> (string-length fstr) 0) (string-append "." fstr) ""))))
(register-host-methods! "numberformat"
(list (cons "format" (lambda (self n) (nf-format self n)))
(cons "setMaximumFractionDigits" (lambda (self d) (vector-set! (jhost-state self) 2 (jnum->exact d)) jolt-nil))
(cons "setMinimumFractionDigits" (lambda (self d) (vector-set! (jhost-state self) 1 (jnum->exact d)) jolt-nil))
(cons "setGroupingUsed" (lambda (self b) (vector-set! (jhost-state self) 0 (jolt-truthy? b)) jolt-nil))))
(let ((nf-statics (list (cons "getInstance" (lambda _ (nf-make #t 0 3)))
(cons "getNumberInstance" (lambda _ (nf-make #t 0 3)))
(cons "getIntegerInstance" (lambda _ (nf-make #t 0 0))))))
(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"
(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
;; machine is macOS, otherwise Linux. Code that branches on the OS (socket struct
;; layout, path handling) needs the truth, not a fixed value.
(define (substring-index needle hay)
(let ((nl (string-length needle)) (hl (string-length hay)))
(let loop ((i 0)) (cond ((> (+ i nl) hl) #f)
((string=? (substring hay i (+ i nl)) needle) i)
(else (loop (+ i 1)))))))
(define sys-os-name
(let ((m (symbol->string (machine-type))))
(cond ((or (substring-index "osx" m) (substring-index "macos" m)) "Mac OS X")
((or (substring-index "nt" m) (substring-index "windows" m)) "Windows")
(else "Linux"))))
;; runtime-settable system properties (System/setProperty). A set value wins over
;; the built-in defaults below; clearProperty removes it.
(define sys-prop-table (make-hashtable string-hash string=?))
(define (sys-set-property k v)
(let ((prev (hashtable-ref sys-prop-table k jolt-nil)))
(hashtable-set! sys-prop-table k (if (string? v) v (jolt-str-render-one v)))
prev))
(define (sys-clear-property k)
(let ((prev (hashtable-ref sys-prop-table k jolt-nil)))
(hashtable-delete! sys-prop-table k) prev))
(define (sys-get-property k . dflt)
(let ((set-val (hashtable-ref sys-prop-table k #f)))
(cond (set-val set-val)
((string=? k "os.name") sys-os-name)
((string=? k "line.separator") "\n")
((string=? k "file.separator") "/")
((string=? k "path.separator") ":")
((string=? k "user.dir") (or (getenv "PWD") "."))
((string=? k "user.home") (or (getenv "HOME") ""))
((string=? k "java.io.tmpdir") (or (getenv "TMPDIR") "/tmp"))
((pair? dflt) (car dflt))
(else jolt-nil))))
(define (sys-properties-map)
(jolt-hash-map "os.name" sys-os-name "line.separator" "\n" "file.separator" "/"
"user.dir" (or (getenv "PWD") ".") "user.home" (or (getenv "HOME") "")
"java.io.tmpdir" (or (getenv "TMPDIR") "/tmp")))
;; full environment as an alist of (name . value), via spawning `env`.
(define (all-env-pairs)
(call-with-values
(lambda () (open-process-ports "env" (buffer-mode block) (native-transcoder)))
(lambda (stdin stdout stderr pid)
(let loop ((acc '()))
(let ((l (get-line stdout)))
(if (eof-object? l) (reverse acc)
(let ((eq (let scan ((i 0)) (cond ((= i (string-length l)) #f)
((char=? (string-ref l i) #\=) i)
(else (scan (+ i 1)))))))
(loop (if eq (cons (cons (substring l 0 eq) (substring l (+ eq 1) (string-length l))) acc) acc)))))))))
;; JOLT_BAKE_ENV_ALLOWLIST: when set, only the listed comma-separated
;; names are served; unset (the normal case) reads are live and unfiltered.
(define (env-allowlist)
(let ((a (getenv "JOLT_BAKE_ENV_ALLOWLIST")))
(and a (map str-trim (str-literal-split a ",")))))
(define (sys-getenv . k)
(let ((allow (env-allowlist)))
(if (null? k)
(apply jolt-hash-map
(let loop ((ps (all-env-pairs)) (acc '()))
(cond ((null? ps) (reverse acc))
((and allow (not (member (caar ps) allow))) (loop (cdr ps) acc))
(else (loop (cdr ps) (cons (cdar ps) (cons (caar ps) acc)))))))
(let ((name (car k)))
(if (and allow (not (member name allow))) jolt-nil
(let ((v (getenv name))) (if v v jolt-nil)))))))
;; ---- StringBuilder ----------------------------------------------------------
;; state: a box (1-vector) holding the accumulated string.
(define (sb-str self) (vector-ref (jhost-state self) 0))
(define (sb-set! self s) (vector-set! (jhost-state self) 0 s))
(define (render-piece x)
(cond ((jolt-nil? x) "null") ((char? x) (string x)) ((string? x) x)
(else (jolt-str-render-one x))))
;; (Object.) — a fresh value with distinct identity (libraries use it as a lock
;; or a unique sentinel). Each call returns a new jhost so identical?/= separate.
(register-class-ctor! "Object" (lambda _ (make-jhost "object" (vector))))

View file

@ -1,217 +0,0 @@
;; host-static.ss — the host-interop registry core: the class-statics / class-ctors
;; / tagged-methods tables, the jhost record, and the coercion helpers. The actual
;; entries are registered by host-static-methods.ss (Class/member statics) and
;; host-static-classes.ss (instantiable object classes), loaded after this.
;;
;; The analyzer lowers `Class/member` to a :host-static node and `(Class. ...)` /
;; `(new Class ...)` to a :host-new node (jolt-core/jolt/analyzer.clj); the Chez
;; emit lowers a value ref to (host-static-ref "Class" "member"), a
;; call head to (host-static-call "Class" "member" args...), and a constructor to
;; (host-new "Class" args...). This file is the runtime registry those three
;; resolve against — the class-statics / class-ctors /
;; tagged-methods registries,
;; restricted to the java.lang/util/net/io surface portable cljc code calls.
;; (java.time formatting is a separate increment.)
;;
;; Constructed host objects are `jhost` records (a tag + mutable state); their
;; (.method ...) calls reach record-method-dispatch (records.ss), extended below
;; with a jhost arm that dispatches through host-tagged-methods.
;;
;; Loaded from rt.ss LAST (after natives-str.ss / records.ss): it extends
;; record-method-dispatch and reuses jolt-str-render-one / jolt-re-pattern.
;; ---- registries -------------------------------------------------------------
(define class-statics-tbl (make-hashtable string-hash string=?)) ; "Class" -> (member-ht)
(define class-ctors-tbl (make-hashtable string-hash string=?)) ; "Class" -> ctor proc
(define host-methods-tbl (make-hashtable string-hash string=?)) ; tag -> (method-ht)
;; A class token may arrive fully qualified (java.io.StringReader) or short
;; (StringReader). Register both; resolve by exact then by last dotted segment.
(define (short-class-name s)
(let loop ((i (- (string-length s) 1)))
(cond ((< i 0) s)
((char=? (string-ref s i) #\.) (substring s (+ i 1) (string-length s)))
(else (loop (- i 1))))))
(define (register-class-statics! name members) ; members: list of (str . val/proc)
(let ((h (or (hashtable-ref class-statics-tbl name #f)
(let ((h (make-hashtable string-hash string=?)))
(hashtable-set! class-statics-tbl name h) h))))
(for-each (lambda (p) (hashtable-set! h (car p) (cdr p))) members)))
(define (register-class-ctor! name proc) (hashtable-set! class-ctors-tbl name proc))
(define (register-host-methods! tag members)
(let ((h (or (hashtable-ref host-methods-tbl tag #f)
(let ((h (make-hashtable string-hash string=?)))
(hashtable-set! host-methods-tbl tag h) h))))
(for-each (lambda (p) (hashtable-set! h (car p) (cdr p))) members)))
(define (lookup-class h-tbl name)
(or (hashtable-ref h-tbl name #f)
(hashtable-ref h-tbl (short-class-name name) #f)))
;; ---- host object ------------------------------------------------------------
(define-record-type jhost (fields tag (mutable state)) (nongenerative chez-jhost-v1))
;; record-method-dispatch (records.ss) gets a jhost arm: dispatch (.method obj a*)
;; through the tag's method table.
;; 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
((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) (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 . 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))))
((string=? method "intValue") (->num (jnum->exact n)))
((string=? method "longValue") (->num (jnum->exact n)))
((string=? method "doubleValue") (->num n))
((string=? method "floatValue") (->num 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 ((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))
(define (host-new class . args)
(let ((ctor (lookup-class class-ctors-tbl class)))
(cond
(ctor (apply ctor args))
;; deftype/defrecord: the type name is bound as a VAR (the
;; make-deftype-ctor closure) in its defining ns, not a registered host class.
;; Resolve it in the current ns / clojure.core and invoke it — so (P. args)
;; works the same as the ->P factory.
(else
(let ((cell (or (var-cell-lookup (chez-current-ns) class)
(var-cell-lookup "clojure.core" class))))
(if (and cell (var-cell-defined? cell) (procedure? (var-cell-root cell)))
(apply (var-cell-root cell) args)
(error #f (string-append "No constructor for class " class))))))))
;; ---- coercion helpers -------------------------------------------------------
;; numeric tower: currentTimeMillis/nanoTime are exact longs (JVM).
(define (->num x) x)
(define (jnum->exact n) (exact (truncate n)))
;; parse an integer string in radix; #f on failure
(define (parse-int-str s radix)
(let ((n (string->number (str-trim (if (string? s) s (jolt-str-render-one s))) radix)))
(and n (integer? n) (->num n))))
(define (parse-int-or-throw s radix what)
(or (parse-int-str s radix)
(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 /
;; Infinity / decimal / scientific. #f on failure.
(define (parse-double-str s)
(let ((t (str-trim (if (string? s) s (jolt-str-render-one s)))))
(cond
((or (string=? t "NaN") (string=? t "+NaN") (string=? t "-NaN")) +nan.0)
((or (string=? t "Infinity") (string=? t "+Infinity")) +inf.0)
((string=? t "-Infinity") -inf.0)
(else (let ((n (string->number t))) (and n (real? n) (exact->inexact n)))))))
(define (parse-double-or-throw s)
(or (parse-double-str 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

@ -1,596 +0,0 @@
;; #inst values + a java.time formatting shim.
;;
;; A #inst literal lowers (analyzer :inst node -> emit) to (jolt-inst-from-string
;; "…"); this file parses the RFC3339 string to epoch-ms and models the value as a
;; `jinst` record (one flonum field, ms). Equality / map-key hashing are by the
;; INSTANT (offset-normalized). The overlay inst?/inst-ms read (get x :jolt/type)/(get x :ms),
;; so jolt-get answers those off a jinst — the overlay fns then work unchanged.
;;
;; The java.time surface (DateTimeFormatter/Instant/ZoneId/LocalDateTime/
;; FormatStyle/Locale + the .format/.atZone/.toInstant/… methods) is
;; registered through host-static.ss's class-statics / host-
;; methods registries — so this loads LAST in rt.ss, after host-static.ss and io.ss.
;; --- civil <-> days since the Unix epoch (Howard Hinnant's algorithms) -------
;; No portable UTC mktime on Chez, so compute epoch days directly from y/m/d.
(define (days-from-civil y m d)
(let* ((y2 (if (<= m 2) (- y 1) y))
(era (quotient (if (>= y2 0) y2 (- y2 399)) 400))
(yoe (- y2 (* era 400)))
(doy (+ (quotient (+ (* 153 (+ m (if (> m 2) -3 9))) 2) 5) (- d 1)))
(doe (+ (* yoe 365) (quotient yoe 4) (- (quotient yoe 100)) doy)))
(+ (* era 146097) doe -719468)))
(define (civil-from-days z) ; -> (values year month day)
(let* ((z2 (+ z 719468))
(era (quotient (if (>= z2 0) z2 (- z2 146096)) 146097))
(doe (- z2 (* era 146097)))
(yoe (quotient (+ doe (- (quotient doe 1460)) (quotient doe 36524) (- (quotient doe 146096))) 365))
(y (+ yoe (* era 400)))
(doy (- doe (+ (* 365 yoe) (quotient yoe 4) (- (quotient yoe 100)))))
(mp (quotient (+ (* 5 doy) 2) 153))
(d (+ (- doy (quotient (+ (* 153 mp) 2) 5)) 1))
(m (+ mp (if (< mp 10) 3 -9))))
(values (if (<= m 2) (+ y 1) y) m d)))
;; --- RFC3339 parse: yyyy[-MM[-dd[Thh[:mm[:ss[.fff]]]]]][Z|±hh:mm] -> ms -------
(define-record-type jinst (fields ms) (nongenerative chez-jinst-v1))
(define (digit? c) (and (char>=? c #\0) (char<=? c #\9)))
(define (digits-at s i n) ; n digits from i -> integer, or #f
(and (<= (+ i n) (string-length s))
(let loop ((j i) (acc 0))
(if (= j (+ i n))
acc
(and (digit? (string-ref s j))
(loop (+ j 1) (+ (* acc 10) (- (char->integer (string-ref s j)) 48))))))))
(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: " 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)))
;; -dd
(when (and (< i len) (char=? (string-ref ts i) #\-) (digits-at ts (+ i 1) 2))
(set! day (digits-at ts (+ i 1) 2)) (set! i (+ i 3)))
;; Thh
(when (and (< i len) (or (char=? (string-ref ts i) #\T) (char=? (string-ref ts i) #\t))
(digits-at ts (+ i 1) 2))
(set! hh (digits-at ts (+ i 1) 2)) (set! i (+ i 3))
;; :mm
(when (and (< i len) (char=? (string-ref ts i) #\:) (digits-at ts (+ i 1) 2))
(set! mm (digits-at ts (+ i 1) 2)) (set! i (+ i 3))
;; :ss
(when (and (< i len) (char=? (string-ref ts i) #\:) (digits-at ts (+ i 1) 2))
(set! ss (digits-at ts (+ i 1) 2)) (set! i (+ i 3))
;; .fff (truncate beyond 3)
(when (and (< i len) (char=? (string-ref ts i) #\.))
(let loop ((j (+ i 1)) (k 0) (acc 0))
(if (and (< j len) (digit? (string-ref ts j)))
(loop (+ j 1) (+ k 1) (if (< k 3) (+ (* acc 10) (- (char->integer (string-ref ts j)) 48)) acc))
(begin
(set! frac-ms (* acc (expt 10 (max 0 (- 3 k)))))
(set! i j))))))))
;; offset Z | ±hh:mm
(when (< i len)
(let ((c (string-ref ts i)))
(cond
((or (char=? c #\Z) (char=? c #\z)) (set! i (+ i 1)))
((or (char=? c #\+) (char=? c #\-))
(let ((oh (digits-at ts (+ i 1) 2)) (om (digits-at ts (+ i 4) 2)))
(unless (and oh om (char=? (string-ref ts (+ i 3)) #\:)) (fail))
(set! off-s (* (if (char=? c #\-) -1 1) (+ (* oh 3600) (* om 60))))
(set! i (+ i 6))))
(else (fail)))))
(unless (= i len) (fail))
(let ((base-s (+ (* (days-from-civil year month day) 86400) (* hh 3600) (* mm 60) ss)))
(make-jinst (- (+ (* base-s 1000) frac-ms) (* off-s 1000))))))
;; --- canonical print form: yyyy-MM-ddThh:mm:ss.fff-00:00 (UTC) ---------------
(define (pad2 n) (if (< n 10) (string-append "0" (number->string n)) (number->string n)))
(define (pad4 n) (let ((s (number->string n))) (string-append (make-string (max 0 (- 4 (string-length s))) #\0) s)))
(define (pad3 n) (let ((s (number->string n))) (string-append (make-string (max 0 (- 3 (string-length s))) #\0) s)))
(define (inst-floor-div a b) (let ((q (quotient a b)) (r (remainder a b))) (if (and (not (= r 0)) (< (* a b) 0)) (- q 1) q)))
(define (inst-floor-mod a b) (- a (* (inst-floor-div a b) b)))
(define (inst-fields ms) ; -> list (y mo d hh mm ss frac dow)
(let* ((total-s (inst-floor-div (exact (truncate ms)) 1000))
(frac (- (exact (truncate ms)) (* total-s 1000)))
(days (inst-floor-div total-s 86400))
(sod (inst-floor-mod total-s 86400))
(hh (quotient sod 3600)) (mm (quotient (remainder sod 3600) 60)) (ss (remainder sod 60))
(dow (inst-floor-mod (+ days 4) 7))) ; 1970-01-01 = Thursday; 0=Sunday
(call-with-values (lambda () (civil-from-days days))
(lambda (y mo d) (list y mo d hh mm ss frac dow)))))
(define (inst-rfc3339 inst)
(let ((f (inst-fields (jinst-ms inst))))
(string-append (pad4 (list-ref f 0)) "-" (pad2 (list-ref f 1)) "-" (pad2 (list-ref f 2))
"T" (pad2 (list-ref f 3)) ":" (pad2 (list-ref f 4)) ":" (pad2 (list-ref f 5))
"." (pad3 (list-ref f 6)) "-00:00")))
;; --- DateTimeFormatter pattern engine -----
(define month-names (vector "January" "February" "March" "April" "May" "June" "July"
"August" "September" "October" "November" "December"))
(define day-names (vector "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
(define (format-ms pattern ms)
(let ((f (inst-fields ms)) (n (string-length pattern)) (out (open-output-string)))
(let ((y (list-ref f 0)) (mo (list-ref f 1)) (d (list-ref f 2))
(hh (list-ref f 3)) (mi (list-ref f 4)) (se (list-ref f 5)) (dow (list-ref f 7)))
(define (run-len i c) (let loop ((j i)) (if (and (< j n) (char=? (string-ref pattern j) c)) (loop (+ j 1)) (- j i))))
(let loop ((i 0))
(when (< i n)
(let* ((c (string-ref pattern i)) (k (run-len i c)))
(cond
((char=? c #\')
(if (and (< (+ i 1) n) (char=? (string-ref pattern (+ i 1)) #\'))
(begin (write-char #\' out) (loop (+ i 2)))
(let close ((j (+ i 1)))
(cond ((>= j n) (loop j))
((char=? (string-ref pattern j) #\') (loop (+ j 1)))
(else (write-char (string-ref pattern j) out) (close (+ j 1)))))))
((char=? c #\y) (display (if (>= k 4) (number->string y) (pad2 (modulo y 100))) out) (loop (+ i k)))
((char=? c #\M)
(display (cond ((= k 1) (number->string mo)) ((= k 2) (pad2 mo))
((= k 3) (substring (vector-ref month-names (- mo 1)) 0 3))
(else (vector-ref month-names (- mo 1)))) out)
(loop (+ i k)))
((char=? c #\d) (display (if (= k 1) (number->string d) (pad2 d)) out) (loop (+ i k)))
((char=? c #\E)
(display (if (>= k 4) (vector-ref day-names dow) (substring (vector-ref day-names dow) 0 3)) out)
(loop (+ i k)))
((char=? c #\H) (display (if (= k 1) (number->string hh) (pad2 hh)) out) (loop (+ i k)))
((char=? c #\h)
(let ((h12 (let ((h (modulo hh 12))) (if (= h 0) 12 h))))
(display (if (= k 1) (number->string h12) (pad2 h12)) out)) (loop (+ i k)))
((char=? c #\m) (display (if (= k 1) (number->string mi) (pad2 mi)) out) (loop (+ i k)))
((char=? c #\s) (display (if (= k 1) (number->string se) (pad2 se)) out) (loop (+ i k)))
((char=? c #\a) (display (if (< hh 12) "AM" "PM") out) (loop (+ i k)))
;; timezone — format-ms renders UTC, the HTTP zone is GMT: z/zzz -> GMT,
;; Z (RFC822) -> +0000, X (ISO) -> Z.
((char=? c #\z) (display "GMT" out) (loop (+ i k)))
((char=? c #\Z) (display "+0000" out) (loop (+ i k)))
((char=? c #\X) (display "Z" out) (loop (+ i k)))
(else (write-char c out) (loop (+ i 1)))))))
(get-output-string out))))
;; --- SimpleDateFormat .parse: pattern-driven parse to epoch-ms (UTC/GMT) ------
(define (month-from-name s)
(let ((m3 (ascii-string-down (substring s 0 (min 3 (string-length s))))))
(let loop ((i 0))
(cond ((= i 12) #f)
((string=? (ascii-string-down (substring (vector-ref month-names i) 0 3)) m3) (+ i 1))
(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) (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))))
;; 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))))
(define (read-tz ii) ; consume GMT/UTC/Z or ±hhmm; -> next
(cond ((>= ii inn) ii)
((char-alphabetic? (string-ref input ii)) (cdr (read-alpha ii)))
((or (char=? (string-ref input ii) #\+) (char=? (string-ref input ii) #\-))
(let loop ((j (+ ii 1))) (if (and (< j inn) (or (digit? (string-ref input j)) (char=? (string-ref input j) #\:))) (loop (+ j 1)) j)))
(else ii)))
(let loop ((pi 0) (ii 0))
(if (>= pi pn)
(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)) 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-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 (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-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) (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)) #\'))
(loop (+ pi 2) (if (and (< ii inn) (char=? (string-ref input ii) #\')) (+ ii 1) ii))
(let lit ((pj (+ pi 1)) (ij ii))
(cond ((>= pj pn) (loop pj ij))
((char=? (string-ref pattern pj) #\') (loop (+ pj 1) ij))
((and (< ij inn) (char=? (string-ref input ij) (string-ref pattern pj))) (lit (+ pj 1) (+ ij 1)))
(else (pfail))))))
;; literal: match it; a pattern space tolerates missing/extra spaces.
((char=? c #\space)
(let skip ((ij ii)) (if (and (< ij inn) (char=? (string-ref input ij) #\space)) (skip (+ ij 1)) (loop (+ pi 1) ij))))
((and (< ii inn) (char=? (string-ref input ii) c)) (loop (+ pi 1) (+ ii 1)))
(else (pfail))))))))
;; --- value integration: get / = / hash / pr / type / instance? --------------
(define kw-jolt-type (keyword "jolt" "type"))
(define kw-ms (keyword #f "ms"))
(define inst-type-kw (keyword "jolt" "inst"))
(register-get-arm! jinst?
(lambda (coll k d)
(cond ((jolt=2 k kw-jolt-type) inst-type-kw)
((jolt=2 k kw-ms) (jinst-ms coll))
(else d))))
(register-eq-arm! (lambda (a b) (or (jinst? a) (jinst? b)))
(lambda (a b) (and (jinst? a) (jinst? b) (= (jinst-ms a) (jinst-ms b)))))
(register-hash-arm! jinst? (lambda (x) (jolt-hash (jinst-ms x))))
;; #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))
(= (ms-of a) (ms-of b)))))
(register-hash-arm! time-jhost? (lambda (x) (jolt-hash (ms-of x))))
(define (inst-pr i) (string-append "#inst \"" (inst-rfc3339 i) "\""))
(register-pr-arm! jinst? inst-pr)
(register-str-render! jinst? inst-rfc3339)
(define %it-type jolt-type)
(set! jolt-type (lambda (x) (if (jinst? x) inst-type-kw (%it-type x))))
;; instance? java.util.Date -> a jinst; java.time.Instant/LocalDateTime -> the
;; matching jhost tag. The instance? macro passes the class-name symbol.
(define (class-short tn) (let loop ((i (- (string-length tn) 1)))
(cond ((< i 0) tn) ((char=? (string-ref tn i) #\.) (substring tn (+ i 1) (string-length tn))) (else (loop (- i 1))))))
(register-instance-check-arm!
(lambda (type-sym val)
(let ((tn (class-short (symbol-t-name type-sym))))
(cond
;; a #inst / (Date.) is a java.util.Date; it is NOT a java.sql.Timestamp
;; (on the JVM a Date is not a Timestamp), so answer Timestamp explicitly #f.
((jinst? val) (cond ((string=? tn "Date") #t)
((string=? tn "Timestamp") #f)
(else 'pass)))
((and (jhost? val) (string=? (jhost-tag val) "instant")) (if (string=? tn "Instant") #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) (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))))
;; 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)))
;; 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)))
(register-host-methods! "instant"
(list (cons "atZone" (lambda (self zone) (mk-zoned (ms-of self))))
(cons "toEpochMilli" (lambda (self) (ms-of self)))
(cons "toString" (lambda (self) (inst-rfc3339 (make-jinst (ms-of self)))))))
(register-host-methods! "zoned-dt"
(list (cons "toLocalDateTime" (lambda (self) (mk-local (ms-of self))))
(cons "toInstant" (lambda (self) (mk-instant (ms-of self))))))
;; 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) (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
'((date . ((short . "M/d/yy") (medium . "MMM d, yyyy") (long . "MMMM d, yyyy") (full . "EEEE, MMMM d, yyyy")))
(time . ((short . "h:mm a") (medium . "h:mm:ss a") (long . "h:mm:ss a") (full . "h:mm:ss a")))
(datetime . ((short . "M/d/yy, h:mm a") (medium . "MMM d, yyyy, h:mm:ss a")
(long . "MMMM d, yyyy, h:mm:ss a") (full . "EEEE, MMMM d, yyyy, h:mm:ss a")))))
(define (style-of fs) (vector-ref (jhost-state fs) 0)) ; a symbol: short/medium/long/full
(define (style-fmt kind fs)
(mk-formatter (or (let ((row (assq kind style-patterns))) (and row (let ((e (assq (style-of fs) (cdr row)))) (and e (cdr e)))))
"yyyy-MM-dd HH:mm:ss")))
(register-class-statics! "FormatStyle"
(list (cons "SHORT" (make-jhost "format-style" (vector 'short)))
(cons "MEDIUM" (make-jhost "format-style" (vector 'medium)))
(cons "LONG" (make-jhost "format-style" (vector 'long)))
(cons "FULL" (make-jhost "format-style" (vector 'full)))))
(register-class-statics! "DateTimeFormatter"
(list (cons "ofPattern" (lambda (p . _) (mk-formatter p)))
(cons "ISO_LOCAL_DATE" (mk-formatter "yyyy-MM-dd"))
(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)))))
(register-class-statics! "Instant"
(list (cons "ofEpochMilli" (lambda (ms) (mk-instant (ms->exact ms))))
(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)))))))
;; 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))))
;; 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))
(register-class-statics! "Locale"
(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)
(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)
;; 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) (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) (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).
(define (timezone-of id) (make-jhost "timezone" (vector (if (string? id) id (jolt-str-render-one id)))))
(define timezone-statics
(list (cons "getTimeZone" timezone-of)
(cons "getDefault" (lambda () (timezone-of "default")))))
(register-class-statics! "TimeZone" timezone-statics)
(register-class-statics! "java.util.TimeZone" timezone-statics)
;; java.text.SimpleDateFormat: holds a pattern; .setTimeZone is accepted (format-ms
;; is UTC); .format(date) renders the date per the pattern via the format-ms engine.
(define (sdf-ctor pat . _) (make-jhost "sdf" (vector (if (string? pat) pat (jolt-str-render-one pat)))))
(register-class-ctor! "SimpleDateFormat" sdf-ctor)
(register-class-ctor! "java.text.SimpleDateFormat" sdf-ctor)
(register-host-methods! "sdf"
(list (cons "setTimeZone" (lambda (self tz) jolt-nil))
(cons "setLenient" (lambda (self b) jolt-nil))
(cons "applyPattern" (lambda (self p) (vector-set! (jhost-state self) 0 (jolt-str-render-one p)) jolt-nil))
(cons "toPattern" (lambda (self) (vector-ref (jhost-state self) 0)))
(cons "parse" (lambda (self s) (parse-ms (vector-ref (jhost-state self) 0) (jolt-str-render-one s))))
(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).
(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-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)))
(jinst? (car (seq->list rest-args)))
(= (jinst-ms obj) (jinst-ms (car (seq->list rest-args))))))
((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 '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.
;; Keyed by symbol, like Clojure. *data-readers* is the bindable user table.
(def-var! "clojure.core" "default-data-readers"
(jolt-hash-map (jolt-symbol #f "inst") jolt-inst-from-string
(jolt-symbol #f "uuid") jolt-uuid-from-string))
(def-var! "clojure.core" "*data-readers*" empty-pmap)

View file

@ -1,333 +0,0 @@
;; 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

@ -1,760 +0,0 @@
;; java.io.File + host file I/O, implemented over Chez's filesystem
;; primitives. A File is a
;; path-backed jfile record: (instance? java.io.File f) is true, str/slurp coerce
;; it to its path, and the File method surface (getName/getPath/exists/
;; isDirectory/isFile/listFiles) dispatches through record-method-dispatch.
;;
;; Provides make-file/file?/slurp/spit/flush/dir?/
;; list-dir for the overlay file-seq (20-coll.clj), which calls __file?/__dir?/
;; __list-dir + the .isDirectory/.listFiles/.isFile method surface.
;;
;; Loaded LAST in rt.ss, after
;; dot-forms.ss (so the jfile method arm wraps the fully-built dispatch) and
;; natives-meta.ss / records.ss / printing.ss (jolt-type / instance-check /
;; jolt-str-render-one, which it extends).
(define-record-type jfile (fields path) (nongenerative jolt-jfile-v1))
(define (jolt-file? x) (jfile? x))
;; path string of any value: a jfile -> its path, else its str rendering.
(define (file-path-of x) (if (jfile? x) (jfile-path x) (jolt-str-render-one x)))
;; Resources baked into a standalone binary by `jolt build` (deps.edn
;; :jolt/build :embed). The build emits a register-embedded-resource! per file at
;; heap-build time, so the contents live in the boot image — io/resource serves
;; them with no file on disk. An embedded hit reads through slurp/reader exactly
;; like a jfile would.
(define embedded-resources (make-hashtable equal-hash equal?))
(define (register-embedded-resource! name content)
(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
;; isn't routed through here.)
(define (project-relative p)
(if (or (= (string-length p) 0) (char=? (string-ref p 0) #\/))
p
(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 "/". 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 (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)))
(cond ((< i 0) p)
((char=? (string-ref p i) #\/) (substring p (+ i 1) (string-length p)))
(else (loop (- i 1))))))
;; directory children as full paths, sorted (the __list-dir seed primitive).
(define (jolt-list-dir 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? (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.
(define (make-url spec) (make-jhost "url" (vector spec)))
(define (url-spec u) (vector-ref (jhost-state u) 0))
(define (url-strip-scheme spec)
(if (and (>= (string-length spec) 5) (string=? (substring spec 0 5) "file:"))
(substring spec 5 (string-length spec)) spec))
(define (url-protocol spec)
(let ((i (let loop ((j 0)) (cond ((>= j (string-length spec)) #f)
((char=? (string-ref spec j) #\:) j) (else (loop (+ j 1)))))))
(if i (substring spec 0 i) "")))
;; (java.net.URL. spec) — a basic file/http URL value (a library may register a
;; richer URL shim, which overrides this).
(register-class-ctor! "URL" (lambda (spec . _) (make-url (jolt-str-render-one spec))))
(register-class-ctor! "java.net.URL" (lambda (spec . _) (make-url (jolt-str-render-one spec))))
(register-host-methods! "url"
(list (cons "toString" (lambda (self) (url-spec self)))
(cons "toExternalForm" (lambda (self) (url-spec self)))
(cons "getProtocol" (lambda (self) (url-protocol (url-spec self))))
(cons "getPath" (lambda (self) (url-strip-scheme (url-spec self))))
(cons "getFile" (lambda (self) (url-strip-scheme (url-spec self))))))
;; --- 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)) ; 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 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 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))
((char=? (string-ref p i) #\/) (list (if (= i 0) "/" (substring p 0 i))))
(else (loop (- i 1))))))
(else #f))))
(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)))
'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
;; so file-seq's File branch works.
(define %io-host-call jolt-host-call)
(set! jolt-host-call
(lambda (method target . args)
(cond
((and (jfile? target) (string=? method "isDirectory"))
(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)))))
;; --- slurp / spit / flush ---------------------------------------------------
(define (read-file-string path)
(let ((p (open-input-file path)))
(let ((s (get-string-all p))) (close-port p) (if (eof-object? s) "" s))))
;; Drain a jhost reader (StringReader / PushbackReader): read code units from the
;; current position to EOF (-1) and assemble the string. Used by slurp; advances
;; the reader, as on the JVM.
(define (drain-reader r)
(let loop ((acc '()))
(let ((u (record-method-dispatch r "read" jolt-nil)))
(if (or (jolt-nil? u) (and (number? u) (< u 0)))
(list->string (reverse acc))
(loop (cons (integer->char (exact (truncate u))) acc))))))
(define (reader-jhost? x)
(and (jhost? x) (member (jhost-tag x) '("string-reader" "pushback-reader"))))
;; Refill a host reader so subsequent read/slurp see `s` (the unconsumed tail).
(define (reader-refill! r s)
(cond
((string=? (jhost-tag r) "string-reader")
(vector-set! (jhost-state r) 0 s) (vector-set! (jhost-state r) 1 0))
((string=? (jhost-tag r) "pushback-reader")
(vector-set! (jhost-state r) 0 (host-new "StringReader" s))
(vector-set! (jhost-state r) 1 '()))))
;; Read ONE form from a host reader (StringReader/PushbackReader): drain the
;; remaining chars, parse one form, push the tail back. -> (values form found?).
;; (read r) over a java.io reader — cuerdas' interpolation reads this way.
(define (host-reader-read-form r)
(let* ((s (drain-reader r)) (pr (jolt-parse-next s)))
(if (jolt-nil? pr)
(begin (reader-refill! r "") (values jolt-nil #f))
(begin (reader-refill! r (jolt-nth pr 1)) (values (jolt-nth pr 0) #t)))))
;; clojure.edn/read over a reader: drain the jhost reader to a string and read the
;; first EDN form (read-string). Re-asserted over the prelude in post-prelude.ss.
(define (chez-edn-read reader)
(jolt-invoke (var-deref "clojure.core" "read-string")
(if (reader-jhost? reader) (drain-reader reader) (jolt-str-render-one reader))))
;; line-seq: an io/reader is a jhost StringReader. Drain it (or take a string)
;; and split on newline; a trailing newline does NOT yield a final empty line
;; (like readLine -> nil at EOF). Re-asserted in post-prelude.ss.
(define (chez-lines s)
(let loop ((cs (string->list s)) (cur '()) (acc '()))
(cond ((null? cs) (reverse (if (null? cur) acc (cons (list->string (reverse cur)) acc))))
((char=? (car cs) #\newline) (loop (cdr cs) '() (cons (list->string (reverse cur)) acc)))
(else (loop (cdr cs) (cons (car cs) cur) acc)))))
(define (chez-line-seq rdr)
(list->cseq (chez-lines (cond ((string? rdr) rdr)
((reader-jhost? rdr) (drain-reader rdr))
(else (jolt-str-render-one rdr))))))
;; (slurp src :encoding "...") — pull the charset from the trailing kwargs.
(define (slurp-encoding opts)
(let loop ((o opts))
(cond ((or (null? o) (null? (cdr o))) '())
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "encoding"))
(list (jolt-str-render-one (cadr o))))
(else (loop (cddr o))))))
;; drain a byte input-stream shim (tagged-table) one byte at a time to a bytevector.
(define (drain-byte-stream src)
(let loop ((acc '()))
(let ((b (record-method-dispatch src "read" jolt-nil)))
(if (or (jolt-nil? b) (and (number? b) (< b 0)))
(u8-list->bytevector (reverse acc))
(loop (cons (bitwise-and (jnum->exact b) #xff) acc))))))
(define (jolt-slurp src . opts)
(cond
((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
;; default). clj-http-lite slurps response-body byte arrays.
((bytevector? src) (decode-bytevector src (slurp-encoding opts)))
((and (jolt-array? src) (eq? (jolt-array-kind src) 'byte))
(decode-bytevector (na-bytearray->bv src) (slurp-encoding opts)))
;; a byte input-stream shim (e.g. clj-http-lite's :as :stream body): drain it.
((and (htable? src) (jolt-truthy? (jolt-ref-get src (keyword "jolt" "input-stream"))))
(decode-bytevector (drain-byte-stream src) (slurp-encoding opts)))
((string? src) (read-file-string (project-relative src)))
(else (error #f "slurp: unsupported source" src))))
(define (spit-append? opts)
(let loop ((o opts))
(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))))))
(define (jolt-spit path content . opts)
(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)
jolt-nil))
(define (jolt-flush) (flush-output-port (current-output-port)) jolt-nil)
;; --- str / type / instance? integration ------------------------------------
;; str of a jfile is its path (Clojure's File.toString).
(register-str-render! jfile? jfile-path)
;; stdin line seam: the clojure.core *in* reader (50-io.clj) drives read-line /
;; read / read+string through __stdin-read-line. Return the next line (newline
;; stripped) or nil at EOF. Without this, (read-line) and the REPL call nil.
(def-var! "clojure.core" "__stdin-read-line"
(lambda () (let ((l (get-line (current-input-port)))) (if (eof-object? l) jolt-nil l))))
;; (type f) -> :jolt/file (the tagged-file :jolt/type). Re-def-var!
;; "type": natives-meta.ss already bound the var to the old jolt-type value, so the
;; set! alone (which updates the symbol for internal callers) wouldn't reach it.
(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))))
;; (instance? java.io.File f): the instance? macro passes the class-name symbol;
;; match "File" / "java.io.File" (and any *.File) against a jfile.
(register-instance-check-arm!
(lambda (type-sym val)
(let ((tname (symbol-t-name type-sym)))
(if (and (jfile? val)
(or (string=? tname "File") (string=? tname "java.io.File")
(string=? (path-last-segment tname) "File")))
#t
'pass))))
;; --- def-var! the native names the overlay file-seq + str/slurp use ----
(def-var! "clojure.core" "__make-file" jolt-make-file)
(def-var! "clojure.core" "__file?" jolt-file?)
(def-var! "clojure.core" "__dir?" jolt-dir?)
(def-var! "clojure.core" "__list-dir" (lambda (p) (list->cseq (jolt-list-dir p))))
(def-var! "clojure.core" "slurp" jolt-slurp)
(def-var! "clojure.core" "spit" jolt-spit)
(def-var! "clojure.core" "flush" jolt-flush)
;; --- with-open's close seam (__close): a map-like value closes via its :close
;; fn; a jhost reader/writer/file via its .close method (a no-op here); anything
;; else is an error.
(define (jolt-close x)
(cond
((jolt-nil? x) jolt-nil)
((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))
(begin (jolt-invoke closef) jolt-nil)
(error #f "with-open: don't know how to close" x))))))
(def-var! "clojure.core" "__close" jolt-close)
;; --- clojure.java.io/reader: an in-memory java.io.Reader over the source. An
;; existing reader passes through; a File / path / URL is slurped; a char[] (or
;; any seq) becomes a reader over (apply str …). Mirrors io.clj's reader. Returns
;; 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-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)))))
((string? x) (host-new "StringReader" (read-file-string (project-relative x))))
((or (cseq? x) (empty-list-t? x) (pvec? x))
(host-new "StringReader" (seq-source->string x)))
(else (host-new "StringReader" (jolt-str-render-one x)))))
;; --- clojure.java.io/writer: an existing writer passes through; a File / path
;; gets a file-backed writer (host-static.ss "file-writer") that persists on
;; flush/close. Mirrors io.clj's writer over the host's StringWriter/file ports.
(define (jolt-io-writer x)
(cond
((and (jhost? x) (string=? (jhost-tag x) "writer")) x)
((and (jhost? x) (string=? (jhost-tag x) "file-writer")) x)
((jfile? x) (make-jhost "file-writer" (vector (jfile-path x) "")))
((string? x) (make-jhost "file-writer" (vector x "")))
(else (error #f "io/writer: don't know how to create a writer from" x))))
;; --- clojure.java.io ns -----------------------------------------------------
(def-var! "clojure.java.io" "file" jolt-make-file)
(def-var! "clojure.java.io" "as-file" (lambda (x) (if (jfile? x) x (make-jfile (file-path-of x)))))
;; "reader" is bound by natives-array.ss (loaded later) so a char[] argument is
;; handled; that binding delegates here via jolt-io-reader for everything else.
(def-var! "clojure.java.io" "writer" jolt-io-writer)
(def-var! "clojure.java.io" "input-stream" jolt-io-reader)
(def-var! "clojure.java.io" "output-stream" jolt-io-writer)
;; resource: jolt has no classpath, so a named resource is resolved against the
;; loader's source roots (a project's :paths, e.g. "resources"). Returns a File
;; (slurp/reader-able) for the first match, else nil. get-source-roots is the
;; loader's accessor (loader.ss), resolved at call time — the runtime CLI loads it.
(define (jolt-io-resource name)
(let* ((nm (jolt-str-render-one name))
(emb (hashtable-ref embedded-resources nm #f)))
(if emb (make-embedded-res nm emb)
(let loop ((roots (get-source-roots)))
(cond ((null? roots) jolt-nil)
((file-exists? (string-append (car roots) "/" nm)) (make-jfile (string-append (car roots) "/" nm)))
(else (loop (cdr roots))))))))
(def-var! "clojure.java.io" "resource" jolt-io-resource)
;; as-url honors a library-registered URL class (e.g. jolt-lang/http-client's full
;; java.net.URL shim) so io/as-url and (URL. spec) agree; else the file-only jhost.
(def-var! "clojure.java.io" "as-url"
(lambda (x)
(cond ((and (jhost? x) (string=? (jhost-tag x) "url")) x)
((htable? x) x)
(else (let ((ctor (lookup-class class-ctors-tbl "URL")))
(if ctor (ctor (jolt-str-render-one x)) (make-url (jolt-str-render-one x))))))))
;; --- java.lang.ClassLoader --------------------------------------------------
;; jolt has no classpath; a "classloader" resolves a named resource against the
;; loader's source roots (the same model as clojure.java.io/resource), returning a
;; file: URL or nil. getSystemClassLoader / a thread's contextClassLoader both hand
;; back this loader. Libraries that probe the classpath (e.g. migratus's migration-
;; dir discovery) then fall back to the filesystem when a resource isn't a root.
(define the-classloader (make-jhost "classloader" (vector)))
(define (cl-get-resource self name)
(let ((nm (jolt-str-render-one name)))
(let loop ((roots (get-source-roots)))
(cond ((null? roots) jolt-nil)
((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
;; clearing (instance semantics; the static Thread/interrupted reads-and-clears).
;; getContextClassLoader hands back the loader.
(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))
(cons "isInterrupted" (lambda (self)
(and (box? (jhost-state self)) (unbox (jhost-state self)) #t)))))
(define (current-thread-handle) (make-jhost "thread" (current-interrupt-box)))
(register-class-statics! "Thread" (list (cons "currentThread" current-thread-handle)))
(register-class-statics! "java.lang.Thread" (list (cons "currentThread" current-thread-handle)))
;; --- java.io.File / java.util.UUID constructors -----------------------------
;; (java.io.File. parent child) joins with "/"; (File. path) wraps the path.
(register-class-ctor! "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))))
;; 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)))
(cons "fromString" (lambda (s) (jolt-parse-uuid (jolt-str-render-one s))))))
(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))))))
;; (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,
;; kept in a jhost "uri" carrying the original string. (str u)/(.toString u) give
;; the original; getHost is nil for a relative URI (hiccup.util/to-str branches on
;; it). instance? java.net.URI + extend-protocol dispatch work via value-host-tags.
(define (uri-index-of s ch from)
(let ((n (string-length s)))
(let loop ((i from)) (cond ((>= i n) #f) ((char=? (string-ref s i) ch) i) (else (loop (+ i 1)))))))
(define (uri-scheme-end s)
;; index of ':' that ends a scheme (letter then alnum/+-. before any /?#), or #f.
(let ((n (string-length s)))
(and (> n 0) (char-alphabetic? (string-ref s 0))
(let loop ((i 1))
(cond ((>= i n) #f)
((char=? (string-ref s i) #\:) i)
((let ((c (string-ref s i)))
(or (char-alphabetic? c) (char-numeric? c) (char=? c #\+) (char=? c #\-) (char=? c #\.)))
(loop (+ i 1)))
(else #f))))))
(define (uri-parse s)
(let* ((n (string-length s))
(se (uri-scheme-end s))
(scheme (and se (substring s 0 se)))
(rest-start (if se (+ se 1) 0))
;; fragment
(hash (uri-index-of s #\# rest-start))
(frag (and hash (substring s (+ hash 1) n)))
(pre-frag-end (or hash n))
;; query
(qm (uri-index-of s #\? rest-start))
(query (and qm (< qm pre-frag-end) (substring s (+ qm 1) pre-frag-end)))
(hp-end (cond ((and qm (< qm pre-frag-end)) qm) (else pre-frag-end)))
;; authority (after "//")
(has-auth (and (<= (+ rest-start 2) n)
(char=? (string-ref s rest-start) #\/)
(char=? (string-ref s (+ rest-start 1)) #\/)))
(auth-start (and has-auth (+ rest-start 2)))
(auth-end (and has-auth
(let loop ((i auth-start))
(cond ((>= i hp-end) hp-end)
((char=? (string-ref s i) #\/) i)
(else (loop (+ i 1)))))))
(authority (and has-auth (substring s auth-start auth-end)))
(path-start (if has-auth auth-end rest-start))
(path (substring s path-start hp-end)))
;; host:port from authority (strip userinfo@)
(let* ((at (and authority (uri-index-of authority #\@ 0)))
(hostport (if at (substring authority (+ at 1) (string-length authority)) authority))
(colon (and hostport (uri-index-of hostport #\: 0)))
(host (cond ((not hostport) jolt-nil)
(colon (substring hostport 0 colon))
(else hostport)))
(port (if (and colon (< (+ colon 1) (string-length hostport)))
(or (string->number (substring hostport (+ colon 1) (string-length hostport))) -1)
-1)))
(make-jhost "uri"
(list (cons 'string s)
(cons 'scheme (or scheme jolt-nil))
(cons 'authority (or authority jolt-nil))
(cons 'host (if (and host (string? host) (= 0 (string-length host))) jolt-nil host))
(cons 'port (->num port))
(cons 'path (if (= 0 (string-length path)) (if has-auth "" jolt-nil) path))
(cons 'query (or query jolt-nil))
(cons 'fragment (or frag jolt-nil)))))))
(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)))
(cons "getScheme" (lambda (u) (uri-field u 'scheme)))
(cons "getAuthority" (lambda (u) (uri-field u 'authority)))
(cons "getHost" (lambda (u) (uri-field u 'host)))
(cons "getPort" (lambda (u) (uri-field u 'port)))
(cons "getPath" (lambda (u) (uri-field u 'path)))
(cons "getRawPath" (lambda (u) (uri-field u 'path)))
(cons "getQuery" (lambda (u) (uri-field u 'query)))
(cons "getRawQuery" (lambda (u) (uri-field u 'query)))
(cons "getFragment" (lambda (u) (uri-field u 'fragment)))
(cons "isAbsolute" (lambda (u) (not (jolt-nil? (uri-field u 'scheme)))))
(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)))
(register-pr-readable-arm! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "uri")))
(lambda (x) (string-append "#object[java.net.URI \"" (uri-field x 'string) "\"]")))
;; class of the host value types defined by now (uri/uuid/file).
(register-class-arm! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "uri"))) (lambda (x) "java.net.URI"))
(register-class-arm! juuid? (lambda (x) "java.util.UUID"))
(register-class-arm! jfile? (lambda (x) "java.io.File"))

File diff suppressed because it is too large Load diff

View file

@ -1,67 +0,0 @@
;; clojure.math — host shim over native flonum math.
;;
;; clojure.math is registered as native bindings, NOT a .clj file — so there's no
;; source tier to emit. The def-var! shims here back each clojure.math fn over
;; Chez's native procedures. The analyzer knows the clojure.math ns exists, so a
;; ref like clojure.math/sqrt lowers to a var-deref; these cells back it at
;; runtime.
;;
;; jolt is all-flonum, so every result is a flonum (inputs arrive as flonums; Chez
;; sqrt/sin/expt/... return flonums for flonum args). Semantics match
;; Clojure 1.11 clojure.math: round = floor(x+0.5), rint = round-half-even,
;; floor/ceil/floor-div return doubles, to-degrees/to-radians via PI.
(define jolt-math-pi (acos -1.0))
(define jolt-math-e (exp 1.0))
(define (jolt-math-cbrt x)
;; sign-aware so negative inputs stay real (expt of a negative flonum to a
;; fractional power goes complex).
(if (< x 0.0)
(- (expt (- x) (/ 1.0 3.0)))
(expt x (/ 1.0 3.0))))
;; clojure.math/round returns a long (exact); floor/ceil/signum/rint return doubles.
(define (jolt-math-round x) (exact (floor (+ x 0.5))))
(define (jolt-math-signum x) (cond ((< x 0.0) -1.0) ((> x 0.0) 1.0) (else 0.0)))
(define (jolt-math-to-degrees r) (/ (* r 180.0) jolt-math-pi))
(define (jolt-math-to-radians d) (/ (* d jolt-math-pi) 180.0))
(define (jolt-math-hypot a b) (sqrt (+ (* a a) (* b b))))
(define (jolt-math-floor-div a b) (floor (/ a b)))
(define (jolt-math-floor-mod a b) (- a (* b (floor (/ a b)))))
;; clojure.math fns always return a DOUBLE; Chez's sqrt/expt/sin/floor/... return
;; EXACT for exact args ((sqrt 9) -> 3, (sin 0) -> 0), so coerce.
(define (m1 f) (lambda (x) (exact->inexact (f x))))
(define (m2 f) (lambda (a b) (exact->inexact (f a b))))
(def-var! "clojure.math" "sqrt" (m1 sqrt))
(def-var! "clojure.math" "cbrt" jolt-math-cbrt)
(def-var! "clojure.math" "pow" (m2 expt))
(def-var! "clojure.math" "exp" (m1 exp))
(def-var! "clojure.math" "expm1" (lambda (x) (- (exp x) 1.0)))
(def-var! "clojure.math" "log" (m1 log))
(def-var! "clojure.math" "log10" (lambda (x) (exact->inexact (log x 10.0))))
(def-var! "clojure.math" "log1p" (lambda (x) (log (+ 1.0 x))))
(def-var! "clojure.math" "sin" (m1 sin))
(def-var! "clojure.math" "cos" (m1 cos))
(def-var! "clojure.math" "tan" (m1 tan))
(def-var! "clojure.math" "asin" (m1 asin))
(def-var! "clojure.math" "acos" (m1 acos))
(def-var! "clojure.math" "atan" (m1 atan))
;; clojure.math/atan2 is atan2(y, x); Chez's 2-arg atan is (atan y x).
(def-var! "clojure.math" "atan2" (lambda (y x) (exact->inexact (atan y x))))
(def-var! "clojure.math" "sinh" (m1 sinh))
(def-var! "clojure.math" "cosh" (m1 cosh))
(def-var! "clojure.math" "tanh" (m1 tanh))
(def-var! "clojure.math" "floor" (m1 floor))
(def-var! "clojure.math" "ceil" (m1 ceiling))
(def-var! "clojure.math" "rint" (m1 round))
(def-var! "clojure.math" "round" jolt-math-round)
(def-var! "clojure.math" "signum" jolt-math-signum)
(def-var! "clojure.math" "to-degrees" jolt-math-to-degrees)
(def-var! "clojure.math" "to-radians" jolt-math-to-radians)
(def-var! "clojure.math" "hypot" jolt-math-hypot)
(def-var! "clojure.math" "floor-div" jolt-math-floor-div)
(def-var! "clojure.math" "floor-mod" jolt-math-floor-mod)
(def-var! "clojure.math" "E" jolt-math-e)
(def-var! "clojure.math" "PI" jolt-math-pi)

View file

@ -1,210 +0,0 @@
;; natives-array.ss — Java-style mutable arrays for the Chez host.
;;
;; A jolt-array wraps a Chez mutable vector + a `kind` tag (for bytes?). The array
;; CONSTRUCTORS are native (they build the backing); the overlay's aget/aset/alength
;; are pure over count / nth / jolt.host/ref-put!, so we extend those dispatchers
;; to see a jolt-array (backed by a Chez vector). Loaded after host-table.ss (ref-put!),
;; transients.ss, seq.ss (the dispatchers it chains).
(define-record-type jolt-array (fields (mutable vec) kind) (nongenerative jolt-array-v1))
;; JVM array class name per element kind ((class (int-array 3)) -> "[I", like the
;; JVM's Class.getName for arrays). Object arrays use the descriptor form.
(define (na-array-class-name arr)
(case (jolt-array-kind arr)
((int) "[I") ((long) "[J") ((short) "[S") ((double) "[D")
((float) "[F") ((boolean) "[Z") ((byte) "[B") ((char) "[C")
(else "[Ljava.lang.Object;")))
(define (na-idx i) (if (and (number? i) (not (exact? i))) (exact (floor i)) i))
(define (na-from-seq x kind) (make-jolt-array (list->vector (seq->list (jolt-seq x))) kind))
;; (T-array size) | (T-array size init) | (T-array seq)
(define (na-num-array a rest init kind)
(if (number? a)
(make-jolt-array (make-vector (exact (na-idx a)) (if (pair? rest) (car rest) init)) kind)
(na-from-seq a kind)))
;; numeric tower: array element defaults / masked bytes / count are
;; EXACT integers (= JVM byte/short/int), matching exact integer literals.
(define (na-byte-of v) (bitwise-and (exact (floor v)) #xff))
;; --- constructors -----------------------------------------------------------
(define (na-object-array a . rest) (na-num-array a rest jolt-nil 'object))
;; integer kinds default to exact 0 (JVM int/long/short 0 -> "0", not "0.0").
(define (na-int-array a . rest) (na-num-array a rest 0 'int))
(define (na-long-array a . rest) (na-num-array a rest 0 'long))
(define (na-short-array a . rest) (na-num-array a rest 0 'short))
(define (na-double-array a . rest) (na-num-array a rest 0.0 'double))
(define (na-float-array a . rest) (na-num-array a rest 0.0 'float))
(define (na-boolean-array a . rest) (na-num-array a rest #f 'boolean))
;; char-array is a real 'char array (instance? "[C"), seqing as chars via the
;; dispatchers below — io/reader (extended here) and str/slurp consume the seq.
(define (na-char-array a . rest)
(cond
((string? a) (make-jolt-array (list->vector (string->list a)) 'char))
((number? a) (make-jolt-array (make-vector (exact (na-idx a)) #\nul) 'char))
(else (make-jolt-array
(list->vector (map (lambda (c) (if (char? c) c (integer->char (exact (truncate c)))))
(seq->list (jolt-seq a)))) 'char))))
;; (byte-array n [init]) | (byte-array coll). Also coerces the host's OTHER byte
;; carrier — a Chez bytevector (what String/.getBytes produce) — and a string's
;; UTF-8 bytes, so bytevector and byte-array interconvert across interop seams.
(define (na-byte-array a . rest)
(cond
((number? a) (make-jolt-array (make-vector (exact (na-idx a)) (na-byte-of (if (pair? rest) (car rest) 0))) 'byte))
((bytevector? a) (make-jolt-array (list->vector (bytevector->u8-list a)) 'byte))
((string? a) (make-jolt-array (list->vector (bytevector->u8-list (string->utf8 a))) 'byte))
(else (make-jolt-array (list->vector (map na-byte-of (seq->list (jolt-seq a)))) 'byte))))
;; jolt byte-array -> Chez bytevector (for String decode / utf8->string).
(define (na-bytearray->bv arr)
(let* ((v (jolt-array-vec arr)) (n (vector-length v)) (bv (make-bytevector n)))
(do ((i 0 (+ i 1))) ((= i n)) (bytevector-u8-set! bv i (bitwise-and (exact (vector-ref v i)) #xff)))
bv))
(define (na-make-array a . rest) ; (make-array len) | (make-array type len ...)
(make-jolt-array (make-vector (exact (na-idx (if (number? a) a (car rest)))) jolt-nil) 'object))
(define (na-into-array a . rest) (na-from-seq (if (pair? rest) (car rest) a) 'object))
(define (na-to-array coll) (na-from-seq coll 'object))
(define (na-aclone arr)
(if (jolt-array? arr)
(make-jolt-array (vector-copy (jolt-array-vec arr)) (jolt-array-kind arr))
(na-from-seq arr 'object)))
;; --- typed aset (return the stored value) -----------------------------------
(define (na-aset! arr i v) (vector-set! (jolt-array-vec arr) (exact (na-idx i)) v) v)
(define (na-aset-int arr i v) (na-aset! arr i v))
(define (na-aset-long arr i v) (na-aset! arr i v))
(define (na-aset-short arr i v) (na-aset! arr i v))
(define (na-aset-double arr i v) (na-aset! arr i v))
(define (na-aset-float arr i v) (na-aset! arr i v))
(define (na-aset-char arr i v) (na-aset! arr i v))
(define (na-aset-boolean arr i v) (na-aset! arr i v))
(define (na-aset-byte arr i v)
(vector-set! (jolt-array-vec arr) (exact (na-idx i)) (na-byte-of v)) v)
;; --- coercions (identity on arrays; byte/short are masked scalar casts) ------
(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) (jolt-byte-cast x))
(define (na-short x) (jolt-short-cast x))
;; --- chunked seqs -----------------------------------------------------------
;; 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) (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)
(set! jolt-count (lambda (c) (if (jolt-array? c) (vector-length (jolt-array-vec c)) (%na-count c))))
(define %na-seq jolt-seq)
(set! jolt-seq (lambda (c) (if (jolt-array? c) (list->cseq (vector->list (jolt-array-vec c))) (%na-seq c))))
(define %na-nth jolt-nth)
(set! jolt-nth
(case-lambda
((c i) (if (jolt-array? c) (vector-ref (jolt-array-vec c) (exact (na-idx i))) (%na-nth c i)))
((c i d) (if (jolt-array? c)
(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 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/
;; array-seq/vec already use the set!-extended globals; ref-put! is a host var
;; (var-deref'd), so re-assert its cell to the array-aware closure.
(define %na-ref-put! jolt-ref-put!)
(set! jolt-ref-put!
(lambda (t k v)
(if (jolt-array? t) (begin (vector-set! (jolt-array-vec t) (exact (na-idx k)) v) t)
(%na-ref-put! t k v))))
(def-var! "jolt.host" "ref-put!" jolt-ref-put!)
;; --- array identity: type / class / instance? recognize arrays ---------------
;; (type arr) / (class arr) -> the JVM array class name; (class …) delegates to
;; (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))))
;; 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
;; (non-array string tokens are already normalized to symbols there); decide it
;; here, deferring everything else.
(register-instance-check-arm!
(lambda (type-sym val)
(let ((tname (cond ((string? type-sym) type-sym)
((symbol-t? type-sym) (symbol-t-name type-sym))
(else #f))))
(if (and tname (> (string-length tname) 0) (char=? (string-ref tname 0) #\[))
(and (jolt-array? val) (string=? (na-array-class-name val) tname))
'pass))))
;; clojure.java.io/reader over a char-array reads its chars (the JVM char[] branch).
(def-var! "clojure.java.io" "reader"
(lambda (x)
(if (jolt-array? x)
(host-new "StringReader"
(apply string-append (map jolt-str-render-one (seq->list (jolt-seq x)))))
(jolt-io-reader x))))
;; --- bind into clojure.core -------------------------------------------------
(for-each (lambda (p) (def-var! "clojure.core" (car p) (cdr p)))
(list
(cons "object-array" na-object-array) (cons "int-array" na-int-array)
(cons "long-array" na-long-array) (cons "short-array" na-short-array)
(cons "double-array" na-double-array) (cons "float-array" na-float-array)
(cons "boolean-array" na-boolean-array)
(cons "byte-array" na-byte-array) (cons "char-array" na-char-array)
(cons "array?" (lambda (x) (jolt-array? x)))
(cons "make-array" na-make-array)
(cons "into-array" na-into-array) (cons "to-array" na-to-array) (cons "aclone" na-aclone)
(cons "aset-int" na-aset-int) (cons "aset-long" na-aset-long)
(cons "aset-short" na-aset-short) (cons "aset-double" na-aset-double)
(cons "aset-float" na-aset-float) (cons "aset-char" na-aset-char)
(cons "aset-boolean" na-aset-boolean) (cons "aset-byte" na-aset-byte)
(cons "bytes" na-bytes) (cons "bytes?" na-bytes?)
(cons "booleans" na-identity) (cons "ints" na-identity) (cons "longs" na-identity)
(cons "shorts" na-identity) (cons "doubles" na-identity) (cons "floats" na-identity)
(cons "chars" na-identity) (cons "byte" na-byte) (cons "short" na-short)
(cons "chunk-buffer" na-chunk-buffer) (cons "chunk-append" na-chunk-append)
(cons "chunk" na-chunk) (cons "chunk-cons" na-chunk-cons)
(cons "chunk-first" na-chunk-first) (cons "chunk-rest" na-chunk-rest)
(cons "chunk-next" na-chunk-next) (cons "chunked-seq?" na-chunked-seq?)))
;; --- clojure.java.io/copy ---------------------------------------------------
;; Copy src -> dst, JVM-style. Raw bytes (byte-array / bytevector / string) and a
;; jhost reader write in one shot; any other source (a stream shim with a .read
;; method, e.g. jolt-lang/http-client's ByteArrayInputStream) drains via .read
;; into a byte-array buffer and .write to dst — both reached through method
;; dispatch, so a library's tagged-table streams work without the host knowing
;; their layout. Lives here (not io.ss) because io.ss loads before byte-array.
(define (jolt-io-copy src dst . _opts)
(define (write-all! bytes)
(record-method-dispatch dst "write" (list->cseq (list bytes 0 (vector-length (jolt-array-vec bytes))))))
(cond
((or (bytevector? src) (string? src)
(and (jolt-array? src) (eq? (jolt-array-kind src) 'byte)))
(write-all! (na-byte-array src)))
((and (jhost? src) (member (jhost-tag src) '("string-reader" "pushback-reader")))
(write-all! (na-byte-array (drain-reader src))))
(else
(let ((buf (na-byte-array 8192)))
(let loop ()
(let ((n (record-method-dispatch src "read" (list->cseq (list buf 0 8192)))))
(when (and (number? n) (> (jnum->exact n) 0))
(record-method-dispatch dst "write" (list->cseq (list buf 0 n)))
(loop)))))))
jolt-nil)
(def-var! "clojure.java.io" "copy" jolt-io-copy)

View file

@ -1,69 +0,0 @@
;; natives-queue.ss — clojure.lang.PersistentQueue for the Chez host.
;;
;; A functional queue: a `front` Scheme list (the dequeue end, head = front of the
;; queue) + a reversed `rear` Scheme list (the enqueue end, head = most recent).
;; conj adds to rear; peek/first read front; pop drops the front, rebalancing
;; rear->front when front empties — amortized O(1). A queue is jolt-sequential?, so
;; seq=?/seq-hash give cross-type equality (= [1 2 3] (queue 1 2 3)) for free, like
;; the JVM. Loaded after seq/collections/lazy-bridge/records/host-table so every
;; dispatcher it chains is at its latest binding.
(define-record-type jolt-queue (fields front rear cnt) (nongenerative jolt-queue-v1))
(define jolt-queue-empty (make-jolt-queue '() '() 0))
(define (queue-conj q x)
(if (null? (jolt-queue-front q))
(make-jolt-queue (list x) '() (fx+ (jolt-queue-cnt q) 1))
(make-jolt-queue (jolt-queue-front q) (cons x (jolt-queue-rear q)) (fx+ (jolt-queue-cnt q) 1))))
(define (queue->list q) (append (jolt-queue-front q) (reverse (jolt-queue-rear q))))
(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)))
;; 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))))))
;; --- extend the collection dispatchers to see a jolt-queue ------------------
(define %q-seq jolt-seq)
(set! jolt-seq (lambda (x) (if (jolt-queue? x)
(let ((l (queue->list x))) (if (null? l) jolt-nil (list->cseq l)))
(%q-seq x))))
(define %q-count jolt-count)
(set! jolt-count (lambda (x) (if (jolt-queue? x) (jolt-queue-cnt x) (%q-count x))))
(define %q-empty? jolt-empty?)
(set! jolt-empty? (lambda (x) (if (jolt-queue? x) (fx=? 0 (jolt-queue-cnt x)) (%q-empty? x))))
(define %q-peek jolt-peek)
(set! jolt-peek (lambda (x) (if (jolt-queue? x) (queue-peek x) (%q-peek x))))
(define %q-pop jolt-pop)
(set! jolt-pop (lambda (x) (if (jolt-queue? x) (queue-pop x) (%q-pop x))))
(define %q-conj1 jolt-conj1)
(set! jolt-conj1 (lambda (coll x) (if (jolt-queue? coll) (queue-conj coll x) (%q-conj1 coll x))))
;; sequential => seq=?/seq-hash handle queue equality + hashing.
(define %q-sequential? jolt-sequential?)
(set! jolt-sequential? (lambda (x) (or (jolt-queue? x) (%q-sequential? x))))
;; printing: render the elements as a parenthesized list (delegate to the seq path).
(define (jolt-seq-or-empty x) (let ((s (jolt-seq x))) (if (jolt-nil? s) jolt-empty-list s)))
(register-pr-readable-arm! jolt-queue? (lambda (x) (jolt-pr-readable (jolt-seq-or-empty x))))
(register-str-render! jolt-queue? (lambda (x) (jolt-str-render-one (jolt-seq-or-empty x))))
;; class / type / instance? recognize a queue.
(register-class-arm! jolt-queue? (lambda (x) "clojure.lang.PersistentQueue"))
(register-instance-check-arm!
(lambda (type-sym val)
(if (jolt-queue? val)
(let ((tn (cond ((string? type-sym) type-sym)
((symbol-t? type-sym) (symbol-t-name type-sym)) (else ""))))
(and (member (last-dot tn)
'("PersistentQueue" "IPersistentCollection" "Sequential" "Collection" "Object"))
#t))
'pass)))
;; clojure.lang.PersistentQueue/EMPTY + a queue? predicate.
(register-class-statics! "PersistentQueue" (list (cons "EMPTY" jolt-queue-empty)))
(register-class-statics! "clojure.lang.PersistentQueue" (list (cons "EMPTY" jolt-queue-empty)))
(def-var! "clojure.core" "queue?" (lambda (x) (jolt-queue? x)))
;; the FQ class token self-evaluates (for (instance? clojure.lang.PersistentQueue …)).
(def-var! "clojure.core" "clojure.lang.PersistentQueue" "clojure.lang.PersistentQueue")

View file

@ -1,400 +0,0 @@
;; natives-str.ss — java.lang.String method interop on Chez.
;;
;; (.method s arg*) on a string target lowers to record-method-dispatch (emit.ss),
;; which falls through to jolt-string-method here when the target is a string.
;; Covers the
;; portable java.lang.String/CharSequence methods cljc libraries actually call.
;; Case mapping is ASCII (the whole engine is byte-oriented), indexOf returns -1
;; on miss as on the JVM, indices come in as flonums, char results are Scheme
;; chars, and numeric results are flonums to match jolt's number model.
;;
;; Loaded from rt.ss AFTER regex.ss (the regex methods reuse jolt-re-pattern /
;; regex-t-irx) and records.ss (which calls jolt-string-method).
;; --- ASCII case mapping (byte-oriented) -------
(define (ascii-up-char c)
(if (and (char<=? #\a c) (char<=? c #\z))
(integer->char (fx- (char->integer c) 32)) c))
(define (ascii-down-char c)
(if (and (char<=? #\A c) (char<=? c #\Z))
(integer->char (fx+ (char->integer c) 32)) c))
(define (ascii-string-up s) (list->string (map ascii-up-char (string->list s))))
(define (ascii-string-down s) (list->string (map ascii-down-char (string->list s))))
;; --- ASCII trim: drop leading/trailing chars with code <= space (JVM .trim) ---
(define (str-trim s)
(let ((len (string-length s)))
(let scan-l ((i 0))
(cond ((fx=? i len) "")
((char<=? (string-ref s i) #\space) (scan-l (fx+ i 1)))
(else (let scan-r ((j (fx- len 1)))
(if (char<=? (string-ref s j) #\space)
(scan-r (fx- j 1))
(substring s i (fx+ j 1)))))))))
(define (str-triml s)
(let ((len (string-length s)))
(let loop ((i 0))
(cond ((fx=? i len) "")
((char<=? (string-ref s i) #\space) (loop (fx+ i 1)))
(else (substring s i len))))))
(define (str-trimr s)
(let loop ((j (fx- (string-length s) 1)))
(cond ((fx<? j 0) "")
((char<=? (string-ref s j) #\space) (loop (fx- j 1)))
(else (substring s 0 (fx+ j 1))))))
;; --- substring search: first index of `needle` in `s` at/after `from`, or -1 --
(define (str-index-of s needle from)
(let ((nlen (string-length needle)) (slen (string-length s)))
(let loop ((i (max 0 from)))
(cond ((fx>? (fx+ i nlen) slen) -1)
((string=? (substring s i (fx+ i nlen)) needle) i)
(else (loop (fx+ i 1)))))))
(define (str-last-index-of s needle)
(let ((nlen (string-length needle)) (slen (string-length s)))
(let loop ((i (fx- slen nlen)) (found -1))
(cond ((fx<? i 0) found)
((string=? (substring s i (fx+ i nlen)) needle) i)
(else (loop (fx- i 1) found))))))
;; A needle arg: a char value -> its 1-char string; a number -> the char at that
;; code point (JVM treats an int arg to indexOf as a char code); else a string.
(define (str-needle x)
(cond ((char? x) (string x))
((number? x) (string (integer->char (exact (truncate x)))))
((string? x) x)
(else (jolt-str x))))
;; literal replace-all (JVM String.replace(CharSequence,CharSequence)).
(define (str-replace-literal s a b)
(let ((alen (string-length a)) (slen (string-length s)))
(if (fx=? alen 0) s
(let loop ((i 0) (acc '()))
(cond ((fx>? (fx+ i alen) slen)
(apply string-append (reverse (cons (substring s i slen) acc))))
((string=? (substring s i (fx+ i alen)) a)
(loop (fx+ i alen) (cons b acc)))
(else (loop (fx+ i 1) (cons (substring s i (fx+ i 1)) acc))))))))
;; A compiled irregex for a plain-string Java-regex pattern (or a jolt-regex).
(define (str-irx pat) (regex-t-irx (jolt-re-pattern pat)))
;; JVM String.split: split fully, then drop trailing empty strings.
(define (str-split-drop-trailing parts)
(let loop ((p (reverse parts)))
(if (and (pair? p) (string=? (car p) "")) (loop (cdr p)) (reverse p))))
;; Encode a string to bytes (a bytevector) under a named charset. UTF-8 default;
;; ISO-8859-1/latin1/ascii are one byte per char; UTF-16/UTF-32 via Chez's codecs
;; (plain "UTF-16" emits a big-endian BOM then BE, matching the JVM). Shared by
;; .getBytes and decode-bytevector (String.).
(define (charset-encode-bv s csname)
(let ((cs (ascii-string-down (if (string? csname) csname (jolt-str-render-one csname)))))
(cond
((or (string=? cs "utf-8") (string=? cs "utf8")) (string->utf8 s))
((member cs '("iso-8859-1" "latin1" "iso8859-1" "us-ascii" "ascii"))
(let* ((n (string-length s)) (bv (make-bytevector n)))
(do ((i 0 (+ i 1))) ((= i n) bv)
(bytevector-u8-set! bv i (bitwise-and (char->integer (string-ref s i)) #xff)))))
((string=? cs "utf-16be") (string->utf16 s (endianness big)))
((string=? cs "utf-16le") (string->utf16 s (endianness little)))
((or (string=? cs "utf-16") (string=? cs "utf16") (string=? cs "unicode"))
(let ((be (string->utf16 s (endianness big))))
(let* ((n (bytevector-length be)) (bv (make-bytevector (+ n 2))))
(bytevector-u8-set! bv 0 #xfe) (bytevector-u8-set! bv 1 #xff)
(bytevector-copy! be 0 bv 2 n) bv)))
((or (string=? cs "utf-32be") (string=? cs "utf-32") (string=? cs "utf32"))
(string->utf32 s (endianness big)))
((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))
((string=? method "length") (string-length s)) ; exact int (= JVM)
((string=? method "isEmpty") (fx=? (string-length s) 0))
((string=? method "charAt") (string-ref s (jolt->idx (arg 0))))
((string=? method "substring")
(substring s (jolt->idx (arg 0))
(if (fx>? (length rest) 1) (jolt->idx (arg 1)) (string-length s))))
((string=? method "indexOf")
(str-index-of s (str-needle (arg 0))
(if (fx>? (length rest) 1) (jolt->idx (arg 1)) 0)))
((string=? method "lastIndexOf")
(str-last-index-of s (str-needle (arg 0))))
((string=? method "startsWith")
(let ((p (arg 0))) (and (fx>=? (string-length s) (string-length p))
(string=? (substring s 0 (string-length p)) p))))
((string=? method "endsWith")
(let ((p (arg 0)) (slen (string-length s)))
(and (fx>=? slen (string-length p))
(string=? (substring s (fx- slen (string-length p)) slen) p))))
((string=? method "contains")
(fx>=? (str-index-of s (str-needle (arg 0)) 0) 0))
((string=? method "concat") (string-append s (arg 0)))
((string=? method "replace") (str-replace-literal s (str-needle (arg 0)) (str-needle (arg 1))))
((string=? method "equalsIgnoreCase")
(string=? (ascii-string-down s) (ascii-string-down (arg 0))))
((string=? method "compareTo")
(let ((o (arg 0))) (cond ((string<? s o) -1.0) ((string>? s o) 1.0) (else 0.0))))
((string=? method "getBytes")
;; (.getBytes s) / (.getBytes s charset) -> a jolt byte-array (seqable /
;; countable / alength-able, like (byte-array …)); the JVM returns byte[].
(na-byte-array
(charset-encode-bv s (if (null? rest)
"utf-8"
(if (string? (arg 0)) (arg 0) (jolt-str-render-one (arg 0)))))))
((string=? method "matches") (if (irregex-match (str-irx (arg 0)) s) #t #f))
((string=? method "replaceAll") (irregex-replace/all (str-irx (arg 0)) s (arg 1)))
((string=? method "replaceFirst") (irregex-replace (str-irx (arg 0)) s (arg 1)))
((string=? method "split")
(apply jolt-vector (str-split-drop-trailing (irregex-split (str-irx (arg 0)) s))))
;; universal object-methods that reach a string target (seed object-methods):
;; a thrown string / Exception. ctor (which keeps the message string) answers
;; getMessage with itself; equals is value equality.
((or (string=? method "getMessage") (string=? method "getLocalizedMessage")) s)
((string=? method "equals") (and (string? (arg 0)) (string=? s (arg 0))))
;; String.intern: jolt strings aren't pooled, but value equality holds, so the
;; canonical representation is the string itself.
((string=? method "intern") s)
;; A class token is its canonical-name string, so Class methods land here:
;; (.getName (.getClass x)) / (.getSimpleName …) over the name string.
((or (string=? method "getName") (string=? method "getCanonicalName")) s)
((string=? method "getSimpleName")
(let ((i (str-last-index-of s "."))) (if (>= i 0) (substring s (+ i 1) (string-length s)) s)))
;; .getChars srcBegin srcEnd dst dstBegin — copy s[srcBegin,srcEnd) into the
;; char-array dst at dstBegin (used by buffered readers, e.g. data.json).
((string=? method "getChars")
(let ((src-begin (jolt->idx (arg 0))) (src-end (jolt->idx (arg 1)))
(dv (jolt-array-vec (arg 2))) (dst-begin (jolt->idx (arg 3))))
(let loop ((i src-begin) (j dst-begin))
(when (fx<? i src-end)
(vector-set! dv j (string-ref s i))
(loop (fx+ i 1) (fx+ j 1)))))
jolt-nil)
((string=? method "subSequence")
(substring s (jolt->idx (arg 0)) (jolt->idx (arg 1))))
;; Class.isArray over a class-name string: array classes are "[…" (e.g. "[C").
((string=? method "isArray") (and (fx>? (string-length s) 0) (char=? (string-ref s 0) #\[)))
(else (error #f (string-append "No method " method " for value")))))
;; --- clojure.core str-* primitives (the substrate clojure.string.clj calls) ---
;; clojure.string.clj is pure Clojure over these
;; natives; def-var!'d here so the emitted
;; clojure.string prelude tier's var-derefs resolve:
;; string/ascii-* (ASCII), string/find (index or nil), core-str-* (regex|literal).
;; (string/split sep s) -> parts, splitting on each non-overlapping sep.
(define (str-literal-split s sep)
(let ((slen (string-length s)) (plen (string-length sep)))
(if (fx=? plen 0)
(map string (string->list s))
(let loop ((i 0) (start 0) (acc '()))
(cond ((fx>? (fx+ i plen) slen)
(reverse (cons (substring s start slen) acc)))
((string=? (substring s i (fx+ i plen)) sep)
(loop (fx+ i plen) (fx+ i plen) (cons (substring s start i) acc)))
(else (loop (fx+ i 1) start acc)))))))
(define (str-upper s) (ascii-string-up s))
(define (str-lower s) (ascii-string-down s))
(define (str-reverse-b s) (list->string (reverse (string->list s))))
;; (str-find needle haystack) -> exact int index of first occurrence, or nil.
(define (str-find needle s)
(let ((i (str-index-of s needle 0)))
(if (fx<? i 0) jolt-nil i)))
;; (str-join coll [sep]) -> stringify each element (Clojure str), join by sep.
;; str-join-strs (defined below) does the join; here we just render each element.
(define (str-join coll . opt)
(let ((sep (if (pair? opt) (jolt-str-render-one (car opt)) "")))
(str-join-strs (map jolt-str-render-one (seq->list coll)) sep)))
;; (re-split irx s limit) -> parts, splitting at each match. Keeps interior AND
;; trailing empty strings (the clojure.string wrapper drops trailing for limit 0);
;; a positive limit yields at most `limit` parts (the rest kept unsplit).
;; The clojure.string.clj split wrapper
;; layers the trailing-empty trim on top.
(define (re-split irx s limit)
(let ((len (string-length s)))
(let loop ((start 0) (last 0) (out '()))
(if (and limit (fx>=? (length out) (fx- limit 1)))
(reverse (cons (substring s last len) out))
(let ((m (and (fx<=? start len) (irregex-search irx s start))))
(if (not m)
(reverse (cons (substring s last len) out))
(let ((ms (irregex-match-start-index m 0))
(me (irregex-match-end-index m 0)))
(if (fx=? me ms) ; zero-width: step past to avoid a stall
(if (fx>=? start len)
(reverse (cons (substring s last len) out))
(loop (fx+ start 1) last out))
(loop me me (cons (substring s last ms) out))))))))))
;; (str-split pat s [limit]) -> parts. Regex or literal separator; a positive
;; limit caps the part count (the unsplit tail kept), matching core-str-split.
(define (str-split pat s . opt)
(let ((limit (if (and (pair? opt) (not (jolt-nil? (car opt)))) (jolt->idx (car opt)) #f)))
(if (jolt-regex? pat)
(apply jolt-vector (re-split (regex-t-irx pat) s limit))
(let ((parts (str-literal-split s pat)))
(apply jolt-vector
(if (and limit (fx>? limit 0) (fx>? (length parts) limit))
(append (list-head parts (fx- limit 1))
(list (str-join-strs (list-tail parts (fx- limit 1)) pat)))
parts))))))
(define (str-join-strs strs sep)
(let loop ((xs strs) (first #t) (acc '()))
(cond ((null? xs) (apply string-append (reverse acc)))
(first (loop (cdr xs) #f (cons (car xs) acc)))
(else (loop (cdr xs) #f (cons (car xs) (cons sep acc)))))))
;; $0/$1... expansion in a string replacement against an irregex match (the
;; JVM/seed replacement syntax). $N -> group N's text (dropped if non-matching).
(define (expand-dollar repl m)
(let ((len (string-length repl)))
(let loop ((i 0) (acc '()))
(if (fx>=? i len)
(apply string-append (reverse acc))
(let ((c (string-ref repl i)))
(if (and (char=? c #\$) (fx<? (fx+ i 1) len)
(char<=? #\0 (string-ref repl (fx+ i 1)))
(char<=? (string-ref repl (fx+ i 1)) #\9))
(let* ((n (fx- (char->integer (string-ref repl (fx+ i 1))) 48))
(g (and (fx<=? n (irregex-match-num-submatches m))
(irregex-match-substring m n))))
(loop (fx+ i 2) (if g (cons g acc) acc)))
(loop (fx+ i 1) (cons (string c) acc))))))))
;; One match's replacement text. A string gets $N expansion; a fn (jolt closure)
;; is called with the match result (whole string, or [whole g1 ...] when grouped)
;; and its result stringified.
(define (replacement-text replacement m)
(cond
((string? replacement) (expand-dollar replacement m))
((procedure? replacement) (jolt-str-render-one (jolt-invoke replacement (irx-result m))))
(else (jolt-str-render-one replacement))))
;; regex replace, first or all matches.
(define (re-replace irx s replacement all?)
(let ((len (string-length s)))
(let loop ((start 0) (last 0) (acc '()))
(let ((m (and (fx<=? start len) (irregex-search irx s start))))
(if (not m)
(apply string-append (reverse (cons (substring s last len) acc)))
(let ((ms (irregex-match-start-index m 0))
(me (irregex-match-end-index m 0)))
(if (fx=? me ms) ; zero-width: step past
(if (fx>=? start len)
(apply string-append (reverse (cons (substring s last len) acc)))
(loop (fx+ start 1) last acc))
(let ((acc2 (cons (replacement-text replacement m)
(cons (substring s last ms) acc))))
(if all?
(loop me me acc2)
(apply string-append (reverse (cons (substring s me len) acc2))))))))))))
;; (str-replace-all pat repl s) / (str-replace pat repl s) — regex or literal.
(define (str-replace-all pat repl s)
(if (jolt-regex? pat)
(re-replace (regex-t-irx pat) s repl #t)
;; 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
(string-append (substring s 0 i) b (substring s (fx+ i alen) (string-length s))))))
(define (str-replace pat repl s)
(if (jolt-regex? pat)
(re-replace (regex-t-irx pat) s repl #f)
(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)
(def-var! "clojure.core" "str-trim" str-trim)
(def-var! "clojure.core" "str-triml" str-triml)
(def-var! "clojure.core" "str-trimr" str-trimr)
(def-var! "clojure.core" "str-find" str-find)
(def-var! "clojure.core" "str-reverse-b" str-reverse-b)
(def-var! "clojure.core" "str-join" str-join)
(def-var! "clojure.core" "str-split" str-split)
(def-var! "clojure.core" "str-replace" str-replace)
(def-var! "clojure.core" "str-replace-all" str-replace-all)
;; (require ...) / (use ...) at runtime: register each spec's :as alias + :refer
;; names into the runtime ns tables (chez-register-spec!, ns.ss), keyed by the
;; current ns. The spine also pre-registers these at analyze time (idempotent),
;; so ns-aliases/ns-resolve over an :as alias resolve. Specs arrive evaluated
;; (quoted).
(define (chez-runtime-require . specs)
(for-each (lambda (s) (chez-register-spec! (chez-current-ns) s)) specs)
jolt-nil)
(def-var! "clojure.core" "require" chez-runtime-require)
;; use = require + refer ALL of the target's public vars (unless an explicit
;; :only/:refer filter is given, which chez-register-spec! handles per-name).
(define (chez-runtime-use . specs)
(for-each
(lambda (spec)
(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)
jolt-nil)
(def-var! "clojure.core" "use" chez-runtime-use)
;; import: bring a deftype/defrecord from another ns into the current one. A spec
;; [from-ns Type ...] binds each Type's ctor closure under the current ns, so its
;; (Type. ...) constructor (host-new resolves it as a var) works after :import.
(define (chez-runtime-import . specs)
(for-each
(lambda (spec)
(let ((items (cond ((pvec? spec) (seq->list spec))
((or (cseq? spec) (empty-list-t? spec)) (seq->list spec))
(else '()))))
(when (and (pair? items) (symbol-t? (car items)))
(let ((from (symbol-t-name (car items))))
(for-each
(lambda (tn)
(when (symbol-t? tn)
(let ((c (var-cell-lookup from (symbol-t-name tn))))
(when (and c (var-cell-defined? c))
(def-var! (chez-current-ns) (symbol-t-name tn) (var-cell-root c))))))
(cdr items))))))
specs)
jolt-nil)
(def-var! "clojure.core" "import" chez-runtime-import)

View file

@ -1,163 +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")))
;; 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

@ -1,122 +0,0 @@
#!/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

@ -1,95 +0,0 @@
;; lazy-seq bridge — make-lazy-seq / coll->cells.
;;
;; The `lazy-seq` macro (00-syntax.clj) expands to
;; (make-lazy-seq (fn* [] (coll->cells (do body))))
;; and `lazy-cat` to (concat (lazy-seq c) ...). These back every overlay fn
;; built on lazy-seq — repeat / iterate / cycle / dedupe / take-nth / keep /
;; interpose / reductions / tree-seq (-> flatten) / lazy-cat.
;;
;; Bridge to the cseq model (seq.ss): a `jolt-lazyseq` is a deferred seq — a 0-arg
;; thunk that, when forced once, yields a seq (cseq | nil). coll->cells coerces the
;; body result to a seq (= jolt-seq), so the thunk already returns a seq; jolt-seq
;; is extended to force a lazyseq. The one trap: (cons x (a-lazy-seq)) must NOT
;; force the tail (else (repeat x) = (lazy-seq (cons x (repeat x))) loops forever),
;; so jolt-cons defers a lazyseq tail into a lazy cseq cell.
;;
;; Loaded LAST (after host-table.ss): %ls-seq then captures the fully-extended
;; jolt-seq (sorted-aware), so a lazy body returning a sorted coll still seqs.
(define-record-type jolt-lazyseq
(fields (mutable thunk) (mutable val) (mutable realized?))
(nongenerative jolt-lazyseq-v1))
(define (jolt-make-lazy-seq thunk) (make-jolt-lazyseq thunk jolt-nil #f))
;; force once and memoize. The thunk is (fn [] (coll->cells body)); coll->cells
;; already coerced the body to a seq (cseq | nil) via the live jolt-seq, so the
;; result needs no further coercion (a nested lazyseq was forced by coll->cells).
(define (force-lazyseq x)
(if (jolt-lazyseq-realized? x)
(jolt-lazyseq-val x)
(let ((r (jolt-invoke (jolt-lazyseq-thunk x))))
(jolt-lazyseq-val-set! x r)
(jolt-lazyseq-realized?-set! x #t)
(jolt-lazyseq-thunk-set! x #f)
r)))
;; coll->cells: coerce the body result to the cell representation = a seq | nil.
(define (jolt-coll->cells c) (jolt-seq c))
;; extend jolt-seq to force a lazyseq (a lazyseq is seqable -> its realized seq).
(define %ls-seq jolt-seq)
(set! jolt-seq (lambda (x) (if (jolt-lazyseq? x) (force-lazyseq x) (%ls-seq x))))
;; (cons x lazyseq): keep the tail lazy — force it only when the cseq cell is
;; walked, so an infinite (repeat/iterate/cycle) stays productive.
(define %ls-cons jolt-cons)
(set! jolt-cons (lambda (x coll)
(if (jolt-lazyseq? coll)
(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
;; see an unknown type and return false. Recognizing it as sequential is enough
;; for equality + hash (seq=? / seq-hash coerce via jolt-seq); count / empty? /
;; nth / the printers don't, so coerce those explicitly.
(define %ls-sequential? jolt-sequential?)
(set! jolt-sequential? (lambda (x) (or (jolt-lazyseq? x) (%ls-sequential? x))))
(define %ls-count jolt-count)
(set! jolt-count (lambda (x) (if (jolt-lazyseq? x) (%ls-count (jolt-seq x)) (%ls-count x))))
(define %ls-empty? jolt-empty?)
(set! jolt-empty? (lambda (x) (if (jolt-lazyseq? x) (%ls-empty? (jolt-seq x)) (%ls-empty? x))))
(define %ls-nth jolt-nth)
(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. 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
;; reference, so the set! is enough), seq? is reached through var-deref, which
;; reads the var-cell root — so the patched closure must be re-def-var!'d, not just
;; set!. (Exposed once dynamic binding let with-in-str/line-seq reach seq?.)
(define %ls-seq? jolt-seq?)
(set! jolt-seq? (lambda (x) (or (jolt-lazyseq? x) (%ls-seq? x))))
(def-var! "clojure.core" "seq?" jolt-seq?)
(def-var! "clojure.core" "make-lazy-seq" jolt-make-lazy-seq)
(def-var! "clojure.core" "coll->cells" jolt-coll->cells)

View file

@ -1,397 +0,0 @@
;; loader.ss — file-based namespace loading + a shell primitive.
;;
;; The corpus/CLI spine compiles one program at a time; namespaces declared in
;; that program see each other because a top-level (do …) unrolls. A real project
;; spans many FILES, so `require` must locate a namespace's source on the search
;; roots and load it — transitively, once each.
;;
;; Loaded by cli.ss AFTER compile-eval.ss (it calls jolt-compile-eval-form). The
;; gates load compile-eval.ss but NOT this file, so the corpus/unit/sci runners
;; keep their alias-only `require` and are unaffected.
;; --- search roots -----------------------------------------------------------
;; An ordered list of directory strings. `require` searches them left to right.
;; The CLI seeds this with the project's resolved deps roots (jolt.deps) plus the
;; jolt-core roots so jolt.main/jolt.deps themselves load.
(define source-roots '("."))
(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.
(define (ns-seg-munge seg)
(list->string (map (lambda (c) (if (char=? c #\-) #\_ c)) (string->list seg))))
(define (ns-name->rel name)
(let loop ((cs (string->list name)) (seg '()) (segs '()))
(cond
((null? cs)
(let ((all (reverse (cons (list->string (reverse seg)) segs))))
(let join ((xs all) (acc ""))
(cond ((null? xs) acc)
((string=? acc "") (join (cdr xs) (ns-seg-munge (car xs))))
(else (join (cdr xs) (string-append acc "/" (ns-seg-munge (car xs)))))))))
((char=? (car cs) #\.)
(loop (cdr cs) '() (cons (list->string (reverse seg)) segs)))
(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 ((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)))
;; --- the loaded set ---------------------------------------------------------
;; Seeded with every namespace that already has vars at load time — the baked
;; prelude/image (clojure.core, clojure.string, jolt.analyzer, …). A `require` of
;; one of those then no-ops instead of hunting for a (nonexistent) source file.
(define loaded-ns (make-hashtable string-hash string=?))
(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
;; no-op rather than hunt the (absent) source.
(define (ns-has-vars? name)
(let ((found #f))
(vector-for-each
(lambda (c) (when (and (not found) (string=? (var-cell-ns c) name)) (set! found #t)))
(hashtable-values var-table))
found))
;; Called after a file-backed namespace finishes loading, with (name file). The
;; build driver sets this to record app namespaces in dependency order for AOT
;; emission; a no-op for normal runs.
(define ns-loaded-hook (lambda (name file) #f))
(define (set-ns-loaded-hook! f) (set! ns-loaded-hook f))
;; Read every form from a file and compile+eval it in turn. The first form is
;; normally (ns …), which expands to (in-ns …) and switches the current ns, so
;; later forms compile in that namespace — (chez-current-ns) is re-read each step.
;;
;; Reads by POSITION rather than via __parse-next: a top-level form that reads as
;; nothing — a :cljs-only #? with no matching branch, a #_ discard, a trailing
;; comment — yields rdr-eof but still advances. parse-next collapses that to "no
;; 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 (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
;; restored afterward, since loading the file switched it.
(define (load-namespace name)
(unless (hashtable-ref loaded-ns name #f)
(let ((file (find-ns-file name)))
(cond
(file
(hashtable-set! loaded-ns name #t) ; mark before load so a cycle terminates
(let ((saved (chez-current-ns)))
(load-jolt-file file)
;; restore the current ns (thread-local); *ns* reads derive from it.
(set-chez-ns! saved))
(ns-loaded-hook name file))
;; No source file but the namespace exists in memory (AOT'd into a built
;; binary): it's already defined — mark loaded and move on.
((ns-has-vars? name)
(hashtable-set! loaded-ns name #t))
(else
(error #f (string-append "Could not locate " (ns-name->rel name)
".clj (or .cljc) on the source roots") name))))))
;; load-file: load an explicit path (a `run FILE`), in the current ns.
(define (jolt-load-file path)
(load-jolt-file path)
jolt-nil)
;; The target ns name of a require/use spec ([ns …] / (ns …) / bare ns).
(define (spec-target-name 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 '()))))
(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 (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 . specs0)
(for-each
(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)
;; 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 (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))))
paths)
jolt-nil)
(def-var! "clojure.core" "load" jolt-load)
;; --- shell primitive (jolt.host/sh, sh-out) ---------------------------------
;; `sh` runs `sh -c CMD`, inheriting stdout/stderr (so git progress shows), and
;; returns the exit code. `sh-out` captures stdout to a string (exit ignored) for
;; commands whose output we parse (git rev-parse). Used by jolt.deps for git.
(define (jolt-sh cmd) (system cmd))
(def-var! "jolt.host" "sh" jolt-sh)
(define (jolt-sh-out cmd)
(call-with-values
(lambda () (open-process-ports (string-append "exec sh -c " (sh-quote cmd))
(buffer-mode block) (native-transcoder)))
(lambda (stdin stdout stderr pid)
(close-port stdin)
(let ((out (get-string-all stdout)))
(close-port stdout) (close-port stderr)
(if (eof-object? out) "" out)))))
(define (sh-quote s) ; single-quote for the outer sh -c
(string-append "'"
(apply string-append
(map (lambda (c) (if (char=? c #\') "'\\''" (string c))) (string->list s)))
"'"))
(def-var! "jolt.host" "sh-out" jolt-sh-out)
;; 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)) (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

@ -1,226 +0,0 @@
;; multimethods — the multimethod dispatch runtime on the Chez host.
;;
;; defmulti/defmethod are macros that expand to ctx-capturing setup CALLS
;; (defmulti-setup / defmethod-setup, + the table ops get-method/methods/
;; remove-method/prefer-method/prefers), implemented here against
;; the runtime's ns/var machinery.
;;
;; A multimethod VALUE is a jolt-multifn record carrying its dispatch fn and a
;; mutable method table (dispatch-val -> method fn, keyed with jolt= so keyword/
;; vector/number dispatch values match by value). jolt-invoke dispatches it:
;; an exact method, else an isa?/hierarchy match (resolved through prefer-method
;; and the overlay's isa?/derive/hierarchy), else the :default method.
;;
;; NS resolution: defmulti expands to (defmulti-setup (quote name) ...) with a
;; BARE symbol — the Chez RT has no compile-time current ns at the call site, so a
;; runtime `chez-current-ns` box names where to def-var! the multifn. It defaults
;; to "user" (matching the analyzer's ns for -e user code); the assembled prelude
;; sets it to "clojure.core" around its own load (program-with-prelude), so the
;; print-method/print-dup defmultis land in clojure.core. defmethod-setup and the
;; symbol-taking table ops resolve the multifn via (var-deref (chez-current-ns) …),
;; so they agree with defmulti. Loaded from rt.ss after seq.ss (jolt-invoke),
;; collections.ss (jolt=/key-hash/jolt-hash-map) and the var-cell machinery.
;; THREAD-LOCAL: a Chez thread-parameter, so each OS thread (an nREPL
;; session worker / future) has its own current ns — vars stay global, only the
;; "current ns" pointer is per-thread, matching Clojure's thread-local *ns*. A new
;; thread inherits the forking thread's value. `star-ns-cell` (the *ns* var cell,
;; captured by dyn-binding.ss once *ns* exists) lets chez-current-ns DERIVE from a
;; thread-local (binding [*ns* ..]) so a bound *ns* drives load-string/analyzer
;; resolution; bootstrap-safe (it's #f until then, so we just read the parameter).
(define chez-current-ns-param (make-thread-parameter "user"))
(define star-ns-cell #f)
(define (chez-current-ns)
(if star-ns-cell
(let ((bv (dyn-binding-value star-ns-cell)))
(if (and (not (eq? bv dyn-no-binding)) (jns? bv))
(jns-name bv)
(chez-current-ns-param)))
(chez-current-ns-param)))
(define (set-chez-ns! ns) (chez-current-ns-param ns))
(define-record-type jolt-multifn
(fields name dispatch-fn methods default hierarchy prefers)
(nongenerative jolt-multifn-v1))
(define kw-default (keyword #f "default"))
(define (new-mm-table) (make-hashtable key-hash jolt=))
;; (defmulti-setup 'name dispatch & opts) — opts is a flat :default/:hierarchy plist.
(define (parse-mm-opts opts)
(let loop ((o opts) (dk kw-default) (h #f))
(if (or (null? o) (null? (cdr o)))
(values dk h)
(let ((k (car o)) (v (cadr o)))
(cond
((and (keyword? k) (not (keyword-t-ns k)) (string=? (keyword-t-name k) "default"))
(loop (cddr o) v h))
((and (keyword? k) (not (keyword-t-ns k)) (string=? (keyword-t-name k) "hierarchy"))
(loop (cddr o) dk v))
(else (loop (cddr o) dk h)))))))
(define (jolt-defmulti-setup name-sym dispatch . opts)
(let-values (((dk h) (parse-mm-opts opts)))
(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 . 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 writing ns, else a :refer's home ns (so a
;; defmethod on a referred multifn lands on the real one), else stays in
;; the writing ns (a shadow, as before).
(mns (cond
(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
;; clojure.core multifn (e.g. print-method's 2-arg dispatch) so a
;; (defmethod print-method ...) before naming clojure.core's still
;; dispatches right — the old 1-arg identity fallback crashed.
(let* ((core (var-deref "clojure.core" nm))
(disp (if (jolt-multifn? core)
(jolt-multifn-dispatch-fn core)
(var-deref "clojure.core" "identity")))
(deft (if (jolt-multifn? core) (jolt-multifn-default core) kw-default))
(m (make-jolt-multifn nm disp (new-mm-table) deft #f (new-mm-table))))
(def-var! mns nm m) m))))
(hashtable-set! (jolt-multifn-methods mf) dval impl)
mf))
;; --- dispatch ----------------------------------------------------------------
(define (mm-isa? mf)
;; the overlay's isa? (the hierarchy system is pure Clojure); a per-mm :hierarchy
;; is an atom (deref each dispatch, like a Clojure var) or a plain map.
(let* ((isa (var-deref "clojure.core" "isa?"))
(h (jolt-multifn-hierarchy mf))
(hval (and h (if (jolt-atom? h) (jolt-atom-val h) h))))
(lambda (x y) (jolt-truthy? (if hval (jolt-invoke isa hval x y) (jolt-invoke isa x y))))))
(define (mm-find-isa mf dv)
(let* ((methods (jolt-multifn-methods mf))
(isa? (mm-isa? mf))
(default (jolt-multifn-default mf))
(keys (filter (lambda (k) (not (jolt= k default)))
(vector->list (hashtable-keys methods))))
(matches (filter (lambda (k) (isa? dv k)) keys)))
(cond
((null? matches) #f)
((null? (cdr matches)) (hashtable-ref methods (car matches) #f))
(else
;; >1 isa-match: pick the dominant key (x dominates y when x is
;; prefer-method'd over y, or (isa? x y)); ambiguity with no dominant is an
;; error, as in Clojure.
(let* ((prefers (jolt-multifn-prefers mf))
(pref? (lambda (x y)
(let ((px (hashtable-ref prefers x #f)))
(and px (hashtable-ref px y #f) #t))))
(dom? (lambda (x y) (or (pref? x y) (isa? x y))))
(best (fold-left (lambda (b k) (if (dom? k b) k b)) (car matches) (cdr matches))))
(for-each
(lambda (k)
(when (and (not (jolt= k best)) (not (dom? best k)))
(error #f (string-append "Multiple methods in multimethod '" (jolt-multifn-name mf)
"' match dispatch value - and neither is preferred"))))
matches)
(hashtable-ref methods best #f))))))
(define (multifn-dispatch mf . args)
(let* ((dv (apply jolt-invoke (jolt-multifn-dispatch-fn mf) args))
(methods (jolt-multifn-methods mf))
(direct (hashtable-ref methods dv #f)))
(cond
(direct (apply jolt-invoke direct args))
((mm-find-isa mf dv) => (lambda (m) (apply jolt-invoke m args)))
((hashtable-ref methods (jolt-multifn-default mf) #f)
=> (lambda (m) (apply jolt-invoke m args)))
(else (error #f (string-append "No method in multimethod '" (jolt-multifn-name mf)
"' for dispatch value: " (jolt-pr-str dv)))))))
;; jolt-invoke dispatches a multifn (otherwise falls through to the prior logic).
(define %prev-jolt-invoke jolt-invoke)
(set! jolt-invoke
(lambda (f . args)
(if (jolt-multifn? f)
(apply multifn-dispatch f args)
(apply %prev-jolt-invoke f args))))
;; --- table ops ---------------------------------------------------------------
;; prefer-method/remove-method/remove-all-methods/prefers take the name QUOTED;
;; get-method/methods take the multifn VALUE (Clojure semantics).
(define (mm-of-sym sym) (let ((v (var-deref (chez-current-ns) (symbol-t-name sym))))
(and (jolt-multifn? v) v)))
(define (jolt-prefer-method-setup mm-sym dval-a dval-b)
(let ((mf (mm-of-sym mm-sym)))
(when mf
(let ((sub (or (hashtable-ref (jolt-multifn-prefers mf) dval-a #f)
(let ((h (new-mm-table)))
(hashtable-set! (jolt-multifn-prefers mf) dval-a h) h))))
(hashtable-set! sub dval-b #t)))
mf))
(define (jolt-remove-method-setup mm-sym dval)
(let ((mf (mm-of-sym mm-sym)))
(when mf (hashtable-delete! (jolt-multifn-methods mf) dval))
mf))
(define (jolt-remove-all-methods-setup mm-sym)
(let ((mf (mm-of-sym mm-sym)))
(when mf (hashtable-clear! (jolt-multifn-methods mf)))
mf))
(define (jolt-get-method-setup mf dval)
(if (jolt-multifn? mf)
(or (hashtable-ref (jolt-multifn-methods mf) dval #f)
(hashtable-ref (jolt-multifn-methods mf) (jolt-multifn-default mf) #f)
jolt-nil)
jolt-nil))
(define (jolt-methods-setup mf)
(if (jolt-multifn? mf)
(let-values (((ks vs) (hashtable-entries (jolt-multifn-methods mf))))
(let loop ((i 0) (m (jolt-hash-map)))
(if (fx>=? i (vector-length ks)) m
(loop (fx+ i 1) (jolt-assoc m (vector-ref ks i) (vector-ref vs i))))))
jolt-nil))
(define (jolt-prefers-setup mm-sym)
(let ((mf (mm-of-sym mm-sym)))
(if (not mf) (jolt-hash-map)
(let-values (((ks vs) (hashtable-entries (jolt-multifn-prefers mf))))
(let loop ((i 0) (m (jolt-hash-map)))
(if (fx>=? i (vector-length ks)) m
;; each value is an inner set of preferred-over keys -> a jolt set
(loop (fx+ i 1)
(jolt-assoc m (vector-ref ks i)
(apply jolt-hash-set
(vector->list (hashtable-keys (vector-ref vs i))))))))))))
(def-var! "clojure.core" "defmulti-setup" jolt-defmulti-setup)
(def-var! "clojure.core" "defmethod-setup" jolt-defmethod-setup)
(def-var! "clojure.core" "prefer-method-setup" jolt-prefer-method-setup)
(def-var! "clojure.core" "remove-method-setup" jolt-remove-method-setup)
(def-var! "clojure.core" "remove-all-methods-setup" jolt-remove-all-methods-setup)
(def-var! "clojure.core" "get-method-setup" jolt-get-method-setup)
(def-var! "clojure.core" "methods-setup" jolt-methods-setup)
(def-var! "clojure.core" "prefers-setup" jolt-prefers-setup)

View file

@ -1,28 +0,0 @@
;; Collection constructors + rand — host-coupled natives the overlay assumes as
;; bare clojure.core vars. The persistent-collection constructors already exist
;; in collections.ss (jolt-hash-map / jolt-hash-set / jolt-vector); this just
;; 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.
;; 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 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.
(define (jolt-rand . n)
(let ((r (random 1.0)))
(if (null? n) r (* r (exact->inexact (car n))))))
(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" "rand" jolt-rand)
(def-var! "clojure.core" "map-entry?" jolt-map-entry?)

View file

@ -1,62 +0,0 @@
;; natives-format.ss — a small %-format engine for clojure.core `format` over the
;; all-flonum number model: %d (integer), %s (str), %f / %.Nf (fixed-point), %x/%X
;; (hex int), %o (octal), %c (char int), %b (boolean), %% (literal). Enough for the
;; corpus, not the full Java Formatter spec. Loaded after natives-misc.ss (uses
;; jolt-str-render-one via converters + jolt-truthy?).
(define (->long x) (exact (truncate x)))
(define (pad-left s n c) (if (fx>=? (string-length s) n) s (string-append (make-string (fx- n (string-length s)) c) s)))
(define (fmt-float x prec)
(let* ((neg (< x 0)) (ax (abs x))
(scale (expt 10 prec))
(scaled (round (* (inexact ax) scale)))
(i (exact (truncate (/ scaled scale))))
(frac (exact (truncate (- scaled (* i scale))))))
(string-append (if neg "-" "")
(number->string i)
(if (fx>? prec 0) (string-append "." (pad-left (number->string frac) prec #\0)) ""))))
(define (jolt-format fmt . args)
(let ((out (open-output-string)))
(let loop ((i 0) (as args))
(if (fx>=? i (string-length fmt))
(get-output-string out)
(let ((c (string-ref fmt i)))
(if (char=? c #\%)
;; parse a directive: %[-][0][width][.prec]conv
(let scan ((j (fx+ i 1)) (left #f) (zero #f) (width #f) (prec #f) (seen-dot #f))
(let ((d (string-ref fmt j)))
(cond
((char=? d #\%) (write-char #\% out) (loop (fx+ j 1) as))
((and (not seen-dot) (not width) (char=? d #\-))
(scan (fx+ j 1) #t zero width prec seen-dot))
((and (not seen-dot) (not width) (char=? d #\0))
(scan (fx+ j 1) left #t width prec seen-dot))
((char=? d #\.) (scan (fx+ j 1) left zero width 0 #t))
((and (char>=? d #\0) (char<=? d #\9))
(if seen-dot
(scan (fx+ j 1) left zero width (fx+ (fx* (or prec 0) 10) (fx- (char->integer d) 48)) seen-dot)
(scan (fx+ j 1) left zero (fx+ (fx* (or width 0) 10) (fx- (char->integer d) 48)) prec seen-dot)))
(else
(let* ((a (if (null? as) jolt-nil (car as)))
(rest (if (null? as) '() (cdr as)))
(s (case d
((#\d) (number->string (->long a)))
((#\s) (jolt-str-render-one a))
((#\f) (fmt-float a (or prec 6)))
((#\x) (string-downcase (number->string (->long a) 16)))
((#\X) (string-upcase (number->string (->long a) 16)))
((#\o) (number->string (->long a) 8))
((#\b) (if (jolt-truthy? a) "true" "false"))
((#\c) (string (integer->char (->long a))))
(else (string #\% d))))
;; pad to width: left-justify with spaces, else right-justify
;; (zero-pad only a right-justified number).
(s (if (and width (fx<? (string-length s) width))
(let ((p (fx- width (string-length s))))
(if left (string-append s (make-string p #\space))
(string-append (make-string p (if (and zero (memv d '(#\d #\f #\x #\X #\o))) #\0 #\space)) s)))
s)))
(display s out)
(loop (fx+ j 1) rest))))))
(begin (write-char c out) (loop (fx+ i 1) as))))))))
(def-var! "clojure.core" "format" jolt-format)

View file

@ -1,157 +0,0 @@
;; metadata — meta / with-meta. Chez values don't
;; carry metadata, so collections use an identity-keyed side-table: with-meta
;; returns a fresh COPY of the value (new identity) and records its meta there, so
;; the original is unchanged (Clojure's immutable-with-meta) and a copy made by a
;; later op (conj/assoc) drops the meta. Symbols carry meta in their own field.
;; meta on a non-metadatable value (number/string/keyword) is nil.
;;
;; Loaded after records.ss (jrec) + collections/seq/values (the ctors it copies).
;; Weak so a collection's metadata is reclaimed with the collection — collection
;; ops (conj/assoc/into) carry meta forward onto fresh values, so a strong table
;; would retain every meta-bearing intermediate.
(define meta-table (make-weak-eq-hashtable))
(define (jolt-meta x)
(cond
((symbol-t? x) (let ((m (symbol-t-meta x))) (if (jolt-nil? m) jolt-nil m)))
;; a var's meta is {:ns :name} (derived from the cell) + any def-time user
;; meta from rt.ss's var-meta-table.
((var-cell? x)
(let ((user (hashtable-ref var-meta-table x #f)))
(jolt-assoc (if user user (jolt-hash-map))
jolt-kw-var-ns (var-cell-ns x)
jolt-kw-var-name (var-cell-name x))))
;; 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-order x)))
((pset? x) (make-pset (pset-m 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))
;; 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))
;; 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))
(else (error #f "with-meta: value does not support metadata" x))))
(def-var! "clojure.core" "meta" jolt-meta)
(def-var! "clojure.core" "with-meta" jolt-with-meta)
;; Carry SRC's collection metadata onto DST (a freshly-built collection of the
;; same kind), as Clojure's ops do — each new collection threads its receiver's
;; meta() forward. Returns DST. The size check is the fast path: programs that
;; never attach collection metadata pay one O(1) check per op, no lookup.
(define (meta-carry src dst)
(if (fx=? 0 (hashtable-size meta-table))
dst
(let ((m (hashtable-ref meta-table src #f)))
(if m
;; never attach to the shared () singleton — use a fresh instance
(let ((d (if (empty-list-t? dst) (fresh-empty-list) dst)))
(hashtable-set! meta-table d m) d)
dst))))
;; (type x) — Clojure's (or (:type (meta x)) (class x)). With no JVM classes the
;; "class" is a host taxonomy: a record yields its ns-qualified class-name SYMBOL
;; (user.TyR), everything else a keyword (:number/:vector/:seq/…).
;; MUST be total — a non-record value
;; falling through to a crash would read as a divergence, not the right keyword.
;; Forward refs (jolt-lazyseq?, the sorted-htable / wrapper predicates) all bind by
;; call time (every host .ss loads before any user expr runs).
(define ty-kw-type (keyword #f "type")) ; the :type meta key
(define ty-kw-jtype (keyword "jolt" "type")) ; tagged-map discriminator (ex-info)
(define ty-number (keyword #f "number"))
(define ty-string (keyword #f "string"))
(define ty-keyword (keyword #f "keyword"))
(define ty-symbol (keyword #f "symbol"))
(define ty-boolean (keyword #f "boolean"))
(define ty-char (keyword #f "char"))
(define ty-vector (keyword #f "vector"))
(define ty-map (keyword #f "map"))
(define ty-set (keyword #f "set"))
(define ty-seq (keyword #f "seq"))
(define ty-fn (keyword #f "fn"))
(define ty-atom (keyword "jolt" "atom"))
(define ty-volatile (keyword "jolt" "volatile"))
(define ty-regex (keyword "jolt" "regex"))
(define ty-var (keyword "jolt" "var"))
(define ty-transient (keyword "jolt" "transient"))
(define ty-uuid (keyword "jolt" "uuid"))
(define ty-sorted-set (keyword "jolt" "sorted-set"))
(define ty-object (keyword #f "object"))
(define (jolt-type x)
(let* ((m (jolt-meta x))
(override (if (jolt-nil? m) jolt-nil (jolt-get m ty-kw-type jolt-nil))))
(cond
((not (jolt-nil? override)) override) ; :type meta wins
;; record -> its ns-qualified class-name STRING (= (class x)). jolt models
;; classes as strings, so (symbol (str (type r))) is NOT (type r) — as on the
;; JVM where type is a Class, not a Symbol.
((jrec? x) (jrec-tag x))
((jolt-nil? x) jolt-nil)
((boolean? x) ty-boolean)
((number? x) ty-number)
((string? x) ty-string)
((keyword? x) ty-keyword)
((symbol-t? x) ty-symbol)
((char? x) ty-char)
;; host wrappers — keyed by their :jolt/* tags (checked before the
;; collection arms; none of these are pvec/pmap/pset).
((jolt-atom? x) ty-atom)
((jvol? x) ty-volatile)
((jolt-regex? x) ty-regex)
((var-cell? x) ty-var)
((jolt-transient? x) ty-transient)
((juuid? x) ty-uuid)
((htable-sorted-set? x) ty-sorted-set)
((htable-sorted-map? x) ty-map)
;; collections — pvec INCLUDES map entries (:vector).
((pvec? x) ty-vector)
((pmap? x) ; a :jolt/type-tagged map (ex-info) -> its tag
(let ((t (jolt-get x ty-kw-jtype jolt-nil))) (if (jolt-nil? t) ty-map t)))
((pset? x) ty-set)
((or (cseq? x) (empty-list-t? x) (jolt-lazyseq? x)) ty-seq)
((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

@ -1,111 +0,0 @@
;; misc scalar natives — UUID, tagged-literal, bigint, and the hash API. (format /
;; printf moved to natives-format.ss.)
;;
;; Loaded after the printers (pr-str of a uuid is #uuid "…") and converters
;; (jolt-str-render-one for %s / str of a uuid).
;; --- UUID --------------------------------------------------------------------
;; A uuid is a record wrapping its canonical 36-char lowercase string. str -> the
;; bare string; pr-str -> #uuid "…"; not map?/coll?.
(define-record-type juuid (fields s) (nongenerative chez-juuid-v1))
(define (jolt-uuid-pred? x) (juuid? x))
(define hexd "0123456789abcdef")
(define (rand-hex) (string-ref hexd (random 16)))
;; v4: 8-4-4-4-12, version nibble (index 14) = 4, variant nibble (index 19) in 8-b.
(define (random-uuid-str)
(let ((cs (make-string 36)))
(let loop ((i 0))
(if (fx=? i 36) cs
(begin
(string-set! cs i
(cond ((or (fx=? i 8) (fx=? i 13) (fx=? i 18) (fx=? i 23)) #\-)
((fx=? i 14) #\4)
((fx=? i 19) (string-ref "89ab" (random 4)))
(else (rand-hex))))
(loop (fx+ i 1)))))))
(define (jolt-random-uuid) (make-juuid (random-uuid-str)))
;; #uuid literal -> a uuid value (the emitter lowers the :uuid node to this). The
;; reader already validated the shape; lowercase for value equality.
(define (jolt-uuid-from-string s) (make-juuid (string-downcase s)))
;; parse-uuid: validate the canonical shape (8-4-4-4-12 hex), lowercase, -> uuid;
;; nil if the string doesn't conform (Clojure parse-uuid), error on a non-string.
(define (hex-char? c) (or (and (char>=? c #\0) (char<=? c #\9))
(and (char>=? c #\a) (char<=? c #\f))
(and (char>=? c #\A) (char<=? c #\F))))
(define (uuid-shape? s)
(and (string? s) (fx=? (string-length s) 36)
(let loop ((i 0))
(if (fx=? i 36) #t
(let ((c (string-ref s i)))
(cond ((or (fx=? i 8) (fx=? i 13) (fx=? i 18) (fx=? i 23)) (and (char=? c #\-) (loop (fx+ i 1))))
((hex-char? c) (loop (fx+ i 1)))
(else #f)))))))
(define (jolt-parse-uuid s)
(cond ((not (string? s)) (error #f "parse-uuid: not a string" s))
((uuid-shape? s) (make-juuid (string-downcase s)))
(else jolt-nil)))
;; uuid? / random-uuid / parse-uuid are OVERLAY fns (they read :jolt/type), so
;; the prelude would clobber a def-var! here — they're asserted in post-prelude.ss.
;; str of a uuid -> the bare 36-char string; pr-str -> #uuid "…".
(register-str-render! juuid? juuid-s)
(define (juuid-pr u) (string-append "#uuid \"" (juuid-s u) "\""))
(register-pr-arm! juuid? juuid-pr)
;; two uuids are = iff same string.
(register-eq-arm! (lambda (a b) (or (juuid? a) (juuid? b)))
(lambda (a b) (and (juuid? a) (juuid? b) (string=? (juuid-s a) (juuid-s b)))))
;; --- bigint / biginteger -----------------------------------------------------
;; jolt models every number as a double; an integer-valued double prints without
;; a ".0" (jolt-num->string), so bigint is just the number for the corpus range.
;; (Arbitrary-precision beyond 2^53 is a separate concern.)
(define (jolt-bigint x) x)
(def-var! "clojure.core" "bigint" jolt-bigint)
(def-var! "clojure.core" "biginteger" jolt-bigint)
;; --- tagged-literal ----------------------------------------------------------
;; (tagged-literal tag form): a tagged value with :tag / :form. tagged-literal? is
;; overlay (reads :jolt/type) so it's overridden in post-prelude.ss.
(define-record-type jtagged (fields tag form) (nongenerative chez-jtagged-v1))
(define (jolt-tagged-literal tag form) (make-jtagged tag form))
(define (jolt-tagged-literal-pred? x) (jtagged? x))
(define kw-tl-tag (keyword #f "tag"))
(define kw-tl-form (keyword #f "form"))
(register-get-arm! jtagged?
(lambda (coll k d)
(cond ((jolt=2 k kw-tl-tag) (jtagged-tag coll))
((jolt=2 k kw-tl-form) (jtagged-form coll))
(else d))))
(define (jtagged-pr t) (string-append "#" (jolt-pr-str (jtagged-tag t)) " " (jolt-pr-readable (jtagged-form t))))
(register-pr-arm! jtagged? jtagged-pr)
;; two tagged literals are = iff same tag and (recursively) = form, like the JVM's
;; TaggedLiteral — so they work as map keys / set members. (jolt-hash already
;; hashes the fields structurally, so eq/hash stay consistent.)
(register-eq-arm! (lambda (a b) (or (jtagged? a) (jtagged? b)))
(lambda (a b) (and (jtagged? a) (jtagged? b)
(jolt=2 (jtagged-tag a) (jtagged-tag b))
(jolt=2 (jtagged-form a) (jtagged-form b)))))
(def-var! "clojure.core" "tagged-literal" jolt-tagged-literal)
;; tagged-literal? is OVERLAY (reads :jolt/type) — asserted in post-prelude.ss.
;; --- hash family (24-bit masked so int? holds) -------------------------------
;; The public hash API over jolt-hash (values.ss). hash-ordered/-unordered-coll
;; fold the element hashes the way Clojure's IHash mixers do.
(define (nm-h24 x) (bitwise-and (jolt-hash x) #xffffff))
(define (nm-hash x) (nm-h24 x))
(define (nm-hash-combine a b)
(bitwise-and (bitwise-xor (nm-h24 a) (+ (nm-h24 b) #x9e3779)) #xffffff))
(define (nm-hash-ordered-coll coll)
(let loop ((xs (seq->list (jolt-seq coll))) (h 1))
(if (null? xs) h (loop (cdr xs) (bitwise-and (+ (* 31 h) (nm-h24 (car xs))) #xffffff)))))
(define (nm-hash-unordered-coll coll)
(let loop ((xs (seq->list (jolt-seq coll))) (h 0))
(if (null? xs) h (loop (cdr xs) (bitwise-and (+ h (nm-h24 (car xs))) #xffffff)))))
(def-var! "clojure.core" "hash" nm-hash)
(def-var! "clojure.core" "hash-combine" nm-hash-combine)
(def-var! "clojure.core" "hash-ordered-coll" nm-hash-ordered-coll)
(def-var! "clojure.core" "hash-unordered-coll" nm-hash-unordered-coll)

View file

@ -1,88 +0,0 @@
;; bit ops + string->number parsers — host-coupled natives (bit family,
;; parse-long/double). jolt models every number as a double, so bit ops coerce
;; to an exact integer, operate, and return a flonum. parse-* use strict shapes
;; (Clojure 1.11: nil on malformed, throw on a non-string).
;; bit ops return EXACT integers (= JVM long). ->int coerces the operand.
(define (->int x) (exact (truncate x)))
(define (jolt-bit-and a b) (bitwise-and (->int a) (->int b)))
(define (jolt-bit-or a b) (bitwise-ior (->int a) (->int b)))
(define (jolt-bit-xor a b) (bitwise-xor (->int a) (->int b)))
(define (jolt-bit-and-not a b) (bitwise-and (->int a) (bitwise-not (->int b))))
(define (jolt-bit-not a) (bitwise-not (->int a)))
(define (jolt-bit-shift-left x n) (bitwise-arithmetic-shift-left (->int x) (->int n)))
(define (jolt-bit-shift-right x n) (bitwise-arithmetic-shift-right (->int x) (->int n)))
(define (bit-mask n) (bitwise-arithmetic-shift-left 1 (->int n)))
(define (jolt-bit-set x n) (bitwise-ior (->int x) (bit-mask n)))
(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 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 (bitwise-and (->int x) #xFFFFFFFFFFFFFFFF)
(bitwise-and (->int n) 63)))
;; ---- string->scalar parsers -------------------------------------------------
(define (ascii-digit? c) (and (char>=? c #\0) (char<=? c #\9)))
(define (skip-digits s i n) (let loop ((i i)) (if (and (< i n) (ascii-digit? (string-ref s i))) (loop (+ i 1)) i)))
(define (sign-at? s i n) (and (< i n) (let ((c (string-ref s i))) (or (char=? c #\+) (char=? c #\-)))))
(define (parse-long-shape? s)
(let* ((n (string-length s)) (i0 (if (sign-at? s 0 n) 1 0)))
(and (> n i0) (= (skip-digits s i0 n) n))))
(define (jolt-parse-long s)
(if (not (string? s)) (error #f "parse-long requires a string" s)
(if (parse-long-shape? s) (string->number s) jolt-nil))) ; exact long
;; strict float shape: [+-]? ( D+ (. D*)? | . D+ ) ([eE][+-]? D+)? fully anchored.
(define (parse-double-shape? s)
(let ((n (string-length s)))
(and (> n 0)
(call/cc
(lambda (no)
(let* ((i0 (if (sign-at? s 0 n) 1 0))
(after-int (skip-digits s i0 n))
(had-int (> after-int i0))
;; mantissa end
(jm (cond
((and had-int (< after-int n) (char=? (string-ref s after-int) #\.))
(skip-digits s (+ after-int 1) n)) ; D+ . D*
((and (not had-int) (< i0 n) (char=? (string-ref s i0) #\.))
(let ((k (skip-digits s (+ i0 1) n))) ; . D+
(if (> k (+ i0 1)) k (no #f))))
(had-int after-int)
(else (no #f))))
;; optional exponent
(je (if (and (< jm n) (let ((c (string-ref s jm))) (or (char=? c #\e) (char=? c #\E))))
(let* ((es (if (sign-at? s (+ jm 1) n) (+ jm 2) (+ jm 1)))
(ee (skip-digits s es n)))
(if (> ee es) ee (no #f)))
jm)))
(= je n)))))))
(define (jolt-parse-double s)
(if (not (string? s)) (error #f "parse-double requires a string" s)
(cond
((string=? s "Infinity") +inf.0)
((string=? s "-Infinity") -inf.0)
((string=? s "NaN") +nan.0)
((parse-double-shape? s) (exact->inexact (string->number s)))
(else jolt-nil))))
(def-var! "clojure.core" "__bit-and" jolt-bit-and)
(def-var! "clojure.core" "__bit-or" jolt-bit-or)
(def-var! "clojure.core" "__bit-xor" jolt-bit-xor)
(def-var! "clojure.core" "__bit-and-not" jolt-bit-and-not)
(def-var! "clojure.core" "bit-not" jolt-bit-not)
(def-var! "clojure.core" "bit-shift-left" jolt-bit-shift-left)
(def-var! "clojure.core" "bit-shift-right" jolt-bit-shift-right)
(def-var! "clojure.core" "bit-set" jolt-bit-set)
(def-var! "clojure.core" "bit-clear" jolt-bit-clear)
(def-var! "clojure.core" "bit-flip" jolt-bit-flip)
(def-var! "clojure.core" "bit-test" jolt-bit-test)
(def-var! "clojure.core" "unsigned-bit-shift-right" jolt-unsigned-bit-shift-right)
(def-var! "clojure.core" "parse-long" jolt-parse-long)
(def-var! "clojure.core" "parse-double" jolt-parse-double)

View file

@ -1,58 +0,0 @@
;; natives-reader.ss — reader/macro runtime-support natives: the #?() reader feature
;; set, the reader-conditional + re-matcher tagged-map constructors, and macroexpand.
;;
;; Loaded late (after ns.ss): macroexpand forward-refs the runtime macro table
;; (host-contract hc-macro?/hc-expand-1) + the analyzer ctx, resolved at call time
;; after the spine loads. The hash / transient? / rseq / cat natives that used to
;; live here moved to natives-misc, transients, natives-seq, and natives-transduce.
;; --- reader feature set (for #?() conditionals) — mutable list of name strings,
;; default jolt + default. __reader-features returns the strings; -set! replaces.
(define nr-reader-features (list "jolt" "default"))
(define (nr-reader-features-get) (list->cseq nr-reader-features))
(define (nr-reader-features-set! names)
(set! nr-reader-features
(map (lambda (n) (cond ((keyword-t? n) (keyword-t-name n)) ((string? n) n) (else (jolt-pr-str n))))
(seq->list (jolt-seq names))))
jolt-nil)
;; --- 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-reader-conditional form splicing?)
(jolt-hash-map nr-kw-type nr-kw-rc nr-kw-form form nr-kw-spl splicing?))
;; --- macroexpand-1 / macroexpand: expand a (quoted) call form via the runtime
;; macro table (host-contract hc-macro?/hc-expand-1; forward-referenced, resolved
;; at call time after the spine loads). macroexpand loops until the head is no
;; longer a macro (subforms are not expanded, matching Clojure).
(define (nr-macroexpand-1 form)
(if (and (cseq? form) (cseq-list? form) (symbol-t? (seq-first form)))
(let ((ctx (make-analyze-ctx (chez-current-ns))))
(if (hc-macro? ctx (seq-first form)) (hc-expand-1 ctx form) form))
form))
(define (nr-macroexpand form)
(let loop ((cur form))
(let ((nxt (nr-macroexpand-1 cur))) (if (eq? cur nxt) cur (loop nxt)))))
(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" "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

@ -1,247 +0,0 @@
;; seq-native shims — native seq fns the overlay assumes are clojure.core
;; natives. Each is a pure fn over the existing seq layer (seq.ss) — collection
;; arities only; the 1-arg transducer arities follow below. Loaded last (after
;; converters.ss for jolt-compare and seq.ss for the reduced record).
;; reduced / reduced? — the box itself is the jolt-reduced record from seq.ss
;; (so the reduce machinery there can see it); these just expose the constructor
;; and predicate. (deref a-reduced) is handled in atoms.ss.
(define (jolt-reduced-new x) (make-jolt-reduced x))
(define (jolt-reduced-pred x) (jolt-reduced? x))
(define (ensure-reduced x) (if (jolt-reduced? x) x (make-jolt-reduced x)))
;; ============================================================================
;; transducers — the 1-arg arity of map/filter/take/... returns a
;; transducer (fn [rf] rf') where rf' is a reducing fn with arities
;; []=init, [acc]=complete, [acc x]=step. rf and the mapping/predicate fns are jolt values, so every
;; 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) (apply jolt-invoke f (cdr a))))))))
(define (td-filter pred)
(lambda (rf)
(lambda a
(case (length a)
((0) (jolt-invoke rf))
((1) (jolt-invoke rf (car a)))
(else (if (jolt-truthy? (jolt-invoke pred (cadr a)))
(jolt-invoke rf (car a) (cadr a))
(car a)))))))
(define (td-remove pred) (td-filter (lambda (x) (jolt-not (jolt-invoke pred x)))))
(define (td-take n)
(lambda (rf)
(let ((left n))
(lambda a
(case (length a)
((0) (jolt-invoke rf))
((1) (jolt-invoke rf (car a)))
(else (if (<= left 0)
(make-jolt-reduced (car a))
(let ((r (jolt-invoke rf (car a) (cadr a))))
(set! left (- left 1))
(if (<= left 0) (ensure-reduced r) r)))))))))
(define (td-drop n)
(lambda (rf)
(let ((left n))
(lambda a
(case (length a)
((0) (jolt-invoke rf))
((1) (jolt-invoke rf (car a)))
(else (if (> left 0) (begin (set! left (- left 1)) (car a))
(jolt-invoke rf (car a) (cadr a)))))))))
(define (td-take-while pred)
(lambda (rf)
(lambda a
(case (length a)
((0) (jolt-invoke rf))
((1) (jolt-invoke rf (car a)))
(else (if (jolt-truthy? (jolt-invoke pred (cadr a)))
(jolt-invoke rf (car a) (cadr a))
(make-jolt-reduced (car a))))))))
(define (td-drop-while pred)
(lambda (rf)
(let ((dropping #t))
(lambda a
(case (length a)
((0) (jolt-invoke rf))
((1) (jolt-invoke rf (car a)))
(else (begin
(when (and dropping (not (jolt-truthy? (jolt-invoke pred (cadr a)))))
(set! dropping #f))
(if dropping (car a) (jolt-invoke rf (car a) (cadr a))))))))))
;; (mapcat f) transducer: map f, then splice (cat) f's result into rf, honoring a
;; mid-splice `reduced`.
(define (td-mapcat f)
(lambda (rf)
(lambda a
(case (length a)
((0) (jolt-invoke rf))
((1) (jolt-invoke rf (car a)))
(else (let loop ((acc (car a))
(xs (seq->list (jolt-seq (jolt-invoke f (cadr a))))))
(if (or (null? xs) (jolt-reduced? acc)) acc
(loop (jolt-invoke rf acc (car xs)) (cdr xs)))))))))
;; (into to xform from): transduce `from` through `xform` with conj as the rf.
(define (into-xform to xform from)
(let* ((conj-rf (lambda a (if (fx=? (length a) 1) (car a) ; completion = identity
(jolt-conj1 (car a) (cadr a)))))
(xrf (jolt-invoke xform conj-rf))
(res (reduce-seq xrf to (jolt-seq from))))
(jolt-invoke xrf res)))
;; mapcat: (mapcat f) -> transducer; (mapcat f coll & colls) -> map f across the
;; colls (stops at shortest), then concat the results.
(define (jolt-mapcat f . colls)
(if (null? colls)
(td-mapcat f)
;; 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)
(if (jolt-nil? s) jolt-empty-list
(let ((x (seq-first s)))
(if (jolt-truthy? (jolt-invoke pred x))
(cseq-lazy x (lambda () (take-while-seq pred (jolt-seq (seq-more s)))))
jolt-empty-list))))
(define jolt-take-while
(case-lambda
((pred) (td-take-while pred))
((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))))
(loop (jolt-seq (seq-more s)))
(if (jolt-nil? s) jolt-empty-list s))))
(define jolt-drop-while
(case-lambda
((pred) (td-drop-while pred))
((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;
;; with pad, a short final partition is padded from pad (and may be < n if pad
;; runs out). Each partition is a seq; the whole result is a lazy seq of seqs.
(define jolt-partition
(case-lambda
((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))
(values (reverse acc) s (length acc))
(loop (fx- n 1) (jolt-seq (seq-more s)) (cons (seq-first s) acc)))))
(define (partition* n step has-pad pad coll)
(let loop ((s (jolt-seq coll)))
(if (jolt-nil? s) jolt-empty-list
(let-values (((part rest taken) (take-n n s)))
(cond
;; full partition: emit it, advance `step` from its START
((fx=? taken n)
(cseq-lazy (list->cseq part)
(lambda () (loop (jolt-seq (advance-by step s))))))
;; short final partition with pad: top up to n from pad, then stop
((and has-pad (fx>? taken 0))
(let ((padded (append part (take-list (- n taken) (jolt-seq pad)))))
(cseq-lazy (list->cseq padded) (lambda () jolt-empty-list))))
;; short final partition, no pad: dropped (Clojure keeps only full ones)
(else jolt-empty-list))))))
(define (advance-by step s) ; drop `step` elements from s (seq), returns a seq
(let loop ((step step) (s s))
(if (or (fx<=? step 0) (jolt-nil? s)) s
(loop (fx- step 1) (jolt-seq (seq-more s))))))
(define (take-list n s) ; up to n elements of seq s as a Scheme list
(let loop ((n n) (s s) (acc '()))
(if (or (fx<=? n 0) (jolt-nil? s)) (reverse acc)
(loop (fx- n 1) (jolt-seq (seq-more s)) (cons (seq-first s) acc)))))
;; sort: (sort coll) uses compare; (sort cmp coll) uses cmp, whose result may be
;; a 3-way number (<0 / 0 / >0) OR a boolean (a Clojure-style less-than pred).
(define (cmp->less cmp)
(lambda (a b)
(let ((r (jolt-invoke cmp a b)))
(if (number? r) (< r 0) (jolt-truthy? r)))))
(define jolt-sort
(case-lambda
((coll) (jolt-sort* (cmp->less jolt-compare) coll))
((cmp coll) (jolt-sort* (cmp->less cmp) coll))))
(define (jolt-sort* less? coll)
(let ((s (jolt-seq coll)))
(if (jolt-nil? s) jolt-empty-list
(list->cseq (list-sort less? (seq->list s))))))
;; 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
;; (value-position path), so widening the procedures is what makes the 1-arg form
;; work. Capture the originals (collection arities) first, then redefine.
(define %prev-jolt-map jolt-map)
(set! jolt-map (lambda (f . colls)
(if (null? colls) (td-map f) (apply %prev-jolt-map f colls))))
(define %prev-jolt-filter jolt-filter)
(set! jolt-filter (case-lambda ((pred) (td-filter pred))
((pred coll) (%prev-jolt-filter pred coll))))
(define %prev-jolt-remove jolt-remove)
(set! jolt-remove (case-lambda ((pred) (td-remove pred))
((pred coll) (%prev-jolt-remove pred coll))))
(define %prev-jolt-take jolt-take)
(set! jolt-take (case-lambda ((n) (td-take n))
((n coll) (%prev-jolt-take n coll))))
(define %prev-jolt-drop jolt-drop)
(set! jolt-drop (case-lambda ((n) (td-drop n))
((n coll) (%prev-jolt-drop n coll))))
;; into: add the 3-arg (into to xform from). The 2-arg stays the seq.ss fold.
(define %prev-jolt-into jolt-into)
(set! jolt-into (case-lambda ((to from) (%prev-jolt-into to from))
((to xform from) (into-xform to xform from))))
(def-var! "clojure.core" "reduced" jolt-reduced-new)
(def-var! "clojure.core" "reduced?" jolt-reduced-pred)
(def-var! "clojure.core" "mapcat" jolt-mapcat)
(def-var! "clojure.core" "take-while" jolt-take-while)
(def-var! "clojure.core" "drop-while" jolt-drop-while)
(def-var! "clojure.core" "partition" jolt-partition)
(def-var! "clojure.core" "sort" jolt-sort)
(def-var! "clojure.core" "identical?" jolt-identical?)
;; rseq: vectors + sorted colls only (Clojure), the reverse of the ascending seq.
(define (jolt-rseq coll)
(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

@ -1,96 +0,0 @@
;; natives-transduce.ss — the transducer surface: volatiles, the `cat` transducer,
;; and sequence / transduce application.
;;
;; `sequence` and `transduce` are seed natives. The stateful transducer arities
;; (take-nth/map-indexed/partition-by/dedupe/distinct, all overlay) use
;; volatile!/vswap!/vreset!/deref, shimmed here.
;;
;; Volatiles are a native mutable box (jvol) — the overlay vreset!/vswap! drive a
;; volatile through jolt.host/ref-put!+get, but a Chez volatile is a record, not a
;; tagged table, so those overlay versions are overridden natively in
;; post-prelude.ss. transduce/sequence build on the existing into-xform / reduce-
;; seq machinery (natives-seq.ss / seq.ss). Loaded after those + atoms.ss (deref).
;; --- volatiles ---------------------------------------------------------------
(define-record-type jvol (fields (mutable v)) (nongenerative chez-jvol-v1))
(define (jolt-volatile! x) (make-jvol x))
(define (jolt-vreset! vol x) (jvol-v-set! vol x) x)
(define (jolt-vswap! vol f . args)
(let ((nv (apply jolt-invoke f (jvol-v vol) args))) (jvol-v-set! vol nv) nv))
(define (jolt-volatile-pred? x) (jvol? x))
;; deref reads a volatile too (partition-all/-by transducers @-deref their box).
(define %xf-deref jolt-deref)
(set! jolt-deref (lambda (x) (if (jvol? x) (jvol-v x) (%xf-deref x))))
(def-var! "clojure.core" "volatile!" jolt-volatile!)
(def-var! "clojure.core" "deref" jolt-deref)
;; --- 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)))
(define jolt-sequence
(case-lambda
((coll) (jolt-seq coll))
((xform coll) (sequence-xf xform coll))))
(def-var! "clojure.core" "sequence" jolt-sequence)
;; --- cat ---------------------------------------------------------------------
;; cat transducer: each input item is itself a collection, concatenated into the
;; downstream reducing fn.
(define (jolt-cat rf)
(lambda a
(cond
((null? a) (jolt-invoke rf))
((null? (cdr a)) (jolt-invoke rf (car a)))
(else
(let loop ((xs (seq->list (jolt-seq (cadr a)))) (acc (car a)))
(if (null? xs) acc (loop (cdr xs) (jolt-invoke rf acc (car xs)))))))))
(def-var! "clojure.core" "cat" jolt-cat)

View file

@ -1,391 +0,0 @@
;; namespaces — the namespace value model.
;;
;; The namespace ops (find-ns/resolve/in-ns/…) work over the rt.ss var-table
;; (cells carry ns + name + defined?) and the multimethods.ss chez-current-ns
;; box. A namespace VALUE is a `jns` record carrying its name string — distinct
;; from a map/record so (map? ns) is #f, but the overlay's `ns-name` reads
;; (get ns :name); that's overridden natively in post-prelude.ss (loads after
;; the overlay clobbers it).
;;
;; Loaded LAST from rt.ss. The analyzer bakes a def's target ns at compile time,
;; so a runtime in-ns redirects only *ns* / str-of-ns, not later defs in the
;; same program.
(define-record-type jns (fields name) (nongenerative chez-jns-v1))
;; registry: name-string -> jns. Seeded with the two always-present namespaces;
;; grown by in-ns / create-ns. find-ns ALSO derives existence from the var-table
;; (any cell with that ns), so a namespace that only ever had vars def'd into it
;; is still found.
(define ns-registry (make-hashtable string-hash string=?))
(define (intern-ns! name)
(or (hashtable-ref ns-registry name #f)
(let ((n (make-jns name))) (hashtable-set! ns-registry name n) n)))
(intern-ns! "user")
(intern-ns! "clojure.core")
;; --- namespace aliases ------------------------------------------------------
;; (require '[ns :as a]) registers a -> ns so the analyzer can resolve a/foo to
;; ns/foo. Keyed by (compile-ns . alias). The requires are pre-registered at
;; analyze time (compile-eval.ss) — analysis precedes eval, so a runtime require
;; no-op is fine. Also drives jolt-ns-aliases below.
(define ns-alias-table (make-hashtable equal-hash equal?))
(define (chez-register-alias! cns alias target)
(hashtable-set! ns-alias-table (cons cns alias) target))
(define (chez-resolve-alias cns alias)
(hashtable-ref ns-alias-table (cons cns alias) #f))
;; :refer brings an UNQUALIFIED name into cns, resolving to target-ns/name.
(define ns-refer-table (make-hashtable equal-hash equal?))
(define (chez-register-refer! cns name target)
(hashtable-set! ns-refer-table (cons cns name) target))
;; refer-all (a bare `use`): cns -> list of fully-referred target ns names. A name
;; not found per-name resolves to the first refer-all target that defines it.
(define ns-refer-all-table (make-hashtable equal-hash equal?))
(define (chez-register-refer-all! cns target)
(let ((cur (hashtable-ref ns-refer-all-table cns '())))
(unless (member target cur)
(hashtable-set! ns-refer-all-table cns (cons target cur)))))
(define (chez-resolve-refer cns name)
(or (hashtable-ref ns-refer-table (cons cns name) #f)
(let loop ((ts (hashtable-ref ns-refer-all-table cns '())))
(cond ((null? ts) #f)
((let ((c (var-cell-lookup (car ts) name))) (and c (var-cell-defined? c))) (car ts))
(else (loop (cdr ts)))))))
;; parse a require/use spec FORM and register its :as alias + :refer names under
;; `cns`. spec: [ns :as a :refer [x y] ...] / (ns ...) / bare ns. opts are
;; keyword/value pairs after the ns symbol.
(define (chez-register-spec! cns spec)
(let ((items (cond ((pvec? spec) (seq->list spec))
((or (cseq? spec) (empty-list-t? spec)) (seq->list spec))
(else '()))))
(when (and (pair? items) (symbol-t? (car items)))
(let ((target (symbol-t-name (car items))))
(let loop ((xs (cdr items)))
(when (and (pair? xs) (pair? (cdr xs)))
(let ((k (car xs)) (v (cadr xs)))
(when (keyword? k)
(cond
((string=? (keyword-t-name k) "as")
(when (symbol-t? v) (chez-register-alias! cns (symbol-t-name v) target)))
;; :refer (require) and :only (use) both bring unqualified names
;; into cns resolving to target/name.
((or (string=? (keyword-t-name k) "refer") (string=? (keyword-t-name k) "only"))
(cond
;; :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))
;; :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))))))))
(loop (cddr xs))))))))
;; a namespace designator -> its name string (a jns or a symbol; the corpus never
;; passes a bare string).
(define (ns-desig->name d)
(if (jns? d) (jns-name d) (symbol-t-name d)))
(define (ns-has-vars? nm)
(let ((found #f))
(vector-for-each
(lambda (c) (when (and (not found) (string=? (var-cell-ns c) nm)) (set! found #t)))
(hashtable-values var-table))
found))
(define (jolt-find-ns desig)
(let ((nm (ns-desig->name desig)))
(or (hashtable-ref ns-registry nm #f)
(and (ns-has-vars? nm) (intern-ns! nm))
jolt-nil)))
(define (jolt-the-ns desig)
(if (jns? desig) desig
(let ((n (jolt-find-ns desig)))
(if (jns? n) n (error #f "No namespace" desig)))))
(define (jolt-create-ns desig) (intern-ns! (ns-desig->name desig)))
;; in-ns: register + switch the current ns + re-bind *ns* + return the jns. This
;; updates only the RUNTIME current ns — subsequent defs in the same program were
;; already ns-baked by the analyzer, so it does not redirect them. It is enough
;; for *ns* / str-of-ns to track the switch.
(define (jolt-in-ns desig)
(let* ((nm (ns-desig->name desig)) (n (intern-ns! nm)))
;; set the THREAD-LOCAL current ns; *ns* reads derive from it (dyn-binding.ss),
;; so this is per-thread — concurrent nREPL sessions don't clobber each other.
(set-chez-ns! nm)
n))
;; ns-name: a namespace's name as a (no-ns) symbol. Overrides the overlay (which
;; reads (get ns :name) = nil on a jns record) — wired in via post-prelude.ss.
(define (jolt-ns-name desig)
(jolt-symbol #f (jns-name (jolt-the-ns desig))))
(define (jolt-all-ns)
(let ((seen (make-hashtable string-hash string=?)))
(vector-for-each (lambda (k) (hashtable-set! seen k #t)) (hashtable-keys ns-registry))
(vector-for-each (lambda (c) (hashtable-set! seen (var-cell-ns c) #t)) (hashtable-values var-table))
(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. 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) (keep? c))
(set! m (jolt-assoc m (jolt-symbol #f (var-cell-name c)) c))))
(hashtable-values var-table))
m))
(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.
(define (jolt-ns-aliases . desig)
(let ((cns (if (pair? desig) (ns-desig->name (car desig)) (chez-current-ns)))
(m (jolt-hash-map)))
(vector-for-each
(lambda (k)
(when (string=? (car k) cns)
(set! m (jolt-assoc m (jolt-symbol #f (cdr k))
(intern-ns! (hashtable-ref ns-alias-table k #f))))))
(hashtable-keys ns-alias-table))
m))
;; ns-refers: the {sym -> var} referred into `desig` via refer/use.
(define (jolt-ns-refers desig)
(let ((cns (ns-desig->name desig)) (m (jolt-hash-map)))
(vector-for-each
(lambda (k)
(when (string=? (car k) cns)
(let* ((target (hashtable-ref ns-refer-table k #f))
(c (and target (var-cell-lookup target (cdr k)))))
(when c (set! m (jolt-assoc m (jolt-symbol #f (cdr k)) c))))))
(hashtable-keys ns-refer-table))
m))
;; ns-imports: clojure.core auto-imports the 96 public java.lang classes into
;; every ns. jolt has no classloader, but returns that map (short symbol ->
;; canonical class-name token) so (count (ns-imports 'user)) = 96 like the JVM.
(define jolt-default-import-names
'("AbstractMethodError" "Appendable" "ArithmeticException" "ArrayIndexOutOfBoundsException"
"ArrayStoreException" "AssertionError" "BigDecimal" "BigInteger" "Boolean" "Byte"
"Callable" "CharSequence" "Character" "Class" "ClassCastException" "ClassCircularityError"
"ClassFormatError" "ClassLoader" "ClassNotFoundException" "CloneNotSupportedException"
"Cloneable" "Comparable" "Compiler" "Deprecated" "Double" "Enum"
"EnumConstantNotPresentException" "Error" "Exception" "ExceptionInInitializerError" "Float"
"IllegalAccessError" "IllegalAccessException" "IllegalArgumentException"
"IllegalMonitorStateException" "IllegalStateException" "IllegalThreadStateException"
"IncompatibleClassChangeError" "IndexOutOfBoundsException" "InheritableThreadLocal"
"InstantiationError" "InstantiationException" "Integer" "InternalError" "InterruptedException"
"Iterable" "LinkageError" "Long" "Math" "NegativeArraySizeException" "NoClassDefFoundError"
"NoSuchFieldError" "NoSuchFieldException" "NoSuchMethodError" "NoSuchMethodException"
"NullPointerException" "Number" "NumberFormatException" "Object" "OutOfMemoryError" "Override"
"Package" "Process" "ProcessBuilder" "Readable" "Runnable" "Runtime" "RuntimeException"
"RuntimePermission" "SecurityException" "SecurityManager" "Short" "StackOverflowError"
"StackTraceElement" "StrictMath" "String" "StringBuffer" "StringBuilder"
"StringIndexOutOfBoundsException" "SuppressWarnings" "System" "Thread" "Thread$State"
"Thread$UncaughtExceptionHandler" "ThreadDeath" "ThreadGroup" "ThreadLocal" "Throwable"
"TypeNotPresentException" "UnknownError" "UnsatisfiedLinkError" "UnsupportedClassVersionError"
"UnsupportedOperationException" "VerifyError" "VirtualMachineError" "Void"))
(define jolt-default-imports
(let loop ((ns jolt-default-import-names) (m (jolt-hash-map)))
(if (null? ns) m
(loop (cdr ns)
(jolt-assoc m (jolt-symbol #f (car ns)) (string-append "java.lang." (car ns)))))))
(define (jolt-ns-imports . _) jolt-default-imports)
;; resolve: an unqualified symbol resolves in the current ns then clojure.core; a
;; qualified one in its own ns. Returns the var iff genuinely defined, else nil —
;; never interns an empty cell (var-cell-lookup is non-creating).
;; resolve `sym` in the current ns: a qualified ns part is read as an :as alias
;; (then a real ns); an unqualified name resolves in the current ns, its :refers,
;; then clojure.core. (ns-resolve does the same against an explicit ns.)
(define (jolt-resolve sym)
(let* ((cns (chez-current-ns))
(sns (symbol-t-ns sym)) (nm (symbol-t-name sym))
(c (if (string? sns)
(var-cell-lookup (or (chez-resolve-alias cns sns) sns) nm)
(or (var-cell-lookup cns nm)
(let ((ref (chez-resolve-refer cns nm))) (and ref (var-cell-lookup ref nm)))
(var-cell-lookup "clojure.core" nm)))))
(if (and c (var-cell-defined? c)) c jolt-nil)))
(define (jolt-find-var sym)
(let ((sns (symbol-t-ns sym)) (nm (symbol-t-name sym)))
(if (string? sns)
(let ((c (var-cell-lookup sns nm))) (if (and c (var-cell-defined? c)) c jolt-nil))
(error #f "find-var requires a fully-qualified symbol" sym))))
;; ns-unmap: clear the mapping — drop defined? and reset the root to unbound, so a
;; later resolve returns nil.
(define (jolt-ns-unmap ns-desig sym)
(let ((c (var-cell-lookup (ns-desig->name ns-desig) (symbol-t-name sym))))
(when c (var-cell-defined?-set! c #f) (var-cell-root-set! c jolt-unbound)))
jolt-nil)
;; --- ns runtime fns ---------------------------------------------------------
;; ns-resolve: resolve `sym` as if reading it in namespace `ns-desig`. Qualified
;; syms consult that ns's :as aliases; unqualified resolve in the ns, its :refers,
;; then clojure.core. Returns the var or nil (never interns).
(define (jolt-ns-resolve ns-desig sym)
(let* ((cns (ns-desig->name ns-desig))
(sns (symbol-t-ns sym)) (nm (symbol-t-name sym))
(c (if (string? sns)
(var-cell-lookup (or (chez-resolve-alias cns sns) sns) nm)
(or (var-cell-lookup cns nm)
(let ((ref (chez-resolve-refer cns nm))) (and ref (var-cell-lookup ref nm)))
(var-cell-lookup "clojure.core" nm)))))
(if (and c (var-cell-defined? c)) c jolt-nil)))
;; remove-ns: drop the namespace from the registry AND its vars, so find-ns
;; (which also derives existence from the var-table) returns nil afterward.
(define (jolt-remove-ns desig)
(let ((nm (ns-desig->name desig)))
(hashtable-delete! ns-registry nm)
(vector-for-each
(lambda (k) (let ((c (hashtable-ref var-table k #f)))
(when (and c (string=? (var-cell-ns c) nm)) (hashtable-delete! var-table k))))
(hashtable-keys var-table))
jolt-nil))
;; 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.
;; A runtime alias is registered into the SAME table the analyzer consults, so a
;; later form in the program resolves alias/foo (the spine analyzes form by form).
(define (jolt-alias alias-sym ns-sym)
(chez-register-alias! (chez-current-ns) (symbol-t-name alias-sym) (ns-desig->name ns-sym))
jolt-nil)
(define (jolt-ns-unalias ns-desig alias-sym)
(hashtable-delete! ns-alias-table (cons (ns-desig->name ns-desig) (symbol-t-name alias-sym)))
jolt-nil)
;; refer: bring every public var of `ns-sym` into the current ns as an unqualified
;; name (filters accepted/ignored — the corpus uses the bare form). refer-clojure
;; is a no-op (clojure.core always resolves on Chez).
(define (jolt-refer ns-sym . _filters)
(let ((target (ns-desig->name ns-sym)) (cns (chez-current-ns)))
(vector-for-each
(lambda (c) (when (and (string=? (var-cell-ns c) target) (var-cell-defined? c))
(chez-register-refer! cns (var-cell-name c) target)))
(hashtable-values var-table))
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!: 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)
(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
;; var-cell and (resolve '+) would be nil — diverging from Clojure where it is a
;; var. def-var! each to its value-position procedure so it has a real, defined
;; cell (calls still inline, so no perf hit; #'+ deref and ((resolve '+) 1 2) also
;; work now). The clojure.core prelude, loaded AFTER rt.ss, overwrites the cells
;; for names it also defines in the overlay (map/filter/…); the purely-inlined
;; scalars (+/-/</inc/…) keep these.
(for-each
(lambda (p) (def-var! "clojure.core" (car p) (cdr p)))
(list
(cons "+" jolt-add) (cons "-" jolt-sub) (cons "*" jolt-mul) (cons "/" jolt-div)
(cons "<" <) (cons ">" >) (cons "<=" <=) (cons ">=" >=)
(cons "=" jolt=) (cons "inc" jolt-inc) (cons "dec" jolt-dec) (cons "not" jolt-not)
(cons "min" min) (cons "max" max)
(cons "mod" modulo) (cons "rem" remainder) (cons "quot" quotient)
(cons "vector" jolt-vector) (cons "hash-map" jolt-hash-map) (cons "hash-set" jolt-hash-set)
(cons "conj" jolt-conj) (cons "get" jolt-get) (cons "nth" jolt-nth) (cons "count" jolt-count)
(cons "assoc" jolt-assoc) (cons "dissoc" jolt-dissoc) (cons "contains?" jolt-contains?)
(cons "empty?" jolt-empty?) (cons "peek" jolt-peek) (cons "pop" jolt-pop)
(cons "first" jolt-first) (cons "rest" jolt-rest) (cons "next" jolt-next) (cons "seq" jolt-seq)
(cons "cons" jolt-cons) (cons "list" jolt-list) (cons "reverse" jolt-reverse) (cons "last" jolt-last)
(cons "map" jolt-map) (cons "filter" jolt-filter) (cons "remove" jolt-remove)
(cons "reduce" jolt-reduce) (cons "into" jolt-into) (cons "concat" jolt-concat) (cons "apply" jolt-apply)
(cons "range" jolt-range) (cons "take" jolt-take) (cons "drop" jolt-drop)
(cons "keys" jolt-keys) (cons "vals" jolt-vals)
(cons "even?" jolt-even?) (cons "odd?" jolt-odd?) (cons "pos?" jolt-pos?) (cons "neg?" jolt-neg?)
(cons "zero?" jolt-zero?) (cons "identity" jolt-identity)
(cons "ex-info" jolt-ex-info)))
;; --- bindings + *ns* --------------------------------------------------------
(def-var! "clojure.core" "find-ns" jolt-find-ns)
(def-var! "clojure.core" "the-ns" jolt-the-ns)
(def-var! "clojure.core" "create-ns" jolt-create-ns)
(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-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)
(def-var! "clojure.core" "resolve" jolt-resolve)
(def-var! "clojure.core" "ns-resolve" jolt-ns-resolve)
(def-var! "clojure.core" "find-var" jolt-find-var)
(def-var! "clojure.core" "ns-unmap" jolt-ns-unmap)
(def-var! "clojure.core" "remove-ns" jolt-remove-ns)
(def-var! "clojure.core" "intern" jolt-intern)
(def-var! "clojure.core" "alias" jolt-alias)
(def-var! "clojure.core" "ns-unalias" jolt-ns-unalias)
(def-var! "clojure.core" "refer" jolt-refer)
(def-var! "clojure.core" "refer-clojure" jolt-refer-clojure)
(def-var! "clojure.core" "alter-meta!" jolt-alter-meta!)
(def-var! "clojure.core" "reset-meta!" jolt-reset-meta!)
;; *ns* starts at the user namespace (the current ns for -e user code). in-ns
;; re-binds it. (ns-name is overridden natively in post-prelude.ss.)
(def-var! "clojure.core" "*ns*" (intern-ns! "user"))
;; --- printer patches: a namespace renders as its name (str / pr-str / -e) ----
(register-pr-arm! jns? jns-name)
(register-str-render! jns? jns-name)

View file

@ -1,122 +0,0 @@
;; png.ss — jolt.png: a minimal PNG writer, the built-in the
;; ray-tracer-multi example renders through. Truecolor (8-bit RGB), no
;; compression: the IDAT zlib stream uses DEFLATE "stored" (uncompressed) blocks,
;; so there is no compressor to carry — just CRC-32 / Adler-32 framing over Chez
;; bytevectors. def-var!'d into the jolt.png namespace, so a (require '[jolt.png])
;; resolves it as a baked namespace (no source file).
;; --- CRC-32 (PNG chunk checksum) --------------------------------------------
(define png-crc-table
(let ((t (make-vector 256)))
(do ((n 0 (+ n 1))) ((= n 256) t)
(let loop ((c n) (k 0))
(if (= k 8)
(vector-set! t n c)
(loop (if (odd? c) (bitwise-xor #xedb88320 (bitwise-arithmetic-shift-right c 1))
(bitwise-arithmetic-shift-right c 1))
(+ k 1)))))))
(define (png-crc32 bv)
(let ((len (bytevector-length bv)))
(let loop ((i 0) (c #xffffffff))
(if (= i len)
(bitwise-xor c #xffffffff)
(loop (+ i 1)
(bitwise-xor (bitwise-arithmetic-shift-right c 8)
(vector-ref png-crc-table
(bitwise-and (bitwise-xor c (bytevector-u8-ref bv i)) #xff))))))))
;; --- Adler-32 (zlib checksum) -----------------------------------------------
(define (png-adler32 bv)
(let ((len (bytevector-length bv)))
(let loop ((i 0) (a 1) (b 0))
(if (= i len)
(bitwise-ior (bitwise-arithmetic-shift-left b 16) a)
(let ((a* (modulo (+ a (bytevector-u8-ref bv i)) 65521)))
(loop (+ i 1) a* (modulo (+ b a*) 65521)))))))
;; --- byte helpers -----------------------------------------------------------
(define (png-u32be n)
(let ((bv (make-bytevector 4)))
(bytevector-u8-set! bv 0 (bitwise-and (bitwise-arithmetic-shift-right n 24) #xff))
(bytevector-u8-set! bv 1 (bitwise-and (bitwise-arithmetic-shift-right n 16) #xff))
(bytevector-u8-set! bv 2 (bitwise-and (bitwise-arithmetic-shift-right n 8) #xff))
(bytevector-u8-set! bv 3 (bitwise-and n #xff))
bv))
(define (png-bytes . bs) (u8-list->bytevector bs))
(define (png-cat . bvs)
(let* ((total (apply + (map bytevector-length bvs)))
(out (make-bytevector total)))
(let loop ((bvs bvs) (off 0))
(if (null? bvs) out
(let ((n (bytevector-length (car bvs))))
(bytevector-copy! (car bvs) 0 out off n)
(loop (cdr bvs) (+ off n)))))))
;; one PNG chunk: length(4) + type(4) + data + crc32(type+data)(4)
(define (png-chunk type-str data)
(let ((type (string->utf8 type-str)))
(png-cat (png-u32be (bytevector-length data)) type data
(png-u32be (png-crc32 (png-cat type data))))))
;; DEFLATE "stored" stream of raw: ≤65535-byte blocks, each 1 header byte
;; (BFINAL bit) + LEN(2 LE) + NLEN(2 LE) + raw. Wrapped as zlib (0x78 0x01 …
;; adler32).
(define (png-deflate-stored raw)
(let ((len (bytevector-length raw)))
(let loop ((off 0) (acc (list (png-bytes #x78 #x01))))
(if (>= off len)
(apply png-cat (reverse (cons (png-u32be (png-adler32 raw)) acc)))
(let* ((n (min 65535 (- len off)))
(final (if (>= (+ off n) len) 1 0))
(block (png-cat (png-bytes final)
(png-bytes (bitwise-and n #xff) (bitwise-arithmetic-shift-right n 8))
(png-bytes (bitwise-and (bitwise-not n) #xff)
(bitwise-and (bitwise-arithmetic-shift-right (bitwise-not n) 8) #xff))
(let ((b (make-bytevector n))) (bytevector-copy! raw off b 0 n) b))))
(loop (+ off n) (cons block acc)))))))
;; --- the image value --------------------------------------------------------
(define-record-type pimg (fields w h data (mutable cur)) (nongenerative jolt-png-img-v1))
(define (png-clamp-byte n)
(let ((x (cond ((and (number? n) (exact? n) (integer? n)) n)
((number? n) (exact (floor n)))
(else 0))))
(cond ((< x 0) 0) ((> x 255) 255) (else x))))
(define (png-image w h) (make-pimg w h (make-bytevector (* w h 3) 0) 0))
(define (png-put! img r g b)
(let ((d (pimg-data img)) (c (pimg-cur img)))
(when (<= (+ c 3) (bytevector-length d))
(bytevector-u8-set! d c (png-clamp-byte r))
(bytevector-u8-set! d (+ c 1) (png-clamp-byte g))
(bytevector-u8-set! d (+ c 2) (png-clamp-byte b))
(pimg-cur-set! img (+ c 3)))
jolt-nil))
;; scanlines with a 0 (None) filter byte per row -> raw -> zlib -> IDAT
(define (png-raw img w h)
(let* ((stride (* w 3)) (raw (make-bytevector (* h (+ 1 stride)))) (src (pimg-data img)))
(do ((y 0 (+ y 1))) ((= y h) raw)
(let ((ro (* y (+ 1 stride))))
(bytevector-u8-set! raw ro 0) ; filter: None
(bytevector-copy! src (* y stride) raw (+ ro 1) stride)))))
(define png-signature (png-bytes #x89 #x50 #x4e #x47 #x0d #x0a #x1a #x0a))
(define (png-ihdr w h)
(png-cat (png-u32be w) (png-u32be h)
(png-bytes 8 2 0 0 0))) ; bitdepth 8, colortype 2 (RGB), deflate, filter 0, no interlace
(define (png-write img w h path)
(let* ((idat (png-deflate-stored (png-raw img w h)))
(bytes (png-cat png-signature
(png-chunk "IHDR" (png-ihdr w h))
(png-chunk "IDAT" idat)
(png-chunk "IEND" (make-bytevector 0))))
(p (open-file-output-port path (file-options no-fail) (buffer-mode block))))
(put-bytevector p bytes)
(close-port p)
jolt-nil))
(def-var! "jolt.png" "image" png-image)
(def-var! "jolt.png" "put!" png-put!)
(def-var! "jolt.png" "write" png-write)

View file

@ -1,150 +0,0 @@
;; post-prelude overrides — loaded AFTER the assembled clojure.core
;; prelude, so these win over the overlay's own def-var!.
;;
;; A few clojure.core predicates are implemented in the overlay by inspecting a
;; tagged value's :jolt/type key (e.g. (get x :jolt/type)). That key doesn't
;; exist for native representations: a jolt char is a Scheme char, an atom is a
;; Chez record. The overlay's def-var! loads after rt.ss, so it clobbers the
;; correct native shims (predicates.ss / atoms.ss) with versions that return
;; false on every Chez value. Re-assert the native versions here.
(def-var! "clojure.core" "char?" jolt-char-pred?)
(def-var! "clojure.core" "atom?" jolt-atom?)
;; atom watches/validators: the overlay drives these via jolt.host/ref-put! on a
;; tagged table (get a :watches), which a Chez atom record is not — re-assert the
;; native versions (defined in atoms.ss), and swap!/reset! notify+validate there.
(def-var! "clojure.core" "add-watch" jolt-add-watch)
(def-var! "clojure.core" "remove-watch" jolt-remove-watch)
(def-var! "clojure.core" "set-validator!" jolt-set-validator!)
(def-var! "clojure.core" "get-validator" jolt-get-validator)
;; volatiles: a Chez volatile is a jvol record, but the overlay vreset!/vswap!/
;; volatile? drive it via jolt.host/ref-put!+get / :jolt/type (tagged-table only).
;; Override with the native versions (defined in natives-transduce.ss).
(def-var! "clojure.core" "vreset!" jolt-vreset!)
(def-var! "clojure.core" "vswap!" jolt-vswap!)
(def-var! "clojure.core" "volatile?" jolt-volatile-pred?)
;; bound?: the overlay reads (get v :root) — nil on a Chez var-cell record, so it
;; would wrongly report every var unbound. Native version (defined in vars.ss).
(def-var! "clojure.core" "bound?" jolt-bound?)
;; uuid?/random-uuid/parse-uuid/tagged-literal? are overlay (read :jolt/type or
;; build tagged tables) — re-assert the native versions (natives-misc.ss).
(def-var! "clojure.core" "uuid?" jolt-uuid-pred?)
(def-var! "clojure.core" "random-uuid" jolt-random-uuid)
(def-var! "clojure.core" "parse-uuid" jolt-parse-uuid)
(def-var! "clojure.core" "tagged-literal?" jolt-tagged-literal-pred?)
;; ns-name: the overlay reads (get ns :name) — nil on a jns namespace record.
;; Native version (defined in ns.ss) returns the namespace's name symbol.
(def-var! "clojure.core" "ns-name" jolt-ns-name)
;; concurrency: the overlay's future-done?/future-cancelled?/realized? read a
;; future-map's :cached/:cancelled keys, and promise/deliver are a non-blocking
;; atom shim. A Chez future/promise is a record, and we want JVM (blocking,
;; shared-heap) semantics — re-assert the native versions. realized?
;; wraps the overlay (which still handles delay/lazy-seq/atom) for non-futures.
(def-var! "clojure.core" "future-done?" jolt-native-future-done?)
(def-var! "clojure.core" "future-cancelled?" jolt-native-future-cancelled?)
(def-var! "clojure.core" "future?" jolt-future?)
(def-var! "clojure.core" "promise" jolt-promise-new)
(def-var! "clojure.core" "deliver" jolt-deliver)
;; agents: the overlay (50-io) is a synchronous shim (agent = atom, send applies
;; immediately). Re-assert the native async agents (per-agent serialized worker),
;; matching the JVM. await/restart-agent are new (the overlay has neither).
(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" "deref" jolt-deref)
(let ((overlay-realized? (var-deref "clojure.core" "realized?")))
(def-var! "clojure.core" "realized?"
(lambda (x)
(cond
((or (jolt-future? x) (jolt-promise? x) (jolt-delay? x)) (jolt-conc-realized? x))
;; 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.
(def-var! "clojure.edn" "read"
(case-lambda
((reader) (chez-edn-read reader))
((opts reader)
(jolt-invoke (var-deref "clojure.edn" "read-string") opts
(if (reader-jhost? reader) (drain-reader reader) (jolt-str-render-one reader))))))
;; line-seq: a jhost reader (io/reader result) -> drain+split; a map-reader (the
;; overlay's :read-line-fn model, e.g. with-in-str) -> the overlay version.
(let ((overlay-line-seq (var-deref "clojure.core" "line-seq")))
(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. 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?)
;; 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 — 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
;; pushback-reader) — cuerdas' string interpolation — would miss. Intercept a host
;; reader; everything else (the *in* reify) delegates to the overlay.
(let ((ov-read (var-deref "clojure.core" "read")))
(def-var! "clojure.core" "read"
(case-lambda
(() (jolt-invoke ov-read))
((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))))
(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)))
(else ev)))
(jolt-invoke ov-read stream e? ev))))))
(let ((ov-rps (var-deref "clojure.core" "read+string")))
(def-var! "clojure.core" "read+string"
(case-lambda
(() (jolt-invoke ov-rps))
((stream) (jolt-invoke (var-deref "clojure.core" "read+string") stream #t jolt-nil))
((stream e? ev)
(if (reader-jhost? stream)
(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))
(jolt-vector ev "")))
(let ((rest (jolt-nth pr 1)))
(reader-refill! stream rest)
(jolt-vector (jolt-nth pr 0) (substring s 0 (- (string-length s) (string-length rest)))))))
(jolt-invoke ov-rps stream e? ev))))))

View file

@ -1,110 +0,0 @@
;; type predicates + simple accessors — host-coupled natives.
;;
;; These are host primitives (not clojure.core overlay fns), so they're never
;; def-var!'d by the assembled prelude; the Chez host must provide them.
;; map?/vector?/set? are STRICT over the persistent-collection records, seq? is
;; true only for real sequences, coll? is the union. Record arms are added by
;; records.ss, which extends these dispatchers.
(define (jolt-map? x) (pmap? x))
;; a map entry is a pvec under the hood AND is vector? — Clojure's MapEntry
;; implements IPersistentVector, so (vector? (first {:a 1})) is true.
(define (jolt-vector? x) (pvec? x))
(define (jolt-set? x) (pset? x))
(define (jolt-seq? x) (or (cseq? 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) (jolt-lazyseq? x)))
(define (jolt-number? x) (number? x))
(define (jolt-string? x) (string? x))
(define (jolt-char-pred? x) (char? x))
;; JVM-parity number-type predicates over the Chez numeric tower. integer? is the
;; INTEGER TYPE (exact integer = Long/BigInt), NOT integer-VALUED: (integer? 3.0)
;; is false on the JVM (3.0 is a Double). float? = flonum (double). ratio? = exact
;; non-integer (= JVM Ratio). rational? = exact (integer or ratio; jolt has no
;; 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)))
;; 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). 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.
(define (jolt-name x)
(cond
((keyword? x) (keyword-t-name x))
((symbol-t? x) (symbol-t-name x))
((string? x) x)
(else (error #f "name: expected string/symbol/keyword" x))))
;; (namespace x): keyword/symbol ns string, or nil when unqualified.
(define (jolt-namespace x)
(let ((ns (cond ((keyword? x) (keyword-t-ns x))
((symbol-t? x) (symbol-t-ns x))
(else (error #f "namespace: expected symbol/keyword" x)))))
(if (or (jolt-nil? ns) (not ns) (eq? ns '())) jolt-nil ns)))
(def-var! "clojure.core" "nil?" jolt-nil?)
(def-var! "clojure.core" "number?" jolt-number?)
(def-var! "clojure.core" "string?" jolt-string?)
(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" "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
;; otherwise). Uses Scheme = (value across the tower), not jolt= (category-aware).
(define (jolt-num-equiv . xs)
;; 1-arity short-circuits to true for ANY value (Clojure's == 1-arg returns true
;; before the number check); 2+ args must all be numbers.
(if (and (pair? xs) (null? (cdr xs)))
#t
(let all-num? ((ys xs))
(cond
((null? ys) (or (null? xs) (apply = xs)))
((number? (car ys)) (all-num? (cdr ys)))
(else (error #f "== requires numbers" xs))))))
(def-var! "clojure.core" "==" jolt-num-equiv)
(def-var! "clojure.core" "symbol?" jolt-symbol?)
(def-var! "clojure.core" "keyword?" keyword?)
(def-var! "clojure.core" "map?" jolt-map?)
(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" "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

@ -1,144 +0,0 @@
;; readable printer + output seams — the __pr-str1 / __write / __with-out-str
;; host seams the overlay's pr-str/pr/prn/print/println/*-str family is built on
;; (jolt-core/clojure/core/20-coll.clj).
;;
;; jolt-pr-str (rt.ss) is STR-style: strings render raw. pr-str needs READABLE
;; (pr) style: strings quoted+escaped at every nesting level. This adds the
;; readable renderer; it mirrors jolt-pr-str but quotes strings and recurses into
;; itself, delegating scalars (nil/bool/number/keyword/symbol/char/regex) to
;; jolt-pr-str (already readable for those). The canonical ORDERED printer is
;; still future work — unordered colls render in HAMT order, compared via `=`.
;; inner string escape (no surrounding quotes): " \ newline tab return.
(define (jolt-str-escape s)
(let loop ((cs (string->list s)) (acc '()))
(if (null? cs)
(list->string (reverse acc))
(loop (cdr cs)
(let ((c (car cs)))
(case c
((#\") (cons #\" (cons #\\ acc)))
((#\\) (cons #\\ (cons #\\ acc)))
((#\newline) (cons #\n (cons #\\ acc)))
((#\tab) (cons #\t (cons #\\ acc)))
((#\return) (cons #\r (cons #\\ acc)))
(else (cons c acc))))))))
;; A host shim registers a type's readable rendering via register-pr-readable-arm!,
;; or register-pr-arm! for types whose str and readable forms match (most host types:
;; inst, uuid, record, var, …). Disjoint types, checked before the base cases.
(define jolt-pr-readable-arms '())
(define (register-pr-readable-arm! pred render)
(set! jolt-pr-readable-arms (cons (cons pred render) jolt-pr-readable-arms)))
(define (register-pr-arm! pred render)
(register-pr-str-arm! pred render)
(register-pr-readable-arm! pred render))
(define (jolt-pr-readable-base x)
(cond
((string? x) (string-append "\"" (jolt-str-escape x) "\""))
;; pr renders the infinities / NaN in READABLE form (##Inf reads back), unlike
;; str's "Infinity"/"-Infinity"/"NaN". Applies at every nesting level.
((and (flonum? x) (fl= x +inf.0)) "##Inf")
((and (flonum? x) (fl= x -inf.0)) "##-Inf")
((and (flonum? x) (not (fl= x x))) "##NaN")
;; transients print as a cold tagged type (print-method routes this through a
;; multimethod; the readable fallback renders it directly).
;; forward refs to transients.ss (loaded later) — resolved at call time.
((jolt-transient? x)
(case (jolt-transient-kind x)
((vec) "#<transient vector>") ((set) "#<transient set>") (else "#<transient map>")))
((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))
(cond ((null? as) (jolt-pr-readable-base x))
(((caar as) x) ((cdar as) x))
(else (loop (cdr as))))))
;; *print-meta* support. The var is def'd after this file loads, so capture its
;; cell lazily; jolt-var-get (patched by dyn-binding.ss) honors a `binding`.
(define pr-meta-cell #f)
(define (pr-print-meta?)
(unless pr-meta-cell (set! pr-meta-cell (jolt-var "clojure.core" "*print-meta*")))
(jolt-truthy? (jolt-var-get pr-meta-cell)))
;; The metadata to print before x, or jolt-nil. A var prints as #'ns/name (its
;; {:ns :name} is derived, not user metadata) and a procedure is opaque — skip both.
(define (pr-user-meta x)
(if (or (var-cell? x) (procedure? x)) jolt-nil (jolt-meta x)))
(define (jolt-pr-readable x)
(if (pr-print-meta?)
(let ((m (pr-user-meta x)))
(if (jolt-nil? m)
(jolt-pr-readable-dispatch x)
(string-append "^" (jolt-pr-readable-dispatch m) " " (jolt-pr-readable-dispatch x))))
(jolt-pr-readable-dispatch x)))
;; __pr-str1: render ONE value readably (the overlay's pr-str joins these).
(define (jolt-pr-str1 x) (jolt-pr-readable x))
;; __write: push a string to output. Normally this goes to the current Chez port
;; (so __with-out-str's redirect captures it). When clojure.pprint is active it
;; installs __pprint-write-hook; jolt-write then offers each string to the hook,
;; which routes it column-aware into a clojure.pprint pretty-writer if *out* is
;; bound to one (returns truthy) and otherwise declines (returns nil) so the
;; string falls through to the port. This is the JVM behaviour where core print
;; honours *out*; jolt only needs it for the pretty-printer.
(define jolt-pprint-write-hook jolt-nil)
;; suppressed while __with-out-str captures output to a string port: there the
;; redirect, not *out*, defines where text goes (pr-str / print-str rely on it).
(define jolt-pprint-hook-suppressed (make-thread-parameter #f))
(define (jolt-write s)
(if (and (not (jolt-nil? jolt-pprint-write-hook))
(not (jolt-pprint-hook-suppressed))
(jolt-truthy? (jolt-invoke jolt-pprint-write-hook s)))
jolt-nil
(begin (display s) jolt-nil)))
(def-var! "clojure.core" "__set-pprint-write-hook!"
(lambda (f) (set! jolt-pprint-write-hook f) jolt-nil))
;; clojure.pprint wraps its writing in this so core print routes into the active
;; pretty-writer even under an outer with-out-str (which sets suppressed). A
;; pr-str/print-str nested inside then re-suppresses, so its capture still works.
(def-var! "clojure.core" "__with-pprint-routing"
(lambda (thunk)
(parameterize ((jolt-pprint-hook-suppressed #f)) (jolt-invoke thunk))))
;; __with-out-str: run a jolt thunk with *out* rebound to a string port, return
;; the captured text.
(define (jolt-with-out-str thunk)
(with-output-to-string
(lambda () (parameterize ((jolt-pprint-hook-suppressed #t)) (jolt-invoke thunk)))))
;; __eprint / __eprintf: stderr seams. Flush each write — like the JVM's
;; auto-flushing System.err — so a long-running process (a server that never
;; returns from -main) shows its log lines instead of leaving them in a buffer
;; that only drains at exit.
(define (jolt-eprint s)
(display s (current-error-port))
(flush-output-port (current-error-port))
jolt-nil)
(define (jolt-eprintf fmt . args)
(apply fprintf (current-error-port) fmt args)
(flush-output-port (current-error-port))
jolt-nil)
(def-var! "clojure.core" "__pr-str1" jolt-pr-str1)
(def-var! "clojure.core" "__write" jolt-write)
(def-var! "clojure.core" "__with-out-str" jolt-with-out-str)
(def-var! "clojure.core" "__eprint" jolt-eprint)
(def-var! "clojure.core" "__eprintf" jolt-eprintf)

File diff suppressed because it is too large Load diff

File diff suppressed because it is too large Load diff

View file

@ -1,274 +0,0 @@
;; regex on Chez via vendored irregex.
;;
;; Chez has no regex at all. We vendor
;; Alex Shinn's irregex (vendor/irregex, BSD) — a portable Scheme regex with
;; PCRE/Java-style STRING patterns — and wrap jolt's re-* surface over it.
;;
;; irregex maps cleanly onto the Clojure fns: irregex-match is an anchored
;; whole-string match (= re-matches), irregex-search finds the first match
;; anywhere (= re-find), irregex-match-substring extracts group N (0 = whole).
;; Results follow Clojure shape: a 0-group match is the whole string; a grouped
;; match is a jolt VECTOR [whole g1 ...] (a non-participating group is nil); a nil
;; result is jolt-nil; re-seq is a jolt seq (nil when there are no matches).
;;
;; The re-* fns are def-var!'d into clojure.core so prelude / -e code resolves
;; them at runtime (they're NOT subset native-ops: irregex's Unicode/property-
;; class semantics keep them out
;; of the subset-parity corpus). Loaded from rt.ss after def-var! is defined.
;; irregex.scm is portable R[457]RS; two small adaptations for Chez's top level:
;; a cond-expand at expression position (Chez's is library-only), and `error`
;; called with a lone string (Chez's error wants who+msg). The wrapper normalizes
;; both without changing behavior for valid patterns.
(define-syntax cond-expand
(syntax-rules (else)
((_ (else e ...)) (begin e ...))
((_ (else e ...) c ...) (begin e ...))
((_ (req e ...) c ...) (cond-expand c ...))
((_) (if #f #f))))
(define %chez-error error)
(define (error . args)
(if (and (pair? args) (string? (car args)))
(apply %chez-error #f args)
(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
;; UTF-8 high bytes counted as letters, which a Unicode-char Scheme string can't
;; reproduce byte-for-byte; the corpus tests ASCII inputs, where they agree. An
;; unmapped name is left as-is (irregex errors, as before — no new behavior). The
;; ORIGINAL source is kept for printing; only the compiled pattern is translated.
(define (prop-class name)
(cond
;; L/Alpha: ASCII letters + non-ASCII up to just below the UTF-16 surrogate gap
;; (D800). This covers essentially every real letter (Latin/Greek/Cyrillic/CJK/…
;; live below D800); the supplementary planes above it are rare and a range that
;; reaches them makes irregex's char-set construction call integer->char on a
;; surrogate and crash. N/Z stay ASCII-only.
((or (string=? name "L") (string=? name "Alpha")) "a-zA-Z\\x80-\\x{D7FF}")
((string=? name "Lu") "A-Z")
((string=? name "Ll") "a-z")
((or (string=? name "N") (string=? name "Nd") (string=? name "Digit")) "0-9")
((or (string=? name "Z") (string=? name "Zs")) " ")
((string=? name "Ps") "([{")
((string=? name "Pe") ")\\]}")
(else #f)))
;; Tracks whether the cursor is inside a [...] char class: a \p{X} there emits the
;; class CONTENT (inlined), standalone it emits a wrapping [X]. Escapes
;; (\[, \]) don't toggle the class. \P (negation) only wraps when standalone.
(define (translate-prop-classes src)
(let ((len (string-length src)) (out (open-output-string)))
(let loop ((i 0) (in-class #f))
(if (fx>=? i len)
(get-output-string out)
(let ((c (string-ref src i)))
(cond
;; \p{Name} / \P{Name}
((and (char=? c #\\) (fx<? (fx+ i 2) len)
(let ((p (string-ref src (fx+ i 1)))) (or (char=? p #\p) (char=? p #\P)))
(char=? (string-ref src (fx+ i 2)) #\{))
(let* ((close (let scan ((j (fx+ i 3)))
(cond ((fx>=? j len) #f)
((char=? (string-ref src j) #\}) j)
(else (scan (fx+ j 1))))))
(cls (and close (prop-class (substring src (fx+ i 3) close)))))
(cond
((not cls) (write-char c out) (loop (fx+ i 1) in-class))
(in-class (display cls out) (loop (fx+ close 1) in-class))
(else
(display "[" out)
(when (char=? (string-ref src (fx+ i 1)) #\P) (display "^" out))
(display cls out) (display "]" out)
(loop (fx+ close 1) in-class)))))
;; any other escape: copy the pair verbatim, don't toggle class state
((and (char=? c #\\) (fx<? (fx+ i 1) len))
(write-char c out) (write-char (string-ref src (fx+ i 1)) out)
(loop (fx+ i 2) in-class))
((and (not in-class) (char=? c #\[))
(write-char c out) (loop (fx+ i 1) #t))
((and in-class (char=? c #\]))
(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
;; and pass the equivalent option symbols. Scoped groups ((?:…), (?=…), (?<n>…))
;; and groups with a flag irregex can't express are left untouched for irregex.
(define (regex-flag->opt c)
(cond ((char=? c #\s) 'single-line) ; DOTALL — . matches newline
((char=? c #\i) 'case-insensitive)
((char=? c #\m) 'multi-line) ; ^/$ match at line boundaries
(else #f)))
(define (regex-parse-flags src)
(let loop ((s src) (opts '()))
(if (and (>= (string-length s) 4)
(char=? (string-ref s 0) #\() (char=? (string-ref s 1) #\?))
(let scan ((i 2) (fs '()))
(cond
((>= i (string-length s)) (values (reverse opts) s))
((char=? (string-ref s i) #\))
(let ((mapped (map regex-flag->opt fs)))
(if (and (pair? fs) (for-all (lambda (x) x) mapped))
(loop (substring s (+ i 1) (string-length s)) (append opts mapped))
(values (reverse opts) s)))) ; unmappable flag — leave as-is
((char=? (string-ref s i) #\:) (values (reverse opts) s)) ; scoped group
(else (scan (+ i 1) (cons (string-ref s i) fs)))))
(values (reverse opts) s))))
;; 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)))
(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)))
;; An irregex match -> the Clojure result: whole string (no groups) or the
;; [whole g1 ... gn] vector (nil for a non-participating group).
(define (irx-result m)
(let ((n (irregex-match-num-submatches m)))
(if (= n 0)
(irregex-match-substring m 0)
(let loop ((i n) (acc '()))
(if (< i 0)
(apply jolt-vector acc)
(let ((s (irregex-match-substring m i)))
(loop (- i 1) (cons (if s s jolt-nil) acc))))))))
(define (jolt-re-matches re s)
(let ((m (irregex-match (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
;; nil, so (if-let [m (re-seq ...)] ...) works).
(define (jolt-re-seq re s)
(let ((irx (regex-t-irx (jolt-re-pattern re)))
(len (string-length s)))
(let loop ((start 0) (acc '()))
(let ((m (and (<= start len) (irregex-search irx s start))))
(if m
(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?)

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