Compare commits
No commits in common. "main" and "stage2-tier6-ns-fns" have entirely different histories.
main
...
stage2-tie
313 changed files with 18691 additions and 46616 deletions
236
.github/workflows/release.yml
vendored
236
.github/workflows/release.yml
vendored
|
|
@ -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
|
||||
90
.github/workflows/tests.yml
vendored
90
.github/workflows/tests.yml
vendored
|
|
@ -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
|
||||
- uses: actions/checkout@v4
|
||||
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
|
||||
- name: Cache Janet build
|
||||
id: cache-janet
|
||||
uses: actions/cache@v4
|
||||
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
4
.gitignore
vendored
|
|
@ -1,8 +1,4 @@
|
|||
AGENTS.md
|
||||
.DS_Store
|
||||
CLAUDE.md
|
||||
build/
|
||||
target/
|
||||
.clj-kondo/
|
||||
.dirge/
|
||||
.claude/
|
||||
|
|
|
|||
3
.gitmodules
vendored
3
.gitmodules
vendored
|
|
@ -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
96
AGENTS.md
Normal 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
70
CLAUDE.md
Normal 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
367
LICENSE
|
|
@ -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
172
Makefile
|
|
@ -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
398
README.md
|
|
@ -2,233 +2,255 @@
|
|||
|
||||
[](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
|
||||
[doc/building-and-deps.md](doc/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 1–2 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 [`doc/grammar.ebnf`](doc/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
1
bench/.gitignore
vendored
|
|
@ -1 +0,0 @@
|
|||
.cpcache/
|
||||
120
bench/README.md
120
bench/README.md
|
|
@ -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.6–7.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 (~10–15×)** 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 (~8–10×) 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.
|
||||
|
|
@ -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"))))
|
||||
|
|
@ -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"))))
|
||||
|
|
@ -1 +0,0 @@
|
|||
{:paths ["."]}
|
||||
|
|
@ -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"))))
|
||||
|
|
@ -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"))))
|
||||
|
|
@ -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))
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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"))))
|
||||
70
bench/run.sh
70
bench/run.sh
|
|
@ -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
|
||||
41
bin/joltc
41
bin/joltc
|
|
@ -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 "$@"
|
||||
|
||||
117
doc/building-and-deps.md
Normal file
117
doc/building-and-deps.md
Normal file
|
|
@ -0,0 +1,117 @@
|
|||
# Building and dependencies
|
||||
|
||||
How to build Jolt from source and how to pull Clojure libraries into a project.
|
||||
|
||||
## 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)
|
||||
jpm build
|
||||
```
|
||||
|
||||
This produces two executables under `build/`:
|
||||
|
||||
- **`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.
|
||||
|
||||
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
|
||||
|
||||
`(require ...)` resolves a namespace to a file by searching an ordered list of
|
||||
source roots — the stdlib first, then any extra roots — trying `<ns>.clj` then
|
||||
`<ns>.cljc` (dots become directories, dashes become underscores). Extra roots
|
||||
come from:
|
||||
|
||||
- `JOLT_PATH` — a colon-separated list of directories (like a classpath), applied
|
||||
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 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 build/jolt myfile.clj
|
||||
```
|
||||
|
||||
## Dependencies via deps.edn
|
||||
|
||||
`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
|
||||
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/tag "1.0.0"}
|
||||
my/helpers {:local/root "../helpers"}}}
|
||||
```
|
||||
|
||||
```bash
|
||||
jolt-deps run -m myapp.main
|
||||
```
|
||||
|
||||
### What's supported
|
||||
|
||||
- **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.
|
||||
|
||||
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 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.
|
||||
|
|
@ -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. *)
|
||||
138
doc/self-hosting-architecture.md
Normal file
138
doc/self-hosting-architecture.md
Normal 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."
|
||||
172
doc/self-hosting-compiler.md
Normal file
172
doc/self-hosting-compiler.md
Normal 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 3–4 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.
|
||||
91
doc/tools-deps.md
Normal file
91
doc/tools-deps.md
Normal file
|
|
@ -0,0 +1,91 @@
|
|||
# deps.edn support — design notes
|
||||
|
||||
How Jolt loads pure-Clojure libraries from a `deps.edn`, and why it's built the
|
||||
way it is. For how to *use* it, see [building-and-deps.md](building-and-deps.md).
|
||||
|
||||
Scope, decided up front:
|
||||
|
||||
- **git + local deps only** — no Maven/`~/.m2` resolution.
|
||||
- **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.
|
||||
- **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 jpm handles dependencies
|
||||
|
||||
jpm's package code (`jpm/pm.janet`) splits into a fetch half and a build half,
|
||||
and we use only the first:
|
||||
|
||||
- **`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/*` and anything else → ignored.
|
||||
|
||||
Each resolved dependency contributes its own `:paths` (default `["src"]`) as
|
||||
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.
|
||||
|
||||
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.
|
||||
|
||||
`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 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).
|
||||
|
||||
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
|
||||
|
||||
- Pure `clj`/`cljc` only — JVM interop, host classes, and unimplemented
|
||||
`clojure.core` corners fail. Coverage is per-function: a namespace can load with
|
||||
most functions working and a few not.
|
||||
- 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).
|
||||
|
||||
## Conformance
|
||||
|
||||
`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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -1,113 +0,0 @@
|
|||
# Building and dependencies
|
||||
|
||||
How to run Jolt from source and how to pull Clojure libraries into a project.
|
||||
|
||||
## Running
|
||||
|
||||
```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")'
|
||||
```
|
||||
|
||||
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.
|
||||
|
||||
`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.
|
||||
|
||||
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.
|
||||
|
||||
## How namespaces are found
|
||||
|
||||
`(require ...)` resolves a namespace to a file by searching an ordered list of
|
||||
source roots — the stdlib first, then any extra roots — trying `<ns>.clj` then
|
||||
`<ns>.cljc` (dots become directories, dashes become underscores). Extra roots
|
||||
come from:
|
||||
|
||||
- `JOLT_PATH` — a colon-separated list of directories (like a classpath), applied
|
||||
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.
|
||||
|
||||
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
|
||||
```
|
||||
|
||||
## 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`):
|
||||
|
||||
```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
|
||||
```
|
||||
|
||||
Example `deps.edn`:
|
||||
|
||||
```clojure
|
||||
{:paths ["src"]
|
||||
:deps {weavejester/medley {:git/url "https://github.com/weavejester/medley"
|
||||
:git/sha "<full-sha>"}
|
||||
my/helpers {:local/root "../helpers"}}}
|
||||
```
|
||||
|
||||
```bash
|
||||
bin/joltc 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.
|
||||
- **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`.
|
||||
|
||||
### What's not
|
||||
|
||||
- **No Maven.** `:mvn/version` deps are skipped with a warning — 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.
|
||||
|
||||
See [`tools-deps.md`](tools-deps.md) for the design rationale.
|
||||
|
|
@ -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).
|
||||
|
|
@ -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
|
||||
|
|
@ -1,179 +0,0 @@
|
|||
# RFC 0001 — A Specification for the Clojure Language
|
||||
|
||||
- **Status**: Draft
|
||||
- **Champions**: jolt maintainers
|
||||
- **Created**: 2026-06-10
|
||||
|
||||
## Summary
|
||||
|
||||
Produce a normative, implementation-independent specification of the Clojure
|
||||
language — the reader, the evaluation model, the special forms, the data types
|
||||
and their equality/hashing/ordering contracts, sequences and laziness, and the
|
||||
`clojure.core` library — to the standard set by R7RS Scheme and the Racket
|
||||
reference. The specification is developed *in this repository*, validated
|
||||
continuously by jolt's executable conformance suite, and intended to be useful
|
||||
to every alternative implementation (ClojureScript, jank, babashka/sci,
|
||||
Basilisp, ClojureCLR, jolt).
|
||||
|
||||
## Motivation
|
||||
|
||||
Clojure has no specification. The language is defined by:
|
||||
|
||||
1. the reference JVM implementation's source,
|
||||
2. docstrings (frequently silent on edge cases),
|
||||
3. community folklore (ClojureDocs examples, mailing-list threads),
|
||||
4. each alternative implementation's reverse-engineering effort.
|
||||
|
||||
Every alternative implementation independently re-derives answers to the same
|
||||
questions — *what does `(nth coll nil)` do? is `(first "")` an error? does
|
||||
`conj` on `nil` produce a list or vector? in what order does `reduce-kv` visit
|
||||
a map?* — and they routinely diverge. The cross-dialect
|
||||
[clojure-test-suite](https://github.com/jank-lang/clojure-test-suite) exists
|
||||
precisely because these divergences are real and frequent: it currently
|
||||
encodes hundreds of edge-case assertions that no normative document captures.
|
||||
|
||||
Building jolt's self-hosted compiler forced us to answer these questions
|
||||
one at a time (the conformance harness runs every behavior through three
|
||||
independent execution paths and demands agreement). That work product — over
|
||||
300 three-way-validated conformance assertions, ~1,500 behavioral spec cases,
|
||||
and a frozen catalog of which forms are language vs. host — is the seed of a
|
||||
specification, currently trapped in test files. This RFC proposes promoting it
|
||||
into prose with normative force.
|
||||
|
||||
### Why us / why now
|
||||
|
||||
A useful spec needs an implementation that can *afford* to be strict. The
|
||||
reference implementation can't adopt a spec retroactively without breaking
|
||||
changes; an alternative implementation chasing drop-in compatibility can't
|
||||
deviate from the reference even where the reference is accidental. jolt's
|
||||
goals (self-hosted, minimal seed, multiple execution paths that must agree)
|
||||
already require us to decide, for every form, *what the contract is* — we are
|
||||
writing the spec anyway, in test form. The marginal cost of writing it down
|
||||
properly is small; the value to the ecosystem is large.
|
||||
|
||||
## Goals
|
||||
|
||||
1. **Normative core**: reader grammar, evaluation model, all special forms,
|
||||
data types with equality/hashing/ordering contracts, seq/laziness
|
||||
contracts, namespaces/vars, and per-var entries for the portable
|
||||
`clojure.core` surface.
|
||||
2. **Executable**: every normative statement is paired with at least one
|
||||
conformance test. The spec and the suite are maintained together; a spec
|
||||
claim without a test is marked `unverified`.
|
||||
3. **Host classification**: every `clojure.core` var is classified
|
||||
**portable** (specified normatively), **host-dependent** (interface
|
||||
specified, behavior host-defined — e.g. `slurp`, `*out*`), or
|
||||
**JVM-specific** (documented as outside the portable language — e.g.
|
||||
`bases`, `definline`, agents/STM as currently scoped).
|
||||
4. **Versioned against reference Clojure**: each spec edition states the
|
||||
reference version it describes (initially 1.12) and records *deliberate*
|
||||
divergences (e.g. where reference behavior is accidental — these become
|
||||
labeled "implementation-defined" with the reference behavior noted).
|
||||
5. **Useful to other implementations**: no jolt-specific concepts in
|
||||
normative text. jolt appears only in conformance-suite references.
|
||||
|
||||
## Non-goals
|
||||
|
||||
- Specifying the JVM interop surface (`proxy`, `gen-class`, `.`-forms beyond
|
||||
their syntax), agents, STM refs, or the Java class hierarchy mapping.
|
||||
These are catalogued as host/JVM surface, not specified.
|
||||
- Specifying `clojure.spec`, `core.async`, or other contrib libraries
|
||||
(candidates for later, separate documents).
|
||||
- Changing the language. The spec describes Clojure as it is; divergence
|
||||
decisions document reality, they don't invent semantics.
|
||||
- Replacing clojure-test-suite — we contribute to it and cite it.
|
||||
|
||||
## The specification document
|
||||
|
||||
Lives in `docs/spec/`. Shape (mirroring R7RS chapters):
|
||||
|
||||
| § | Document | Content |
|
||||
|---|---|---|
|
||||
| 0 | `00-front-matter.md` | conformance terms (RFC 2119), entry format, host classification |
|
||||
| 1 | `01-evaluation.md` | evaluation model: forms, environments, vars, macroexpansion order |
|
||||
| 2 | `02-reader.md` | lexical syntax: formal grammar, all reader macros, reader conditionals |
|
||||
| 3 | `03-special-forms.md` | the special forms, one normative entry each |
|
||||
| 4 | `04-data-types.md` | nil/booleans/numbers/strings/chars/keywords/symbols/colls; equality, hashing, ordering |
|
||||
| 5 | `05-sequences.md` | the seq abstraction, laziness contract, realization boundaries |
|
||||
| 6 | `06-namespaces-vars.md` | namespaces, vars, dynamic binding, resolution |
|
||||
| 7 | `07-polymorphism.md` | protocols, records/types, multimethods, hierarchies |
|
||||
| 8 | `08-macros.md` | defmacro, syntax-quote/hygiene, `&env`/`&form` |
|
||||
| 9 | `09-core-library.md` | normative per-var entries for the portable surface |
|
||||
| A | `coverage.md` | generated status dashboard: 694 vars × {specified, tested, implemented, classification} |
|
||||
|
||||
### The normative entry format
|
||||
|
||||
Every special form and library var gets an entry with these fields
|
||||
(exemplars in `03-special-forms.md` and `09-core-library.md`):
|
||||
|
||||
```
|
||||
### name
|
||||
Signature(s), since-version
|
||||
1. Semantics — numbered MUST/SHOULD statements
|
||||
2. Edge cases — nil, empty, bounds, wrong-type behavior (normative)
|
||||
3. Errors — what MUST throw, and when error type is implementation-defined
|
||||
4. Examples — executable, drawn from ClojureDocs where community-validated
|
||||
5. Conformance — test IDs that verify each numbered statement
|
||||
```
|
||||
|
||||
### Evidence sources, in priority order
|
||||
|
||||
1. **Differential testing** against reference Clojure 1.12 (the ground truth
|
||||
for behavior questions).
|
||||
2. **clojure-test-suite** (cross-dialect agreement = portable semantics;
|
||||
dialect splits = host-dependent candidates).
|
||||
3. **ClojureDocs export** (`clojuredocs-export.edn`, 694 core vars, 648 with
|
||||
community examples) — examples become spec examples after verification.
|
||||
4. **jank's language test corpus** (~800 per-form tests under
|
||||
`test/jank/{form,call,metadata,reader-macro,syntax-quote,var}`) — the
|
||||
per-construct granularity model for §2–§3 conformance.
|
||||
5. Reference implementation source — last resort, for intent.
|
||||
|
||||
## Current baseline (measured 2026-06-10)
|
||||
|
||||
- ClojureDocs inventory: **694** `clojure.core` vars (648 with examples).
|
||||
- jolt implements **572**; **373 (66%)** are exercised by the behavioral
|
||||
spec/conformance suites; 139 implemented-but-untested.
|
||||
- Initial classification of the 182 unimplemented: ~31 dynamic vars, ~20
|
||||
agents/taps, ~11 STM, ~15 special-form docs, ~105 to adjudicate
|
||||
(genuinely-portable gaps spotted already: `compare`, `any?`, `update-keys`,
|
||||
`update-vals`, `parse-long`, `parse-double`, `parse-boolean`,
|
||||
`partitionv`, `splitv-at`, `macroexpand`, `time`, `with-redefs`).
|
||||
- Conformance: 302 assertions × 3 execution paths; ~1,500 behavioral cases;
|
||||
clojure-test-suite ≥ 4081/4707 assertions.
|
||||
|
||||
## Process
|
||||
|
||||
1. **Section by section**, in chapter order. §2 (reader) and §3 (special
|
||||
forms) first — they are the smallest closed sets and jank's corpus gives
|
||||
per-construct conformance shape immediately.
|
||||
2. Each PR that adds/edits normative text MUST add or cite the conformance
|
||||
tests for every numbered statement, and update `coverage.md`.
|
||||
3. Divergences from reference Clojure discovered during writing get filed,
|
||||
then either fixed in jolt or recorded as a labeled divergence — never
|
||||
silently spec'd to jolt's behavior.
|
||||
4. Editions: spec snapshots versioned independently of jolt releases
|
||||
(`Clojure Language Specification, Draft N`).
|
||||
5. When a chapter stabilizes, solicit review from other implementations
|
||||
(jank, babashka, Basilisp maintainers) before marking it Stable.
|
||||
|
||||
## Alternatives considered
|
||||
|
||||
- **Contribute prose to clojure-test-suite instead**: the suite is the right
|
||||
*conformance* home but tests can't express rationale, classification, or
|
||||
grammar; both are needed and they cross-reference.
|
||||
- **Spec only what jolt implements**: rejected — the host classification of
|
||||
the *full* 694-var surface is half the value.
|
||||
- **EDN/data-format spec only** (edn already has a loose spec): far too
|
||||
narrow; the evaluation model and core library are where divergence lives.
|
||||
|
||||
## 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.
|
||||
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
|
||||
once §1–§3 stabilize).
|
||||
|
|
@ -1,95 +0,0 @@
|
|||
# RFC 0002 — Reader-Conditional Feature Set
|
||||
|
||||
- **Status**: Superseded (2026-06-25) — jolt now includes `:clj` in the default
|
||||
set; see the note below.
|
||||
- **Created**: 2026-06-10
|
||||
- **Spec**: `docs/spec/02-reader.md` §2.3 S18
|
||||
|
||||
> **Update (2026-06-25).** The default set is now **`#{:jolt :clj :default}`** —
|
||||
> `:clj` is satisfied by default. The clj ecosystem's `.cljc` libraries gate
|
||||
> their host code behind `#?(:clj …)` with no `:jolt`/`:default` fallback, so
|
||||
> the conformance libraries (core.cache, core.match, tick, malli, …) only load
|
||||
> with `:clj` present; requiring an opt-in for each was friction with no payoff
|
||||
> once jolt's `clojure.lang.*`/`java.*` emulation was broad enough to run those
|
||||
> `:clj` branches. Matching is still by **clause order**, so a library can place
|
||||
> a `:jolt` branch first to override. There is no `JOLT_FEATURES` environment
|
||||
> variable; a loading context overrides the set at runtime with
|
||||
> `reader-features-set!`. The rest of this RFC is the original (reverted)
|
||||
> design.
|
||||
|
||||
## Summary
|
||||
|
||||
jolt's reader-conditional feature set is **`#{:jolt :default}`**, matched in
|
||||
**clause order** (the first clause whose key the platform satisfies wins).
|
||||
A loading context may opt a foreign, clj-targeted library into `:clj`
|
||||
compatibility via `reader-features-set!` (or process-wide via the
|
||||
`JOLT_FEATURES` environment variable). jolt does **not** satisfy `:clj` by
|
||||
default.
|
||||
|
||||
## Background
|
||||
|
||||
`#?(:clj … :cljs … :default …)` selects a branch by platform feature at read
|
||||
time. Until now jolt satisfied `:clj` — a compatibility shortcut inheriting
|
||||
the JVM branches of `.cljc` files, on the theory that the `:clj` branch is
|
||||
usually the "main" implementation. Each dialect chooses its own policy:
|
||||
ClojureScript satisfies only `:cljs`; jank uses `:jank`; babashka includes
|
||||
`:clj` because it genuinely is JVM-Clojure-compatible to a deep degree.
|
||||
|
||||
Two defects forced the decision:
|
||||
|
||||
1. jolt is *not* JVM-compatible where it matters for `:clj` branches: they
|
||||
contain interop (`java.util.*`, `deftype` over JVM classes) and encode
|
||||
JVM-specific *expectations* in tests (e.g. `parse-uuid`'s reference
|
||||
permissiveness), both of which jolt fails.
|
||||
2. The old implementation also matched by **key priority** (`:clj` first,
|
||||
then `:default`) rather than clause order — `#?(:default 5 :clj 6)` read
|
||||
as `6`, diverging from Clojure on all platforms.
|
||||
|
||||
## Decision and evidence
|
||||
|
||||
Measured A/B over the cross-dialect clojure-test-suite (identical tree,
|
||||
2026-06-10):
|
||||
|
||||
| Feature set | Assertions reached | Pass | Fail | Error | Clean files |
|
||||
|---|---|---|---|---|---|
|
||||
| `clj, default` (old) | 4967 | 4324 | 524 | 119 | 78 |
|
||||
| `jolt, default` (new) | **5069** | **4470** | **518** | **81** | **86** |
|
||||
|
||||
The portable convention reads *more* of the suite (`:default` branches were
|
||||
being shadowed by `:clj` ones jolt can't satisfy) and improves every metric:
|
||||
+146 passes, −38 errors, +8 clean files. The `:clj` shortcut was a net
|
||||
liability, not a compatibility win.
|
||||
|
||||
The opposing case — loading real-world clj-targeted libraries — is real:
|
||||
SCI's `.cljc` sources select their implementation via `#?(:clj …)`/`:cljs`
|
||||
with no `:jolt` branches, and fail to load under the portable set. That is a
|
||||
property of the **loading context**, not of the platform: the resolution is
|
||||
per-context opt-in, exactly how the SCI bootstrap now loads
|
||||
(`(reader-features-set! ["jolt" "clj" "default"])`).
|
||||
|
||||
## Specification (normative, mirrored in spec §2.3 S18)
|
||||
|
||||
1. The platform feature set is implementation-defined and MUST be
|
||||
documented. jolt's is `#{:jolt :default}`.
|
||||
2. Matching MUST be by clause order: the first clause whose key is in the
|
||||
feature set wins. `:default` matches on every platform.
|
||||
`#?(:default 5 :clj 6)` is `5` everywhere.
|
||||
3. An unmatched conditional reads as nothing (no form); an unmatched
|
||||
`#?@(…)` splices nothing.
|
||||
4. Implementations SHOULD provide a per-loading-context override so foreign
|
||||
libraries written for other dialects can be read under a compatibility
|
||||
set; using it is a deliberate, scoped decision (jolt:
|
||||
`reader-features-set!` / `JOLT_FEATURES`).
|
||||
|
||||
## Consequences
|
||||
|
||||
- Suite baselines re-measured and raised: `baseline-pass` 4324 → 4470,
|
||||
`baseline-clean-files` 78 → 86.
|
||||
- Reader tests assert the portable set + clause-order semantics, plus one
|
||||
opt-in round-trip through `reader-features-set!`.
|
||||
- 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).
|
||||
- `.cljc` authors targeting jolt can write `:jolt` branches and rely on
|
||||
`:default` fallbacks.
|
||||
|
|
@ -1,108 +0,0 @@
|
|||
# RFC 0003: Transients — semantics and the Chez mutable backing
|
||||
|
||||
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
|
||||
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:
|
||||
|
||||
- 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` 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).
|
||||
|
||||
Read ops work on an active transient where Clojure supports them: `get`,
|
||||
`contains?`, `count`, and `nth` (vector kind) see through the transient.
|
||||
`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
|
||||
pattern
|
||||
|
||||
(persistent! (reduce conj! (transient []) coll))
|
||||
|
||||
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.
|
||||
|
||||
**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
|
||||
Clojure — documented, not checked, same as the JVM.
|
||||
|
||||
**`(conj!)` / `(conj! t)` arities** follow Clojure's transducer-era contract:
|
||||
zero args makes a fresh `(transient [])`, one arg returns it untouched.
|
||||
`assoc!` tolerates a dangling final key (treated as `k nil`), matching the
|
||||
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.
|
||||
|
||||
## Why transients live in the host
|
||||
|
||||
Transients are part of the value/representation layer in the Chez runtime
|
||||
(`host/chez/transients.ss`), not the portable `clojure.core` overlay, 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).
|
||||
|
||||
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*.
|
||||
|
||||
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.
|
||||
|
||||
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!`.
|
||||
|
||||
## 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.
|
||||
- `transient?` (Jolt extension, useful in tests) stays; Clojure has no public
|
||||
predicate, so it must not leak into portability-sensitive code.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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 3–4 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.
|
||||
|
|
@ -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).
|
||||
|
|
@ -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.
|
||||
|
|
@ -1,88 +0,0 @@
|
|||
# Clojure Language Specification — Front Matter
|
||||
|
||||
**Edition**: Draft 1 · **Describes**: Clojure 1.12 (reference) · **Status**: in progress
|
||||
|
||||
This document specifies the Clojure programming language independently of any
|
||||
implementation. See `docs/rfc/0001-language-specification.md` for motivation,
|
||||
process, and scope.
|
||||
|
||||
## 1. Conformance terminology
|
||||
|
||||
The key words **MUST**, **MUST NOT**, **SHOULD**, **SHOULD NOT**, and **MAY**
|
||||
are to be interpreted as described in RFC 2119.
|
||||
|
||||
- A statement marked **MUST** is normative: a conforming implementation
|
||||
exhibits exactly this behavior, and the conformance suite tests it.
|
||||
- **implementation-defined** marks behavior a conforming implementation must
|
||||
document but may choose (e.g. the concrete error type thrown where the
|
||||
reference throws a JVM exception class).
|
||||
- **host-defined** marks behavior delegated to the host platform (e.g. what
|
||||
`slurp` accepts as a source).
|
||||
- **⚠ reference-divergence** marks a place where this spec deliberately
|
||||
differs from observed reference behavior, with rationale; the reference
|
||||
behavior is always recorded alongside.
|
||||
|
||||
## 2. Classification of the core surface
|
||||
|
||||
Every `clojure.core` var carries exactly one classification (dashboard:
|
||||
`coverage.md`):
|
||||
|
||||
| Class | Meaning | Spec treatment |
|
||||
|---|---|---|
|
||||
| **portable** | semantics independent of host | full normative entry (§9) |
|
||||
| **host-dependent** | portable *interface*, host-defined behavior | interface entry; behavior host-defined |
|
||||
| **JVM-specific** | meaningful only on the JVM | catalogued in Appendix; not specified |
|
||||
|
||||
Initial classifications are mechanical and reviewable; reclassification is an
|
||||
ordinary spec change.
|
||||
|
||||
## 3. The normative entry format
|
||||
|
||||
Each special form (§3) and portable var (§9) is specified as:
|
||||
|
||||
```
|
||||
### name — since <version>
|
||||
(signature ...) (signature ...)
|
||||
|
||||
Semantics
|
||||
S1. <numbered normative statement, MUST/SHOULD/MAY>
|
||||
S2. ...
|
||||
Edge cases
|
||||
E1. <nil / empty / bounds / wrong-type behavior — normative>
|
||||
Errors
|
||||
X1. <what MUST throw; error TYPE is implementation-defined unless stated>
|
||||
Examples
|
||||
<executable; verified against the reference; sourced from ClojureDocs
|
||||
where community-validated>
|
||||
Conformance
|
||||
S1 → <suite>/<test id>; E1 → ... (statements without a test: UNVERIFIED)
|
||||
```
|
||||
|
||||
The **Conformance** field is load-bearing: every numbered statement names the
|
||||
test(s) that verify it. A normative statement with no test is labeled
|
||||
`UNVERIFIED` and is a defect in the spec.
|
||||
|
||||
## 4. Evidence and verification
|
||||
|
||||
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.
|
||||
|
||||
## 5. Chapter plan
|
||||
|
||||
| § | File | Status |
|
||||
|---|---|---|
|
||||
| 1 | `01-evaluation.md` | planned |
|
||||
| 2 | `02-reader.md` | **drafted** (grammar + reader-macro catalog; 2 divergences open) |
|
||||
| 3 | `03-special-forms.md` | **exemplars written** (`if`, `let*`); catalog complete |
|
||||
| 4 | `04-data-types.md` | planned (numeric-tower design note required) |
|
||||
| 5 | `05-sequences.md` | planned (laziness contract from jolt Phase-5 work) |
|
||||
| 6 | `06-namespaces-vars.md` | planned |
|
||||
| 7 | `07-polymorphism.md` | planned |
|
||||
| 8 | `08-macros.md` | planned |
|
||||
| 9 | `09-core-library.md` | **exemplars written** (`first`, `reduce`, `parse-uuid`) |
|
||||
| A | `coverage.md` | **generated** (regenerate: `python3 tools/spec_coverage.py`) |
|
||||
|
|
@ -1,255 +0,0 @@
|
|||
# §2 The Reader (Lexical Syntax)
|
||||
|
||||
**Status**: token grammar drafted; reader-macro catalog complete with
|
||||
normative entries; #inst and literal-collapse divergences resolved.
|
||||
Conformance: jolt `reader-forms-spec` + `reader-syntax-spec` (granularity
|
||||
model: jank's per-construct corpus, 62 files under
|
||||
`test/jank/{reader-macro,syntax-quote}` — adapted rows cited per entry).
|
||||
|
||||
The reader maps a stream of characters to *forms* (data). Reading is
|
||||
independent of evaluation: every form the reader produces is a value of the
|
||||
language (§4), and `read-string` exposes the reader as a function. Evaluation
|
||||
of forms is §1's concern; only `quote`-family reader macros reference it here.
|
||||
|
||||
## 2.1 Tokens
|
||||
|
||||
Whitespace is space, tab, newline, return, **and comma** (`,` is whitespace —
|
||||
S1). A `;` begins a comment to end of line (S2). Tokens:
|
||||
|
||||
```
|
||||
form := literal | symbol | keyword | list | vector | map | set
|
||||
| reader-macro-form
|
||||
list := '(' form* ')'
|
||||
vector := '[' form* ']'
|
||||
map := '{' (form form)* '}'
|
||||
literal := nil | boolean | number | string | character
|
||||
nil := 'nil' boolean := 'true' | 'false'
|
||||
```
|
||||
|
||||
- S3. A map literal MUST contain an even number of forms; duplicate keys
|
||||
MUST be an error at read time.
|
||||
- S4. A set literal (`#{…}`, §2.3) with duplicate elements MUST be an error
|
||||
at read time.
|
||||
|
||||
### Numbers
|
||||
|
||||
```
|
||||
integer := ['+'|'-'] (digits | '0' [xX] hexdigits | '0' octdigits | radixR digits)
|
||||
float := ['+'|'-'] digits '.' digits? exponent? | ['+'|'-'] digits exponent
|
||||
ratio := ['+'|'-'] digits '/' digits ; host-numeric-tower (§4 note)
|
||||
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.
|
||||
|
||||
### Symbols and keywords
|
||||
|
||||
```
|
||||
symbol := name | ns '/' name ; '/' alone names the division fn
|
||||
keyword := ':' name | ':' ns '/' name | '::' name | '::' alias '/' name
|
||||
```
|
||||
|
||||
- S6. Symbol constituent characters: alphanumerics and `* + ! - _ ' ? < > =
|
||||
. $ & %` (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`.)
|
||||
|
||||
### Strings and characters
|
||||
|
||||
- S8. Strings are `"…"` with escapes `\" \\ \n \t \r \b \f \uNNNN \oNNN`.
|
||||
- S9. Character literals: `\c`, the named set `\newline \space \tab
|
||||
\return \backspace \formfeed`, unicode `\uNNNN`, octal `\oNNN`.
|
||||
|
||||
**Conformance** (2.1): jolt `reader-syntax-spec` "dispatch & sugar";
|
||||
clojure-test-suite reader files; jank `form/*` literal dirs. S3/S4 duplicate
|
||||
checks → UNVERIFIED (rows to add).
|
||||
|
||||
## 2.2 Quote-family reader macros
|
||||
|
||||
| Sugar | Reads as | |
|
||||
|---|---|---|
|
||||
| `'form` | `(quote form)` | S10 |
|
||||
| `@form` | `(clojure.core/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.
|
||||
|
||||
**Conformance**: jolt `reader-forms-spec` "var-quote #'", "metadata ^",
|
||||
"syntax-quote"; jank `var-quote/pass-qualified.jank`, `metadata/*`.
|
||||
|
||||
## 2.3 Dispatch (`#`) reader macros
|
||||
|
||||
| Form | Meaning | Entry |
|
||||
|---|---|---|
|
||||
| `#{…}` | set literal | S4 above |
|
||||
| `#"…"` | regex literal — reads to a regex value; escaping is regex-level, not string-level (single `\d`) | S15 |
|
||||
| `#(…)` | anonymous fn | S16 below |
|
||||
| `#_form` | discard | S17 below |
|
||||
| `#?(…)` / `#?@(…)` | reader conditional (+splicing) | S18 below |
|
||||
| `##Inf ##-Inf ##NaN` | symbolic floats | S19 |
|
||||
| `#tag form` | tagged literal | S20 below |
|
||||
| `#! …` | shebang comment line (implementations SHOULD accept) | |
|
||||
|
||||
### S16 — anonymous function `#(…)`
|
||||
|
||||
- `#(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
|
||||
(#(+ %1 %2) 1 2) ;=> 3
|
||||
(apply #(apply + %&) [1 2 3]) ;=> 6
|
||||
(map #(* % %) [1 2]) ;=> (1 4)
|
||||
```
|
||||
|
||||
### S17 — discard `#_`
|
||||
|
||||
- `#_form` reads and discards the next form entirely (it is never evaluated).
|
||||
- Discards compose: `#_ #_ a b` discards two following forms.
|
||||
- `#_` inside collection literals removes the element: `[1 #_2 3]` ⇒ `[1 3]`.
|
||||
|
||||
### S18 — reader conditionals
|
||||
|
||||
- `#?(:feat₁ f₁ :feat₂ f₂ …)` reads as the form of the first feature key the
|
||||
platform satisfies, else nothing. `:default` matches any platform.
|
||||
`#?@(…)` splices a sequential form into the surrounding context.
|
||||
- Feature keys are implementation-defined; each implementation MUST document
|
||||
its feature set, and SHOULD follow the portable convention *own dialect key
|
||||
+ `:default`*. Matching MUST be by **clause order** — the first clause whose
|
||||
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.)
|
||||
- Reader conditionals MUST be an error outside `.cljc`-style reading unless
|
||||
the implementation documents otherwise.
|
||||
|
||||
### S19 — symbolic values
|
||||
|
||||
`##Inf`, `##-Inf`, `##NaN` read as the IEEE-754 values. `(= ##NaN ##NaN)` is
|
||||
false; `(NaN? ##NaN)` is true.
|
||||
|
||||
### S20 — tagged literals
|
||||
|
||||
- `#tag form`: the reader resolves `tag` in the data-reader table and MUST
|
||||
apply the reader function to the *read* form, yielding its result as the
|
||||
read value. An unknown tag MUST be a read error (jank
|
||||
`fail-unsupported-tag`).
|
||||
- Built-in tags every implementation MUST provide: `#uuid "…"` → a UUID
|
||||
value (§9 `parse-uuid` semantics — round-trips through printing), and
|
||||
`#inst "…"` → an instant value: RFC3339 with partial-timestamp defaults
|
||||
(`#inst "2020"` ≡ `#inst "2020-01-01T00:00:00.000-00:00"`), equality by
|
||||
instant (offset-normalized), `inst?`/`inst-ms` (epoch milliseconds), printed
|
||||
canonically as `#inst "yyyy-MM-ddThh:mm:ss.fff-00:00"` and round-tripping. A
|
||||
malformed timestamp MUST be an error.
|
||||
|
||||
**Conformance** (2.3): jolt `reader-forms-spec` "#() (% %N %&)" + new rows
|
||||
(symbolic values, stacked discard, conditionals); `uuid-spec` reader-literal
|
||||
group; jank `reader-macro/{function,regex,uuid,symbolic-value}/*`,
|
||||
`fail-unsupported-tag.jank`.
|
||||
|
||||
## 2.4 Syntax-quote
|
||||
|
||||
Syntax-quote (`` ` ``) is read-level template construction with namespace
|
||||
resolution:
|
||||
|
||||
- S21. Inside syntax-quote, an unqualified symbol that resolves in
|
||||
`clojure.core` MUST be qualified to `clojure.core/sym`; a symbol resolving
|
||||
through a namespace alias MUST be qualified to the aliased namespace; an
|
||||
unresolved symbol MUST be qualified to the current namespace. Special-form
|
||||
names stay bare.
|
||||
- S22. `sym#` generates a fresh symbol, stable *within one syntax-quote
|
||||
template* (all `sym#` in the same template denote the same generated
|
||||
symbol; distinct templates generate distinct symbols).
|
||||
- S23. `~form` inserts the value of `form`; `~@form` splices a sequential
|
||||
value; `~'sym` is the idiom for an intentionally-unqualified symbol.
|
||||
- S24. Syntax-quote distributes through collection literals (vectors, maps,
|
||||
sets) — qualification and unquoting apply inside them.
|
||||
- S25. A syntax-quoted self-evaluating literal is the literal, collapsed at
|
||||
read time — so nested/adjacent backticks over literals are inert:
|
||||
`(= "meow" ```"meow")` is true. General nested syntax-quote over symbols
|
||||
and collections expands recursively (quasiquote semantics) — that general
|
||||
case remains UNVERIFIED pending dedicated conformance rows.
|
||||
|
||||
**Conformance**: jolt `reader-forms-spec` "syntax-quote" (gensym, unquote,
|
||||
splice) + conformance "syntax-quote fully-qualifies"; jank
|
||||
`syntax-quote/{pass-gensym,pass-namespace-resolution,pass-resolve-alias,
|
||||
unquote,unquote-splice}/*`. S25 → UNVERIFIED.
|
||||
|
||||
## 2.5 What the reader is not
|
||||
|
||||
The reader performs **no macroexpansion and no evaluation** (tagged-literal
|
||||
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 1–12, 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.
|
||||
|
|
@ -1,155 +0,0 @@
|
|||
# §3 Special Forms
|
||||
|
||||
**Status**: catalog complete; normative exemplars for `if` and `let*`; the
|
||||
remaining entries follow the same format (tracked in `coverage.md`).
|
||||
|
||||
A *special form* is a form whose head symbol is evaluated by rule rather than
|
||||
by function application or macroexpansion. The special forms of Clojure are:
|
||||
|
||||
> `def` · `if` · `do` · `let*` · `fn*` · `loop*` · `recur` · `quote` · `var`
|
||||
> · `throw` · `try`/`catch`/`finally` · `set!` · `monitor-enter` ·
|
||||
> `monitor-exit` (host) · the interop forms `.` and `new` (host)
|
||||
|
||||
`let`, `fn`, `loop`, `and`, `or`, `when`, … are **macros** over these (§8);
|
||||
implementations MUST treat them as redefinable macros, not additional special
|
||||
forms. `monitor-enter`/`monitor-exit`, `.` and `new` are host forms: their
|
||||
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).
|
||||
|
||||
---
|
||||
|
||||
### if — since 1.0
|
||||
|
||||
```
|
||||
(if test then)
|
||||
(if test then else)
|
||||
```
|
||||
|
||||
**Semantics**
|
||||
|
||||
- S1. `test` MUST be evaluated first, exactly once.
|
||||
- S2. Every value other than `nil` and `false` is *logically true*. If the
|
||||
value of `test` is logically true, `then` MUST be evaluated and its value
|
||||
returned; otherwise `else` (or `nil` when absent) MUST be evaluated and its
|
||||
value returned.
|
||||
- S3. The branch not taken MUST NOT be evaluated.
|
||||
- S4. `if` MUST be usable in tail position with respect to `recur` (§3
|
||||
`recur`): an `if` whose branch is a `recur` form is a valid recur target
|
||||
path.
|
||||
|
||||
**Edge cases**
|
||||
|
||||
- E1. `(if test then)` with a logically false `test` evaluates to `nil`.
|
||||
- E2. The empty collections (`()`, `[]`, `{}`, `#{}`), the number `0`, and
|
||||
the empty string `""` are logically **true** (only `nil`/`false` are
|
||||
false). ⚠ This differs from several Lisps and is a frequent divergence
|
||||
source in alternative implementations.
|
||||
|
||||
**Errors**
|
||||
|
||||
- X1. `(if)` and `(if test)` with fewer than two argument forms, or more
|
||||
than three, MUST be a compile-time error.
|
||||
|
||||
**Examples**
|
||||
|
||||
```clojure
|
||||
(if 0 :t :f) ;=> :t
|
||||
(if "" :t :f) ;=> :t
|
||||
(if nil :t :f) ;=> :f
|
||||
(if false :t) ;=> nil
|
||||
```
|
||||
|
||||
**Conformance**
|
||||
|
||||
S1–S3, E1–E2 → 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).
|
||||
|
||||
---
|
||||
|
||||
### let* — since 1.0
|
||||
|
||||
```
|
||||
(let* [sym₁ init₁ … symₙ initₙ] body…)
|
||||
```
|
||||
|
||||
`let*` is the primitive sequential-binding form. The user-facing `let` macro
|
||||
adds destructuring and expands to `let*` (§8); `let*` itself accepts **only
|
||||
simple symbols** in binding positions.
|
||||
|
||||
**Semantics**
|
||||
|
||||
- S1. Each `initᵢ` MUST be evaluated in order, exactly once, in an
|
||||
environment where `sym₁…symᵢ₋₁` are bound to their values (sequential
|
||||
scope, as Scheme `let*`).
|
||||
- S2. The body forms MUST be evaluated in order with all bindings in scope;
|
||||
the value of the last body form is the value of the `let*` form. An empty
|
||||
body evaluates to `nil`.
|
||||
- S3. A later binding MAY rebind the same symbol; each binding creates a new
|
||||
lexical binding visible from the next init onward (no mutation of the
|
||||
earlier binding is implied).
|
||||
- S4. Bindings are lexical and immutable: there is no form that assigns to a
|
||||
`let*`-bound local. (Closures capture bindings by value; see §3 `fn*`.)
|
||||
- S5. The binding vector MUST be a vector literal with an even number of
|
||||
forms.
|
||||
|
||||
**Edge cases**
|
||||
|
||||
- E1. `(let* [] body)` is valid and equivalent to `(do body…)`.
|
||||
- E2. Binding a symbol that names a var shadows the var for the lexical
|
||||
extent of the body; `(var sym)` within that extent still denotes the var.
|
||||
|
||||
**Errors**
|
||||
|
||||
- X1. An odd number of binding forms MUST be a compile-time error.
|
||||
- X2. A non-symbol in a binding position (e.g. a destructuring pattern) MUST
|
||||
be a compile-time error for `let*` — destructuring belongs to the `let`
|
||||
macro. ("Bad binding form, expected symbol" in the reference.)
|
||||
|
||||
**Examples**
|
||||
|
||||
```clojure
|
||||
(let* [a 1 b (+ a 1)] (* a b)) ;=> 2
|
||||
(let* [x 1 x (inc x)] x) ;=> 2
|
||||
(let* [] 42) ;=> 42
|
||||
```
|
||||
|
||||
**Conformance**
|
||||
|
||||
S1–S3, E1 → jolt `forms-spec` let group; clojure-test-suite
|
||||
`core_test/let.cljc`; jank corpus `form/let/*`. X2 → jolt
|
||||
`destructuring-spec` "primitives reject patterns". S4, X1 → UNVERIFIED
|
||||
(cases to add).
|
||||
|
||||
---
|
||||
|
||||
## Remaining entries (format above; status in coverage.md)
|
||||
|
||||
| Form | Notes for the entry author |
|
||||
|---|---|
|
||||
| `def` | var creation vs re-binding; metadata on the name; `(def x)` unbound; return value is the var |
|
||||
| `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 |
|
||||
| `.` / `new` | syntax only; behavior host-defined |
|
||||
|
|
@ -1,366 +0,0 @@
|
|||
# §9 The Core Library
|
||||
|
||||
**Status**: entry format fixed; exemplars for `first`, `reduce`, `parse-uuid`.
|
||||
The full portable surface (≈500 vars after classification, dashboard in
|
||||
`coverage.md`) is filled in chapter-by-chapter using this format.
|
||||
|
||||
Entries specify *behavioral contracts*, not implementations. Performance
|
||||
characteristics are specified only where the language community relies on
|
||||
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
|
||||
|
||||
```
|
||||
(first coll)
|
||||
```
|
||||
|
||||
**Semantics**
|
||||
|
||||
- S1. MUST return the first element of `(seq coll)`.
|
||||
- S2. If `(seq coll)` is `nil` (i.e. `coll` is empty or `nil`), MUST return
|
||||
`nil`.
|
||||
- S3. MUST accept anything *seqable* (§5): seqs, lists, vectors, maps
|
||||
(yielding map entries), sets, strings (yielding characters), `nil`.
|
||||
- S4. On a lazy sequence, MUST realize at most the first element (§5
|
||||
laziness contract).
|
||||
|
||||
**Edge cases**
|
||||
|
||||
- E1. `(first nil)` ⇒ `nil`; `(first [])` ⇒ `nil`; `(first "")` ⇒ `nil`.
|
||||
- E2. A `nil` or `false` first *element* is returned as-is — callers cannot
|
||||
distinguish "empty" from "first element is nil" via `first` alone (that is
|
||||
what `seq` is for).
|
||||
- E3. On a map, the element is a map entry; on an unordered collection (map,
|
||||
set) *which* element is first is implementation-defined but MUST be
|
||||
consistent with that collection's seq order for the same collection value.
|
||||
|
||||
**Errors**
|
||||
|
||||
- X1. A non-seqable argument (e.g. a number) MUST throw.
|
||||
|
||||
**Examples**
|
||||
|
||||
```clojure
|
||||
(first [1 2 3]) ;=> 1
|
||||
(first '()) ;=> nil
|
||||
(first "ab") ;=> \a
|
||||
(first {:a 1}) ;=> [:a 1]
|
||||
(first [nil 2]) ;=> nil
|
||||
```
|
||||
|
||||
**Conformance**
|
||||
|
||||
S1–S3, E1–E2 → jolt `sequences-spec` "seq / access"; clojure-test-suite
|
||||
`core_test/first.cljc`. S4 → jolt `lazy-seqs-spec` counter cases. X1 →
|
||||
clojure-test-suite `core_test/first.cljc` (throwing cases).
|
||||
|
||||
---
|
||||
|
||||
### reduce — since 1.0
|
||||
|
||||
```
|
||||
(reduce f coll)
|
||||
(reduce f init coll)
|
||||
```
|
||||
|
||||
**Semantics**
|
||||
|
||||
- S1. With `init`: MUST return `init` if `(seq coll)` is nil; otherwise MUST
|
||||
return `(f … (f (f init e₁) e₂) … eₙ)`, applying `f` left-to-right over the
|
||||
elements, exactly once each.
|
||||
- S2. Without `init`: if `coll` is empty, MUST return `(f)` (f called with
|
||||
no arguments); if `coll` has one element, MUST return that element
|
||||
*without calling `f`*; otherwise as S1 with `init = e₁` over `e₂…eₙ`.
|
||||
- S3. **Reduced short-circuit**: if any intermediate result is a `reduced`
|
||||
value, iteration MUST stop and the dereferenced value MUST be returned
|
||||
immediately; `f` MUST NOT be called again.
|
||||
- S4. `reduce` is eager: it MUST fully realize the consumed portion of a
|
||||
lazy `coll` (to the end, or to the `reduced` point).
|
||||
|
||||
**Edge cases**
|
||||
|
||||
- E1. `(reduce f nil)` ⇒ `(f)`; `(reduce f init nil)` ⇒ `init`.
|
||||
- E2. A `reduced` value as the *initial* `init` is NOT unwrapped before the
|
||||
first call in the reference — ⚠ under-documented; differential result to
|
||||
pin down and test before this entry is marked verified.
|
||||
- E3. Visit order over maps is entry order of the map's seq;
|
||||
over vectors/lists/seqs it is sequential order (normative).
|
||||
|
||||
**Errors**
|
||||
|
||||
- X1. Without `init`, on an empty coll, if `f` has no zero-arg arity the
|
||||
call `(f)` MUST throw (arity error).
|
||||
|
||||
**Examples**
|
||||
|
||||
```clojure
|
||||
(reduce + [1 2 3 4]) ;=> 10
|
||||
(reduce + 10 [1 2 3 4]) ;=> 20
|
||||
(reduce + []) ;=> 0 ; (+) is 0
|
||||
(reduce + [5]) ;=> 5 ; f not called
|
||||
(reduce (fn [a x] (if (> a 2) (reduced a) (+ a x))) 0 [1 2 3 4 5]) ;=> 3
|
||||
```
|
||||
|
||||
**Conformance**
|
||||
|
||||
S1–S3, E1 → jolt `sequences-spec` "map filter reduce" group +
|
||||
`transducers-spec` "reduce honors reduced"; clojure-test-suite
|
||||
`core_test/reduce.cljc`. S2 (single-element, f-not-called) → jolt conformance
|
||||
"reduce single no init". E2 → UNVERIFIED (differential test to add). S4 →
|
||||
`lazy-seqs-spec`.
|
||||
|
||||
---
|
||||
|
||||
### parse-uuid — since 1.11
|
||||
|
||||
```
|
||||
(parse-uuid s)
|
||||
```
|
||||
|
||||
**Semantics**
|
||||
|
||||
- S1. If `s` is a string in canonical UUID form — five groups of hex digits
|
||||
of lengths 8, 4, 4, 4, 12 separated by `-` — MUST return a UUID value `u`
|
||||
such that `(uuid? u)` is true and `(str u)` is the lowercase form of `s`.
|
||||
- S2. Parsing MUST be case-insensitive and equality on the results
|
||||
case-insensitive: `(= (parse-uuid s) (parse-uuid (upper-case s)))` is true.
|
||||
- S3. If `s` is a string not in canonical form, MUST return `nil`.
|
||||
⚠ reference-divergence: reference Clojure (java.util.UUID) additionally
|
||||
accepts non-canonical forms like `"0-0-0-0-0"`; ClojureScript and other
|
||||
dialects are strict. This spec adopts **strict** (the cross-dialect
|
||||
behavior); the reference's permissiveness is recorded as host leniency.
|
||||
- S4. UUID values MUST support value equality, hashing (usable as map keys
|
||||
and set members), `str` (lowercase canonical form), and print as the
|
||||
tagged literal `#uuid "…"` such that the printed form reads back equal
|
||||
(§2 tagged literals).
|
||||
|
||||
**Edge cases**
|
||||
|
||||
- E1. `""`, over-long, truncated, non-hex characters, and misplaced dashes
|
||||
⇒ `nil`.
|
||||
|
||||
**Errors**
|
||||
|
||||
- X1. A non-string argument MUST throw.
|
||||
|
||||
**Examples**
|
||||
|
||||
```clojure
|
||||
(parse-uuid "b6883c0a-0342-4007-9966-bc2dfa6b109e") ;=> #uuid "b6883c0a-…"
|
||||
(uuid? *1) ;=> true
|
||||
(parse-uuid "df0993") ;=> nil
|
||||
(parse-uuid 1000) ;; throws
|
||||
```
|
||||
|
||||
**Conformance**
|
||||
|
||||
S1–S4, E1, X1 → jolt `uuid-spec` (30 cases) + 6 three-path conformance
|
||||
cases; clojure-test-suite `core_test/parse_uuid.cljc`,
|
||||
`core_test/uuid_qmark.cljc`, `core_test/random_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**
|
||||
|
||||
S1–S3 → `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**
|
||||
|
||||
S1–S4, X1–X3 → 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**
|
||||
|
||||
S1–S4, X1–X2 → 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**
|
||||
|
||||
S1–S4 → 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`,
|
||||
648 core vars have community examples) — but every example is verified
|
||||
against the reference before inclusion.
|
||||
- When writing an entry surfaces a behavior question, settle it by
|
||||
differential test first; if dialects split, that's a classification
|
||||
decision (host-dependent / divergence note), not a coin flip.
|
||||
- An entry is **Verified** when no field carries UNVERIFIED; `coverage.md`
|
||||
tracks per-var status.
|
||||
|
|
@ -1,55 +0,0 @@
|
|||
# The Clojure Language Specification (Draft)
|
||||
|
||||
A normative, implementation-independent specification of the Clojure
|
||||
language, developed alongside jolt's self-hosted compiler and validated by
|
||||
its executable conformance suites. **Why**: Clojure has no spec — every
|
||||
alternative implementation re-derives semantics from the reference
|
||||
implementation and folklore. See the RFC for motivation, scope, evidence
|
||||
sources, and process: [`../rfc/0001-language-specification.md`](../rfc/0001-language-specification.md).
|
||||
|
||||
## Documents
|
||||
|
||||
| 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 |
|
||||
| [`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`).
|
||||
|
||||
## Current numbers (2026-06-22)
|
||||
|
||||
Of the 694 `clojure.core` vars in the ClojureDocs inventory, jolt interns 574.
|
||||
Broadly:
|
||||
|
||||
- **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)
|
||||
|
||||
## 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`.
|
||||
- `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
|
||||
the granularity model for §2/§3 conformance.
|
||||
|
||||
The invariant: **every numbered normative statement names its conformance
|
||||
test**, or is marked UNVERIFIED. The spec cannot drift from the
|
||||
implementations that check it.
|
||||
|
|
@ -1,721 +0,0 @@
|
|||
# Appendix A — Coverage Dashboard (generated)
|
||||
|
||||
Generated 2026-06-26 by `tools/spec_coverage.py` — do not edit by hand.
|
||||
|
||||
Surface: **694** clojure.core vars (ClojureDocs export; 648 with
|
||||
community examples). jolt interns 594 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 |
|
||||
| stm-refs | 11 | out of scope pending concurrency design note |
|
||||
| jvm-specific | 46 | catalogued, not specified |
|
||||
|
||||
Classifications are initial and mechanical — reclassifying is an ordinary
|
||||
spec change. A var is *Verified* only when its §9 entry exists and carries no
|
||||
UNVERIFIED field; that column will be added as entries land.
|
||||
|
||||
## Per-var status
|
||||
|
||||
| Var | Status | ClojureDocs examples |
|
||||
|---|---|---|
|
||||
| `*` | implemented+tested | ✓ |
|
||||
| `*'` | implemented+tested | ✓ |
|
||||
| `*1` | implemented+tested | ✓ |
|
||||
| `*2` | implemented+tested | ✓ |
|
||||
| `*3` | implemented+tested | ✓ |
|
||||
| `*agent*` | dynamic-var | ✓ |
|
||||
| `*allow-unresolved-vars*` | dynamic-var | ✓ |
|
||||
| `*assert*` | implemented+tested | ✓ |
|
||||
| `*clojure-version*` | implemented+tested | ✓ |
|
||||
| `*command-line-args*` | implemented-untested | ✓ |
|
||||
| `*compile-files*` | implemented+tested | ✓ |
|
||||
| `*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 | |
|
||||
| `*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 | ✓ |
|
||||
| `*reader-resolver*` | dynamic-var | |
|
||||
| `*repl*` | dynamic-var | |
|
||||
| `*source-path*` | dynamic-var | ✓ |
|
||||
| `*suppress-read*` | dynamic-var | |
|
||||
| `*unchecked-math*` | implemented+tested | ✓ |
|
||||
| `*use-context-classloader*` | dynamic-var | ✓ |
|
||||
| `*verbose-defrecords*` | dynamic-var | |
|
||||
| `*warn-on-reflection*` | implemented+tested | ✓ |
|
||||
| `+` | implemented+tested | ✓ |
|
||||
| `+'` | implemented+tested | ✓ |
|
||||
| `-` | implemented+tested | ✓ |
|
||||
| `-'` | implemented+tested | ✓ |
|
||||
| `->` | implemented+tested | ✓ |
|
||||
| `->>` | implemented+tested | ✓ |
|
||||
| `->ArrayChunk` | jvm-specific | |
|
||||
| `->Eduction` | implemented+tested | |
|
||||
| `->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+tested | ✓ |
|
||||
| `<=` | implemented+tested | ✓ |
|
||||
| `=` | implemented+tested | ✓ |
|
||||
| `==` | implemented+tested | ✓ |
|
||||
| `>` | implemented+tested | ✓ |
|
||||
| `>=` | implemented+tested | ✓ |
|
||||
| `EMPTY-NODE` | jvm-specific | |
|
||||
| `Inst` | jvm-specific | |
|
||||
| `NaN?` | implemented+tested | ✓ |
|
||||
| `PrintWriter-on` | jvm-specific | ✓ |
|
||||
| `StackTraceElement->vec` | jvm-specific | ✓ |
|
||||
| `Throwable->map` | jvm-specific | ✓ |
|
||||
| `abs` | implemented+tested | ✓ |
|
||||
| `accessor` | jvm-specific | ✓ |
|
||||
| `aclone` | implemented+tested | ✓ |
|
||||
| `add-classpath` | jvm-specific | ✓ |
|
||||
| `add-tap` | agents-taps | ✓ |
|
||||
| `add-watch` | implemented+tested | ✓ |
|
||||
| `agent` | implemented+tested | ✓ |
|
||||
| `agent-error` | implemented+tested | ✓ |
|
||||
| `agent-errors` | agents-taps | |
|
||||
| `aget` | implemented+tested | ✓ |
|
||||
| `alength` | implemented+tested | ✓ |
|
||||
| `alias` | implemented+tested | ✓ |
|
||||
| `all-ns` | implemented+tested | ✓ |
|
||||
| `alter` | stm-refs | ✓ |
|
||||
| `alter-meta!` | implemented+tested | ✓ |
|
||||
| `alter-var-root` | implemented+tested | ✓ |
|
||||
| `amap` | jvm-specific | ✓ |
|
||||
| `ancestors` | implemented+tested | ✓ |
|
||||
| `and` | implemented+tested | ✓ |
|
||||
| `any?` | implemented+tested | ✓ |
|
||||
| `apply` | implemented+tested | ✓ |
|
||||
| `areduce` | jvm-specific | ✓ |
|
||||
| `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 | ✓ |
|
||||
| `assert` | implemented+tested | ✓ |
|
||||
| `assoc` | implemented+tested | ✓ |
|
||||
| `assoc!` | implemented+tested | ✓ |
|
||||
| `assoc-in` | implemented+tested | ✓ |
|
||||
| `associative?` | implemented+tested | ✓ |
|
||||
| `atom` | implemented+tested | ✓ |
|
||||
| `await` | implemented+tested | ✓ |
|
||||
| `await-for` | agents-taps | ✓ |
|
||||
| `await1` | agents-taps | |
|
||||
| `bases` | jvm-specific | ✓ |
|
||||
| `bean` | implemented+tested | ✓ |
|
||||
| `bigdec` | implemented+tested | ✓ |
|
||||
| `bigint` | implemented+tested | ✓ |
|
||||
| `biginteger` | implemented+tested | ✓ |
|
||||
| `binding` | implemented+tested | ✓ |
|
||||
| `bit-and` | implemented+tested | ✓ |
|
||||
| `bit-and-not` | implemented+tested | ✓ |
|
||||
| `bit-clear` | implemented+tested | ✓ |
|
||||
| `bit-flip` | implemented+tested | ✓ |
|
||||
| `bit-not` | implemented+tested | ✓ |
|
||||
| `bit-or` | implemented+tested | ✓ |
|
||||
| `bit-set` | implemented+tested | ✓ |
|
||||
| `bit-shift-left` | implemented+tested | ✓ |
|
||||
| `bit-shift-right` | implemented+tested | ✓ |
|
||||
| `bit-test` | implemented+tested | ✓ |
|
||||
| `bit-xor` | implemented+tested | ✓ |
|
||||
| `boolean` | implemented+tested | ✓ |
|
||||
| `boolean-array` | implemented+tested | ✓ |
|
||||
| `boolean?` | implemented+tested | ✓ |
|
||||
| `booleans` | implemented+tested | ✓ |
|
||||
| `bound-fn` | implemented+tested | ✓ |
|
||||
| `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 | ✓ |
|
||||
| `case` | implemented+tested | ✓ |
|
||||
| `cast` | jvm-specific | ✓ |
|
||||
| `cat` | implemented+tested | ✓ |
|
||||
| `catch` | special-form | ✓ |
|
||||
| `char` | implemented+tested | ✓ |
|
||||
| `char-array` | implemented+tested | ✓ |
|
||||
| `char-escape-string` | implemented+tested | ✓ |
|
||||
| `char-name-string` | implemented+tested | ✓ |
|
||||
| `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 | ✓ |
|
||||
| `chunked-seq?` | implemented+tested | ✓ |
|
||||
| `class` | implemented+tested | ✓ |
|
||||
| `class?` | implemented+tested | ✓ |
|
||||
| `clear-agent-errors` | agents-taps | |
|
||||
| `clojure-version` | implemented+tested | ✓ |
|
||||
| `coll?` | implemented+tested | ✓ |
|
||||
| `comment` | implemented+tested | ✓ |
|
||||
| `commute` | stm-refs | ✓ |
|
||||
| `comp` | implemented+tested | ✓ |
|
||||
| `comparator` | implemented+tested | ✓ |
|
||||
| `compare` | implemented+tested | ✓ |
|
||||
| `compare-and-set!` | implemented+tested | ✓ |
|
||||
| `compile` | jvm-specific | ✓ |
|
||||
| `complement` | implemented+tested | ✓ |
|
||||
| `completing` | implemented+tested | ✓ |
|
||||
| `concat` | implemented+tested | ✓ |
|
||||
| `cond` | implemented+tested | ✓ |
|
||||
| `cond->` | implemented+tested | ✓ |
|
||||
| `cond->>` | implemented+tested | ✓ |
|
||||
| `condp` | implemented+tested | ✓ |
|
||||
| `conj` | implemented+tested | ✓ |
|
||||
| `conj!` | implemented+tested | ✓ |
|
||||
| `cons` | implemented+tested | ✓ |
|
||||
| `constantly` | implemented+tested | ✓ |
|
||||
| `construct-proxy` | implemented+tested | ✓ |
|
||||
| `contains?` | implemented+tested | ✓ |
|
||||
| `count` | implemented+tested | ✓ |
|
||||
| `counted?` | implemented+tested | ✓ |
|
||||
| `create-ns` | implemented+tested | ✓ |
|
||||
| `create-struct` | jvm-specific | ✓ |
|
||||
| `cycle` | implemented+tested | ✓ |
|
||||
| `dec` | implemented+tested | ✓ |
|
||||
| `dec'` | implemented+tested | ✓ |
|
||||
| `decimal?` | implemented+tested | ✓ |
|
||||
| `declare` | implemented+tested | ✓ |
|
||||
| `dedupe` | implemented+tested | ✓ |
|
||||
| `def` | special-form | ✓ |
|
||||
| `default-data-readers` | implemented+tested | ✓ |
|
||||
| `definline` | jvm-specific | |
|
||||
| `definterface` | implemented+tested | ✓ |
|
||||
| `defmacro` | special-form | ✓ |
|
||||
| `defmethod` | implemented+tested | ✓ |
|
||||
| `defmulti` | implemented+tested | ✓ |
|
||||
| `defn` | implemented+tested | ✓ |
|
||||
| `defn-` | implemented+tested | ✓ |
|
||||
| `defonce` | implemented+tested | ✓ |
|
||||
| `defprotocol` | implemented+tested | ✓ |
|
||||
| `defrecord` | implemented+tested | ✓ |
|
||||
| `defstruct` | jvm-specific | ✓ |
|
||||
| `deftype` | implemented+tested | ✓ |
|
||||
| `delay` | implemented+tested | ✓ |
|
||||
| `delay?` | implemented+tested | ✓ |
|
||||
| `deliver` | implemented+tested | ✓ |
|
||||
| `denominator` | implemented+tested | ✓ |
|
||||
| `deref` | implemented+tested | ✓ |
|
||||
| `derive` | implemented+tested | ✓ |
|
||||
| `descendants` | implemented+tested | ✓ |
|
||||
| `destructure` | implemented+tested | ✓ |
|
||||
| `disj` | implemented+tested | ✓ |
|
||||
| `disj!` | implemented+tested | ✓ |
|
||||
| `dissoc` | implemented+tested | ✓ |
|
||||
| `dissoc!` | implemented+tested | ✓ |
|
||||
| `distinct` | implemented+tested | ✓ |
|
||||
| `distinct?` | implemented+tested | ✓ |
|
||||
| `do` | special-form | ✓ |
|
||||
| `doall` | implemented+tested | ✓ |
|
||||
| `dorun` | implemented+tested | ✓ |
|
||||
| `doseq` | implemented+tested | ✓ |
|
||||
| `dosync` | stm-refs | ✓ |
|
||||
| `dotimes` | implemented+tested | ✓ |
|
||||
| `doto` | implemented+tested | ✓ |
|
||||
| `double` | implemented+tested | ✓ |
|
||||
| `double-array` | implemented+tested | ✓ |
|
||||
| `double?` | implemented+tested | ✓ |
|
||||
| `doubles` | implemented+tested | ✓ |
|
||||
| `drop` | implemented+tested | ✓ |
|
||||
| `drop-last` | implemented+tested | ✓ |
|
||||
| `drop-while` | implemented+tested | ✓ |
|
||||
| `eduction` | implemented+tested | ✓ |
|
||||
| `empty` | implemented+tested | ✓ |
|
||||
| `empty?` | implemented+tested | ✓ |
|
||||
| `ensure` | stm-refs | ✓ |
|
||||
| `ensure-reduced` | implemented+tested | ✓ |
|
||||
| `enumeration-seq` | implemented+tested | ✓ |
|
||||
| `error-handler` | agents-taps | ✓ |
|
||||
| `error-mode` | agents-taps | ✓ |
|
||||
| `eval` | implemented+tested | ✓ |
|
||||
| `even?` | implemented+tested | ✓ |
|
||||
| `every-pred` | implemented+tested | ✓ |
|
||||
| `every?` | implemented+tested | ✓ |
|
||||
| `ex-cause` | implemented+tested | ✓ |
|
||||
| `ex-data` | implemented+tested | ✓ |
|
||||
| `ex-info` | implemented+tested | ✓ |
|
||||
| `ex-message` | implemented+tested | ✓ |
|
||||
| `extend` | implemented+tested | ✓ |
|
||||
| `extend-protocol` | implemented+tested | ✓ |
|
||||
| `extend-type` | implemented+tested | ✓ |
|
||||
| `extenders` | implemented+tested | ✓ |
|
||||
| `extends?` | implemented+tested | ✓ |
|
||||
| `false?` | implemented+tested | ✓ |
|
||||
| `ffirst` | implemented+tested | ✓ |
|
||||
| `file-seq` | implemented+tested | ✓ |
|
||||
| `filter` | implemented+tested | ✓ |
|
||||
| `filterv` | implemented+tested | ✓ |
|
||||
| `finally` | special-form | ✓ |
|
||||
| `find` | implemented+tested | ✓ |
|
||||
| `find-keyword` | implemented+tested | ✓ |
|
||||
| `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+tested | ✓ |
|
||||
| `floats` | implemented+tested | ✓ |
|
||||
| `flush` | implemented+tested | ✓ |
|
||||
| `fn` | implemented+tested | ✓ |
|
||||
| `fn?` | implemented+tested | ✓ |
|
||||
| `fnext` | implemented+tested | ✓ |
|
||||
| `fnil` | implemented+tested | ✓ |
|
||||
| `for` | implemented+tested | ✓ |
|
||||
| `force` | implemented+tested | ✓ |
|
||||
| `format` | implemented+tested | ✓ |
|
||||
| `frequencies` | implemented+tested | ✓ |
|
||||
| `future` | implemented+tested | ✓ |
|
||||
| `future-call` | implemented+tested | ✓ |
|
||||
| `future-cancel` | implemented+tested | ✓ |
|
||||
| `future-cancelled?` | implemented+tested | ✓ |
|
||||
| `future-done?` | implemented+tested | ✓ |
|
||||
| `future?` | implemented+tested | ✓ |
|
||||
| `gen-class` | jvm-specific | ✓ |
|
||||
| `gen-interface` | jvm-specific | ✓ |
|
||||
| `gensym` | implemented+tested | ✓ |
|
||||
| `get` | implemented+tested | ✓ |
|
||||
| `get-in` | implemented+tested | ✓ |
|
||||
| `get-method` | implemented+tested | ✓ |
|
||||
| `get-proxy-class` | implemented+tested | ✓ |
|
||||
| `get-thread-bindings` | implemented+tested | ✓ |
|
||||
| `get-validator` | implemented+tested | ✓ |
|
||||
| `group-by` | implemented+tested | ✓ |
|
||||
| `halt-when` | implemented+tested | ✓ |
|
||||
| `hash` | implemented+tested | ✓ |
|
||||
| `hash-combine` | implemented+tested | ✓ |
|
||||
| `hash-map` | implemented+tested | ✓ |
|
||||
| `hash-ordered-coll` | implemented+tested | ✓ |
|
||||
| `hash-set` | implemented+tested | ✓ |
|
||||
| `hash-unordered-coll` | implemented+tested | ✓ |
|
||||
| `ident?` | implemented+tested | ✓ |
|
||||
| `identical?` | implemented+tested | ✓ |
|
||||
| `identity` | implemented+tested | ✓ |
|
||||
| `if` | special-form | ✓ |
|
||||
| `if-let` | implemented+tested | ✓ |
|
||||
| `if-not` | implemented+tested | ✓ |
|
||||
| `if-some` | implemented+tested | ✓ |
|
||||
| `ifn?` | implemented+tested | ✓ |
|
||||
| `import` | implemented+tested | ✓ |
|
||||
| `in-ns` | implemented+tested | ✓ |
|
||||
| `inc` | implemented+tested | ✓ |
|
||||
| `inc'` | implemented+tested | ✓ |
|
||||
| `indexed?` | implemented+tested | ✓ |
|
||||
| `infinite?` | implemented+tested | ✓ |
|
||||
| `init-proxy` | implemented+tested | ✓ |
|
||||
| `inst-ms` | implemented+tested | ✓ |
|
||||
| `inst-ms*` | implemented+tested | |
|
||||
| `inst?` | implemented+tested | ✓ |
|
||||
| `instance?` | implemented+tested | ✓ |
|
||||
| `int` | implemented+tested | ✓ |
|
||||
| `int-array` | implemented+tested | ✓ |
|
||||
| `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 | ✓ |
|
||||
| `io!` | stm-refs | ✓ |
|
||||
| `isa?` | implemented+tested | ✓ |
|
||||
| `iterate` | implemented+tested | ✓ |
|
||||
| `iteration` | jvm-specific | ✓ |
|
||||
| `iterator-seq` | implemented+tested | ✓ |
|
||||
| `juxt` | implemented+tested | ✓ |
|
||||
| `keep` | implemented+tested | ✓ |
|
||||
| `keep-indexed` | implemented+tested | ✓ |
|
||||
| `key` | implemented+tested | ✓ |
|
||||
| `keys` | implemented+tested | ✓ |
|
||||
| `keyword` | implemented+tested | ✓ |
|
||||
| `keyword?` | implemented+tested | ✓ |
|
||||
| `last` | implemented+tested | ✓ |
|
||||
| `lazy-cat` | implemented+tested | ✓ |
|
||||
| `lazy-seq` | implemented+tested | ✓ |
|
||||
| `let` | implemented+tested | ✓ |
|
||||
| `letfn` | implemented+tested | ✓ |
|
||||
| `line-seq` | implemented+tested | ✓ |
|
||||
| `list` | implemented+tested | ✓ |
|
||||
| `list*` | implemented+tested | ✓ |
|
||||
| `list?` | implemented+tested | ✓ |
|
||||
| `load` | implemented+tested | ✓ |
|
||||
| `load-file` | implemented-untested | ✓ |
|
||||
| `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 | ✓ |
|
||||
| `loop` | implemented+tested | ✓ |
|
||||
| `macroexpand` | implemented+tested | ✓ |
|
||||
| `macroexpand-1` | implemented+tested | ✓ |
|
||||
| `make-array` | implemented+tested | ✓ |
|
||||
| `make-hierarchy` | implemented+tested | ✓ |
|
||||
| `map` | implemented+tested | ✓ |
|
||||
| `map-entry?` | implemented+tested | ✓ |
|
||||
| `map-indexed` | implemented+tested | ✓ |
|
||||
| `map?` | implemented+tested | ✓ |
|
||||
| `mapcat` | implemented+tested | ✓ |
|
||||
| `mapv` | implemented+tested | ✓ |
|
||||
| `max` | implemented+tested | ✓ |
|
||||
| `max-key` | implemented+tested | ✓ |
|
||||
| `memfn` | implemented+tested | ✓ |
|
||||
| `memoize` | implemented+tested | ✓ |
|
||||
| `merge` | implemented+tested | ✓ |
|
||||
| `merge-with` | implemented+tested | ✓ |
|
||||
| `meta` | implemented+tested | ✓ |
|
||||
| `method-sig` | jvm-specific | ✓ |
|
||||
| `methods` | implemented+tested | ✓ |
|
||||
| `min` | implemented+tested | ✓ |
|
||||
| `min-key` | implemented+tested | ✓ |
|
||||
| `mix-collection-hash` | jvm-specific | |
|
||||
| `mod` | implemented+tested | ✓ |
|
||||
| `monitor-enter` | special-form | |
|
||||
| `monitor-exit` | special-form | |
|
||||
| `munge` | implemented+tested | ✓ |
|
||||
| `name` | implemented+tested | ✓ |
|
||||
| `namespace` | implemented+tested | ✓ |
|
||||
| `namespace-munge` | implemented+tested | ✓ |
|
||||
| `nat-int?` | implemented+tested | ✓ |
|
||||
| `neg-int?` | implemented+tested | ✓ |
|
||||
| `neg?` | implemented+tested | ✓ |
|
||||
| `new` | special-form | ✓ |
|
||||
| `newline` | implemented+tested | ✓ |
|
||||
| `next` | implemented+tested | ✓ |
|
||||
| `nfirst` | implemented+tested | ✓ |
|
||||
| `nil?` | implemented+tested | ✓ |
|
||||
| `nnext` | implemented+tested | ✓ |
|
||||
| `not` | implemented+tested | ✓ |
|
||||
| `not-any?` | implemented+tested | ✓ |
|
||||
| `not-empty` | implemented+tested | ✓ |
|
||||
| `not-every?` | implemented+tested | ✓ |
|
||||
| `not=` | implemented+tested | ✓ |
|
||||
| `ns` | implemented+tested | ✓ |
|
||||
| `ns-aliases` | implemented+tested | ✓ |
|
||||
| `ns-imports` | implemented+tested | ✓ |
|
||||
| `ns-interns` | implemented+tested | ✓ |
|
||||
| `ns-map` | implemented+tested | ✓ |
|
||||
| `ns-name` | implemented+tested | ✓ |
|
||||
| `ns-publics` | implemented+tested | ✓ |
|
||||
| `ns-refers` | implemented+tested | ✓ |
|
||||
| `ns-resolve` | implemented+tested | ✓ |
|
||||
| `ns-unalias` | implemented+tested | ✓ |
|
||||
| `ns-unmap` | implemented+tested | ✓ |
|
||||
| `nth` | implemented+tested | ✓ |
|
||||
| `nthnext` | implemented+tested | ✓ |
|
||||
| `nthrest` | implemented+tested | ✓ |
|
||||
| `num` | implemented+tested | ✓ |
|
||||
| `number?` | implemented+tested | ✓ |
|
||||
| `numerator` | implemented+tested | ✓ |
|
||||
| `object-array` | implemented+tested | ✓ |
|
||||
| `odd?` | implemented+tested | ✓ |
|
||||
| `or` | implemented+tested | ✓ |
|
||||
| `parents` | implemented+tested | ✓ |
|
||||
| `parse-boolean` | implemented+tested | ✓ |
|
||||
| `parse-double` | implemented+tested | ✓ |
|
||||
| `parse-long` | implemented+tested | ✓ |
|
||||
| `parse-uuid` | implemented+tested | ✓ |
|
||||
| `partial` | implemented+tested | ✓ |
|
||||
| `partition` | implemented+tested | ✓ |
|
||||
| `partition-all` | implemented+tested | ✓ |
|
||||
| `partition-by` | implemented+tested | ✓ |
|
||||
| `partitionv` | implemented+tested | |
|
||||
| `partitionv-all` | implemented+tested | |
|
||||
| `pcalls` | implemented+tested | ✓ |
|
||||
| `peek` | implemented+tested | ✓ |
|
||||
| `persistent!` | implemented+tested | ✓ |
|
||||
| `pmap` | implemented+tested | ✓ |
|
||||
| `pop` | implemented+tested | ✓ |
|
||||
| `pop!` | implemented+tested | ✓ |
|
||||
| `pop-thread-bindings` | implemented+tested | |
|
||||
| `pos-int?` | implemented+tested | ✓ |
|
||||
| `pos?` | implemented+tested | ✓ |
|
||||
| `pr` | implemented+tested | ✓ |
|
||||
| `pr-str` | implemented+tested | ✓ |
|
||||
| `prefer-method` | implemented+tested | ✓ |
|
||||
| `prefers` | implemented+tested | ✓ |
|
||||
| `primitives-classnames` | jvm-specific | ✓ |
|
||||
| `print` | implemented+tested | ✓ |
|
||||
| `print-ctor` | jvm-specific | ✓ |
|
||||
| `print-dup` | implemented+tested | ✓ |
|
||||
| `print-method` | implemented+tested | ✓ |
|
||||
| `print-simple` | jvm-specific | ✓ |
|
||||
| `print-str` | implemented+tested | ✓ |
|
||||
| `printf` | implemented+tested | ✓ |
|
||||
| `println` | implemented+tested | ✓ |
|
||||
| `println-str` | implemented+tested | ✓ |
|
||||
| `prn` | implemented+tested | ✓ |
|
||||
| `prn-str` | implemented+tested | ✓ |
|
||||
| `promise` | implemented+tested | ✓ |
|
||||
| `proxy` | implemented+tested | ✓ |
|
||||
| `proxy-call-with-super` | implemented+tested | |
|
||||
| `proxy-mappings` | implemented+tested | ✓ |
|
||||
| `proxy-name` | jvm-specific | |
|
||||
| `proxy-super` | implemented+tested | ✓ |
|
||||
| `push-thread-bindings` | implemented+tested | |
|
||||
| `pvalues` | implemented+tested | ✓ |
|
||||
| `qualified-ident?` | implemented+tested | ✓ |
|
||||
| `qualified-keyword?` | implemented+tested | ✓ |
|
||||
| `qualified-symbol?` | implemented+tested | ✓ |
|
||||
| `quot` | implemented+tested | ✓ |
|
||||
| `quote` | special-form | ✓ |
|
||||
| `rand` | implemented+tested | ✓ |
|
||||
| `rand-int` | implemented+tested | ✓ |
|
||||
| `rand-nth` | implemented+tested | ✓ |
|
||||
| `random-sample` | implemented+tested | ✓ |
|
||||
| `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-matches` | implemented+tested | ✓ |
|
||||
| `re-pattern` | implemented+tested | ✓ |
|
||||
| `re-seq` | implemented+tested | ✓ |
|
||||
| `read` | implemented+tested | ✓ |
|
||||
| `read+string` | implemented+tested | ✓ |
|
||||
| `read-line` | implemented+tested | ✓ |
|
||||
| `read-string` | implemented+tested | ✓ |
|
||||
| `reader-conditional` | implemented+tested | ✓ |
|
||||
| `reader-conditional?` | implemented+tested | ✓ |
|
||||
| `realized?` | implemented+tested | ✓ |
|
||||
| `record?` | implemented+tested | ✓ |
|
||||
| `recur` | special-form | ✓ |
|
||||
| `reduce` | implemented+tested | ✓ |
|
||||
| `reduce-kv` | implemented+tested | ✓ |
|
||||
| `reduced` | implemented+tested | ✓ |
|
||||
| `reduced?` | implemented+tested | ✓ |
|
||||
| `reductions` | implemented+tested | ✓ |
|
||||
| `ref` | stm-refs | ✓ |
|
||||
| `ref-history-count` | stm-refs | ✓ |
|
||||
| `ref-max-history` | stm-refs | |
|
||||
| `ref-min-history` | stm-refs | ✓ |
|
||||
| `ref-set` | stm-refs | ✓ |
|
||||
| `refer` | implemented+tested | ✓ |
|
||||
| `refer-clojure` | implemented+tested | ✓ |
|
||||
| `reify` | implemented+tested | ✓ |
|
||||
| `release-pending-sends` | agents-taps | ✓ |
|
||||
| `rem` | implemented+tested | ✓ |
|
||||
| `remove` | implemented+tested | ✓ |
|
||||
| `remove-all-methods` | implemented+tested | ✓ |
|
||||
| `remove-method` | implemented+tested | ✓ |
|
||||
| `remove-ns` | implemented+tested | ✓ |
|
||||
| `remove-tap` | agents-taps | |
|
||||
| `remove-watch` | implemented+tested | ✓ |
|
||||
| `repeat` | implemented+tested | ✓ |
|
||||
| `repeatedly` | implemented+tested | ✓ |
|
||||
| `replace` | implemented+tested | ✓ |
|
||||
| `replicate` | implemented+tested | ✓ |
|
||||
| `require` | implemented+tested | ✓ |
|
||||
| `requiring-resolve` | jvm-specific | ✓ |
|
||||
| `reset!` | implemented+tested | ✓ |
|
||||
| `reset-meta!` | implemented+tested | ✓ |
|
||||
| `reset-vals!` | implemented+tested | ✓ |
|
||||
| `resolve` | implemented+tested | ✓ |
|
||||
| `rest` | implemented+tested | ✓ |
|
||||
| `restart-agent` | implemented+tested | ✓ |
|
||||
| `resultset-seq` | jvm-specific | ✓ |
|
||||
| `reverse` | implemented+tested | ✓ |
|
||||
| `reversible?` | implemented+tested | ✓ |
|
||||
| `rseq` | implemented+tested | ✓ |
|
||||
| `rsubseq` | implemented+tested | ✓ |
|
||||
| `run!` | implemented+tested | ✓ |
|
||||
| `satisfies?` | implemented+tested | ✓ |
|
||||
| `second` | implemented+tested | ✓ |
|
||||
| `select-keys` | implemented+tested | ✓ |
|
||||
| `send` | implemented+tested | ✓ |
|
||||
| `send-off` | implemented+tested | ✓ |
|
||||
| `send-via` | agents-taps | ✓ |
|
||||
| `seq` | implemented+tested | ✓ |
|
||||
| `seq-to-map-for-destructuring` | implemented+tested | ✓ |
|
||||
| `seq?` | implemented+tested | ✓ |
|
||||
| `seqable?` | implemented+tested | ✓ |
|
||||
| `seque` | implemented+tested | ✓ |
|
||||
| `sequence` | implemented+tested | ✓ |
|
||||
| `sequential?` | implemented+tested | ✓ |
|
||||
| `set` | implemented+tested | ✓ |
|
||||
| `set!` | special-form | ✓ |
|
||||
| `set-agent-send-executor!` | agents-taps | ✓ |
|
||||
| `set-agent-send-off-executor!` | agents-taps | ✓ |
|
||||
| `set-error-handler!` | agents-taps | ✓ |
|
||||
| `set-error-mode!` | agents-taps | ✓ |
|
||||
| `set-validator!` | implemented+tested | ✓ |
|
||||
| `set?` | implemented+tested | ✓ |
|
||||
| `short` | implemented+tested | ✓ |
|
||||
| `short-array` | implemented+tested | ✓ |
|
||||
| `shorts` | implemented+tested | ✓ |
|
||||
| `shuffle` | implemented+tested | ✓ |
|
||||
| `shutdown-agents` | agents-taps | ✓ |
|
||||
| `simple-ident?` | implemented+tested | ✓ |
|
||||
| `simple-keyword?` | implemented+tested | ✓ |
|
||||
| `simple-symbol?` | implemented+tested | ✓ |
|
||||
| `slurp` | implemented+tested | ✓ |
|
||||
| `some` | implemented+tested | ✓ |
|
||||
| `some->` | implemented+tested | ✓ |
|
||||
| `some->>` | implemented+tested | ✓ |
|
||||
| `some-fn` | implemented+tested | ✓ |
|
||||
| `some?` | implemented+tested | ✓ |
|
||||
| `sort` | implemented+tested | ✓ |
|
||||
| `sort-by` | implemented+tested | ✓ |
|
||||
| `sorted-map` | implemented+tested | ✓ |
|
||||
| `sorted-map-by` | implemented+tested | ✓ |
|
||||
| `sorted-set` | implemented+tested | ✓ |
|
||||
| `sorted-set-by` | implemented+tested | ✓ |
|
||||
| `sorted?` | implemented+tested | ✓ |
|
||||
| `special-symbol?` | implemented+tested | ✓ |
|
||||
| `spit` | implemented+tested | ✓ |
|
||||
| `split-at` | implemented+tested | ✓ |
|
||||
| `split-with` | implemented+tested | ✓ |
|
||||
| `splitv-at` | implemented+tested | |
|
||||
| `str` | implemented+tested | ✓ |
|
||||
| `stream-into!` | jvm-specific | |
|
||||
| `stream-reduce!` | jvm-specific | |
|
||||
| `stream-seq!` | jvm-specific | |
|
||||
| `stream-transduce!` | jvm-specific | |
|
||||
| `string?` | implemented+tested | ✓ |
|
||||
| `struct` | jvm-specific | ✓ |
|
||||
| `struct-map` | jvm-specific | ✓ |
|
||||
| `subs` | implemented+tested | ✓ |
|
||||
| `subseq` | implemented+tested | ✓ |
|
||||
| `subvec` | implemented+tested | ✓ |
|
||||
| `supers` | implemented+tested | ✓ |
|
||||
| `swap!` | implemented+tested | ✓ |
|
||||
| `swap-vals!` | implemented+tested | ✓ |
|
||||
| `symbol` | implemented+tested | ✓ |
|
||||
| `symbol?` | implemented+tested | ✓ |
|
||||
| `sync` | stm-refs | |
|
||||
| `tagged-literal` | implemented+tested | ✓ |
|
||||
| `tagged-literal?` | implemented+tested | |
|
||||
| `take` | implemented+tested | ✓ |
|
||||
| `take-last` | implemented+tested | ✓ |
|
||||
| `take-nth` | implemented+tested | ✓ |
|
||||
| `take-while` | implemented+tested | ✓ |
|
||||
| `tap>` | agents-taps | ✓ |
|
||||
| `test` | implemented+tested | ✓ |
|
||||
| `the-ns` | implemented+tested | ✓ |
|
||||
| `thread-bound?` | implemented+tested | ✓ |
|
||||
| `throw` | special-form | ✓ |
|
||||
| `time` | implemented+tested | ✓ |
|
||||
| `to-array` | implemented+tested | ✓ |
|
||||
| `to-array-2d` | implemented+tested | ✓ |
|
||||
| `trampoline` | implemented+tested | ✓ |
|
||||
| `transduce` | implemented+tested | ✓ |
|
||||
| `transient` | implemented+tested | ✓ |
|
||||
| `tree-seq` | implemented+tested | ✓ |
|
||||
| `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 | ✓ |
|
||||
| `unquote` | jvm-specific | ✓ |
|
||||
| `unquote-splicing` | jvm-specific | ✓ |
|
||||
| `unreduced` | implemented+tested | ✓ |
|
||||
| `unsigned-bit-shift-right` | implemented+tested | ✓ |
|
||||
| `update` | implemented+tested | ✓ |
|
||||
| `update-in` | implemented+tested | ✓ |
|
||||
| `update-keys` | implemented+tested | ✓ |
|
||||
| `update-proxy` | implemented+tested | ✓ |
|
||||
| `update-vals` | implemented+tested | ✓ |
|
||||
| `uri?` | implemented+tested | ✓ |
|
||||
| `use` | implemented+tested | ✓ |
|
||||
| `uuid?` | implemented+tested | ✓ |
|
||||
| `val` | implemented+tested | ✓ |
|
||||
| `vals` | implemented+tested | ✓ |
|
||||
| `var` | special-form | ✓ |
|
||||
| `var-get` | implemented+tested | ✓ |
|
||||
| `var-set` | implemented+tested | ✓ |
|
||||
| `var?` | implemented+tested | ✓ |
|
||||
| `vary-meta` | implemented+tested | ✓ |
|
||||
| `vec` | implemented+tested | ✓ |
|
||||
| `vector` | implemented+tested | ✓ |
|
||||
| `vector-of` | jvm-specific | ✓ |
|
||||
| `vector?` | implemented+tested | ✓ |
|
||||
| `volatile!` | implemented+tested | ✓ |
|
||||
| `volatile?` | implemented+tested | ✓ |
|
||||
| `vreset!` | implemented+tested | ✓ |
|
||||
| `vswap!` | implemented+tested | ✓ |
|
||||
| `when` | implemented+tested | ✓ |
|
||||
| `when-first` | implemented+tested | ✓ |
|
||||
| `when-let` | implemented+tested | ✓ |
|
||||
| `when-not` | implemented+tested | ✓ |
|
||||
| `when-some` | implemented+tested | ✓ |
|
||||
| `while` | implemented+tested | ✓ |
|
||||
| `with-bindings` | implemented+tested | ✓ |
|
||||
| `with-bindings*` | implemented+tested | ✓ |
|
||||
| `with-in-str` | implemented+tested | ✓ |
|
||||
| `with-loading-context` | jvm-specific | |
|
||||
| `with-local-vars` | implemented+tested | ✓ |
|
||||
| `with-meta` | implemented+tested | ✓ |
|
||||
| `with-open` | implemented+tested | ✓ |
|
||||
| `with-out-str` | implemented+tested | ✓ |
|
||||
| `with-precision` | implemented+tested | ✓ |
|
||||
| `with-redefs` | implemented+tested | ✓ |
|
||||
| `with-redefs-fn` | implemented+tested | ✓ |
|
||||
| `xml-seq` | implemented+tested | ✓ |
|
||||
| `zero?` | implemented+tested | ✓ |
|
||||
| `zipmap` | implemented+tested | ✓ |
|
||||
|
|
@ -1,216 +0,0 @@
|
|||
# deps.edn support — design notes
|
||||
|
||||
How Jolt loads pure-Clojure libraries from a `deps.edn`, and why it's built the
|
||||
way it is. For how to *use* it, see [building-and-deps.md](building-and-deps.md).
|
||||
|
||||
Scope, decided up front:
|
||||
|
||||
- **git + local deps only** — no Maven/`~/.m2` resolution.
|
||||
- **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.
|
||||
|
||||
## How resolution works
|
||||
|
||||
`jolt.deps` (`jolt-core/jolt/deps.clj`) reads `deps.edn` (jolt's own reader
|
||||
parses the EDN), then walks `:deps`:
|
||||
|
||||
- `:git/url` + `:git/sha` (+ optional `:deps/root`) → clone the sha into the git
|
||||
cache and contribute the checkout (or its `:deps/root` subdir);
|
||||
- `: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.
|
||||
|
||||
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.
|
||||
|
||||
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.
|
||||
|
||||
## How the CLI ties it together
|
||||
|
||||
`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:
|
||||
|
||||
- `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 1–2 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.
|
||||
|
||||
## Limitations
|
||||
|
||||
- Pure `clj`/`cljc` only — JVM interop, host classes, and unimplemented
|
||||
`clojure.core` corners fail. Coverage is per-function: a namespace can load with
|
||||
most functions working and a few not.
|
||||
- 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{…}`).
|
||||
|
|
@ -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)
|
||||
|
|
@ -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")
|
||||
|
|
@ -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"))
|
||||
|
|
@ -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)"
|
||||
|
|
@ -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))
|
||||
|
|
@ -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)))))
|
||||
|
|
@ -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))))
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
120
host/chez/cts.sh
120
host/chez/cts.sh
|
|
@ -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
|
||||
186
host/chez/dce.ss
186
host/chez/dce.ss
|
|
@ -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?))))))))
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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))
|
||||
|
|
@ -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!)
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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")
|
||||
|
|
@ -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?)
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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))
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)))))
|
||||
|
|
@ -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)
|
||||
|
|
@ -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
|
|
@ -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))))
|
||||
|
||||
|
|
@ -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)))
|
||||
|
||||
|
|
@ -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)
|
||||
|
|
@ -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))))))
|
||||
|
|
@ -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
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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")
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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)"
|
||||
|
|
@ -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)
|
||||
|
|
@ -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")))
|
||||
|
|
@ -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)
|
||||
|
|
@ -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?)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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))
|
||||
|
|
@ -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)
|
||||
391
host/chez/ns.ss
391
host/chez/ns.ss
|
|
@ -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)
|
||||
122
host/chez/png.ss
122
host/chez/png.ss
|
|
@ -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)
|
||||
|
|
@ -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))))))
|
||||
|
|
@ -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?)
|
||||
|
|
@ -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)
|
||||
1007
host/chez/reader.ss
1007
host/chez/reader.ss
File diff suppressed because it is too large
Load diff
Some files were not shown because too many files have changed in this diff Show more
Loading…
Add table
Add a link
Reference in a new issue