Compare commits
No commits in common. "main" and "docs/host-interop-concurrency-refs" have entirely different histories.
main
...
docs/host-
151 changed files with 5920 additions and 17136 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
|
|
||||||
6
.github/workflows/tests.yml
vendored
6
.github/workflows/tests.yml
vendored
|
|
@ -56,11 +56,7 @@ jobs:
|
||||||
- name: Install JDK + Clojure (certify oracle)
|
- name: Install JDK + Clojure (certify oracle)
|
||||||
run: |
|
run: |
|
||||||
sudo apt-get install -y default-jdk rlwrap
|
sudo apt-get install -y default-jdk rlwrap
|
||||||
# --retry + --fail so a transient CDN error retries instead of handing
|
curl -L -O https://github.com/clojure/brew-install/releases/latest/download/linux-install.sh
|
||||||
# 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
|
sudo bash linux-install.sh
|
||||||
clojure --version
|
clojure --version
|
||||||
|
|
||||||
|
|
|
||||||
1
.gitignore
vendored
1
.gitignore
vendored
|
|
@ -2,7 +2,6 @@ AGENTS.md
|
||||||
.DS_Store
|
.DS_Store
|
||||||
CLAUDE.md
|
CLAUDE.md
|
||||||
build/
|
build/
|
||||||
target/
|
|
||||||
.clj-kondo/
|
.clj-kondo/
|
||||||
.dirge/
|
.dirge/
|
||||||
.claude/
|
.claude/
|
||||||
|
|
|
||||||
3
.gitmodules
vendored
3
.gitmodules
vendored
|
|
@ -4,6 +4,3 @@
|
||||||
[submodule "vendor/sci"]
|
[submodule "vendor/sci"]
|
||||||
path = vendor/sci
|
path = vendor/sci
|
||||||
url = https://github.com/borkdude/sci.git
|
url = https://github.com/borkdude/sci.git
|
||||||
[submodule "vendor/clojure-test-suite"]
|
|
||||||
path = vendor/clojure-test-suite
|
|
||||||
url = https://github.com/jank-lang/clojure-test-suite.git
|
|
||||||
|
|
|
||||||
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
|
THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE
|
||||||
PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION
|
PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF
|
||||||
OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT.
|
THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT.
|
||||||
|
|
||||||
1. DEFINITIONS
|
1. DEFINITIONS
|
||||||
|
|
||||||
"Contribution" means:
|
"Contribution" means:
|
||||||
|
|
||||||
a) in the case of the initial Contributor, the initial content
|
a) in the case of the initial Contributor, the initial code and
|
||||||
Distributed under this Agreement, and
|
documentation distributed under this Agreement, and
|
||||||
|
|
||||||
b) in the case of each subsequent Contributor:
|
b) in the case of each subsequent Contributor:
|
||||||
i) changes to the Program, and
|
|
||||||
ii) additions to the Program;
|
|
||||||
where such changes and/or additions to the Program originate from
|
|
||||||
and are Distributed by that particular Contributor. A Contribution
|
|
||||||
"originates" from a Contributor if it was added to the Program by
|
|
||||||
such Contributor itself or anyone acting on such Contributor's behalf.
|
|
||||||
Contributions do not include changes or additions to the Program that
|
|
||||||
are not Modified Works.
|
|
||||||
|
|
||||||
"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
|
"Licensed Patents" mean patent claims licensable by a Contributor which
|
||||||
are necessarily infringed by the use or sale of its Contribution alone
|
are necessarily infringed by the use or sale of its Contribution alone
|
||||||
or when combined with the Program.
|
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.
|
Agreement.
|
||||||
|
|
||||||
"Recipient" means anyone who receives the Program under this Agreement
|
"Recipient" means anyone who receives the Program under this Agreement,
|
||||||
or any Secondary License (as applicable), including Contributors.
|
including all Contributors.
|
||||||
|
|
||||||
"Derivative Works" shall mean any work, whether in Source Code or other
|
|
||||||
form, that is based on (or derived from) the Program and for which the
|
|
||||||
editorial revisions, annotations, elaborations, or other modifications
|
|
||||||
represent, as a whole, an original work of authorship.
|
|
||||||
|
|
||||||
"Modified Works" shall mean any work in Source Code or other form that
|
|
||||||
results from an addition to, deletion from, or modification of the
|
|
||||||
contents of the Program, including, for purposes of clarity any new file
|
|
||||||
in Source Code form that contains any contents of the Program. Modified
|
|
||||||
Works shall not include works that contain only declarations,
|
|
||||||
interfaces, types, classes, structures, or files of the Program solely
|
|
||||||
in each case in order to link to, bind by name, or subclass the Program
|
|
||||||
or Modified Works thereof.
|
|
||||||
|
|
||||||
"Distribute" means the acts of a) distributing or b) making available
|
|
||||||
in any manner that enables the transfer of a copy.
|
|
||||||
|
|
||||||
"Source Code" means the form of a Program preferred for making
|
|
||||||
modifications, including but not limited to software source code,
|
|
||||||
documentation source, and configuration files.
|
|
||||||
|
|
||||||
"Secondary License" means either the GNU General Public License,
|
|
||||||
Version 2.0, or any later versions of that license, including any
|
|
||||||
exceptions or additional permissions as identified by the initial
|
|
||||||
Contributor.
|
|
||||||
|
|
||||||
2. GRANT OF RIGHTS
|
2. GRANT OF RIGHTS
|
||||||
|
|
||||||
a) Subject to the terms of this Agreement, each Contributor hereby
|
a) Subject to the terms of this Agreement, each Contributor hereby
|
||||||
grants Recipient a non-exclusive, worldwide, royalty-free copyright
|
grants Recipient a non-exclusive, worldwide, royalty-free copyright
|
||||||
license to reproduce, prepare Derivative Works of, publicly display,
|
license to reproduce, prepare derivative works of, publicly display,
|
||||||
publicly perform, Distribute and sublicense the Contribution of such
|
publicly perform, distribute and sublicense the Contribution of such
|
||||||
Contributor, if any, and such Derivative Works.
|
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
|
b) Subject to the terms of this Agreement, each Contributor hereby
|
||||||
grants Recipient a non-exclusive, worldwide, royalty-free patent
|
grants Recipient a non-exclusive, worldwide, royalty-free patent license
|
||||||
license under Licensed Patents to make, use, sell, offer to sell,
|
under Licensed Patents to make, use, sell, offer to sell, import and
|
||||||
import and otherwise transfer the Contribution of such Contributor,
|
otherwise transfer the Contribution of such Contributor, if any, in
|
||||||
if any, in Source Code or other form. This patent license shall
|
source code and object code form. This patent license shall apply to the
|
||||||
apply to the combination of the Contribution and the Program if, at
|
combination of the Contribution and the Program if, at the time the
|
||||||
the time the Contribution is added by the Contributor, such addition
|
Contribution is added by the Contributor, such addition of the
|
||||||
of the Contribution causes such combination to be covered by the
|
Contribution causes such combination to be covered by the Licensed
|
||||||
Licensed Patents. The patent license shall not apply to any other
|
Patents. The patent license shall not apply to any other combinations
|
||||||
combinations which include the Contribution. No hardware per se is
|
which include the Contribution. No hardware per se is licensed
|
||||||
licensed hereunder.
|
hereunder.
|
||||||
|
|
||||||
c) Recipient understands that although each Contributor grants the
|
c) Recipient understands that although each Contributor grants the
|
||||||
licenses to its Contributions set forth herein, no assurances are
|
licenses to its Contributions set forth herein, no assurances are
|
||||||
provided by any Contributor that the Program does not infringe the
|
provided by any Contributor that the Program does not infringe the
|
||||||
patent or other intellectual property rights of any other entity.
|
patent or other intellectual property rights of any other entity. Each
|
||||||
Each Contributor disclaims any liability to Recipient for claims
|
Contributor disclaims any liability to Recipient for claims brought by
|
||||||
brought by any other entity based on infringement of intellectual
|
any other entity based on infringement of intellectual property rights
|
||||||
property rights or otherwise. As a condition to exercising the
|
or otherwise. As a condition to exercising the rights and licenses
|
||||||
rights and licenses granted hereunder, each Recipient hereby
|
granted hereunder, each Recipient hereby assumes sole responsibility to
|
||||||
assumes sole responsibility to secure any other intellectual
|
secure any other intellectual property rights needed, if any. For
|
||||||
property rights needed, if any. For example, if a third party
|
example, if a third party patent license is required to allow Recipient
|
||||||
patent license is required to allow Recipient to Distribute the
|
to distribute the Program, it is Recipient's responsibility to acquire
|
||||||
Program, it is Recipient's responsibility to acquire that license
|
that license before distributing the Program.
|
||||||
before distributing the Program.
|
|
||||||
|
|
||||||
d) Each Contributor represents that to its knowledge it has
|
d) Each Contributor represents that to its knowledge it has sufficient
|
||||||
sufficient copyright rights in its Contribution, if any, to grant
|
copyright rights in its Contribution, if any, to grant the copyright
|
||||||
the copyright license set forth in this Agreement.
|
license set forth in this Agreement.
|
||||||
|
|
||||||
e) Notwithstanding the terms of any Secondary License, no
|
|
||||||
Contributor makes additional grants to any Recipient (other than
|
|
||||||
those set forth in this Agreement) as a result of such Recipient's
|
|
||||||
receipt of the Program under the terms of a Secondary License
|
|
||||||
(if permitted under the terms of Section 3).
|
|
||||||
|
|
||||||
3. REQUIREMENTS
|
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
|
a) it complies with the terms and conditions of this Agreement; and
|
||||||
accordance with section 3.2, and the Contributor must accompany
|
|
||||||
the Program with a statement that the Source Code for the Program
|
|
||||||
is available under this Agreement, and informs Recipients how to
|
|
||||||
obtain it in a reasonable manner on or through a medium customarily
|
|
||||||
used for software exchange; and
|
|
||||||
|
|
||||||
b) the Contributor may Distribute the Program under a license
|
b) its license agreement:
|
||||||
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;
|
|
||||||
|
|
||||||
ii) effectively excludes on behalf of all other Contributors all
|
i) effectively disclaims on behalf of all Contributors all warranties
|
||||||
liability for damages, including direct, indirect, special,
|
and conditions, express and implied, including warranties or conditions
|
||||||
incidental and consequential damages, such as lost profits;
|
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
|
ii) effectively excludes on behalf of all Contributors all liability for
|
||||||
in the Source Code under section 3.2; and
|
damages, including direct, indirect, special, incidental and
|
||||||
|
consequential damages, such as lost profits;
|
||||||
|
|
||||||
iv) requires any subsequent distribution of the Program by any
|
iii) states that any provisions which differ from this Agreement are
|
||||||
party to be under a license that satisfies the requirements
|
offered by that Contributor alone and not by any other party; and
|
||||||
of this section 3.
|
|
||||||
|
|
||||||
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
|
When the Program is made available in source code form:
|
||||||
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
|
|
||||||
|
|
||||||
b) a copy of this Agreement must be included with each copy of
|
a) it must be made available under this Agreement; and
|
||||||
the Program.
|
|
||||||
|
|
||||||
3.3 Contributors may not remove or alter any copyright, patent,
|
b) a copy of this Agreement must be included with each copy of the
|
||||||
trademark, attribution notices, disclaimers of warranty, or limitations
|
Program.
|
||||||
of liability ("notices") contained within the Program from any copy of
|
|
||||||
the Program which they Distribute, provided that Contributors may add
|
Contributors may not remove or alter any copyright notices contained
|
||||||
their own appropriate notices.
|
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
|
4. COMMERCIAL DISTRIBUTION
|
||||||
|
|
||||||
Commercial distributors of software may accept certain responsibilities
|
Commercial distributors of software may accept certain responsibilities
|
||||||
with respect to end users, business partners and the like. While this
|
with respect to end users, business partners and the like. While this
|
||||||
license is intended to facilitate the commercial use of the Program,
|
license is intended to facilitate the commercial use of the Program, the
|
||||||
the Contributor who includes the Program in a commercial product
|
Contributor who includes the Program in a commercial product offering
|
||||||
offering should do so in a manner which does not create potential
|
should do so in a manner which does not create potential liability for
|
||||||
liability for other Contributors. Therefore, if a Contributor includes
|
other Contributors. Therefore, if a Contributor includes the Program in
|
||||||
the Program in a commercial product offering, such Contributor
|
a commercial product offering, such Contributor ("Commercial
|
||||||
("Commercial Contributor") hereby agrees to defend and indemnify every
|
Contributor") hereby agrees to defend and indemnify every other
|
||||||
other Contributor ("Indemnified Contributor") against any losses,
|
Contributor ("Indemnified Contributor") against any losses, damages and
|
||||||
damages and costs (collectively "Losses") arising from claims, lawsuits
|
costs (collectively "Losses") arising from claims, lawsuits and other
|
||||||
and other legal actions brought by a third party against the Indemnified
|
legal actions brought by a third party against the Indemnified
|
||||||
Contributor to the extent caused by the acts or omissions of such
|
Contributor to the extent caused by the acts or omissions of such
|
||||||
Commercial Contributor in connection with its distribution of the Program
|
Commercial Contributor in connection with its distribution of the
|
||||||
in a commercial product offering. The obligations in this section do not
|
Program in a commercial product offering. The obligations in this
|
||||||
apply to any claims or Losses relating to any actual or alleged
|
section do not apply to any claims or Losses relating to any actual or
|
||||||
intellectual property infringement. In order to qualify, an Indemnified
|
alleged intellectual property infringement. In order to qualify, an
|
||||||
Contributor must: a) promptly notify the Commercial Contributor in
|
Indemnified Contributor must: a) promptly notify the Commercial
|
||||||
writing of such claim, and b) allow the Commercial Contributor to control,
|
Contributor in writing of such claim, and b) allow the Commercial
|
||||||
and cooperate with the Commercial Contributor in, the defense and any
|
Contributor to control, and cooperate with the Commercial Contributor
|
||||||
related settlement negotiations. The Indemnified Contributor may
|
in, the defense and any related settlement negotiations. The Indemnified
|
||||||
participate in any such claim at its own expense.
|
Contributor may participate in any such claim at its own expense.
|
||||||
|
|
||||||
For example, a Contributor might include the Program in a commercial
|
For example, a Contributor might include the Program in a commercial
|
||||||
product offering, Product X. That Contributor is then 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, or offers warranties related to Product X, those performance
|
||||||
claims and warranties are such Commercial Contributor's responsibility
|
claims and warranties are such Commercial Contributor's responsibility
|
||||||
alone. Under this section, the Commercial Contributor would have to
|
alone. Under this section, the Commercial Contributor would have to
|
||||||
defend claims against the other Contributors related to those performance
|
defend claims against the other Contributors related to those
|
||||||
claims and warranties, and if a court requires any other Contributor to
|
performance claims and warranties, and if a court requires any other
|
||||||
pay any damages as a result, the Commercial Contributor must pay
|
Contributor to pay any damages as a result, the Commercial Contributor
|
||||||
those damages.
|
must pay those damages.
|
||||||
|
|
||||||
5. NO WARRANTY
|
5. NO WARRANTY
|
||||||
|
|
||||||
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT
|
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED
|
||||||
PERMITTED BY APPLICABLE LAW, THE PROGRAM IS PROVIDED ON AN "AS IS"
|
ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND,
|
||||||
BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR
|
EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES
|
||||||
IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF
|
OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR
|
||||||
TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR
|
A PARTICULAR PURPOSE. Each Recipient is solely responsible for
|
||||||
PURPOSE. Each Recipient is solely responsible for determining the
|
determining the appropriateness of using and distributing the Program
|
||||||
appropriateness of using and distributing the Program and assumes all
|
and assumes all risks associated with its exercise of rights under this
|
||||||
risks associated with its exercise of rights under this Agreement,
|
Agreement, including but not limited to the risks and costs of program
|
||||||
including but not limited to the risks and costs of program errors,
|
errors, compliance with applicable laws, damage to or loss of data,
|
||||||
compliance with applicable laws, damage to or loss of data, programs
|
programs or equipment, and unavailability or interruption of operations.
|
||||||
or equipment, and unavailability or interruption of operations.
|
|
||||||
|
|
||||||
6. DISCLAIMER OF LIABILITY
|
6. DISCLAIMER OF LIABILITY
|
||||||
|
|
||||||
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT
|
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR
|
||||||
PERMITTED BY APPLICABLE LAW, NEITHER RECIPIENT NOR ANY CONTRIBUTORS
|
ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT,
|
||||||
SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
|
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING
|
||||||
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION LOST
|
WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF
|
||||||
PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
||||||
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR
|
||||||
ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE
|
DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED
|
||||||
EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE
|
HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
|
||||||
POSSIBILITY OF SUCH DAMAGES.
|
|
||||||
|
|
||||||
7. GENERAL
|
7. GENERAL
|
||||||
|
|
||||||
If any provision of this Agreement is invalid or unenforceable under
|
If any provision of this Agreement is invalid or unenforceable under
|
||||||
applicable law, it shall not affect the validity or enforceability of
|
applicable law, it shall not affect the validity or enforceability of
|
||||||
the remainder of the terms of this Agreement, and without further
|
the remainder of the terms of this Agreement, and without further action
|
||||||
action by the parties hereto, such provision shall be reformed to the
|
by the parties hereto, such provision shall be reformed to the minimum
|
||||||
minimum extent necessary to make such provision valid and enforceable.
|
extent necessary to make such provision valid and enforceable.
|
||||||
|
|
||||||
If Recipient institutes patent litigation against any entity
|
If Recipient institutes patent litigation against any entity (including
|
||||||
(including a cross-claim or counterclaim in a lawsuit) alleging that the
|
a cross-claim or counterclaim in a lawsuit) alleging that the Program
|
||||||
Program itself (excluding combinations of the Program with other software
|
itself (excluding combinations of the Program with other software or
|
||||||
or hardware) infringes such Recipient's patent(s), then such Recipient's
|
hardware) infringes such Recipient's patent(s), then such Recipient's
|
||||||
rights granted under Section 2(b) shall terminate as of the date such
|
rights granted under Section 2(b) shall terminate as of the date such
|
||||||
litigation is filed.
|
litigation is filed.
|
||||||
|
|
||||||
All Recipient's rights under this Agreement shall terminate if it
|
All Recipient's rights under this Agreement shall terminate if it fails
|
||||||
fails to comply with any of the material terms or conditions of this
|
to comply with any of the material terms or conditions of this Agreement
|
||||||
Agreement and does not cure such failure in a reasonable period of
|
and does not cure such failure in a reasonable period of time after
|
||||||
time after becoming aware of such noncompliance. If all Recipient's
|
becoming aware of such noncompliance. If all Recipient's rights under
|
||||||
rights under this Agreement terminate, Recipient agrees to cease use
|
this Agreement terminate, Recipient agrees to cease use and distribution
|
||||||
and distribution of the Program as soon as reasonably practicable.
|
of the Program as soon as reasonably practicable. However, Recipient's
|
||||||
However, Recipient's obligations under this Agreement and any licenses
|
obligations under this Agreement and any licenses granted by Recipient
|
||||||
granted by Recipient relating to the Program shall continue and survive.
|
relating to the Program shall continue and survive.
|
||||||
|
|
||||||
Everyone is permitted to copy and distribute copies of this Agreement,
|
Everyone is permitted to copy and distribute copies of this Agreement,
|
||||||
but in order to avoid inconsistency the Agreement is copyrighted and
|
but in order to avoid inconsistency the Agreement is copyrighted and may
|
||||||
may only be modified in the following manner. The Agreement Steward
|
only be modified in the following manner. The Agreement Steward reserves
|
||||||
reserves the right to publish new versions (including revisions) of
|
the right to publish new versions (including revisions) of this
|
||||||
this Agreement from time to time. No one other than the Agreement
|
Agreement from time to time. No one other than the Agreement Steward has
|
||||||
Steward has the right to modify this Agreement. The Eclipse Foundation
|
the right to modify this Agreement. The Eclipse Foundation is the
|
||||||
is the initial Agreement Steward. The Eclipse Foundation may assign the
|
initial Agreement Steward. The Eclipse Foundation may assign the
|
||||||
responsibility to serve as the Agreement Steward to a suitable separate
|
responsibility to serve as the Agreement Steward to a suitable separate
|
||||||
entity. Each new version of the Agreement will be given a distinguishing
|
entity. Each new version of the Agreement will be given a distinguishing
|
||||||
version number. The Program (including Contributions) may always be
|
version number. The Program (including Contributions) may always be
|
||||||
Distributed subject to the version of the Agreement under which it was
|
distributed subject to the version of the Agreement under which it was
|
||||||
received. In addition, after a new version of the Agreement is published,
|
received. In addition, after a new version of the Agreement is
|
||||||
Contributor may elect to Distribute the Program (including its
|
published, Contributor may elect to distribute the Program (including
|
||||||
Contributions) under the new version.
|
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
|
This Agreement is governed by the laws of the State of New York and the
|
||||||
receives no rights or licenses to the intellectual property of any
|
intellectual property laws of the United States of America. No party to
|
||||||
Contributor under this Agreement, whether expressly, by implication,
|
this Agreement will bring a legal action under this Agreement more than
|
||||||
estoppel or otherwise. All rights in the Program not expressly granted
|
one year after the cause of action arose. Each party waives its rights
|
||||||
under this Agreement are reserved. Nothing in this Agreement is intended
|
to a jury trial in any resulting litigation.
|
||||||
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.
|
|
||||||
|
|
|
||||||
82
Makefile
82
Makefile
|
|
@ -4,23 +4,18 @@
|
||||||
# build step. `make test` is the full gate. `make remint` rebuilds the seed after a
|
# build step. `make test` is the full gate. `make remint` rebuilds the seed after a
|
||||||
# source change.
|
# 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
|
.PHONY: test ci values corpus unit smoke buildsmoke selfhost sci certify ffi transient infer directlink numeric inline shakesmoke remint
|
||||||
|
|
||||||
# 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
|
# Full gate (dev machine). Includes the self-host byte-fixpoint, which only holds
|
||||||
# on the same Chez that minted the seed.
|
# on the same Chez that minted the seed.
|
||||||
test: submodules selfhost ci
|
test: selfhost ci
|
||||||
@echo "OK: all gates passed"
|
@echo "OK: all gates passed"
|
||||||
|
|
||||||
# CI gate: behavior only. The checked-in seed is a minted artifact (like a
|
# 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
|
# 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
|
# 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).
|
# 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
|
ci: values corpus unit smoke buildsmoke sci ffi transient infer directlink numeric inline certify
|
||||||
@echo "OK: CI gates passed"
|
@echo "OK: CI gates passed"
|
||||||
|
|
||||||
# Self-host fixpoint: bootstrap.ss rebuild == checked-in seed.
|
# Self-host fixpoint: bootstrap.ss rebuild == checked-in seed.
|
||||||
|
|
@ -47,38 +42,10 @@ smoke:
|
||||||
buildsmoke:
|
buildsmoke:
|
||||||
@sh host/chez/build-smoke.sh
|
@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 conformance: load borkdude/sci's source through joltc (floor-gated).
|
||||||
sci:
|
sci:
|
||||||
@chez --script host/chez/run-sci.ss
|
@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
|
# FFI: bind native functions (typed foreign-procedure), memory, and that a
|
||||||
# :blocking call is collect-safe (a parked thread doesn't pin the collector).
|
# :blocking call is collect-safe (a parked thread doesn't pin the collector).
|
||||||
ffi:
|
ffi:
|
||||||
|
|
@ -94,49 +61,6 @@ transient:
|
||||||
infer:
|
infer:
|
||||||
@chez --script host/chez/run-infer.ss
|
@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$
|
# 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 +
|
# Scheme bindings and routes app->app calls/refs to them, skipping var-deref +
|
||||||
# jolt-invoke; ^:dynamic/^:redef and nested defs opt out.
|
# jolt-invoke; ^:dynamic/^:redef and nested defs opt out.
|
||||||
|
|
|
||||||
83
README.md
83
README.md
|
|
@ -7,31 +7,6 @@ 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
|
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.
|
(`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
|
## Requirements
|
||||||
|
|
||||||
Only [Chez Scheme](https://cisco.github.io/ChezScheme/) (the gate invokes it as
|
Only [Chez Scheme](https://cisco.github.io/ChezScheme/) (the gate invokes it as
|
||||||
|
|
@ -49,18 +24,6 @@ cd jolt
|
||||||
bin/joltc -e '(+ 1 2)' # => 3
|
bin/joltc -e '(+ 1 2)' # => 3
|
||||||
```
|
```
|
||||||
|
|
||||||
The `--recurse-submodules` matters: jolt vendors its regex engine and test
|
|
||||||
suites as git submodules. In a checkout that's missing them (a plain
|
|
||||||
`git clone`, or after pulling a commit that adds one), fetch them with:
|
|
||||||
|
|
||||||
```bash
|
|
||||||
git submodule update --init --recursive
|
|
||||||
```
|
|
||||||
|
|
||||||
Note that GitHub's auto-generated "Source code (zip/tar.gz)" archives on the
|
|
||||||
releases page do **not** contain submodules, so they can't run or build —
|
|
||||||
clone the repo instead (or grab a prebuilt binary from the same page).
|
|
||||||
|
|
||||||
After changing a compiler source — the reader (`host/chez/reader.ss`), the
|
After changing a compiler source — the reader (`host/chez/reader.ss`), the
|
||||||
analyzer/IR/backend (`jolt-core/jolt/*.clj`), or the `clojure.core` overlay
|
analyzer/IR/backend (`jolt-core/jolt/*.clj`), or the `clojure.core` overlay
|
||||||
(`jolt-core/clojure/core/*.clj`) — re-mint the seed:
|
(`jolt-core/clojure/core/*.clj`) — re-mint the seed:
|
||||||
|
|
@ -82,32 +45,6 @@ $ bin/joltc -e '(/ 1 2)'
|
||||||
1/2
|
1/2
|
||||||
```
|
```
|
||||||
|
|
||||||
## REPL and editor integration
|
|
||||||
|
|
||||||
```bash
|
|
||||||
bin/joltc repl # a line REPL with the project's deps loaded
|
|
||||||
bin/joltc --nrepl-server [port] # an nREPL server (default 7888) for editors
|
|
||||||
```
|
|
||||||
|
|
||||||
Both resolve the `deps.edn` in the current directory first, so the project's
|
|
||||||
source roots and native libraries are loaded — `(require '[my.ns])` works live.
|
|
||||||
`--nrepl-server` writes a `.nrepl-port` file in the project dir, so CIDER / Calva / Cursive
|
|
||||||
auto-detect the port; override it with the argument or `JOLT_NREPL_PORT`.
|
|
||||||
|
|
||||||
The server runs in dev mode — calls deref their var, so redefining a function
|
|
||||||
takes effect on the next call without restarting the process. The built-in
|
|
||||||
handler speaks `clone`/`describe`/`eval`/`load-file`/`close`; heavier ops
|
|
||||||
(sessions, interruptible eval, completion) are added as nREPL middleware listed
|
|
||||||
in `deps.edn` under `:nrepl/middleware`.
|
|
||||||
|
|
||||||
```clojure
|
|
||||||
;; from your editor, against the running process:
|
|
||||||
(require '[myapp.core :as app])
|
|
||||||
(app/start!) ; bring the app up
|
|
||||||
;; edit a handler, re-evaluate the defn — the running app sees it, no restart
|
|
||||||
(app/stop!)
|
|
||||||
```
|
|
||||||
|
|
||||||
## Compile a binary
|
## Compile a binary
|
||||||
|
|
||||||
`bin/joltc build` ahead-of-time compiles a project into a single self-contained
|
`bin/joltc build` ahead-of-time compiles a project into a single self-contained
|
||||||
|
|
@ -143,24 +80,6 @@ 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.
|
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.
|
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
|
## Architecture
|
||||||
|
|
||||||
A small Chez runtime (`host/chez/*.ss`: value model, persistent collections, seqs,
|
A small Chez runtime (`host/chez/*.ss`: value model, persistent collections, seqs,
|
||||||
|
|
@ -231,4 +150,4 @@ whose expected values are sourced from reference JVM Clojure. See
|
||||||
|
|
||||||
## License
|
## 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/
|
|
||||||
|
|
@ -34,87 +34,34 @@ control with record state), k-nucleotide proper.
|
||||||
|
|
||||||
## Holistic scorecard
|
## Holistic scorecard
|
||||||
|
|
||||||
`bench/run.sh` compiles each benchmark to an **optimized AOT binary** (`joltc build
|
`JVM=1 bench/run.sh` runs each benchmark on jolt **and** JVM Clojure and prints
|
||||||
--direct-link --opt`) and times it against JVM Clojure running the same portable
|
the jolt/JVM ratio — the absolute-reference scorecard. As of
|
||||||
source — the jolt/JVM scorecard. jolt's optimizing passes fire only in a build;
|
the broadening (2026-06-16), ratios cluster by axis:
|
||||||
`joltc run -m` is unoptimized, so the harness always builds.
|
|
||||||
|
|
||||||
Indicative ratios (M-series, single isolated run — numbers are machine-specific,
|
- **pure compute** (`mandelbrot`) is the floor, ~15× — native arith
|
||||||
regenerate locally), ascending:
|
already gets jolt closest to the JVM.
|
||||||
|
- **collections** ~28×, **fib** ~37×.
|
||||||
| benchmark | ratio | axis |
|
- **dispatch** ~75× (megamorphic), and `mono-dispatch` is *worse* (~110×): the
|
||||||
|---|---|---|
|
JVM inline-caches a runtime-monomorphic call site to near-free, while jolt does
|
||||||
| `fib` | ~0.6× | call + integer arith |
|
a full registry dispatch regardless (devirt only fires on *statically* proven
|
||||||
| `collections` | ~3.5× | persistent map/vector churn |
|
receivers, which `reduce` over a vector doesn't give). This is the signal for
|
||||||
| `mandelbrot` | ~7.5× | pure float compute |
|
the call-site inline cache.
|
||||||
| `binary-trees` | ~10× | escaping short-lived records (allocation/GC) |
|
- **allocation** (`binary-trees`) is the widest gap — but also the most inflated
|
||||||
| `dispatch` | ~12× | megamorphic protocol dispatch |
|
by host memory pressure, so read it as "alloc is the worst axis," not a precise
|
||||||
| `mono-dispatch` | ~15× | monomorphic protocol dispatch |
|
multiple. Numbers are machine-specific; regenerate with `JVM=1 bench/run.sh`.
|
||||||
|
|
||||||
- **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
|
## Running
|
||||||
|
|
||||||
```sh
|
```sh
|
||||||
bench/run.sh # full suite + JVM scorecard
|
bench/run.sh # whole-program optimization on (default)
|
||||||
bench/run.sh fib # one benchmark, default size
|
JOLT_WHOLE_PROGRAM=0 bench/run.sh # WP off, to measure what WP buys
|
||||||
bench/run.sh fib 32 # one benchmark, custom size
|
bench/run.sh binary-trees 16 # 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
|
## A/B against a change
|
||||||
|
|
||||||
To measure a pass, run the suite on `main`, then on the branch, back to back
|
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`;
|
(same machine, quiet) — the same protocol used for the ray tracer. Each
|
||||||
compare the means. A pass is worth landing when it moves a benchmark whose axis it
|
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.
|
targets, even if the ray tracer stays flat.
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,8 @@
|
||||||
;; targets and the ray tracer never exercises (~7% alloc).
|
;; targets and the ray tracer never exercises (~7% alloc).
|
||||||
;;
|
;;
|
||||||
;; Portable Clojure: runs on jolt and JVM Clojure for cross-impl comparison.
|
;; Portable Clojure: runs on jolt and JVM Clojure for cross-impl comparison.
|
||||||
;; bench/run.sh binary-trees 14
|
;; jolt -m binary-trees 14 (JOLT_DIRECT_LINK=1 JOLT_WHOLE_PROGRAM=1)
|
||||||
|
;; clojure -M -m binary-trees 14
|
||||||
(ns binary-trees)
|
(ns binary-trees)
|
||||||
|
|
||||||
(defrecord Node [left right])
|
(defrecord Node [left right])
|
||||||
|
|
|
||||||
|
|
@ -5,7 +5,7 @@
|
||||||
;; records, no collections in the hot loop) doesn't touch.
|
;; records, no collections in the hot loop) doesn't touch.
|
||||||
;;
|
;;
|
||||||
;; Portable Clojure (jolt + JVM Clojure).
|
;; Portable Clojure (jolt + JVM Clojure).
|
||||||
;; bench/run.sh collections 200000
|
;; jolt -m collections 200000 (JOLT_DIRECT_LINK=1 JOLT_WHOLE_PROGRAM=1)
|
||||||
(ns collections)
|
(ns collections)
|
||||||
|
|
||||||
;; map churn: accumulate a frequency map over a stream of keys, then sum it back
|
;; map churn: accumulate a frequency map over a stream of keys, then sum it back
|
||||||
|
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
{:paths ["."]}
|
|
||||||
|
|
@ -6,7 +6,7 @@
|
||||||
;; float-math cost (devirt measured FLAT there).
|
;; float-math cost (devirt measured FLAT there).
|
||||||
;;
|
;;
|
||||||
;; Portable Clojure (jolt + JVM Clojure).
|
;; Portable Clojure (jolt + JVM Clojure).
|
||||||
;; bench/run.sh dispatch 20000
|
;; jolt -m dispatch 20000 (JOLT_DIRECT_LINK=1 JOLT_WHOLE_PROGRAM=1)
|
||||||
(ns dispatch)
|
(ns dispatch)
|
||||||
|
|
||||||
(defprotocol Shape
|
(defprotocol Shape
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,7 @@
|
||||||
;; single-call-site / small-fn inlining and self-call direct-linking.
|
;; single-call-site / small-fn inlining and self-call direct-linking.
|
||||||
;;
|
;;
|
||||||
;; Portable Clojure (jolt + JVM Clojure).
|
;; Portable Clojure (jolt + JVM Clojure).
|
||||||
;; bench/run.sh fib 32
|
;; jolt -m fib 32 (JOLT_DIRECT_LINK=1 JOLT_WHOLE_PROGRAM=1)
|
||||||
(ns fib)
|
(ns fib)
|
||||||
|
|
||||||
(defn fib [n]
|
(defn fib [n]
|
||||||
|
|
|
||||||
|
|
@ -5,10 +5,10 @@
|
||||||
;; on (where devirt/alloc passes measured flat), so it tracks native-arith codegen
|
;; on (where devirt/alloc passes measured flat), so it tracks native-arith codegen
|
||||||
;; and loop quality directly.
|
;; and loop quality directly.
|
||||||
;;
|
;;
|
||||||
;; Portable Clojure (jolt + JVM Clojure). The jolt.png picture demo lives in
|
;; Portable Clojure (jolt + JVM Clojure).
|
||||||
;; mandelbrot_png.clj so this file stays portable for the JVM reference run.
|
;; jolt -m mandelbrot 1000 (JOLT_DIRECT_LINK=1 JOLT_WHOLE_PROGRAM=1)
|
||||||
;; bench/run.sh mandelbrot 1000
|
(ns mandelbrot
|
||||||
(ns mandelbrot)
|
(:require [jolt.png :as png]))
|
||||||
|
|
||||||
(defn count-point [cr ci cap]
|
(defn count-point [cr ci cap]
|
||||||
(loop [i 0 zr 0.0 zi 0.0]
|
(loop [i 0 zr 0.0 zi 0.0]
|
||||||
|
|
@ -32,6 +32,35 @@
|
||||||
(recur (inc y) (+ acc row)))
|
(recur (inc y) (+ acc row)))
|
||||||
acc))))
|
acc))))
|
||||||
|
|
||||||
|
;; --- PNG demo (jolt.png) --------------------------------------------------
|
||||||
|
;; Render a real picture of the set, reusing count-point as the kernel. `render`
|
||||||
|
;; is a separate -main subcommand so the numeric-arg bench path is untouched.
|
||||||
|
|
||||||
|
(defn- color
|
||||||
|
"Escape-iteration count -> RGB. In-set points (n>=cap) are black; faster
|
||||||
|
escapes run through a warm gradient."
|
||||||
|
[n cap]
|
||||||
|
(if (>= n cap)
|
||||||
|
[0 0 0]
|
||||||
|
(let [t (/ (double n) cap)]
|
||||||
|
[(int (* 255 (min 1.0 (* 3.0 t))))
|
||||||
|
(int (* 255 (min 1.0 (max 0.0 (* 3.0 (- t 0.33))))))
|
||||||
|
(int (* 255 (min 1.0 (max 0.0 (* 3.0 (- t 0.66))))))])))
|
||||||
|
|
||||||
|
(defn render!
|
||||||
|
"Render a size×size view of the Mandelbrot set to a PNG at path."
|
||||||
|
[path size]
|
||||||
|
(let [w size h size cap 1000
|
||||||
|
img (png/image w h)]
|
||||||
|
(doseq [py (range h)]
|
||||||
|
(doseq [px (range w)]
|
||||||
|
(let [cr (- (* 3.5 (/ (double px) w)) 2.5) ; real ∈ [-2.5, 1.0]
|
||||||
|
ci (- (* 2.8 (/ (double py) h)) 1.4) ; imag ∈ [-1.4, 1.4]
|
||||||
|
[r g b] (color (count-point cr ci cap) cap)]
|
||||||
|
(png/put! img r g b))))
|
||||||
|
(png/write img w h path)
|
||||||
|
(println "wrote" path (str w "×" h ", cap " cap))))
|
||||||
|
|
||||||
(defn- run-bench [args]
|
(defn- run-bench [args]
|
||||||
(let [n (if (seq args) (Integer/parseInt (first args)) 1000)]
|
(let [n (if (seq args) (Integer/parseInt (first args)) 1000)]
|
||||||
(dotimes [_ 2] (run (quot n 2))) ; warmup
|
(dotimes [_ 2] (run (quot n 2))) ; warmup
|
||||||
|
|
@ -49,4 +78,7 @@
|
||||||
(println "mean:" (/ (Math/round (* mean 10.0)) 10.0) "ms"))))
|
(println "mean:" (/ (Math/round (* mean 10.0)) 10.0) "ms"))))
|
||||||
|
|
||||||
(defn -main [& args]
|
(defn -main [& args]
|
||||||
(run-bench args))
|
(if (= (first args) "render")
|
||||||
|
(render! (or (second args) "mandelbrot.png")
|
||||||
|
(if (nth args 2 nil) (Integer/parseInt (nth args 2)) 600))
|
||||||
|
(run-bench args)))
|
||||||
|
|
|
||||||
|
|
@ -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)))
|
|
||||||
|
|
@ -5,7 +5,7 @@
|
||||||
;; monomorphic dispatch gets to a direct call. Same per-call work as `dispatch`.
|
;; monomorphic dispatch gets to a direct call. Same per-call work as `dispatch`.
|
||||||
;;
|
;;
|
||||||
;; Portable Clojure (jolt + JVM Clojure).
|
;; Portable Clojure (jolt + JVM Clojure).
|
||||||
;; bench/run.sh mono-dispatch 20000
|
;; jolt -m mono-dispatch 20000 (JOLT_DIRECT_LINK=1 JOLT_WHOLE_PROGRAM=1)
|
||||||
(ns mono-dispatch)
|
(ns mono-dispatch)
|
||||||
|
|
||||||
(defprotocol Shape
|
(defprotocol Shape
|
||||||
|
|
|
||||||
80
bench/run.sh
80
bench/run.sh
|
|
@ -1,70 +1,48 @@
|
||||||
#!/bin/sh
|
#!/bin/sh
|
||||||
# Run the jolt benchmark suite against JVM Clojure and print a jolt/JVM scorecard.
|
# Run the jolt benchmark suite and print mean ms per benchmark.
|
||||||
#
|
#
|
||||||
# jolt's optimizing passes (direct-linking, inlining, scalar-replace, whole-program
|
# Each benchmark isolates an axis the ray tracer (float-compute-bound) doesn't
|
||||||
# inference) fire only in an AOT BUILD — `joltc run -m` is unoptimized — so each
|
# capture — see README.md. Run back-to-back against `main` to measure a pass's
|
||||||
# benchmark is compiled to an optimized standalone binary and timed. JVM Clojure
|
# impact.
|
||||||
# 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 # default sizes, whole-program optimization on
|
||||||
# bench/run.sh fib # one benchmark, default size
|
# JOLT_WHOLE_PROGRAM=0 bench/run.sh # compare with WP off
|
||||||
# bench/run.sh fib 32 # one benchmark, custom size
|
# bench/run.sh binary-trees # one benchmark
|
||||||
# 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,
|
# Needs `jolt` on PATH (build with `jpm build`; export PATH="$PWD/build:$PATH").
|
||||||
# the same as `jolt build`; set JOLT_CHEZ_CSV to override the detected csv dir.
|
|
||||||
set -e
|
set -e
|
||||||
cd "$(dirname "$0")"
|
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).
|
export JOLT_DIRECT_LINK="${JOLT_DIRECT_LINK:-1}"
|
||||||
csv="$JOLT_CHEZ_CSV"
|
export JOLT_WHOLE_PROGRAM="${JOLT_WHOLE_PROGRAM:-1}"
|
||||||
if [ -z "$csv" ]; then
|
export JOLT_APP_PATHS="$PWD"
|
||||||
chez_bin="$(command -v chez || command -v scheme || command -v petite || true)"
|
export JOLT_PATH="$PWD"
|
||||||
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)"
|
# name:default-arg (arg sized to run in a few seconds each). Axes: allocation
|
||||||
trap 'rm -rf "$bindir"' EXIT
|
# (binary-trees), megamorphic vs monomorphic dispatch, persistent-collection
|
||||||
|
# churn (collections — now O(log n) via the HAMT, so sized up), pure
|
||||||
# name:default-arg, each sized to run in a few seconds. Axes: see README.md.
|
# float compute (mandelbrot), call+arith recursion (fib).
|
||||||
BENCHES="fib:30 mandelbrot:200 collections:30000 mono-dispatch:2000 dispatch:2000 binary-trees:14"
|
BENCHES="binary-trees:14 dispatch:2000 mono-dispatch:2000 collections:30000 mandelbrot:200 fib:30"
|
||||||
|
|
||||||
|
# JVM=1 also runs each bench on JVM Clojure and prints a jolt/JVM ratio — the
|
||||||
|
# holistic absolute-reference scorecard for the optimization work.
|
||||||
run_one() {
|
run_one() {
|
||||||
ns="${1%%:*}"; arg="${2:-${1##*:}}"
|
ns="${1%%:*}"; arg="${2:-${1##*:}}"
|
||||||
if ! "$joltc" build -m "$ns" -o "$bindir/$ns" --direct-link --opt >/dev/null 2>&1; then
|
jmean=$(jolt -m "$ns" "$arg" 2>&1 | awk '/^mean:/{print $2}')
|
||||||
printf '%-16s jolt build FAILED\n' "$ns"; return
|
if [ -n "$JVM" ]; then
|
||||||
fi
|
vmean=$(clojure -Sdeps '{:paths ["."]}' -M -m "$ns" "$arg" 2>&1 | awk '/^mean:/{print $2}')
|
||||||
jmean=$("$bindir/$ns" "$arg" 2>/dev/null | awk '/^mean:/{print $2}')
|
ratio=$(awk "BEGIN{ if ($vmean+0>0) printf \"%.1f\", ($jmean+0)/($vmean+0); else printf \"-\" }")
|
||||||
if [ -z "$NO_JVM" ]; then
|
printf '%-16s jolt %9s ms jvm %8s ms %sx\n' "$ns" "${jmean:--}" "${vmean:--}" "$ratio"
|
||||||
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
|
else
|
||||||
printf '%-16s jolt %9s ms\n' "$ns" "${jmean:--}"
|
printf '%-16s %9s ms\n' "$ns" "${jmean:--}"
|
||||||
fi
|
fi
|
||||||
}
|
}
|
||||||
|
|
||||||
if [ -n "$1" ]; then
|
if [ -n "$1" ]; then
|
||||||
spec=""
|
for spec in $BENCHES; do
|
||||||
for s in $BENCHES; do [ "${s%%:*}" = "$1" ] && spec="$s"; done
|
[ "${spec%%:*}" = "$1" ] && run_one "$spec" "$2"
|
||||||
[ -n "$spec" ] || { echo "unknown benchmark: $1 (have: ${BENCHES})" >&2; exit 1; }
|
done
|
||||||
run_one "$spec" "$2"
|
|
||||||
else
|
else
|
||||||
echo "jolt benchmark suite — optimized AOT binaries${NO_JVM:+ }${NO_JVM:-, vs JVM Clojure}"
|
echo "jolt benchmark suite (WP=$JOLT_WHOLE_PROGRAM${JVM:+, vs JVM Clojure})"
|
||||||
for spec in $BENCHES; do run_one "$spec"; done
|
for spec in $BENCHES; do run_one "$spec"; done
|
||||||
fi
|
fi
|
||||||
|
|
|
||||||
28
bin/joltc
28
bin/joltc
|
|
@ -13,29 +13,7 @@
|
||||||
# the user's original cwd (the project dir, where deps.edn lives) is passed in
|
# the user's original cwd (the project dir, where deps.edn lives) is passed in
|
||||||
# JOLT_PWD.
|
# JOLT_PWD.
|
||||||
root="$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd)"
|
root="$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd)"
|
||||||
export JOLT_PWD="${JOLT_PWD:-$PWD}"
|
JOLT_PWD="${JOLT_PWD:-$PWD}"
|
||||||
|
export JOLT_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
|
cd "$root" || exit 1
|
||||||
exec ${CHEZ} --script host/chez/cli.ss "$@"
|
exec chez --script host/chez/cli.ss "$@"
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -57,14 +57,14 @@ dependencies, and prepends the resolved source directories to the source roots
|
||||||
for the run. The CLI commands (`jolt.deps` + `jolt.main`):
|
for the run. The CLI commands (`jolt.deps` + `jolt.main`):
|
||||||
|
|
||||||
```bash
|
```bash
|
||||||
bin/joltc run -m NS [args] # resolve deps.edn, load NS, call its -main
|
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 run FILE # resolve deps.edn, load a Clojure file
|
||||||
bin/joltc -M:alias [args] # run the alias's :main-opts
|
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 -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 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 nrepl [port] # start an nREPL server (default 7888) for editors
|
||||||
bin/joltc path # print the resolved source roots (':'-joined)
|
bin/joltc path # print the resolved source roots (':'-joined)
|
||||||
bin/joltc <task> # run a deps.edn :tasks entry
|
bin/joltc <task> # run a deps.edn :tasks entry
|
||||||
```
|
```
|
||||||
|
|
||||||
Example `deps.edn`:
|
Example `deps.edn`:
|
||||||
|
|
|
||||||
|
|
@ -19,36 +19,6 @@ reflection and no class hierarchy. `(class x)` returns the JVM class name for th
|
||||||
scalar/collection types Clojure programs compare against (`"java.lang.Long"`,
|
scalar/collection types Clojure programs compare against (`"java.lang.Long"`,
|
||||||
`"java.lang.String"`, and so on).
|
`"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
|
## What's shimmed
|
||||||
|
|
||||||
This is the surface today, not the whole JVM. Methods not listed generally
|
This is the surface today, not the whole JVM. Methods not listed generally
|
||||||
|
|
@ -87,10 +57,7 @@ aren't implemented; a few are accepted but no-ops (noted inline).
|
||||||
`.hashCode` `.equals` `.getClass` work on any value.
|
`.hashCode` `.equals` `.getClass` work on any value.
|
||||||
- **`java.lang.Class`** — `forName` (throws a catchable `ClassNotFoundException`
|
- **`java.lang.Class`** — `forName` (throws a catchable `ClassNotFoundException`
|
||||||
for a class jolt can't back, so `(try (Class/forName "opt.Dep") (catch …))`
|
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
|
dependency probes work).
|
||||||
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
|
### Strings and text
|
||||||
|
|
||||||
|
|
@ -171,13 +138,8 @@ aren't implemented; a few are accepted but no-ops (noted inline).
|
||||||
`IllegalArgumentException` `IllegalStateException` `IOException`
|
`IllegalArgumentException` `IllegalStateException` `IOException`
|
||||||
`NumberFormatException` `ArithmeticException` `NullPointerException`
|
`NumberFormatException` `ArithmeticException` `NullPointerException`
|
||||||
`ClassCastException` `IndexOutOfBoundsException` `FileNotFoundException`
|
`ClassCastException` `IndexOutOfBoundsException` `FileNotFoundException`
|
||||||
`UnsupportedOperationException` `Error` `AssertionError` and the common network
|
`UnsupportedOperationException` and the common network exceptions, each with
|
||||||
exceptions, each with the `(E.)` / `(E. msg)` / `(E. msg cause)` / `(E. cause)`
|
the `(E.)` / `(E. msg)` / `(E. msg cause)` / `(E. cause)` constructors.
|
||||||
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`
|
What's deliberately absent: STM (`clojure.lang.LockingTransaction/isRunning`
|
||||||
returns `false`), reflection, `gen-class`/`proxy` of Java classes, and
|
returns `false`), reflection, `gen-class`/`proxy` of Java classes, and
|
||||||
|
|
@ -240,32 +202,6 @@ register checks without clobbering each other. This is the mechanism jolt's
|
||||||
HTTP client library uses to emulate `java.net.URL` and `HttpURLConnection` so
|
HTTP client library uses to emulate `java.net.URL` and `HttpURLConnection` so
|
||||||
`clj-http-lite` runs unchanged.
|
`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,
|
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`
|
say) means editing the relevant `host/chez/*.ss` file and running `make remint`
|
||||||
— see [building-and-deps.md](building-and-deps.md).
|
— see [building-and-deps.md](building-and-deps.md).
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,9 @@
|
||||||
# Clojure libraries known to work with Jolt
|
# Clojure libraries known to work with Jolt
|
||||||
|
|
||||||
Libraries confirmed to load and pass their conformance checks on Jolt. A library
|
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),
|
listed here works; some need `JOLT_FEATURES` including `clj` (noted below). See
|
||||||
e.g. the [ring-app example](https://github.com/jolt-lang/examples/tree/main/ring-app).
|
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
|
* [aero](https://github.com/juxt/aero) — EDN configuration with tag literals
|
||||||
(`#ref`/`#env`/`#or`/`#profile`/`#long`/…)
|
(`#ref`/`#env`/`#or`/`#profile`/`#long`/…)
|
||||||
|
|
@ -19,21 +20,23 @@ e.g. the [ring-app example](https://github.com/jolt-lang/examples/tree/main/ring
|
||||||
[jolt-lang/jolt-crypto](https://github.com/jolt-lang/jolt-crypto) (OpenSSL)
|
[jolt-lang/jolt-crypto](https://github.com/jolt-lang/jolt-crypto) (OpenSSL)
|
||||||
* [reitit-core](https://github.com/metosin/reitit) — data-driven routing; the
|
* [reitit-core](https://github.com/metosin/reitit) — data-driven routing; the
|
||||||
`reitit.Trie` Java class is mirrored by
|
`reitit.Trie` Java class is mirrored by
|
||||||
[jolt-lang/router](https://github.com/jolt-lang/router).
|
[jolt-lang/router](https://github.com/jolt-lang/router). `JOLT_FEATURES` `clj`.
|
||||||
* [integrant](https://github.com/weavejester/integrant) — data-driven system
|
* [integrant](https://github.com/weavejester/integrant) — data-driven system
|
||||||
configuration (`#ig/ref`), with its
|
configuration (`#ig/ref`), with its
|
||||||
[dependency](https://github.com/weavejester/dependency) and
|
[dependency](https://github.com/weavejester/dependency) and
|
||||||
[meta-merge](https://github.com/weavejester/meta-merge) deps
|
[meta-merge](https://github.com/weavejester/meta-merge) deps
|
||||||
* [honeysql](https://github.com/seancorfield/honeysql) — SQL formatter and helpers
|
* [honeysql](https://github.com/seancorfield/honeysql) — SQL formatter and helpers
|
||||||
* [clojure.jdbc](https://github.com/yogthos/clojure.jdbc) — via
|
* [clojure.jdbc](https://github.com/yogthos/clojure.jdbc) — as
|
||||||
[jolt-lang/db](https://github.com/jolt-lang/db)'s `jdbc.core`, over the built-in
|
[jolt-lang/db](https://github.com/jolt-lang/db)'s `jdbc.core`, over the built-in
|
||||||
SQLite access (libsqlite3 via Chez's FFI)
|
SQLite access (libsqlite3 via Chez's FFI)
|
||||||
|
* [next.jdbc](https://github.com/seancorfield/next-jdbc) — a compatibility layer in
|
||||||
|
[jolt-lang/db](https://github.com/jolt-lang/db) over `jdbc.core`
|
||||||
* [tools.logging](https://github.com/clojure/tools.logging) — runs verbatim over a
|
* [tools.logging](https://github.com/clojure/tools.logging) — runs verbatim over a
|
||||||
native `clojure.tools.logging.impl` stderr backend
|
native `clojure.tools.logging.impl` stderr backend
|
||||||
* [migratus](https://github.com/yogthos/migratus) — database migrations over
|
* [migratus](https://github.com/yogthos/migratus) — database migrations over the
|
||||||
[jolt-lang/db](https://github.com/jolt-lang/db)
|
next.jdbc layer
|
||||||
* [malli](https://github.com/metosin/malli) — data schema validation, on the
|
* [malli](https://github.com/metosin/malli) — data schema validation, on the
|
||||||
malli-app example.
|
malli-app example. `JOLT_FEATURES` `clj`.
|
||||||
* [markdown-clj](https://github.com/yogthos/markdown-clj) — Markdown → HTML, on the
|
* [markdown-clj](https://github.com/yogthos/markdown-clj) — Markdown → HTML, on the
|
||||||
markdown-app example
|
markdown-app example
|
||||||
* [hiccup](https://github.com/weavejester/hiccup) — HTML from Clojure data, on the
|
* [hiccup](https://github.com/weavejester/hiccup) — HTML from Clojure data, on the
|
||||||
|
|
@ -41,40 +44,11 @@ e.g. the [ring-app example](https://github.com/jolt-lang/examples/tree/main/ring
|
||||||
* [clojure.data.json](https://github.com/clojure/data.json) — JSON reading and writing
|
* [clojure.data.json](https://github.com/clojure/data.json) — JSON reading and writing
|
||||||
* [clojure.spec.alpha](https://github.com/clojure/spec.alpha) — data specs
|
* [clojure.spec.alpha](https://github.com/clojure/spec.alpha) — data specs
|
||||||
* [core.match](https://github.com/clojure/core.match) — pattern matching.
|
* [core.match](https://github.com/clojure/core.match) — pattern matching.
|
||||||
|
`JOLT_FEATURES` `clj`.
|
||||||
* [core.cache](https://github.com/clojure/core.cache) — caching (Basic/FIFO/LRU/
|
* [core.cache](https://github.com/clojure/core.cache) — caching (Basic/FIFO/LRU/
|
||||||
LU/TTL/Soft + the wrapped atom API), over
|
LU/TTL/Soft + the wrapped atom API), over
|
||||||
[data.priority-map](https://github.com/clojure/data.priority-map).
|
[data.priority-map](https://github.com/clojure/data.priority-map).
|
||||||
* [core.memoize](https://github.com/clojure/core.memoize) — function memoization
|
`JOLT_FEATURES` `clj`.
|
||||||
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`;
|
* [tick](https://github.com/juxt/tick) — date/time over Jolt's `java.time`;
|
||||||
`#time/…` literals via `time-literals`.
|
`#time/…` literals via `time-literals`. `JOLT_FEATURES` `clj`.
|
||||||
* [transit-jolt](https://github.com/jolt-lang/transit-jolt) — Transit (JSON) read/write
|
* [transit-jolt](https://github.com/jolt-lang/transit-jolt) — Transit (JSON) read/write
|
||||||
|
|
|
||||||
|
|
@ -1,22 +1,9 @@
|
||||||
# RFC 0002 — Reader-Conditional Feature Set
|
# RFC 0002 — Reader-Conditional Feature Set
|
||||||
|
|
||||||
- **Status**: Superseded (2026-06-25) — jolt now includes `:clj` in the default
|
- **Status**: Accepted (implemented; measured)
|
||||||
set; see the note below.
|
|
||||||
- **Created**: 2026-06-10
|
- **Created**: 2026-06-10
|
||||||
- **Spec**: `docs/spec/02-reader.md` §2.3 S18
|
- **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
|
## Summary
|
||||||
|
|
||||||
jolt's reader-conditional feature set is **`#{:jolt :default}`**, matched in
|
jolt's reader-conditional feature set is **`#{:jolt :default}`**, matched in
|
||||||
|
|
|
||||||
|
|
@ -159,10 +159,9 @@ checks → UNVERIFIED (rows to add).
|
||||||
key the platform satisfies wins (`#?(:default 5 :clj 6)` is `5` everywhere)
|
key the platform satisfies wins (`#?(:default 5 :clj 6)` is `5` everywhere)
|
||||||
— not by key priority. Implementations SHOULD provide a per-loading-context
|
— not by key priority. Implementations SHOULD provide a per-loading-context
|
||||||
compatibility override for foreign-dialect libraries. (jolt:
|
compatibility override for foreign-dialect libraries. (jolt:
|
||||||
`#{:jolt :clj :default}` — jolt emulates `clojure.lang.*`/`java.*`, so it
|
`#{:jolt :default}`, opt-in via `reader-features-set!`/`JOLT_FEATURES`;
|
||||||
reads the `:clj` branch of a `.cljc` library by default; a library can put a
|
decision + A/B data in RFC 0002 — inheriting `:clj` cost 146 suite
|
||||||
`:jolt` branch first to override, or a loading context can call
|
assertions and 38 errors.)
|
||||||
`reader-features-set!`. History in RFC 0002.)
|
|
||||||
- Reader conditionals MUST be an error outside `.cljc`-style reading unless
|
- Reader conditionals MUST be an error outside `.cljc`-style reading unless
|
||||||
the implementation documents otherwise.
|
the implementation documents otherwise.
|
||||||
|
|
||||||
|
|
@ -225,31 +224,3 @@ reader functions are the deliberate exception, S20). Forms read identically
|
||||||
whether or not they will be evaluated; `read-string` of any printable value
|
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
|
`v` followed by evaluation yields a value equal to `v` for the
|
||||||
self-evaluating types (§4 print/read round-trip contract).
|
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.
|
|
||||||
|
|
|
||||||
|
|
@ -10,40 +10,6 @@ them (e.g. vector `nth` is "effectively constant time" — SHOULD-level).
|
||||||
|
|
||||||
---
|
---
|
||||||
|
|
||||||
## Collection return types & laziness (cross-cutting)
|
|
||||||
|
|
||||||
Two contracts hold across the sequence library and are not restated per entry.
|
|
||||||
|
|
||||||
**Return-type fidelity.** A function returns the same *kind* of collection the
|
|
||||||
reference does — value equality is not enough, since `(= [0 1] '(0 1))`.
|
|
||||||
|
|
||||||
- Sequence transformations return **seqs** (lazy unless noted): `map`, `filter`,
|
|
||||||
`remove`, `keep`, `mapcat`, `take`/`drop` and their `-while` forms, `partition`,
|
|
||||||
`partition-all`, `partition-by`, `interpose`, `dedupe`, `distinct`, `concat`,
|
|
||||||
`reductions`, `cons`, `rest`, `sequence`. The *elements* of `partition` /
|
|
||||||
`partition-all` / `partition-by` are themselves seqs, not vectors.
|
|
||||||
- The vector variants return **vectors**: `mapv`, `filterv`, `vec`, `subvec`,
|
|
||||||
`partitionv`, `partitionv-all`, `splitv-at`. `split-at` / `split-with` return a
|
|
||||||
2-vector `[take drop]`. A transducer applied eagerly (`into []`, the
|
|
||||||
`partition-all` transducer's chunks) yields vectors.
|
|
||||||
- Type-preserving functions return the input's type: `replace` over a vector is a
|
|
||||||
vector, over any other seqable a (lazy) seq; `empty`/`into (empty coll)` keep the
|
|
||||||
collection kind; `set`/`into #{}` return sets; `into {}`/`select-keys`/`zipmap`/
|
|
||||||
`frequencies`/`group-by`/`merge` return maps (`group-by` values are vectors).
|
|
||||||
|
|
||||||
**Laziness.** The lazy sequence functions — including `sequence`, `eduction`, and
|
|
||||||
`mapcat` — MUST consume their source incrementally and so terminate on an infinite
|
|
||||||
or unbounded source when only a prefix is demanded: `(first (sequence (map inc)
|
|
||||||
(range)))` and `(take n (mapcat f (range)))` return without realizing the whole
|
|
||||||
source. `(apply concat coll-of-colls)` is likewise lazy in its argument seq. The
|
|
||||||
eager consumers (`reduce`, `into`, `count`, `vec`, `doall`) realize the demanded
|
|
||||||
portion fully.
|
|
||||||
|
|
||||||
These are exercised by the `seq / lazy over infinite` and the per-fn type-predicate
|
|
||||||
rows in the conformance corpus.
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
### first — since 1.0
|
### first — since 1.0
|
||||||
|
|
||||||
```
|
```
|
||||||
|
|
@ -196,164 +162,6 @@ cases; clojure-test-suite `core_test/parse_uuid.cljc`,
|
||||||
|
|
||||||
---
|
---
|
||||||
|
|
||||||
### clojure.template/apply-template, clojure.test/are — since 1.1
|
|
||||||
|
|
||||||
```
|
|
||||||
(apply-template argv expr values)
|
|
||||||
(are argv expr & args)
|
|
||||||
```
|
|
||||||
|
|
||||||
**Semantics**
|
|
||||||
|
|
||||||
- S1. `apply-template` MUST replace every occurrence of each `argv` symbol
|
|
||||||
in `expr` with its corresponding value by structural walk (postwalk symbol
|
|
||||||
substitution), not by lexical binding. Occurrences inside `quote` and at
|
|
||||||
any nesting depth substitute: `(apply-template '[x] '(f 'x) '[if])` ⇒
|
|
||||||
`(f 'if)`.
|
|
||||||
- S2. `do-template` MUST partition `args` by `(count argv)` and expand to a
|
|
||||||
`do` of one substituted `expr` per group.
|
|
||||||
- S3. `clojure.test/are` MUST expand through `do-template` with `expr`
|
|
||||||
wrapped in `is`. Consequently `(are [x] (special-symbol? 'x) if def)`
|
|
||||||
asserts `(special-symbol? 'if)` and `(special-symbol? 'def)` — a
|
|
||||||
let-binding implementation is non-conforming (the quoted symbol would not
|
|
||||||
substitute).
|
|
||||||
|
|
||||||
**Errors**
|
|
||||||
|
|
||||||
- X1. `are` MUST throw at macroexpansion when `(count args)` is not a
|
|
||||||
positive multiple of a non-empty `(count argv)` (empty/empty is allowed).
|
|
||||||
- X2. `apply-template` MUST throw when `argv` is not a vector of symbols.
|
|
||||||
|
|
||||||
**Conformance**
|
|
||||||
|
|
||||||
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
|
## Authoring notes
|
||||||
|
|
||||||
- Source examples from the ClojureDocs export (`clojuredocs-export.edn`,
|
- Source examples from the ClojureDocs export (`clojuredocs-export.edn`,
|
||||||
|
|
|
||||||
|
|
@ -1,21 +1,21 @@
|
||||||
# Appendix A — Coverage Dashboard (generated)
|
# Appendix A — Coverage Dashboard (generated)
|
||||||
|
|
||||||
Generated 2026-06-26 by `tools/spec_coverage.py` — do not edit by hand.
|
Generated 2026-06-22 by `tools/spec_coverage.py` — do not edit by hand.
|
||||||
|
|
||||||
Surface: **694** clojure.core vars (ClojureDocs export; 648 with
|
Surface: **694** clojure.core vars (ClojureDocs export; 648 with
|
||||||
community examples). jolt interns 594 of them.
|
community examples). jolt interns 574 of them.
|
||||||
|
|
||||||
| Status | Count | Meaning |
|
| Status | Count | Meaning |
|
||||||
|---|---|---|
|
|---|---|---|
|
||||||
| implemented+tested | 590 | in jolt and exercised by spec/conformance |
|
| implemented+tested | 568 | in jolt and exercised by spec/conformance |
|
||||||
| implemented-untested | 4 | in jolt, no direct test — spec entries will add them |
|
| implemented-untested | 6 | in jolt, no direct test — spec entries will add them |
|
||||||
| resolvable-not-interned | 0 | works in code but invisible to ns introspection (conformance finding) |
|
| resolvable-not-interned | 0 | works in code but invisible to ns introspection (conformance finding) |
|
||||||
| missing-portable | 0 | portable semantics, jolt lacks it — implementation gap |
|
| missing-portable | 6 | portable semantics, jolt lacks it — implementation gap |
|
||||||
| special-form | 16 | specified in §3, not a library var |
|
| special-form | 16 | specified in §3, not a library var |
|
||||||
| dynamic-var | 11 | classification needed: portable default vs host-dependent |
|
| dynamic-var | 24 | classification needed: portable default vs host-dependent |
|
||||||
| agents-taps | 16 | out of scope pending concurrency design note |
|
| agents-taps | 16 | out of scope pending concurrency design note |
|
||||||
| stm-refs | 11 | out of scope pending concurrency design note |
|
| stm-refs | 11 | out of scope pending concurrency design note |
|
||||||
| jvm-specific | 46 | catalogued, not specified |
|
| jvm-specific | 47 | catalogued, not specified |
|
||||||
|
|
||||||
Classifications are initial and mechanical — reclassifying is an ordinary
|
Classifications are initial and mechanical — reclassifying is an ordinary
|
||||||
spec change. A var is *Verified* only when its §9 entry exists and carries no
|
spec change. A var is *Verified* only when its §9 entry exists and carries no
|
||||||
|
|
@ -27,35 +27,35 @@ UNVERIFIED field; that column will be added as entries land.
|
||||||
|---|---|---|
|
|---|---|---|
|
||||||
| `*` | implemented+tested | ✓ |
|
| `*` | implemented+tested | ✓ |
|
||||||
| `*'` | implemented+tested | ✓ |
|
| `*'` | implemented+tested | ✓ |
|
||||||
| `*1` | implemented+tested | ✓ |
|
| `*1` | missing-portable | ✓ |
|
||||||
| `*2` | implemented+tested | ✓ |
|
| `*2` | missing-portable | ✓ |
|
||||||
| `*3` | implemented+tested | ✓ |
|
| `*3` | missing-portable | ✓ |
|
||||||
| `*agent*` | dynamic-var | ✓ |
|
| `*agent*` | dynamic-var | ✓ |
|
||||||
| `*allow-unresolved-vars*` | dynamic-var | ✓ |
|
| `*allow-unresolved-vars*` | dynamic-var | ✓ |
|
||||||
| `*assert*` | implemented+tested | ✓ |
|
| `*assert*` | implemented+tested | ✓ |
|
||||||
| `*clojure-version*` | implemented+tested | ✓ |
|
| `*clojure-version*` | implemented+tested | ✓ |
|
||||||
| `*command-line-args*` | implemented-untested | ✓ |
|
| `*command-line-args*` | dynamic-var | ✓ |
|
||||||
| `*compile-files*` | implemented+tested | ✓ |
|
| `*compile-files*` | dynamic-var | ✓ |
|
||||||
| `*compile-path*` | dynamic-var | ✓ |
|
| `*compile-path*` | dynamic-var | ✓ |
|
||||||
| `*compiler-options*` | dynamic-var | ✓ |
|
| `*compiler-options*` | dynamic-var | ✓ |
|
||||||
| `*data-readers*` | implemented+tested | ✓ |
|
| `*data-readers*` | dynamic-var | ✓ |
|
||||||
| `*default-data-reader-fn*` | implemented+tested | ✓ |
|
| `*default-data-reader-fn*` | dynamic-var | ✓ |
|
||||||
| `*e` | implemented+tested | ✓ |
|
| `*e` | missing-portable | ✓ |
|
||||||
| `*err*` | implemented+tested | ✓ |
|
| `*err*` | implemented-untested | ✓ |
|
||||||
| `*file*` | implemented-untested | ✓ |
|
| `*file*` | dynamic-var | ✓ |
|
||||||
| `*flush-on-newline*` | implemented+tested | |
|
| `*flush-on-newline*` | dynamic-var | |
|
||||||
| `*fn-loader*` | dynamic-var | |
|
| `*fn-loader*` | dynamic-var | |
|
||||||
| `*in*` | implemented+tested | |
|
| `*in*` | implemented+tested | |
|
||||||
| `*math-context*` | implemented+tested | |
|
| `*math-context*` | dynamic-var | |
|
||||||
| `*ns*` | implemented+tested | ✓ |
|
| `*ns*` | implemented+tested | ✓ |
|
||||||
| `*out*` | implemented+tested | ✓ |
|
| `*out*` | implemented-untested | ✓ |
|
||||||
| `*print-dup*` | implemented+tested | ✓ |
|
| `*print-dup*` | dynamic-var | ✓ |
|
||||||
| `*print-length*` | implemented+tested | ✓ |
|
| `*print-length*` | dynamic-var | ✓ |
|
||||||
| `*print-level*` | implemented+tested | ✓ |
|
| `*print-level*` | dynamic-var | ✓ |
|
||||||
| `*print-meta*` | implemented+tested | ✓ |
|
| `*print-meta*` | dynamic-var | ✓ |
|
||||||
| `*print-namespace-maps*` | implemented-untested | ✓ |
|
| `*print-namespace-maps*` | dynamic-var | ✓ |
|
||||||
| `*print-readably*` | implemented+tested | ✓ |
|
| `*print-readably*` | implemented+tested | ✓ |
|
||||||
| `*read-eval*` | implemented+tested | ✓ |
|
| `*read-eval*` | dynamic-var | ✓ |
|
||||||
| `*reader-resolver*` | dynamic-var | |
|
| `*reader-resolver*` | dynamic-var | |
|
||||||
| `*repl*` | dynamic-var | |
|
| `*repl*` | dynamic-var | |
|
||||||
| `*source-path*` | dynamic-var | ✓ |
|
| `*source-path*` | dynamic-var | ✓ |
|
||||||
|
|
@ -63,7 +63,7 @@ UNVERIFIED field; that column will be added as entries land.
|
||||||
| `*unchecked-math*` | implemented+tested | ✓ |
|
| `*unchecked-math*` | implemented+tested | ✓ |
|
||||||
| `*use-context-classloader*` | dynamic-var | ✓ |
|
| `*use-context-classloader*` | dynamic-var | ✓ |
|
||||||
| `*verbose-defrecords*` | dynamic-var | |
|
| `*verbose-defrecords*` | dynamic-var | |
|
||||||
| `*warn-on-reflection*` | implemented+tested | ✓ |
|
| `*warn-on-reflection*` | implemented-untested | ✓ |
|
||||||
| `+` | implemented+tested | ✓ |
|
| `+` | implemented+tested | ✓ |
|
||||||
| `+'` | implemented+tested | ✓ |
|
| `+'` | implemented+tested | ✓ |
|
||||||
| `-` | implemented+tested | ✓ |
|
| `-` | implemented+tested | ✓ |
|
||||||
|
|
@ -131,7 +131,7 @@ UNVERIFIED field; that column will be added as entries land.
|
||||||
| `assoc-in` | implemented+tested | ✓ |
|
| `assoc-in` | implemented+tested | ✓ |
|
||||||
| `associative?` | implemented+tested | ✓ |
|
| `associative?` | implemented+tested | ✓ |
|
||||||
| `atom` | implemented+tested | ✓ |
|
| `atom` | implemented+tested | ✓ |
|
||||||
| `await` | implemented+tested | ✓ |
|
| `await` | implemented-untested | ✓ |
|
||||||
| `await-for` | agents-taps | ✓ |
|
| `await-for` | agents-taps | ✓ |
|
||||||
| `await1` | agents-taps | |
|
| `await1` | agents-taps | |
|
||||||
| `bases` | jvm-specific | ✓ |
|
| `bases` | jvm-specific | ✓ |
|
||||||
|
|
@ -218,7 +218,7 @@ UNVERIFIED field; that column will be added as entries land.
|
||||||
| `declare` | implemented+tested | ✓ |
|
| `declare` | implemented+tested | ✓ |
|
||||||
| `dedupe` | implemented+tested | ✓ |
|
| `dedupe` | implemented+tested | ✓ |
|
||||||
| `def` | special-form | ✓ |
|
| `def` | special-form | ✓ |
|
||||||
| `default-data-readers` | implemented+tested | ✓ |
|
| `default-data-readers` | jvm-specific | ✓ |
|
||||||
| `definline` | jvm-specific | |
|
| `definline` | jvm-specific | |
|
||||||
| `definterface` | implemented+tested | ✓ |
|
| `definterface` | implemented+tested | ✓ |
|
||||||
| `defmacro` | special-form | ✓ |
|
| `defmacro` | special-form | ✓ |
|
||||||
|
|
@ -375,7 +375,7 @@ UNVERIFIED field; that column will be added as entries land.
|
||||||
| `lazy-cat` | implemented+tested | ✓ |
|
| `lazy-cat` | implemented+tested | ✓ |
|
||||||
| `lazy-seq` | implemented+tested | ✓ |
|
| `lazy-seq` | implemented+tested | ✓ |
|
||||||
| `let` | implemented+tested | ✓ |
|
| `let` | implemented+tested | ✓ |
|
||||||
| `letfn` | implemented+tested | ✓ |
|
| `letfn` | missing-portable | ✓ |
|
||||||
| `line-seq` | implemented+tested | ✓ |
|
| `line-seq` | implemented+tested | ✓ |
|
||||||
| `list` | implemented+tested | ✓ |
|
| `list` | implemented+tested | ✓ |
|
||||||
| `list*` | implemented+tested | ✓ |
|
| `list*` | implemented+tested | ✓ |
|
||||||
|
|
@ -512,7 +512,7 @@ UNVERIFIED field; that column will be added as entries land.
|
||||||
| `rational?` | implemented+tested | ✓ |
|
| `rational?` | implemented+tested | ✓ |
|
||||||
| `rationalize` | implemented+tested | ✓ |
|
| `rationalize` | implemented+tested | ✓ |
|
||||||
| `re-find` | implemented+tested | ✓ |
|
| `re-find` | implemented+tested | ✓ |
|
||||||
| `re-groups` | implemented+tested | ✓ |
|
| `re-groups` | missing-portable | ✓ |
|
||||||
| `re-matcher` | implemented+tested | ✓ |
|
| `re-matcher` | implemented+tested | ✓ |
|
||||||
| `re-matches` | implemented+tested | ✓ |
|
| `re-matches` | implemented+tested | ✓ |
|
||||||
| `re-pattern` | implemented+tested | ✓ |
|
| `re-pattern` | implemented+tested | ✓ |
|
||||||
|
|
@ -558,7 +558,7 @@ UNVERIFIED field; that column will be added as entries land.
|
||||||
| `reset-vals!` | implemented+tested | ✓ |
|
| `reset-vals!` | implemented+tested | ✓ |
|
||||||
| `resolve` | implemented+tested | ✓ |
|
| `resolve` | implemented+tested | ✓ |
|
||||||
| `rest` | implemented+tested | ✓ |
|
| `rest` | implemented+tested | ✓ |
|
||||||
| `restart-agent` | implemented+tested | ✓ |
|
| `restart-agent` | implemented-untested | ✓ |
|
||||||
| `resultset-seq` | jvm-specific | ✓ |
|
| `resultset-seq` | jvm-specific | ✓ |
|
||||||
| `reverse` | implemented+tested | ✓ |
|
| `reverse` | implemented+tested | ✓ |
|
||||||
| `reversible?` | implemented+tested | ✓ |
|
| `reversible?` | implemented+tested | ✓ |
|
||||||
|
|
|
||||||
|
|
@ -72,41 +72,11 @@ bindings resolve. Each entry is a map — `{:name "sqlite3" :darwin
|
||||||
the running process's own symbols, e.g. libc sockets, no external file). A
|
the running process's own symbols, e.g. libc sockets, no external file). A
|
||||||
project inherits its dependencies' `:jolt/native`.
|
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
|
## Standalone binaries
|
||||||
|
|
||||||
`joltc build -m NS` compiles the app and every library into one executable (the
|
`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
|
runtime + compiler are baked in). It loads the resolved `:jolt/native` libs at
|
||||||
linked in (or loaded at startup — see [Native libraries](#native-libraries)), so
|
startup, so an FFI app — sockets, SQLite — runs with no jolt or Chez on the path.
|
||||||
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>`
|
Output goes under the project's `target/`, cargo-style: `target/release/<project>`
|
||||||
by default and with `--opt`, `target/debug/<project>` with `--dev` (the
|
by default and with `--opt`, `target/debug/<project>` with `--dev` (the
|
||||||
|
|
@ -182,30 +152,6 @@ a root, transitively.
|
||||||
- Source only; compiled `.class` files in a git dep are ignored.
|
- 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).
|
- 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
|
## Conformance
|
||||||
|
|
||||||
The known-working libraries (see [libraries.md](libraries.md)) and the
|
The known-working libraries (see [libraries.md](libraries.md)) and the
|
||||||
|
|
|
||||||
|
|
@ -1,20 +1,17 @@
|
||||||
;; async.ss — clojure.core.async channel primitives on real OS threads.
|
;; async.ss — clojure.core.async on real OS threads for the Chez host.
|
||||||
;;
|
;;
|
||||||
;; A `go` block is an OS thread and a channel is a Chez mutex+condition blocking
|
;; A `go` block is an OS thread and a channel is a mutex+condition blocking
|
||||||
;; queue: <! / >! are the blocking <!! / >!! (they "park" by blocking the thread),
|
;; queue: <! / >! are the blocking <!! / >!! (they "park" by blocking the thread).
|
||||||
;; and work ANYWHERE — no CPS transform, no go-only restriction. Real parallelism,
|
;; <! / >! work ANYWHERE — no CPS transform — because they are ordinary blocking
|
||||||
;; shared heap. This is a superset of the JVM model: it has no fixed go-block
|
;; calls. Real parallelism, shared heap. Trade-off: one OS thread per go block
|
||||||
;; thread pool, no MAX-QUEUE-SIZE on pending ops, and parking ops are legal outside
|
;; (fine for typical use, not for thousands of simultaneous go blocks).
|
||||||
;; 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
|
;; 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
|
;; 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
|
;; buffers never block the putter. A transducer is applied on the put side.
|
||||||
;; optional ex-handler catches a throw from the transducer step.
|
|
||||||
;;
|
;;
|
||||||
;; This file provides the primitives; the higher-level dataflow API (mult, mix,
|
;; The fns are def-var!'d into clojure.core.async; go/go-loop/thread are macros
|
||||||
;; pub/sub, pipeline, map, merge, reduce, …) is a Clojure overlay over them.
|
;; (mark-macro!) expanding to go-spawn. Loaded after
|
||||||
;; go/go-loop/thread are macros (mark-macro!) expanding to go-spawn. Loaded after
|
|
||||||
;; concurrency.ss (reuses ms->duration). Requires a threaded Chez build.
|
;; concurrency.ss (reuses ms->duration). Requires a threaded Chez build.
|
||||||
|
|
||||||
;; --- buffers ----------------------------------------------------------------
|
;; --- buffers ----------------------------------------------------------------
|
||||||
|
|
@ -22,8 +19,6 @@
|
||||||
(define (jolt-async-buffer n) (make-async-buffer n 'fixed))
|
(define (jolt-async-buffer n) (make-async-buffer n 'fixed))
|
||||||
(define (jolt-async-dropping-buffer n) (make-async-buffer n 'dropping))
|
(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-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 ---------------------------------------------------------------
|
;; --- channels ---------------------------------------------------------------
|
||||||
;; items: an amortized-O(1) FIFO held as a mutable #(out in len) — `out` is the
|
;; items: an amortized-O(1) FIFO held as a mutable #(out in len) — `out` is the
|
||||||
|
|
@ -32,12 +27,9 @@
|
||||||
;; Each entry is (value . box); box is #f for a buffered value or a 1-slot vector
|
;; 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).
|
;; for an unbuffered rendezvous put (set #t when taken, waking the putter).
|
||||||
;; cap 0 + kind 'unbuffered = rendezvous; cap>0 with kind fixed/dropping/sliding.
|
;; 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
|
(define-record-type async-chan
|
||||||
(fields mu cv (mutable items) cap kind (mutable closed?) (mutable xrf) (mutable takew) exh)
|
(fields mu cv (mutable items) cap kind (mutable closed?) (mutable xrf))
|
||||||
(nongenerative async-chan-v2))
|
(nongenerative async-chan-v1))
|
||||||
|
|
||||||
(define (ac-qnew) (vector '() '() 0))
|
(define (ac-qnew) (vector '() '() 0))
|
||||||
(define (ac-qlen ch) (vector-ref (async-chan-items ch) 2))
|
(define (ac-qlen ch) (vector-ref (async-chan-items ch) 2))
|
||||||
|
|
@ -81,30 +73,17 @@
|
||||||
((null? (cdr args)) (car args)) ; completion
|
((null? (cdr args)) (car args)) ; completion
|
||||||
(else (ac-buf-give! ch (cadr args)) (car args))))) ; step
|
(else (ac-buf-give! ch (cadr args)) (car args))))) ; step
|
||||||
|
|
||||||
;; run the transducer step (or completion) guarded by the channel's ex-handler:
|
(define (ac-make cap kind xrf) (make-async-chan (make-mutex) (make-condition) (ac-qnew) cap kind #f xrf))
|
||||||
;; 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))
|
;; (chan) | (chan n) | (chan buf) | (chan n|buf xform)
|
||||||
(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)
|
(define (jolt-async-chan . args)
|
||||||
(let ((buf (if (pair? args) (car args) jolt-nil))
|
(let ((buf (if (pair? args) (car args) jolt-nil))
|
||||||
(xform (if (and (pair? args) (pair? (cdr args))) (cadr args) jolt-nil))
|
(xform (if (and (pair? args) (pair? (cdr args))) (cadr args) jolt-nil)))
|
||||||
(exh (if (and (pair? args) (pair? (cdr args)) (pair? (cddr args))) (caddr args) jolt-nil)))
|
|
||||||
(let-values (((cap kind)
|
(let-values (((cap kind)
|
||||||
(cond ((async-buffer? buf) (values (async-buffer-n buf) (async-buffer-kind buf)))
|
(cond ((async-buffer? buf) (values (async-buffer-n buf) (async-buffer-kind buf)))
|
||||||
((and (number? buf) (> buf 0)) (values buf 'fixed))
|
((and (number? buf) (> buf 0)) (values buf 'fixed))
|
||||||
(else (values 0 'unbuffered)))))
|
(else (values 0 'unbuffered)))))
|
||||||
(let ((ch (ac-make/exh cap kind (if (jolt-nil? exh) #f exh))))
|
(let ((ch (ac-make cap kind #f)))
|
||||||
(unless (jolt-nil? xform)
|
(unless (jolt-nil? xform)
|
||||||
(async-chan-xrf-set! ch (jolt-invoke xform (ac-make-add-rf ch))))
|
(async-chan-xrf-set! ch (jolt-invoke xform (ac-make-add-rf ch))))
|
||||||
ch))))
|
ch))))
|
||||||
|
|
@ -114,7 +93,7 @@
|
||||||
(define (ac-close! ch)
|
(define (ac-close! ch)
|
||||||
(unless (async-chan-closed? ch)
|
(unless (async-chan-closed? ch)
|
||||||
(async-chan-closed?-set! ch #t)
|
(async-chan-closed?-set! ch #t)
|
||||||
(when (async-chan-xrf ch) (guard (e (#t #f)) (ac-xrf-apply ch)))
|
(when (async-chan-xrf ch) (guard (e (#t #f)) (jolt-invoke (async-chan-xrf ch) ch)))
|
||||||
(condition-broadcast (async-chan-cv ch)))
|
(condition-broadcast (async-chan-cv ch)))
|
||||||
jolt-nil)
|
jolt-nil)
|
||||||
(define (jolt-async-close! ch) (with-mutex (async-chan-mu ch) (ac-close! ch)))
|
(define (jolt-async-close! ch) (with-mutex (async-chan-mu ch) (ac-close! ch)))
|
||||||
|
|
@ -123,22 +102,17 @@
|
||||||
;; transducer the value is run through it (one put -> zero or more channel values);
|
;; transducer the value is run through it (one put -> zero or more channel values);
|
||||||
;; a `reduced` result closes the channel.
|
;; a `reduced` result closes the channel.
|
||||||
(define (jolt-async-give ch v)
|
(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")))
|
(when (jolt-nil? v) (jolt-throw (jolt-ex-info "Can't put nil on a channel" (jolt-hash-map))))
|
||||||
(with-mutex (async-chan-mu ch)
|
(with-mutex (async-chan-mu ch)
|
||||||
(cond
|
(cond
|
||||||
((async-chan-closed? ch) #f)
|
((async-chan-closed? ch) #f)
|
||||||
((async-chan-xrf ch)
|
((async-chan-xrf ch)
|
||||||
(let ((r (ac-xrf-apply ch v)))
|
(let ((r (jolt-invoke (async-chan-xrf ch) ch v)))
|
||||||
(when (jolt-reduced? r) (ac-close! ch))
|
(when (jolt-reduced? r) (ac-close! ch))
|
||||||
#t))
|
#t))
|
||||||
(else
|
(else
|
||||||
(case (async-chan-kind ch)
|
(case (async-chan-kind ch)
|
||||||
((dropping sliding) (ac-buf-give! ch v) #t)
|
((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
|
(else
|
||||||
(if (> (async-chan-cap ch) 0)
|
(if (> (async-chan-cap ch) 0)
|
||||||
(let loop () ; buffered fixed: wait for room
|
(let loop () ; buffered fixed: wait for room
|
||||||
|
|
@ -161,75 +135,44 @@
|
||||||
(condition-broadcast (async-chan-cv ch))
|
(condition-broadcast (async-chan-cv ch))
|
||||||
v))
|
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.
|
;; <! / <!! — 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)
|
(define (jolt-async-take ch)
|
||||||
(with-mutex (async-chan-mu ch)
|
(with-mutex (async-chan-mu ch)
|
||||||
(let loop ()
|
(let loop ()
|
||||||
(cond ((eq? (async-chan-kind ch) 'promise)
|
(cond ((not (ac-qempty? ch)) (ac-take-head! ch))
|
||||||
(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)
|
((async-chan-closed? ch) jolt-nil)
|
||||||
(else (ac-take-wait ch) (loop))))))
|
(else (condition-wait (async-chan-cv ch) (async-chan-mu ch)) (loop))))))
|
||||||
|
|
||||||
;; park in a take, tracking the waiter count so a concurrent offer! to an
|
;; non-blocking take for alts!: a value, jolt-nil (closed+empty), or ac-poll-empty.
|
||||||
;; 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-empty (list 'empty))
|
||||||
(define (ac-poll! ch)
|
(define (ac-poll! ch)
|
||||||
(with-mutex (async-chan-mu ch)
|
(with-mutex (async-chan-mu ch)
|
||||||
(cond ((and (eq? (async-chan-kind ch) 'promise) (not (ac-qempty? ch))) (ac-peek ch))
|
(cond ((not (ac-qempty? ch)) (ac-take-head! ch))
|
||||||
((not (ac-qempty? ch)) (ac-take-head! ch))
|
|
||||||
((async-chan-closed? ch) jolt-nil)
|
((async-chan-closed? ch) jolt-nil)
|
||||||
(else ac-poll-empty))))
|
(else ac-poll-empty))))
|
||||||
|
|
||||||
;; non-blocking give: 'ok (accepted), 'full (would block), or 'closed.
|
;; (alts! [ch ...]) — take from whichever channel is ready first; returns
|
||||||
(define (ac-try-give! ch v)
|
;; [value channel] (value nil if that channel closed). Take-only: every port must
|
||||||
(when (jolt-nil? v) (jolt-throw (jolt-host-throwable "java.lang.IllegalArgumentException" "Can't put nil on a channel")))
|
;; be a channel — put specs [ch val] and the :default option are not supported, so
|
||||||
(with-mutex (async-chan-mu ch)
|
;; reject them with a clear error instead of crashing inside ac-poll!.
|
||||||
(cond
|
;; Polls with a 1ms backoff — no cross-channel wait-set yet.
|
||||||
((async-chan-closed? ch) 'closed)
|
(define ac-1ms (make-time 'time-duration 1000000 0))
|
||||||
((async-chan-xrf ch) (let ((r (ac-xrf-apply ch v)))
|
(define (jolt-async-alts chans)
|
||||||
(when (jolt-reduced? r) (ac-close! ch)) 'ok))
|
(let ((cs (seq->list (jolt-seq chans))))
|
||||||
(else
|
(for-each (lambda (c)
|
||||||
(case (async-chan-kind ch)
|
(unless (async-chan? c)
|
||||||
((dropping sliding) (ac-buf-give! ch v) 'ok)
|
(jolt-throw (jolt-ex-info
|
||||||
((promise) (when (ac-qempty? ch) (ac-qpush! ch (cons v #f))
|
"alts! supports channel ports only (put specs [ch val] and :default are not supported)"
|
||||||
(condition-broadcast (async-chan-cv ch))) 'ok)
|
(jolt-hash-map)))))
|
||||||
(else
|
cs)
|
||||||
(cond
|
(let loop ()
|
||||||
((> (async-chan-cap ch) 0)
|
(let try ((rest cs))
|
||||||
(if (< (ac-qlen ch) (async-chan-cap ch))
|
(if (null? rest)
|
||||||
(begin (ac-qpush! ch (cons v #f)) (condition-broadcast (async-chan-cv ch)) 'ok)
|
(begin (sleep ac-1ms) (loop))
|
||||||
'full))
|
(let ((r (ac-poll! (car rest))))
|
||||||
;; unbuffered: only immediate if a taker is parked to receive it.
|
(if (eq? r ac-poll-empty)
|
||||||
((> (async-chan-takew ch) 0)
|
(try (cdr rest))
|
||||||
(let ((box (vector #f)))
|
(jolt-vector r (car rest)))))))))
|
||||||
(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.
|
;; (timeout ms) — a channel that closes after ms milliseconds.
|
||||||
(define (jolt-async-timeout ms)
|
(define (jolt-async-timeout ms)
|
||||||
|
|
@ -237,28 +180,17 @@
|
||||||
(fork-thread (lambda () (sleep (ms->duration ms)) (jolt-async-close! w)))
|
(fork-thread (lambda () (sleep (ms->duration ms)) (jolt-async-close! w)))
|
||||||
w))
|
w))
|
||||||
|
|
||||||
;; (put! ch v [cb [on-caller?]]) — async put, optional completion callback. If the
|
;; (put! ch v [cb]) / (take! ch cb) — async put/take on a thread, optional callback.
|
||||||
;; put completes immediately and on-caller? (default #t), the callback runs on the
|
(define (jolt-async-put! ch v . cb)
|
||||||
;; calling thread; otherwise on another thread. Returns true unless already closed.
|
(fork-thread (lambda ()
|
||||||
(define (jolt-async-put! ch v . rest)
|
(let ((ok (jolt-async-give ch v)))
|
||||||
(let* ((cb (if (pair? rest) (car rest) jolt-nil))
|
(when (and (pair? cb) (not (jolt-nil? (car cb)))) (jolt-invoke (car cb) ok)))))
|
||||||
(on-caller? (if (and (pair? rest) (pair? (cdr rest))) (jolt-truthy? (cadr rest)) #t))
|
jolt-nil)
|
||||||
(call-cb (lambda (ok) (unless (jolt-nil? cb) (jolt-invoke cb ok)))))
|
(define (jolt-async-take! ch cb)
|
||||||
(case (ac-try-give! ch v)
|
(fork-thread (lambda ()
|
||||||
((ok) (if on-caller? (call-cb #t) (fork-thread (lambda () (call-cb #t)))) #t)
|
(let ((v (jolt-async-take ch)))
|
||||||
((closed) (if on-caller? (call-cb #f) (fork-thread (lambda () (call-cb #f)))) #f)
|
(unless (jolt-nil? cb) (jolt-invoke cb v)))))
|
||||||
(else (fork-thread (lambda () (call-cb (jolt-async-give ch v)))) #t))))
|
jolt-nil)
|
||||||
|
|
||||||
;; (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
|
;; (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
|
;; conveys its value once then closes (a nil result just closes). Dynamic bindings
|
||||||
|
|
@ -292,24 +224,18 @@
|
||||||
;; --- install clojure.core.async ---------------------------------------------
|
;; --- install clojure.core.async ---------------------------------------------
|
||||||
(define (cca-def! name v) (def-var! "clojure.core.async" name v))
|
(define (cca-def! name v) (def-var! "clojure.core.async" name v))
|
||||||
(cca-def! "chan" jolt-async-chan)
|
(cca-def! "chan" jolt-async-chan)
|
||||||
(cca-def! "promise-chan" (lambda args (ac-make 1 'promise #f)))
|
|
||||||
(cca-def! "chan?" async-chan?)
|
(cca-def! "chan?" async-chan?)
|
||||||
(cca-def! "buffer" jolt-async-buffer)
|
(cca-def! "buffer" jolt-async-buffer)
|
||||||
(cca-def! "dropping-buffer" jolt-async-dropping-buffer)
|
(cca-def! "dropping-buffer" jolt-async-dropping-buffer)
|
||||||
(cca-def! "sliding-buffer" jolt-async-sliding-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! "close!" jolt-async-close!)
|
||||||
(cca-def! "<!" jolt-async-take) (cca-def! "<!!" jolt-async-take)
|
(cca-def! "<!" jolt-async-take) (cca-def! "<!!" jolt-async-take)
|
||||||
(cca-def! ">!" jolt-async-give) (cca-def! ">!!" jolt-async-give)
|
(cca-def! ">!" jolt-async-give) (cca-def! ">!!" jolt-async-give)
|
||||||
|
(cca-def! "alts!" jolt-async-alts) (cca-def! "alts!!" jolt-async-alts)
|
||||||
(cca-def! "timeout" jolt-async-timeout)
|
(cca-def! "timeout" jolt-async-timeout)
|
||||||
(cca-def! "put!" jolt-async-put!)
|
(cca-def! "put!" jolt-async-put!)
|
||||||
(cca-def! "take!" jolt-async-take!)
|
(cca-def! "take!" jolt-async-take!)
|
||||||
(cca-def! "offer!" jolt-async-offer!)
|
|
||||||
(cca-def! "go-spawn" async-go-spawn)
|
(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" 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! "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")
|
(cca-def! "thread" cca-thread-macro) (mark-macro! "clojure.core.async" "thread")
|
||||||
|
|
@ -23,38 +23,21 @@
|
||||||
(fields (mutable val) (mutable watches) (mutable validator) lock)
|
(fields (mutable val) (mutable watches) (mutable validator) lock)
|
||||||
(nongenerative jolt-atom-v3))
|
(nongenerative jolt-atom-v3))
|
||||||
|
|
||||||
;; a rejected reference value is IllegalStateException, like ARef.validate.
|
;; (atom init) / (atom init :validator f :meta m): scan the trailing keyword opts
|
||||||
(define (jolt-iref-state-throw)
|
;; for :validator (the only one with runtime behaviour; :meta is accepted/ignored).
|
||||||
(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)
|
(define (jolt-atom-new v . opts)
|
||||||
(let loop ((o opts) (validator jolt-nil) (m #f))
|
(let loop ((o opts) (validator jolt-nil))
|
||||||
(cond
|
(cond
|
||||||
((or (null? o) (null? (cdr o)))
|
((or (null? o) (null? (cdr o))) (make-jolt-atom v '() validator (make-mutex)))
|
||||||
(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"))
|
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "validator"))
|
||||||
(loop (cddr o) (cadr o) m))
|
(loop (cddr o) (cadr o)))
|
||||||
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "meta"))
|
(else (loop (cddr o) validator)))))
|
||||||
(loop (cddr o) validator (cadr o)))
|
|
||||||
(else (loop (cddr o) validator m)))))
|
|
||||||
|
|
||||||
;; validate a candidate value: a non-nil validator that returns falsey rejects.
|
;; validate a candidate value: a non-nil validator that returns falsey rejects.
|
||||||
(define (jolt-atom-validate a v)
|
(define (jolt-atom-validate a v)
|
||||||
(let ((vf (jolt-atom-validator a)))
|
(let ((vf (jolt-atom-validator a)))
|
||||||
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf v)))
|
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf v)))
|
||||||
(jolt-iref-state-throw))))
|
(error #f "Invalid reference state"))))
|
||||||
|
|
||||||
;; notify each watch (k ref old new), in insertion order (alist is reverse-built,
|
;; notify each watch (k ref old new), in insertion order (alist is reverse-built,
|
||||||
;; so walk it reversed to match add order).
|
;; so walk it reversed to match add order).
|
||||||
|
|
@ -123,87 +106,27 @@
|
||||||
(jolt-atom-notify a old v)
|
(jolt-atom-notify a old v)
|
||||||
(jolt-vector old v)))
|
(jolt-vector old v)))
|
||||||
|
|
||||||
;; --- watches / validators: the IRef seam --------------------------------------
|
;; --- watches / validators ---------------------------------------------------
|
||||||
;; 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);
|
;; add-watch interns (key . fn) (replacing any existing key, keeping order);
|
||||||
;; remove-watch drops it; both return the reference. set-validator! installs a
|
;; remove-watch drops it; both return the atom. set-validator! installs a
|
||||||
;; validator and validates the CURRENT value immediately (Clojure throws if it's
|
;; validator and validates the CURRENT value immediately (Clojure throws if it's
|
||||||
;; already invalid); get-validator reads the slot.
|
;; 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)
|
(define (jolt-add-watch a key f)
|
||||||
(cond
|
(jolt-atom-watches-set! a
|
||||||
((jolt-atom? a)
|
(cons (cons key f)
|
||||||
(jolt-atom-watches-set! a (jolt-watch-add (jolt-atom-watches a) key f))
|
(remp (lambda (kv) (jolt=2 (car kv) key)) (jolt-atom-watches a))))
|
||||||
a)
|
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)
|
(define (jolt-remove-watch a key)
|
||||||
(cond
|
(jolt-atom-watches-set! a
|
||||||
((jolt-atom? a)
|
(remp (lambda (kv) (jolt=2 (car kv) key)) (jolt-atom-watches a)))
|
||||||
(jolt-atom-watches-set! a
|
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)
|
(define (jolt-set-validator! a f)
|
||||||
(let ((vf (if (jolt-nil? f) jolt-nil f)))
|
(let ((vf (if (jolt-nil? f) jolt-nil f)))
|
||||||
(cond
|
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf (jolt-atom-val a))))
|
||||||
((jolt-atom? a)
|
(error #f "Invalid reference state"))
|
||||||
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf (jolt-atom-val a))))
|
(jolt-atom-validator-set! a vf)
|
||||||
(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))
|
jolt-nil))
|
||||||
(define (jolt-get-validator a)
|
(define (jolt-get-validator a) (jolt-atom-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" "atom" jolt-atom-new)
|
||||||
(def-var! "clojure.core" "deref" jolt-deref)
|
(def-var! "clojure.core" "deref" jolt-deref)
|
||||||
|
|
|
||||||
74
host/chez/bigdec.ss
Normal file
74
host/chez/bigdec.ss
Normal file
|
|
@ -0,0 +1,74 @@
|
||||||
|
;; BigDecimal. A jbigdec is {unscaled, scale} over Chez arbitrary-precision exact
|
||||||
|
;; integers; its value is unscaled * 10^-scale (1.5M = {15,1}, 1.00M = {100,2},
|
||||||
|
;; 3M = {3,0}). M-suffix literals read to a :bigdec form that the back end lowers
|
||||||
|
;; to jolt-bigdec-from-string; bigdec coerces a number/string. Equality is by
|
||||||
|
;; value (1.0M = 1.00M), str drops the M, pr keeps it, class is
|
||||||
|
;; java.math.BigDecimal. Arithmetic contagion is not modelled.
|
||||||
|
|
||||||
|
(define-record-type jbigdec (fields unscaled scale) (nongenerative chez-jbigdec-v1))
|
||||||
|
|
||||||
|
(define (bd-index-char s ch)
|
||||||
|
(let loop ((i 0))
|
||||||
|
(cond ((>= i (string-length s)) #f)
|
||||||
|
((char=? (string-ref s i) ch) i)
|
||||||
|
(else (loop (+ i 1))))))
|
||||||
|
|
||||||
|
;; "1.50" -> {150,2}; "3" -> {3,0}; "-0.0" -> {0,1}; ".5" -> {5,1}.
|
||||||
|
(define (jolt-bigdec-from-string s)
|
||||||
|
(let* ((neg (and (> (string-length s) 0) (char=? (string-ref s 0) #\-)))
|
||||||
|
(sgn (and (> (string-length s) 0) (or neg (char=? (string-ref s 0) #\+))))
|
||||||
|
(s1 (if sgn (substring s 1 (string-length s)) s))
|
||||||
|
(sign (if neg -1 1))
|
||||||
|
(dot (bd-index-char s1 #\.)))
|
||||||
|
(if dot
|
||||||
|
(let* ((intp (substring s1 0 dot))
|
||||||
|
(fracp (substring s1 (+ dot 1) (string-length s1)))
|
||||||
|
(digs (string-append intp fracp))
|
||||||
|
(unscaled (if (= 0 (string-length digs)) 0 (string->number digs))))
|
||||||
|
(make-jbigdec (* sign unscaled) (string-length fracp)))
|
||||||
|
(make-jbigdec (* sign (string->number s1)) 0))))
|
||||||
|
|
||||||
|
;; bigdec coercion: a bigdec is itself; an exact integer keeps scale 0; a string
|
||||||
|
;; or any other number routes through its decimal text.
|
||||||
|
(define (jolt-bigdec x)
|
||||||
|
(cond
|
||||||
|
((jbigdec? x) x)
|
||||||
|
((and (number? x) (exact? x) (integer? x)) (make-jbigdec x 0))
|
||||||
|
((string? x) (jolt-bigdec-from-string x))
|
||||||
|
((number? x) (jolt-bigdec-from-string (jolt-num->string x)))
|
||||||
|
(else (error #f "bigdec: cannot coerce" x))))
|
||||||
|
|
||||||
|
;; value equality: unscaled_a * 10^scale_b == unscaled_b * 10^scale_a.
|
||||||
|
(define (jbigdec=? a b)
|
||||||
|
(= (* (jbigdec-unscaled a) (expt 10 (jbigdec-scale b)))
|
||||||
|
(* (jbigdec-unscaled b) (expt 10 (jbigdec-scale a)))))
|
||||||
|
|
||||||
|
;; render the decimal text (no M): insert the point `scale` digits from the right.
|
||||||
|
(define (jbigdec->string bd)
|
||||||
|
(let* ((u (jbigdec-unscaled bd)) (sc (jbigdec-scale bd))
|
||||||
|
(neg (< u 0)) (digs (number->string (abs u))))
|
||||||
|
(string-append
|
||||||
|
(if neg "-" "")
|
||||||
|
(if (<= sc 0)
|
||||||
|
digs
|
||||||
|
(let* ((padded (if (<= (string-length digs) sc)
|
||||||
|
(string-append (make-string (- (+ sc 1) (string-length digs)) #\0) digs)
|
||||||
|
digs))
|
||||||
|
(pl (string-length padded)))
|
||||||
|
(string-append (substring padded 0 (- pl sc)) "." (substring padded (- pl sc) pl)))))))
|
||||||
|
|
||||||
|
;; --- wire into the value model ----------------------------------------------
|
||||||
|
(def-var! "clojure.core" "bigdec" jolt-bigdec)
|
||||||
|
|
||||||
|
;; equality: a bigdec equals only another bigdec, by value (matching (= 3M 3) = false).
|
||||||
|
(register-eq-arm! (lambda (a b) (or (jbigdec? a) (jbigdec? b)))
|
||||||
|
(lambda (a b) (and (jbigdec? a) (jbigdec? b) (jbigdec=? a b))))
|
||||||
|
|
||||||
|
;; str drops the M; pr/pr-str keep it.
|
||||||
|
(register-str-render! jbigdec? jbigdec->string)
|
||||||
|
(register-pr-arm! jbigdec? (lambda (x) (string-append (jbigdec->string x) "M")))
|
||||||
|
|
||||||
|
;; class / decimal?
|
||||||
|
(register-class-arm! jbigdec? (lambda (x) "java.math.BigDecimal"))
|
||||||
|
(set! jolt-decimal? (lambda (x) (jbigdec? x)))
|
||||||
|
(def-var! "clojure.core" "decimal?" jolt-decimal?)
|
||||||
|
|
@ -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"))
|
|
||||||
|
|
@ -81,41 +81,6 @@ fi
|
||||||
if ! grep -q '(jv\$app.util\$shout' "$out.build/flat.ss"; then
|
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
|
echo " FAIL: --direct-link did not emit a direct app->app call"; exit 1
|
||||||
fi
|
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,
|
# Tree-shaking (opt-in): same result, and an unreachable def (the `twice` macro,
|
||||||
# expanded at AOT and never called at runtime) is dropped.
|
# 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
|
if ! JOLT_PWD="$app" bin/joltc build -m app.core -o "$out" --tree-shake >/dev/null 2>&1; then
|
||||||
|
|
@ -138,33 +103,4 @@ fi
|
||||||
if grep -q 'def-var! "clojure.core" "group-by"' "$out.build/flat.ss"; then
|
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
|
echo " FAIL: --tree-shake kept an unreachable clojure.core fn (group-by)"; exit 1
|
||||||
fi
|
fi
|
||||||
# A registered data reader that returns a CODE form must be compiled into the
|
echo "build smoke: passed (release + optimized + direct-link + tree-shake + compiler+core shake)"
|
||||||
# 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)"
|
|
||||||
|
|
|
||||||
|
|
@ -23,7 +23,7 @@
|
||||||
;; --- shell helpers ----------------------------------------------------------
|
;; --- shell helpers ----------------------------------------------------------
|
||||||
;; Run a command, return its stdout as one trimmed string ("" on no output).
|
;; Run a command, return its stdout as one trimmed string ("" on no output).
|
||||||
(define (bld-sh-capture cmd)
|
(define (bld-sh-capture cmd)
|
||||||
(let* ((p (process (bld-sh-wrap cmd))) (in (car p)))
|
(let* ((p (process cmd)) (in (car p)))
|
||||||
(let loop ((acc '()))
|
(let loop ((acc '()))
|
||||||
(let ((l (get-line in)))
|
(let ((l (get-line in)))
|
||||||
(if (eof-object? l)
|
(if (eof-object? l)
|
||||||
|
|
@ -37,16 +37,10 @@
|
||||||
(loop (cons l acc)))))))
|
(loop (cons l acc)))))))
|
||||||
|
|
||||||
(define (bld-system cmd)
|
(define (bld-system cmd)
|
||||||
(let ((rc (system (bld-sh-wrap cmd))))
|
(let ((rc (system cmd)))
|
||||||
(unless (zero? rc)
|
(unless (zero? rc)
|
||||||
(error 'jolt-build (string-append "command failed (" (number->string rc) "): " cmd)))))
|
(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)
|
(define (bld-contains? s sub)
|
||||||
(let ((ns (string-length s)) (nsub (string-length sub)))
|
(let ((ns (string-length s)) (nsub (string-length sub)))
|
||||||
(let loop ((i 0))
|
(let loop ((i 0))
|
||||||
|
|
@ -57,24 +51,6 @@
|
||||||
;; --- toolchain discovery ----------------------------------------------------
|
;; --- toolchain discovery ----------------------------------------------------
|
||||||
(define bld-machine (symbol->string (machine-type)))
|
(define bld-machine (symbol->string (machine-type)))
|
||||||
(define bld-osx? (bld-contains? bld-machine "osx"))
|
(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).
|
;; The Chez executable, for the isolated compile pass (see build-binary step 4).
|
||||||
(define bld-chez
|
(define bld-chez
|
||||||
|
|
@ -98,9 +74,6 @@
|
||||||
(cand (string-append bindir "/../lib/csv" bld-version "/" bld-machine)))
|
(cand (string-append bindir "/../lib/csv" bld-version "/" bld-machine)))
|
||||||
cand))))
|
cand))))
|
||||||
|
|
||||||
(define (bld-have-cc?)
|
|
||||||
(> (string-length (bld-sh-capture "command -v cc")) 0))
|
|
||||||
|
|
||||||
(define (bld-check-toolchain)
|
(define (bld-check-toolchain)
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (f)
|
(lambda (f)
|
||||||
|
|
@ -112,21 +85,14 @@
|
||||||
|
|
||||||
;; Link flags. macOS Homebrew layout for the kernel's lz4/zlib/ncurses deps.
|
;; Link flags. macOS Homebrew layout for the kernel's lz4/zlib/ncurses deps.
|
||||||
(define (bld-link-libs)
|
(define (bld-link-libs)
|
||||||
(cond
|
(if bld-osx?
|
||||||
(bld-osx?
|
(let ((lz4 (bld-sh-capture "brew --prefix lz4 2>/dev/null")))
|
||||||
(let ((lz4 (bld-sh-capture "brew --prefix lz4 2>/dev/null")))
|
(string-append
|
||||||
(string-append
|
(if (> (string-length lz4) 0) (string-append "-L" lz4 "/lib ") "")
|
||||||
(if (> (string-length lz4) 0) (string-append "-L" lz4 "/lib ") "")
|
"-llz4 -lz -lncurses -framework Foundation -liconv -lm"))
|
||||||
"-llz4 -lz -lncurses -framework Foundation -liconv -lm")))
|
;; Linux: the Chez kernel pulls in compression (lz4/z), the expression
|
||||||
;; Windows (ta6nt, MinGW-w64 under MSYS2): the Chez kernel pulls in
|
;; editor (ncurses + terminfo), threads, dlopen, libuuid, and clock_gettime.
|
||||||
;; compression, winsock, COM/UUID, and the registry.
|
"-llz4 -lz -lncurses -ltinfo -ldl -lm -lpthread -luuid -lrt"))
|
||||||
(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) ---------------
|
;; --- 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
|
;; A line is either literal Scheme text to inline, or a tag whose emission the build
|
||||||
|
|
@ -145,7 +111,7 @@
|
||||||
'compile-eval
|
'compile-eval
|
||||||
"(load \"host/chez/png.ss\")"
|
"(load \"host/chez/png.ss\")"
|
||||||
"(load \"host/chez/loader.ss\")"
|
"(load \"host/chez/loader.ss\")"
|
||||||
"(load \"host/chez/java/ffi.ss\")"
|
"(load \"host/chez/ffi.ss\")"
|
||||||
"(set-source-roots! (list \"jolt-core\" \"stdlib\"))"))
|
"(set-source-roots! (list \"jolt-core\" \"stdlib\"))"))
|
||||||
|
|
||||||
(define bld-tagged-loads
|
(define bld-tagged-loads
|
||||||
|
|
@ -166,23 +132,12 @@
|
||||||
(q2 (let scan ((i (+ q1 1))) (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)))))
|
(substring s (+ q1 1) q2)))))
|
||||||
|
|
||||||
;; runtime source for PATH: from the binary's embedded store if present (a
|
(define (bld-file-lines path)
|
||||||
;; self-contained joltc building an app, with no jolt checkout on disk), else read
|
(call-with-input-file path
|
||||||
;; from disk (running from a source checkout). build-joltc embeds every runtime
|
(lambda (p)
|
||||||
;; .ss the manifest inlines, so `build` never touches the filesystem for them.
|
(let loop ((acc '()))
|
||||||
(define (bld-source-string path)
|
(let ((l (get-line p)))
|
||||||
(let ((emb (hashtable-ref embedded-resources path #f)))
|
(if (eof-object? l) (reverse acc) (loop (cons l acc))))))))
|
||||||
(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.
|
;; Emit one line to OUT, recursively inlining a `(load ...)` of a repo file.
|
||||||
(define (bld-inline-line line out depth)
|
(define (bld-inline-line line out depth)
|
||||||
|
|
@ -215,38 +170,6 @@
|
||||||
;; The loop itself is emit-image's ei-emit-ns* (optimize? #t, guard? #f).
|
;; 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))
|
(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
|
;; 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
|
;; 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;
|
;; (defmulti/defmethod resolve their target var through it) land in the right ns;
|
||||||
|
|
@ -310,24 +233,21 @@
|
||||||
(define (bld-strs x) (map jolt-str-render-one (seq->list x)))
|
(define (bld-strs x) (map jolt-str-render-one (seq->list x)))
|
||||||
|
|
||||||
;; Emit native-library loads. `natives` is the encoded jolt seq jolt.main/
|
;; Emit native-library loads. `natives` is the encoded jolt seq jolt.main/
|
||||||
;; encode-natives produced: each entry is ["process"] | ["static" form…] |
|
;; encode-natives produced: each entry is ["process"] | ["req" cand…] | ["opt" cand…].
|
||||||
;; ["req" cand…] | ["opt" cand…]. `which` selects 'required (process + static +
|
;; `which` selects 'required (process + req) or 'optional. Required + process loads
|
||||||
;; req) or 'optional. Required loads are emitted before the app forms (the app's
|
;; are emitted before the app forms (the app's defcfn foreign-procedures resolve
|
||||||
;; defcfn foreign-procedures resolve their symbols at top-level eval during
|
;; their symbols at top-level eval during startup, so the libs must be loaded
|
||||||
;; startup, so the libs must be loaded first); a load-shared-object failure there
|
;; first); a load-shared-object failure there is fatal — correct for a required
|
||||||
;; is fatal — correct for a required lib. A "static" lib is cc-linked into the
|
;; lib. Optional loads run in the scheme-start launcher, where guard catches a
|
||||||
;; binary (see bld-native-link-flags), so its symbols are already in the process:
|
;; missing lib (an optional lib's namespace is only present when the app requires
|
||||||
;; it loads them the same way a "process" lib does. Optional loads run in the
|
;; it, so its foreign-procedures aren't among the baked top-level forms).
|
||||||
;; 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)
|
(define (bld-emit-natives out natives which)
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (entry)
|
(lambda (entry)
|
||||||
(let* ((parts (bld-strs entry)) (kind (car parts)) (cands (cdr parts))
|
(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)))
|
(cand-lits (fold-left (lambda (s c) (string-append s (ei-str-lit c) " ")) "" cands)))
|
||||||
(cond
|
(cond
|
||||||
((and (eq? which 'required) (or (string=? kind "process") (string=? kind "static")))
|
((and (eq? which 'required) (string=? kind "process"))
|
||||||
(put-string out "(jolt-build-load-native '() #f #t)\n"))
|
(put-string out "(jolt-build-load-native '() #f #t)\n"))
|
||||||
((and (eq? which 'required) (string=? kind "req"))
|
((and (eq? which 'required) (string=? kind "req"))
|
||||||
(put-string out (string-append "(jolt-build-load-native (list " cand-lits ") #f #f)\n")))
|
(put-string out (string-append "(jolt-build-load-native (list " cand-lits ") #f #f)\n")))
|
||||||
|
|
@ -335,66 +255,6 @@
|
||||||
(put-string out (string-append "(jolt-build-load-native (list " cand-lits ") #t #f)\n"))))))
|
(put-string out (string-append "(jolt-build-load-native (list " cand-lits ") #t #f)\n"))))))
|
||||||
(seq->list natives)))
|
(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
|
;; 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).
|
;; resource-name is the "/"-joined path under the root (what io/resource is asked for).
|
||||||
(define (bld-walk-files root rel acc)
|
(define (bld-walk-files root rel acc)
|
||||||
|
|
@ -436,31 +296,8 @@
|
||||||
;; direct-link?: opt-in closed-world direct-linking (app->app calls bind directly,
|
;; direct-link?: opt-in closed-world direct-linking (app->app calls bind directly,
|
||||||
;; no runtime redefinition). Off by default in every mode — release stays
|
;; no runtime redefinition). Off by default in every mode — release stays
|
||||||
;; dynamically linked.
|
;; 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?)
|
(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
|
(bld-check-toolchain)
|
||||||
;; 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.
|
;; 1. record app namespaces in dependency order as they finish loading.
|
||||||
(let ((app-order '()))
|
(let ((app-order '()))
|
||||||
(set-ns-loaded-hook!
|
(set-ns-loaded-hook!
|
||||||
|
|
@ -489,15 +326,8 @@
|
||||||
(set-optimize! (string=? mode "optimized"))
|
(set-optimize! (string=? mode "optimized"))
|
||||||
(when direct-link?
|
(when direct-link?
|
||||||
((var-deref "jolt.backend-scheme" "set-direct-link!") #t)
|
((var-deref "jolt.backend-scheme" "set-direct-link!") #t)
|
||||||
((var-deref "jolt.backend-scheme" "direct-link-reset!")))
|
((var-deref "jolt.backend-scheme" "direct-link-reset!"))))
|
||||||
;; whole-program param-type fixpoint before per-form emit
|
|
||||||
(when (string=? mode "optimized") (bld-wp-infer! ordered)))
|
|
||||||
(lambda ()
|
(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?
|
(if tree-shake?
|
||||||
(dce-shake
|
(dce-shake
|
||||||
(dce-blob-records "host/chez/seed/prelude.ss")
|
(dce-blob-records "host/chez/seed/prelude.ss")
|
||||||
|
|
@ -506,23 +336,21 @@
|
||||||
;; ns-prelude forms (always kept, no fqn/refs) set the
|
;; ns-prelude forms (always kept, no fqn/refs) set the
|
||||||
;; ns + register aliases before this ns's forms; dce
|
;; ns + register aliases before this ns's forms; dce
|
||||||
;; keeps original order.
|
;; keeps original order.
|
||||||
(let ((src (ldr-read-source (cdr nf))))
|
(let ((src (read-file-string (cdr nf))))
|
||||||
(parameterize ((rdr-source-file (cdr nf)))
|
(append
|
||||||
(append
|
(map (lambda (s) (dce-rec #t #f '() s))
|
||||||
(map (lambda (s) (dce-rec #t #f '() s))
|
(bld-ns-prelude (car nf) src))
|
||||||
(bld-ns-prelude (car nf) src))
|
(ei-emit-ns-records (car nf) src))))
|
||||||
(ei-emit-ns-records (car nf) src)))))
|
|
||||||
ordered))
|
ordered))
|
||||||
(string-append entry-ns "/-main"))
|
(string-append entry-ns "/-main"))
|
||||||
(values #f
|
(values #f
|
||||||
(apply append
|
(apply append
|
||||||
(map (lambda (nf)
|
(map (lambda (nf)
|
||||||
(let ((src (ldr-read-source (cdr nf))))
|
(let ((src (read-file-string (cdr nf))))
|
||||||
(parameterize ((rdr-source-file (cdr nf)))
|
(append (bld-ns-prelude (car nf) src)
|
||||||
(append (bld-ns-prelude (car nf) src)
|
(bld-emit-ns (car nf) src))))
|
||||||
(bld-emit-ns (car nf) src)))))
|
|
||||||
ordered))
|
ordered))
|
||||||
#f))))
|
#f)))
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(set-optimize! #f)
|
(set-optimize! #f)
|
||||||
((var-deref "jolt.backend-scheme" "set-direct-link!") #f)))))
|
((var-deref "jolt.backend-scheme" "set-direct-link!") #f)))))
|
||||||
|
|
@ -533,7 +361,7 @@
|
||||||
(boot (string-append builddir "/jolt.boot"))
|
(boot (string-append builddir "/jolt.boot"))
|
||||||
(boot-h (string-append builddir "/boot_data.h"))
|
(boot-h (string-append builddir "/boot_data.h"))
|
||||||
(main-c (string-append builddir "/main.c")))
|
(main-c (string-append builddir "/main.c")))
|
||||||
(bld-mkdir-p builddir)
|
(bld-system (string-append "mkdir -p '" builddir "'"))
|
||||||
;; 3. flat source = runtime + app + launcher.
|
;; 3. flat source = runtime + app + launcher.
|
||||||
(let ((out (open-output-file flat-ss 'replace)))
|
(let ((out (open-output-file flat-ss 'replace)))
|
||||||
(bld-emit-runtime out drop-compiler? core-strs)
|
(bld-emit-runtime out drop-compiler? core-strs)
|
||||||
|
|
@ -571,176 +399,47 @@
|
||||||
"))\n"
|
"))\n"
|
||||||
" (list \"jolt-core\" \"stdlib\"))))\n"))
|
" (list \"jolt-core\" \"stdlib\"))))\n"))
|
||||||
(put-string out (string-append
|
(put-string out (string-append
|
||||||
;; Call -main only if the entry namespace defines one;
|
" (let ((mainv (var-deref " (ei-str-lit entry-ns) " \"-main\")))\n"
|
||||||
;; a script ns (top-level side effects, no -main) has
|
" (apply jolt-invoke mainv args))\n"
|
||||||
;; 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"))
|
" (exit 0)))\n"))
|
||||||
(close-port out))
|
(close-port out))
|
||||||
;; 4. compile -> boot -> link. Two paths, chosen by whether this process
|
;; 4. compile -> boot -> embed -> link.
|
||||||
;; carries the bundled Chez boots + launcher stub:
|
;; compile-file/make-boot-file run in a FRESH Chez, not this process: the
|
||||||
;; - SELF-CONTAINED (the distributed joltc, jolt-eaj): compile-file +
|
;; loaded runtime shadows `error` (regex.ss, for irregex), which would
|
||||||
;; make-boot-file run IN PROCESS (the compiler is resident — joltc is
|
;; otherwise bake a broken `error` reference into the boot.
|
||||||
;; built from scheme.boot), then the boot is appended to a copy of the
|
(display (string-append "jolt build: compiling " entry-ns " (" mode " mode)\n"))
|
||||||
;; embedded stub. No external Chez, no cc.
|
(let ((cs (string-append builddir "/compile.ss")))
|
||||||
;; - LEGACY (dev bin/joltc): spawn a fresh Chez for compile-file/
|
(let ((p (open-output-file cs 'replace)))
|
||||||
;; make-boot-file, then xxd the boot into a C array and cc-link against
|
(put-string p
|
||||||
;; libkernel.a. Kept so `make buildsmoke` still exercises the cc path.
|
(string-append
|
||||||
(if (jolt-embedded-bytes "stub/launcher")
|
"(import (chezscheme))\n"
|
||||||
(build-self-contained entry-ns out-path mode builddir flat-ss flat-so boot
|
"(compile-file " (ei-str-lit flat-ss) " " (ei-str-lit flat-so) ")\n"
|
||||||
(bld-native-link-flags natives))
|
"(make-boot-file " (ei-str-lit boot) " '()\n "
|
||||||
(build-with-cc entry-ns out-path mode builddir flat-ss flat-so boot boot-h main-c
|
(ei-str-lit (string-append bld-csv-dir "/petite.boot")) "\n "
|
||||||
(bld-native-link-flags natives)))))))))
|
(ei-str-lit (string-append bld-csv-dir "/scheme.boot")) "\n "
|
||||||
|
(ei-str-lit flat-so) ")\n"))
|
||||||
;; --- self-contained link (in-process compile + append the boot to the stub) ---
|
(close-port p))
|
||||||
;; compile-file runs against the DEFAULT interaction environment, so the boot's
|
(bld-system (string-append bld-chez " --script '" cs "'")))
|
||||||
;; top-level defines land in the real symbol cells — the runtime compiler's
|
(bld-system (string-append "xxd -i '" boot "' > '" boot-h "'"))
|
||||||
;; eval'd code must resolve them (var-deref, jolt-invoke, the jolt-n* macros)
|
;; The xxd symbol is derived from the path; normalize to jolt_boot.
|
||||||
;; when the built binary dynamically requires a namespace. Compiling in a clean
|
(bld-system (string-append
|
||||||
;; copy-environment instead orphans every define in locations eval can't see,
|
"sed -i.bak -E 's/unsigned char [A-Za-z0-9_]+\\[\\]/unsigned char jolt_boot[]/; "
|
||||||
;; and the binary dies with "variable var-deref is not bound" the moment a
|
"s/unsigned int [A-Za-z0-9_]+_len/unsigned int jolt_boot_len/' '" boot-h "'"))
|
||||||
;; runtime require compiles source.
|
(let ((mc (open-output-file main-c 'replace)))
|
||||||
;;
|
(put-string mc
|
||||||
;; The default env has a wrinkle the legacy fresh-Chez path doesn't: THIS
|
(string-append
|
||||||
;; process's cells hold jolt's redefinitions of some kernel names (`error`,
|
"#include \"scheme.h\"\n#include \"boot_data.h\"\n"
|
||||||
;; regex.ss), so references to them compile as cell reads — and a read that
|
"int main(int argc, char *argv[]) {\n"
|
||||||
;; runs before the redefining form would find the fresh binary's cell unbound.
|
" Sscheme_init(0);\n"
|
||||||
;; The prologue closes that: it first binds each redefined kernel name's cell
|
" Sregister_boot_file_bytes(\"jolt\", jolt_boot, jolt_boot_len);\n"
|
||||||
;; to its kernel value, making the boot's earliest reads identical to the
|
" Sbuild_heap(0, 0);\n"
|
||||||
;; legacy path's primitive references.
|
" int status = Sscheme_start(argc, (const char **)argv);\n"
|
||||||
|
" Sscheme_deinit();\n return status;\n}\n"))
|
||||||
;; every top-level (define nm …)/(define (nm …) …) name in the flat file that
|
(close-port mc))
|
||||||
;; shadows a scheme-environment VARIABLE (syntax names don't eval; skip them).
|
(bld-system (string-append
|
||||||
(define (bld-kernel-prologue flat-ss)
|
"cc -O2 -I'" bld-csv-dir "' '" main-c "' '" bld-csv-dir "/libkernel.a' "
|
||||||
(let ((seen (make-eq-hashtable))
|
"-o '" out-path "' " (bld-link-libs)))
|
||||||
(kenv (scheme-environment))
|
(display (string-append "jolt build: wrote " out-path "\n")))))))
|
||||||
(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"
|
(def-var! "jolt.host" "build-binary"
|
||||||
(lambda (entry out mode natives embed-dirs ext-roots direct-link? tree-shake?)
|
(lambda (entry out mode natives embed-dirs ext-roots direct-link? tree-shake?)
|
||||||
|
|
|
||||||
|
|
@ -11,26 +11,6 @@
|
||||||
|
|
||||||
(define cli-args (cdr (command-line))) ; drop the script name
|
(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")
|
(load "host/chez/rt.ss")
|
||||||
(set-chez-ns! "clojure.core")
|
(set-chez-ns! "clojure.core")
|
||||||
(load "host/chez/seed/prelude.ss")
|
(load "host/chez/seed/prelude.ss")
|
||||||
|
|
@ -44,7 +24,7 @@
|
||||||
;; jolt.ffi host primitives (memory / library loading) load AFTER the loader's
|
;; 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
|
;; 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).
|
;; 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)
|
(load "host/chez/ffi.ss") ; jolt.ffi (FFI: a library binds native code)
|
||||||
|
|
||||||
;; jolt.main + jolt.deps live under jolt-core; keep them (and stdlib) on the
|
;; 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.
|
;; roots so the CLI's own namespaces — and any jolt.* an app pulls in — resolve.
|
||||||
|
|
@ -52,23 +32,29 @@
|
||||||
(set-source-roots! (list "jolt-core" "stdlib"))
|
(set-source-roots! (list "jolt-core" "stdlib"))
|
||||||
|
|
||||||
;; Render an uncaught jolt throw (any value, not just a Chez condition) to stderr
|
;; 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
|
;; and exit non-zero, instead of Chez's opaque "non-condition value" dump. An
|
||||||
;; message/ex-data/cause + a mapped Clojure backtrace come from the shared
|
;; ex-info shows its message + ex-data; anything else is pr-str'd.
|
||||||
;; renderer (source-registry.ss); the cli adds the top-level source location.
|
(define (jolt-report-uncaught v)
|
||||||
(define (jolt-report-uncaught raw)
|
(let ((port (current-error-port)))
|
||||||
(let ((v (jolt-unwrap-throw raw))
|
(if (and (jolt=2 (jolt-get v jolt-kw-ex-type jolt-nil) jolt-kw-ex-info))
|
||||||
(port (current-error-port)))
|
(begin
|
||||||
(jolt-render-throwable v port)
|
(display "Unhandled exception: " port)
|
||||||
;; The top-level form that was evaluating when this propagated (file:line:col).
|
(display (jolt-str-render-one (jolt-get v jolt-kw-message jolt-nil)) port)
|
||||||
(let ((loc (jolt-current-source-string)))
|
(newline port)
|
||||||
(when loc (display " at " port) (display loc port) (newline port)))
|
(let ((data (jolt-get v jolt-kw-data jolt-nil)))
|
||||||
(let ((bt (jolt-backtrace-string v)))
|
(unless (jolt-nil? data)
|
||||||
(when bt (display " trace:\n" port) (display bt port)))
|
(display " ex-data: " port) (display (jolt-pr-str data) port) (newline port)))
|
||||||
|
(let ((cause (jolt-get v jolt-kw-cause jolt-nil)))
|
||||||
|
(when (condition? cause)
|
||||||
|
(display " cause: " port)
|
||||||
|
(display (with-output-to-string (lambda () (display-condition cause))) port)
|
||||||
|
(newline port))))
|
||||||
|
(begin
|
||||||
|
(display "Unhandled exception: " port)
|
||||||
|
(display (if (condition? v) (with-output-to-string (lambda () (display-condition v))) (jolt-pr-str v)) port)
|
||||||
|
(newline port)))
|
||||||
(exit 1)))
|
(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)))
|
(guard (v (#t (jolt-report-uncaught v)))
|
||||||
(cond
|
(cond
|
||||||
;; -e EXPR — evaluate one expression and print it (blank for nil). Wrapped in
|
;; -e EXPR — evaluate one expression and print it (blank for nil). Wrapped in
|
||||||
|
|
|
||||||
|
|
@ -32,161 +32,45 @@
|
||||||
out))
|
out))
|
||||||
|
|
||||||
;; ============================================================================
|
;; ============================================================================
|
||||||
;; persistent vector — 32-way trie + tail (Clojure's PersistentVector)
|
;; persistent vector — copy-on-write over a Scheme vector
|
||||||
;; ============================================================================
|
;; ============================================================================
|
||||||
;; cnt elements live in a trie of 32-wide nodes (root, height = shift bits) plus a
|
;; A pvec carries an `ent` flag: #t marks a MAP ENTRY (the [k v] pair seq'd out
|
||||||
;; trailing `tail` chunk of 1..32. conj appends to the tail and, when it fills,
|
;; of a map). A map entry equals its [k v] vector and walks like one (nth/count/
|
||||||
;; pushes it into the trie by path-copy — so conj is O(1) amortized and a linear
|
;; seq/=/hash/print all read only `v`), but is NOT `vector?` and IS `map-entry?`
|
||||||
;; build is O(n), not the O(n^2) of a flat copy-on-write array. nth/assoc/pop are
|
;; — matching Clojure's MapEntry. The flag defaults #f, so every
|
||||||
;; O(log32 n). Trie nodes are Scheme vectors holding only their live children
|
;; existing `(make-pvec v)` builds a plain vector; modifying an entry (conj/assoc)
|
||||||
;; (grown left-to-right), so a node's length is its child count.
|
;; likewise yields a plain vector.
|
||||||
;;
|
(define-record-type pvec
|
||||||
;; `ent` #t marks a MAP ENTRY (the [k v] pair seq'd out of a map). An entry has 2
|
(fields v ent)
|
||||||
;; elements (all in the tail), equals its [k v] vector and walks like one, and is
|
(protocol (lambda (new) (case-lambda ((v) (new v #f)) ((v e) (new v e)))))
|
||||||
;; both vector? (Clojure's MapEntry implements IPersistentVector) and map-entry?.
|
(nongenerative chez-pvec-v1))
|
||||||
;; Modifying an entry (conj/assoc/pop) yields a plain vector (ent #f).
|
(define empty-pvec (make-pvec (vector)))
|
||||||
;;
|
|
||||||
;; 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 (jolt-vector . xs) (make-pvec (list->vector xs)))
|
||||||
(define (make-map-entry k v) (make-pvec (vector k v) #t))
|
(define (make-map-entry k v) (make-pvec (vector k v) #t))
|
||||||
(define (jolt-map-entry? x) (and (pvec? x) (pvec-ent x) #t))
|
(define (jolt-map-entry? x) (and (pvec? x) (pvec-ent x) #t))
|
||||||
|
(define (pvec-count p) (vector-length (pvec-v p)))
|
||||||
|
;; 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-nth-d p i d)
|
||||||
|
(let ((v (pvec-v p)) (i (->idx i)))
|
||||||
|
(if (and (fixnum? i) (fx>=? i 0) (fx<? i (vector-length v))) (vector-ref v i) d)))
|
||||||
|
(define (pvec-conj p x)
|
||||||
|
(let* ((v (pvec-v p)) (n (vector-length v)) (out (make-vector (fx+ n 1))))
|
||||||
|
(let loop ((i 0)) (when (fx<? i n) (vector-set! out i (vector-ref v i)) (loop (fx+ i 1))))
|
||||||
|
(vector-set! out n x)
|
||||||
|
(make-pvec out)))
|
||||||
|
(define (pvec-assoc p i x) ; i in [0,count]; =count appends
|
||||||
|
(let* ((v (pvec-v p)) (n (vector-length v)) (i (->idx i)))
|
||||||
|
(cond ((and (fx>=? i 0) (fx<? i n)) (make-pvec (vec-set v i x)))
|
||||||
|
((fx=? i n) (pvec-conj p x))
|
||||||
|
(else (error 'assoc "vector index out of bounds")))))
|
||||||
|
(define (pvec-peek p)
|
||||||
|
(let ((n (pvec-count p))) (if (fx=? n 0) jolt-nil (vector-ref (pvec-v p) (fx- n 1)))))
|
||||||
|
(define (pvec-pop p)
|
||||||
|
(let ((n (pvec-count p)))
|
||||||
|
(if (fx=? n 0) (error 'pop "can't pop empty vector")
|
||||||
|
(make-pvec (vec-copy-range (pvec-v p) 0 (fx- n 1))))))
|
||||||
|
|
||||||
;; ============================================================================
|
;; ============================================================================
|
||||||
;; bitmap HAMT — keys hashed by jolt-hash, leaves compared by jolt=
|
;; bitmap HAMT — keys hashed by jolt-hash, leaves compared by jolt=
|
||||||
|
|
@ -287,109 +171,26 @@
|
||||||
;; ============================================================================
|
;; ============================================================================
|
||||||
;; persistent map / set over the HAMT
|
;; persistent map / set over the HAMT
|
||||||
;; ============================================================================
|
;; ============================================================================
|
||||||
;; A small map keeps its keys in INSERTION order (Clojure's PersistentArrayMap),
|
(define-record-type pmap (fields root cnt) (nongenerative chez-pmap-v1))
|
||||||
;; converting to hash order past a threshold (PersistentHashMap). The HAMT root
|
(define empty-pmap (make-pmap empty-hnode 0))
|
||||||
;; 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
|
(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)
|
(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)))
|
(let* ((added (box #f)) (r (node-assoc (pmap-root m) 0 (key-hash k) k v added)))
|
||||||
(if (unbox added)
|
(make-pmap r (if (unbox added) (fx+ (pmap-cnt m) 1) (pmap-cnt m)))))
|
||||||
(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)
|
(define (pmap-dissoc m k)
|
||||||
(let* ((removed (box #f)) (r (node-dissoc (pmap-root m) 0 (key-hash k) k removed))
|
(let* ((removed (box #f)) (r (node-dissoc (pmap-root m) 0 (key-hash k) k removed)))
|
||||||
(ord (pmap-order m)))
|
(make-pmap r (if (unbox removed) (fx- (pmap-cnt m) 1) (pmap-cnt 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-get m k default) (node-get (pmap-root m) 0 (key-hash k) k default))
|
||||||
(define (pmap-contains? m k) (not (eq? pmap-absent (node-get (pmap-root m) 0 (key-hash k) k pmap-absent))))
|
(define (pmap-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)
|
(define (pmap-fold m proc acc) (node-fold (pmap-root m) proc acc))
|
||||||
;; (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)
|
(define (jolt-hash-map . kvs)
|
||||||
(let loop ((m empty-pmap) (kvs kvs))
|
(let loop ((m empty-pmap) (kvs kvs))
|
||||||
(cond ((null? kvs)
|
(cond ((null? kvs) m)
|
||||||
(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"))
|
((null? (cdr kvs)) (error 'hash-map "odd number of map literal entries"))
|
||||||
(else (loop (pmap-put-ordered m (car kvs) (cadr kvs)) (cddr kvs))))))
|
(else (loop (pmap-assoc 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-record-type pset (fields m) (nongenerative chez-pset-v1))
|
||||||
(define empty-pset (make-pset empty-pmap-hash)) ; sets are hash-ordered
|
(define empty-pset (make-pset empty-pmap))
|
||||||
(define (pset-conj s e) (if (pmap-contains? (pset-m s) e) s (make-pset (pmap-assoc (pset-m s) e e))))
|
(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-disj s e) (make-pset (pmap-dissoc (pset-m s) e)))
|
||||||
(define (pset-contains? s e) (pmap-contains? (pset-m s) e))
|
(define (pset-contains? s e) (pmap-contains? (pset-m s) e))
|
||||||
|
|
@ -410,7 +211,7 @@
|
||||||
((empty-list-t? coll) (cseq-list x jolt-nil))
|
((empty-list-t? coll) (cseq-list x jolt-nil))
|
||||||
((pmap? coll)
|
((pmap? coll)
|
||||||
(cond ((jolt-nil? x) coll) ; (conj m nil) = m
|
(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
|
((pmap? x) (pmap-fold x (lambda (k v m) (pmap-assoc m k v)) coll)) ; merge
|
||||||
((and (pvec? x) (fx=? 2 (pvec-count x)))
|
((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)))
|
(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"))))
|
(else (error 'conj "conj on a map expects a [k v] pair or a map"))))
|
||||||
|
|
@ -421,11 +222,9 @@
|
||||||
(if (null? args)
|
(if (null? args)
|
||||||
(jolt-vector)
|
(jolt-vector)
|
||||||
(let ((coll (car args)) (xs (cdr args)))
|
(let ((coll (car args)) (xs (cdr args)))
|
||||||
(cond
|
(if (jolt-nil? coll)
|
||||||
;; 1-arity returns the coll untouched — (conj nil) is nil
|
(fold-left jolt-conj1 jolt-empty-list xs)
|
||||||
((null? xs) coll)
|
(meta-carry coll (fold-left jolt-conj1 coll xs))))))
|
||||||
((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) ->
|
;; 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
|
;; value) instead of set!-wrapping jolt-get — disjoint coll types, checked before the
|
||||||
|
|
@ -440,16 +239,11 @@
|
||||||
((string? coll) (let ((i (->idx k)))
|
((string? coll) (let ((i (->idx k)))
|
||||||
(if (and (fixnum? i) (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i) d)))
|
(if (and (fixnum? i) (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i) d)))
|
||||||
(else 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)
|
(define (jolt-get-dispatch coll k d)
|
||||||
(if (jrec? coll)
|
(let loop ((as jolt-get-arms))
|
||||||
(jrec-ref coll k d)
|
(cond ((null? as) (jolt-get-base coll k d))
|
||||||
(let loop ((as jolt-get-arms))
|
(((caar as) coll) ((cdar as) coll k d))
|
||||||
(cond ((null? as) (jolt-get-base coll k d))
|
(else (loop (cdr as))))))
|
||||||
(((caar as) coll) ((cdar as) coll k d))
|
|
||||||
(else (loop (cdr as)))))))
|
|
||||||
(define jolt-get
|
(define jolt-get
|
||||||
(case-lambda
|
(case-lambda
|
||||||
((coll k) (jolt-get-dispatch coll k jolt-nil))
|
((coll k) (jolt-get-dispatch coll k jolt-nil))
|
||||||
|
|
@ -462,28 +256,21 @@
|
||||||
(define (rec-coll-method coll name)
|
(define (rec-coll-method coll name)
|
||||||
(and (jrec? coll) (find-method-any-protocol (jrec-tag 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
|
(define jolt-nth
|
||||||
(case-lambda
|
(case-lambda
|
||||||
((coll i)
|
((coll i)
|
||||||
(jolt-nth-nil-idx! i)
|
|
||||||
(let ((i (->idx i)))
|
(let ((i (->idx i)))
|
||||||
(cond ((jolt-nil? coll) jolt-nil) ; RT.nth(nil, i) is nil at any index
|
(cond ((pvec? coll) (let ((v (pvec-v coll)))
|
||||||
((pvec? coll) (let ((v (pvec-v coll)))
|
|
||||||
(if (and (fx>=? i 0) (fx<? i (vector-length v))) (vector-ref v i)
|
(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")))))
|
(error 'nth "index out of bounds"))))
|
||||||
((string? coll) (if (and (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i)
|
((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"))))
|
(error 'nth "index out of bounds")))
|
||||||
((or (cseq? coll) (empty-list-t? coll)) (seq-nth coll i #f jolt-nil))
|
((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)))
|
((rec-coll-method coll "nth") => (lambda (m) (jolt-invoke m coll i)))
|
||||||
(else (error 'nth "unsupported collection")))))
|
(else (error 'nth "unsupported collection")))))
|
||||||
((coll i d)
|
((coll i d)
|
||||||
(jolt-nth-nil-idx! i)
|
|
||||||
(let ((i (->idx i)))
|
(let ((i (->idx i)))
|
||||||
(cond ((jolt-nil? coll) d) ; RT.nth(nil, i, notFound) is notFound
|
(cond ((pvec? coll) (pvec-nth-d coll i d))
|
||||||
((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))
|
((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))
|
((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)))
|
((rec-coll-method coll "nth") => (lambda (m) (jolt-invoke m coll i d)))
|
||||||
|
|
@ -528,21 +315,6 @@
|
||||||
((pset? coll) (pset-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)))))
|
((pvec? coll) (let ((k (->idx k))) (and (fixnum? k) (fx>=? k 0) (fx<? k (pvec-count coll)))))
|
||||||
((jolt-nil? coll) #f)
|
((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)))
|
(else #f)))
|
||||||
|
|
||||||
(define (jolt-empty? coll)
|
(define (jolt-empty? coll)
|
||||||
|
|
@ -555,25 +327,15 @@
|
||||||
((cseq? coll) #f) ; a cseq is non-empty by construction
|
((cseq? coll) #f) ; a cseq is non-empty by construction
|
||||||
(else (error 'empty? "unsupported collection"))))
|
(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)
|
(define (jolt-peek coll)
|
||||||
(cond ((pvec? coll) (pvec-peek coll))
|
(cond ((pvec? coll) (pvec-peek coll))
|
||||||
;; list peek = first; a non-list seq (range, a rest chain) is not an
|
((or (cseq? coll) (empty-list-t? coll)) (jolt-first coll)) ; list peek = first
|
||||||
;; IPersistentStack on the JVM
|
((jolt-nil? coll) jolt-nil) (else (error 'peek "unsupported collection"))))
|
||||||
((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)
|
(define (jolt-pop coll)
|
||||||
(cond ((jolt-nil? coll) jolt-nil) ; RT.pop(nil) is nil
|
(cond ((pvec? coll) (meta-carry coll (pvec-pop coll)))
|
||||||
((pvec? coll) (meta-carry coll (pvec-pop coll)))
|
((cseq? coll) (meta-carry coll (jolt-rest coll))) ; list pop = rest
|
||||||
((and (cseq? coll) (cseq-list? coll)) (meta-carry coll (jolt-rest coll)))
|
|
||||||
((empty-list-t? coll) (error 'pop "can't pop empty list"))
|
((empty-list-t? coll) (error 'pop "can't pop empty list"))
|
||||||
(else (jolt-stack-throw coll))))
|
(else (error 'pop "unsupported collection"))))
|
||||||
|
|
||||||
;; ============================================================================
|
;; ============================================================================
|
||||||
;; equality / hash hooks called from values.ss (jolt=2 / jolt-hash)
|
;; equality / hash hooks called from values.ss (jolt=2 / jolt-hash)
|
||||||
|
|
|
||||||
|
|
@ -20,138 +20,12 @@
|
||||||
;; whose data conversion would turn those into real sets.
|
;; whose data conversion would turn those into real sets.
|
||||||
(define jolt-ce-read jolt-read-form-raw)
|
(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.*
|
;; 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
|
;; 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
|
;; "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,
|
;; 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.
|
;; so every analyze->emit on this spine sees the full core.
|
||||||
((var-deref "jolt.backend-scheme" "set-prelude-mode!") #t)
|
((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.
|
;; (quote X) -> X, else x — unwraps a quoted require spec.
|
||||||
(define (ce-unquote x)
|
(define (ce-unquote x)
|
||||||
|
|
@ -177,22 +51,14 @@
|
||||||
;; (require spec...) / (use spec...) — specs are quoted
|
;; (require spec...) / (use spec...) — specs are quoted
|
||||||
((and hn (or (string=? hn "require") (string=? hn "use")))
|
((and hn (or (string=? hn "require") (string=? hn "use")))
|
||||||
(for-each (lambda (a) (chez-register-spec! ns (ce-unquote a))) (cdr items)))
|
(for-each (lambda (a) (chez-register-spec! ns (ce-unquote a))) (cdr items)))
|
||||||
;; (ns name (:require [a :as x]) ...) — clause specs are literal. Register
|
;; (ns name (:require [a :as x]) ...) — clause specs are literal
|
||||||
;; 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"))
|
((and hn (string=? hn "ns"))
|
||||||
(let ((ns-name (if (and (pair? (cdr items)) (symbol-t? (ce-unwrap-meta (cadr items))))
|
(for-each (lambda (clause)
|
||||||
(symbol-t-name (ce-unwrap-meta (cadr items)))
|
(when (and (cseq? clause) (cseq-list? clause))
|
||||||
ns)))
|
(let ((cl (seq->list clause)))
|
||||||
(for-each (lambda (clause)
|
(when (ce-clause-require? cl)
|
||||||
(when (and (cseq? clause) (cseq-list? clause))
|
(for-each (lambda (spec) (chez-register-spec! ns spec)) (cdr cl))))))
|
||||||
(let ((cl (seq->list clause)))
|
(if (pair? (cdr items)) (cddr items) '())))
|
||||||
(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))))))))
|
(else (for-each (lambda (x) (ce-scan-requires! x ns)) items))))))))
|
||||||
|
|
||||||
;; Already-read FORM -> Scheme source string (analyze -> emit on Chez).
|
;; Already-read FORM -> Scheme source string (analyze -> emit on Chez).
|
||||||
|
|
@ -243,13 +109,7 @@
|
||||||
;; A top-level (do ...) is UNROLLED — each subform compiled+eval'd in turn, like
|
;; 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
|
;; 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.
|
;; 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)
|
(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
|
(cond
|
||||||
;; thread the current ns: an earlier subform may switch it (ns/in-ns call
|
;; 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
|
;; set-chez-ns!), and the next subform must be ANALYZED in that ns so its defs
|
||||||
|
|
@ -264,12 +124,6 @@
|
||||||
;; of the expander fn + (mark-macro! …) so subsequent forms expand it. One
|
;; of the expander fn + (mark-macro! …) so subsequent forms expand it. One
|
||||||
;; macro-expansion path (no separate spine interception).
|
;; macro-expansion path (no separate spine interception).
|
||||||
(else
|
(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)))
|
(eval (read (open-input-string (jolt-analyze-emit-form form ns)))
|
||||||
(interaction-environment)))))
|
(interaction-environment)))))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -151,31 +151,16 @@
|
||||||
(mutable queue) (mutable running?) mu cv)
|
(mutable queue) (mutable running?) mu cv)
|
||||||
(nongenerative jolt-agent-v1))
|
(nongenerative jolt-agent-v1))
|
||||||
|
|
||||||
;; (agent state :meta m :validator f :error-mode e): the ARef ctor contract like
|
;; (agent state) / (agent state :validator f :error-mode m :meta x): only :validator
|
||||||
;; atom's — the validator runs against the initial state, :meta must be a map.
|
;; has runtime behaviour here; other opts are accepted/ignored.
|
||||||
;; :error-mode is accepted/ignored (jolt agents are always :fail).
|
|
||||||
(define (jolt-agent-new state . opts)
|
(define (jolt-agent-new state . opts)
|
||||||
(let loop ((o opts) (validator jolt-nil) (m #f))
|
(let loop ((o opts) (validator jolt-nil))
|
||||||
(cond
|
(cond
|
||||||
((or (null? o) (null? (cdr o)))
|
((or (null? o) (null? (cdr o)))
|
||||||
(let ((a (make-jolt-agent state jolt-nil validator (vector '() '()) #f (make-mutex) (make-condition))))
|
(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"))
|
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "validator"))
|
||||||
(loop (cddr o) (cadr o) m))
|
(loop (cddr o) (cadr o)))
|
||||||
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "meta"))
|
(else (loop (cddr o) validator)))))
|
||||||
(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 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)).
|
;; the front, `in` holds sends reversed onto it (an append-to-a-list send was O(n)).
|
||||||
|
|
@ -204,13 +189,11 @@
|
||||||
(guard (e (#t (with-mutex (jolt-agent-mu a)
|
(guard (e (#t (with-mutex (jolt-agent-mu a)
|
||||||
(jolt-agent-err-set! a e)
|
(jolt-agent-err-set! a e)
|
||||||
(condition-broadcast (jolt-agent-cv a)))))
|
(condition-broadcast (jolt-agent-cv a)))))
|
||||||
(let* ((old (jolt-agent-state a))
|
(let ((nv (apply jolt-invoke (car act) (jolt-agent-state a) (cdr act))))
|
||||||
(nv (apply jolt-invoke (car act) old (cdr act))))
|
|
||||||
(let ((vf (jolt-agent-validator a)))
|
(let ((vf (jolt-agent-validator a)))
|
||||||
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf nv)))
|
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf nv)))
|
||||||
(jolt-iref-state-throw)))
|
(error #f "Invalid reference state")))
|
||||||
(jolt-agent-state-set! a nv)
|
(jolt-agent-state-set! a nv)))
|
||||||
(iref-notify a old nv)))
|
|
||||||
(loop)))))
|
(loop)))))
|
||||||
|
|
||||||
;; send / send-off: enqueue the action, start the worker if idle. (jolt treats them
|
;; send / send-off: enqueue the action, start the worker if idle. (jolt treats them
|
||||||
|
|
@ -277,12 +260,6 @@
|
||||||
(jolt-promise-deref-timed x (car opts) (cadr opts))))
|
(jolt-promise-deref-timed x (car opts) (cadr opts))))
|
||||||
((jolt-agent? x) (jolt-agent-state x))
|
((jolt-agent? x) (jolt-agent-state x))
|
||||||
((jolt-delay? x) (jolt-delay-force 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)))))
|
(else (apply %pre-conc-deref x opts)))))
|
||||||
|
|
||||||
;; realized? for a future/promise/delay. Wrapped over the overlay version in
|
;; realized? for a future/promise/delay. Wrapped over the overlay version in
|
||||||
|
|
@ -301,16 +278,6 @@
|
||||||
(def-var! "clojure.core" "future-cancelled?" jolt-native-future-cancelled?)
|
(def-var! "clojure.core" "future-cancelled?" jolt-native-future-cancelled?)
|
||||||
(def-var! "clojure.core" "promise" jolt-promise-new)
|
(def-var! "clojure.core" "promise" jolt-promise-new)
|
||||||
(def-var! "clojure.core" "deliver" jolt-deliver)
|
(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-new)
|
||||||
(def-var! "clojure.core" "agent?" jolt-agent?)
|
(def-var! "clojure.core" "agent?" jolt-agent?)
|
||||||
(def-var! "clojure.core" "send" jolt-agent-send)
|
(def-var! "clojure.core" "send" jolt-agent-send)
|
||||||
|
|
@ -322,26 +289,6 @@
|
||||||
(def-var! "clojure.core" "delay?" jolt-delay?)
|
(def-var! "clojure.core" "delay?" jolt-delay?)
|
||||||
(def-var! "clojure.core" "deref" jolt-deref)
|
(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 -------------------------------------------
|
;; --- cooperative thread interrupt -------------------------------------------
|
||||||
;; Chez has no force-kill, but its engine timer (set-timer + timer-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
|
;; handler, thread-local) is polled at procedure-call / loop back-edges — so a
|
||||||
|
|
@ -424,188 +371,4 @@
|
||||||
(with-mutex (vector-ref st 1)
|
(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)))))
|
(let loop () (when (> (vector-ref st 0) 0) (condition-wait (vector-ref st 2) (vector-ref st 1)) (loop)))))
|
||||||
jolt-nil))
|
jolt-nil))
|
||||||
(cons "getCount" (lambda (self) (vector-ref (jhost-state self) 0)))))
|
(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)
|
|
||||||
|
|
@ -27,48 +27,17 @@
|
||||||
((and (flonum? v) (fl= v +inf.0)) "Infinity")
|
((and (flonum? v) (fl= v +inf.0)) "Infinity")
|
||||||
((and (flonum? v) (fl= v -inf.0)) "-Infinity")
|
((and (flonum? v) (fl= v -inf.0)) "-Infinity")
|
||||||
((and (flonum? v) (not (fl= v v))) "NaN")
|
((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
|
(else
|
||||||
(let loop ((rs str-render-registry))
|
(let loop ((rs str-render-registry))
|
||||||
(cond
|
(cond
|
||||||
((null? rs) (jolt-pr-str v))
|
((null? rs) (jolt-pr-str v))
|
||||||
(((caar rs) v) ((cdar rs) v))
|
(((caar rs) v) ((cdar rs) v))
|
||||||
(else (loop (cdr rs))))))))
|
(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)
|
(define (jolt-str . xs)
|
||||||
(cond
|
(let loop ((xs xs) (acc '()))
|
||||||
((null? xs) "")
|
(if (null? xs)
|
||||||
;; single arg returns its rendering directly (no string-append copy), so
|
(apply string-append (reverse acc))
|
||||||
;; (str sym) hands back the symbol's own name string — JVM (str x) is
|
(loop (cdr xs) (cons (jolt-str-render-one (car xs)) acc)))))
|
||||||
;; 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.
|
;; jolt indices are flonums; substring etc. need exact ints.
|
||||||
(define (jolt->idx n) (exact (truncate n)))
|
(define (jolt->idx n) (exact (truncate n)))
|
||||||
|
|
@ -117,31 +86,23 @@
|
||||||
(let ((a (car args)))
|
(let ((a (car args)))
|
||||||
(cond
|
(cond
|
||||||
((jolt-symbol? a) a)
|
((jolt-symbol? a) a)
|
||||||
;; (symbol "ns/name") splits the namespace at the FIRST "/" (JVM
|
;; (symbol "ns/name") splits the namespace at the LAST "/" (JVM
|
||||||
;; Symbol.intern), so (namespace (symbol "foo/bar/baz")) => "foo" with
|
;; Symbol.intern), so (namespace (symbol "foo/bar")) => "foo". A lone "/"
|
||||||
;; name "bar/baz". A lone "/" or a leading slash has no namespace. The
|
;; or a leading slash has no namespace. The no-ns sentinel is #f — matches
|
||||||
;; no-ns sentinel is #f — matches emit's quoted-symbol lowering
|
;; emit's quoted-symbol lowering (jolt-symbol #f "x"), so (= 'x (symbol
|
||||||
;; (jolt-symbol #f "x"), so (= 'x (symbol "x")) holds (jolt= compares
|
;; "x")) holds (jolt= compares ns with strict equal?).
|
||||||
;; ns with strict equal?).
|
|
||||||
((string? a)
|
((string? a)
|
||||||
(let ((slen (string-length a)))
|
(let ((slen (string-length a)))
|
||||||
(if (string=? a "/")
|
(if (string=? a "/")
|
||||||
(jolt-symbol #f "/")
|
(jolt-symbol #f "/")
|
||||||
(let loop ((i 1))
|
(let loop ((i (- slen 1)))
|
||||||
(cond ((>= i slen) (jolt-symbol #f a))
|
(cond ((<= i 0) (jolt-symbol #f a))
|
||||||
((char=? (string-ref a i) #\/)
|
((char=? (string-ref a i) #\/)
|
||||||
(jolt-symbol (substring a 0 i) (substring a (+ i 1) slen)))
|
(jolt-symbol (substring a 0 i) (substring a (+ i 1) slen)))
|
||||||
(else (loop (+ i 1))))))))
|
(else (loop (- i 1))))))))
|
||||||
((keyword? a) (jolt-symbol (keyword-t-ns a) (keyword-t-name a)))
|
((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)))))
|
(else (error #f "symbol: requires string/symbol" a)))))
|
||||||
;; (symbol ns name): a nil namespace is the no-ns sentinel #f (NOT jolt-nil),
|
((= (length args) 2) (jolt-symbol (car args) (cadr args)))
|
||||||
;; 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"))))
|
(else (error #f "symbol: wrong arity"))))
|
||||||
|
|
||||||
;; gensym: per-process counter.
|
;; gensym: per-process counter.
|
||||||
|
|
@ -156,12 +117,7 @@
|
||||||
;; int/long: truncate toward zero to an EXACT integer (= JVM long). char -> code
|
;; int/long: truncate toward zero to an EXACT integer (= JVM long). char -> code
|
||||||
;; point (exact). double: always a flonum (= JVM double).
|
;; point (exact). double: always a flonum (= JVM double).
|
||||||
(define (jolt-int x) (if (char? x) (char->integer x) (exact (truncate x))))
|
(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 x) (if (char? x) (exact->inexact (char->integer x)) (exact->inexact x)))
|
||||||
(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).
|
;; 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-cmp3 x y) (cond ((< x y) -1) ((> x y) 1) (else 0)))
|
||||||
|
|
@ -178,11 +134,7 @@
|
||||||
((jolt-nil? b) 1)
|
((jolt-nil? b) 1)
|
||||||
((and (number? a) (number? b)) (jolt-cmp3 a b))
|
((and (number? a) (number? b)) (jolt-cmp3 a b))
|
||||||
((and (string? a) (string? b)) (jolt-strcmp a b))
|
((and (string? a) (string? b)) (jolt-strcmp a b))
|
||||||
;; keywords order like symbols: a nil namespace sorts before any namespace,
|
((and (keyword? a) (keyword? b)) (jolt-strcmp (jolt-kw->string a) (jolt-kw->string b)))
|
||||||
;; 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))
|
((and (jolt-symbol? a) (jolt-symbol? b))
|
||||||
(let ((r (jolt-strcmp (jolt-sym-ns-string a) (jolt-sym-ns-string 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)))
|
(if (= r 0) (jolt-strcmp (symbol-t-name a) (symbol-t-name b)) r)))
|
||||||
|
|
@ -205,84 +157,16 @@
|
||||||
(def-var! "clojure.core" "keyword" jolt-keyword)
|
(def-var! "clojure.core" "keyword" jolt-keyword)
|
||||||
(def-var! "clojure.core" "symbol" jolt-symbol-new)
|
(def-var! "clojure.core" "symbol" jolt-symbol-new)
|
||||||
(def-var! "clojure.core" "gensym" jolt-gensym)
|
(def-var! "clojure.core" "gensym" jolt-gensym)
|
||||||
;; --- checked narrow casts (RT.byteCast/shortCast/intCast/longCast/charCast) --
|
(def-var! "clojure.core" "int" jolt-int)
|
||||||
;; One helper carries the JVM ranges: truncate toward zero, then range-check.
|
;; char: coerce a code point (jolt's all-flonum number) to a Chez char; pass a
|
||||||
;; NaN casts to 0 (Java (long)NaN); an out-of-range value (including a float
|
;; char through. Inverse of int on chars. The cross-compiled emitter's
|
||||||
;; infinity) is IllegalArgumentException "Value out of range for <type>: x".
|
;; chez-str-lit needs it for printable-ASCII escaping.
|
||||||
;; A non-numeric operand is the usual ClassCastException. Numeric types outside
|
(define (jolt-char x) (if (char? x) x (integer->char (exact (round x)))))
|
||||||
;; 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)
|
(def-var! "clojure.core" "char" jolt-char)
|
||||||
;; unchecked-long: truncate + wrap to 64 bits (RT.uncheckedLongCast — a float
|
;; long: same truncation as int in jolt's all-flonum model (seed core-long =
|
||||||
;; infinity saturates, NaN is 0). unchecked-int wraps and sign-folds to 32.
|
;; math/trunc; char -> code point). Distinct cell so (long ...) resolves.
|
||||||
(define (jolt-cast-saturate n lo hi) (cond ((< n lo) lo) ((> n hi) hi) (else n)))
|
(def-var! "clojure.core" "long" jolt-int)
|
||||||
(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)
|
(def-var! "clojure.core" "double" jolt-double)
|
||||||
;; float: Chez has no single-float type, so the value stays a flonum — but the
|
;; float: Chez has no single-float type, so float coerces to a flonum like double.
|
||||||
;; cast range-checks against Float/MAX_VALUE like RT.floatCast (an infinity is
|
(def-var! "clojure.core" "float" jolt-double)
|
||||||
;; 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)
|
(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
|
|
||||||
|
|
@ -90,10 +90,7 @@
|
||||||
;; str re-serializes the read form (compiled identically; comments/whitespace are
|
;; str re-serializes the read form (compiled identically; comments/whitespace are
|
||||||
;; irrelevant).
|
;; irrelevant).
|
||||||
(define (dce-blob-records path)
|
(define (dce-blob-records path)
|
||||||
;; bld-source-string (build.ss) reads the embedded copy when running from a
|
(call-with-input-file path
|
||||||
;; 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)
|
(lambda (p)
|
||||||
(let loop ((acc '()))
|
(let loop ((acc '()))
|
||||||
(let ((form (read p)))
|
(let ((form (read p)))
|
||||||
|
|
|
||||||
|
|
@ -17,6 +17,8 @@
|
||||||
;; A record (jrec) is jolt-map? here (records.ss makes it so) and a collection,
|
;; 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.
|
;; so its protocol method (no dash, not a coll method) lands in the base.
|
||||||
|
|
||||||
|
(define %dot-rmd record-method-dispatch)
|
||||||
|
|
||||||
;; Vectors / maps / sets only (records are jolt-map? here). Raw seqs are excluded:
|
;; Vectors / maps / sets only (records are jolt-map? here). Raw seqs are excluded:
|
||||||
;; coll-interop accepts some seq representations and not others (a
|
;; coll-interop accepts some seq representations and not others (a
|
||||||
;; plain (seq v) returns nil from .count, a lazy-seq returns the count), an
|
;; plain (seq v) returns nil from .count, a lazy-seq returns the count), an
|
||||||
|
|
@ -36,17 +38,6 @@
|
||||||
((or (string=? name "get") (string=? name "valAt"))
|
((or (string=? name "get") (string=? name "valAt"))
|
||||||
(list (apply jolt-get obj args)))
|
(list (apply jolt-get obj args)))
|
||||||
((string=? name "containsKey") (list (jolt-contains? obj (car 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 "size") (list (jolt-count obj)))
|
||||||
((string=? name "isEmpty") (list (jolt-empty? obj)))
|
((string=? name "isEmpty") (list (jolt-empty? obj)))
|
||||||
;; java.util.Map views: keySet (a Set), values (a Collection), entrySet.
|
;; java.util.Map views: keySet (a Set), values (a Collection), entrySet.
|
||||||
|
|
@ -60,12 +51,6 @@
|
||||||
;; branch and is mis-read as a missing :iterator key (nil). Some libraries
|
;; branch and is mis-read as a missing :iterator key (nil). Some libraries
|
||||||
;; (e.g. malli's -vmap) iterate a map this way.
|
;; (e.g. malli's -vmap) iterate a map this way.
|
||||||
((string=? name "iterator") (list (make-jiterator (jolt-seq obj))))
|
((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)))
|
(else #f)))
|
||||||
|
|
||||||
;; Universal object-methods: on a
|
;; Universal object-methods: on a
|
||||||
|
|
@ -88,7 +73,7 @@
|
||||||
((string=? name "equals") (list (if (jolt= obj (car args)) #t #f)))
|
((string=? name "equals") (list (if (jolt= obj (car args)) #t #f)))
|
||||||
(else #f)))
|
(else #f)))
|
||||||
|
|
||||||
(register-method-arm! 30
|
(set! record-method-dispatch
|
||||||
(lambda (obj method-name rest-args)
|
(lambda (obj method-name rest-args)
|
||||||
(let* ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args)))
|
(let* ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args)))
|
||||||
(field? (and (> (string-length method-name) 0)
|
(field? (and (> (string-length method-name) 0)
|
||||||
|
|
@ -97,45 +82,12 @@
|
||||||
(substring method-name 1 (string-length method-name))
|
(substring method-name 1 (string-length method-name))
|
||||||
method-name)))
|
method-name)))
|
||||||
(cond
|
(cond
|
||||||
;; clojure.lang.MultiFn .dispatchFn / .getMethod — clojure.spec.alpha's
|
;; (.getClass x) universal — the class token for any value, before the
|
||||||
;; multi-spec walks a multimethod through these.
|
;; collection/map field-lookup arms below would read it as a missing key.
|
||||||
((jolt-multifn? obj)
|
((string=? method-name "getClass") (jolt-class 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).
|
;; collection interop first (entry count / seq / nth / get / containsKey).
|
||||||
((and (dot-coll? obj) (dot-coll-method obj mname rest))
|
((and (dot-coll? obj) (dot-coll-method obj mname rest))
|
||||||
=> (lambda (box) (car box)))
|
=> (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 obj) / (. obj -field): field read on a record or map.
|
||||||
(field? (jolt-get obj (keyword #f mname) jolt-nil))
|
(field? (jolt-get obj (keyword #f mname) jolt-nil))
|
||||||
;; non-record map: a universal object-method (getMessage/...) wins first,
|
;; non-record map: a universal object-method (getMessage/...) wins first,
|
||||||
|
|
@ -146,4 +98,4 @@
|
||||||
(else
|
(else
|
||||||
(let ((v (jolt-get obj (keyword #f mname) jolt-nil)))
|
(let ((v (jolt-get obj (keyword #f mname) jolt-nil)))
|
||||||
(if (procedure? v) (apply jolt-invoke v obj rest) v)))))
|
(if (procedure? v) (apply jolt-invoke v obj rest) v)))))
|
||||||
(else 'pass)))))
|
(else (%dot-rmd obj method-name rest-args))))))
|
||||||
|
|
@ -77,23 +77,14 @@
|
||||||
(let ((p (dyn-find-binding v)))
|
(let ((p (dyn-find-binding v)))
|
||||||
(if p
|
(if p
|
||||||
(begin (set-cdr! p val) val)
|
(begin (set-cdr! p val) val)
|
||||||
;; a ROOT change is Var.bindRoot: validate, set, notify watches
|
(begin (var-cell-root-set! v val) (var-cell-defined?-set! v #t) val)))
|
||||||
;; (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)))
|
(error #f "var-set: not a var" v)))
|
||||||
|
|
||||||
;; alter-var-root: atomically apply f to the current root plus args.
|
;; alter-var-root: atomically apply f to the current root plus args.
|
||||||
(define (jolt-alter-var-root v f . args)
|
(define (jolt-alter-var-root v f . args)
|
||||||
(let* ((old (var-cell-root v))
|
(let ((new (apply jolt-invoke f (var-cell-root v) args)))
|
||||||
(new (apply jolt-invoke f old args)))
|
|
||||||
(iref-validate v new)
|
|
||||||
(var-cell-root-set! v new)
|
(var-cell-root-set! v new)
|
||||||
(var-cell-defined?-set! v #t)
|
(var-cell-defined?-set! v #t)
|
||||||
(iref-notify v old new)
|
|
||||||
new))
|
new))
|
||||||
|
|
||||||
;; __local-var: a fresh free-standing var cell (not interned). with-local-vars
|
;; __local-var: a fresh free-standing var cell (not interned). with-local-vars
|
||||||
|
|
@ -126,16 +117,6 @@
|
||||||
((eq? cell star-ns-cell) (intern-ns! (chez-current-ns)))
|
((eq? cell star-ns-cell) (intern-ns! (chez-current-ns)))
|
||||||
(else (var-cell-root cell)))))))
|
(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
|
;; 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).
|
;; the original (which errors on an unbound root, matching Clojure).
|
||||||
(define %dyn-var-get jolt-var-get)
|
(define %dyn-var-get jolt-var-get)
|
||||||
|
|
|
||||||
|
|
@ -28,43 +28,3 @@
|
||||||
|
|
||||||
;; *print-meta* — when true, pr prints metadata with a ^ prefix; default false.
|
;; *print-meta* — when true, pr prints metadata with a ^ prefix; default false.
|
||||||
(def-var! "clojure.core" "*print-meta*" #f)
|
(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)
|
|
||||||
|
|
|
||||||
|
|
@ -41,15 +41,6 @@
|
||||||
;; top-level entry: in direct-link mode it binds jv$<fqn> for a top-level def; off
|
;; 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.
|
;; 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"))
|
(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?)
|
(define (ei-compile-form ctx f optimize?)
|
||||||
(let ((ir (jolt-ce-analyze ctx f)))
|
(let ((ir (jolt-ce-analyze ctx f)))
|
||||||
(jolt-ce-emit-top (if optimize? (jolt-ce-run-passes ir ctx) ir))))
|
(jolt-ce-emit-top (if optimize? (jolt-ce-run-passes ir ctx) ir))))
|
||||||
|
|
@ -67,23 +58,15 @@
|
||||||
;; the seed minter (ei-emit-ns: optimize? #f, guard? #t — tolerant, skips a form
|
;; 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 —
|
;; that fails to emit) and `jolt build` (bld-emit-ns: optimize? #t, guard? #f —
|
||||||
;; strict, a failing form errors the build).
|
;; 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?)
|
(define (ei-emit-ns* ns-name src optimize? guard?)
|
||||||
;; set the ns before reading so ::kw auto-resolves against this ns (the runtime
|
;; 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
|
;; loader reads form-by-form after the ns form sets it; the cross-compile reads
|
||||||
;; all forms up front, so set it here).
|
;; all forms up front, so set it here).
|
||||||
(set-chez-ns! ns-name)
|
(set-chez-ns! ns-name)
|
||||||
(let ((hook (ei-emit-form-hook)))
|
(let loop ((forms (ei-read-all src)) (acc '()))
|
||||||
(let loop ((forms (ei-read-all src)) (acc '()))
|
|
||||||
(if (null? forms)
|
(if (null? forms)
|
||||||
(reverse acc)
|
(reverse acc)
|
||||||
(let ((f (let ((f0 (car forms))) (if hook (hook f0) f0))))
|
(let ((f (car forms)))
|
||||||
(ce-scan-requires! f ns-name)
|
(ce-scan-requires! f ns-name)
|
||||||
(cond
|
(cond
|
||||||
((ei-ns-form? f) (loop (cdr forms) acc))
|
((ei-ns-form? f) (loop (cdr forms) acc))
|
||||||
|
|
@ -101,7 +84,7 @@
|
||||||
(ei-compile-form (make-analyze-ctx ns-name) f optimize?))))
|
(ei-compile-form (make-analyze-ctx ns-name) f optimize?))))
|
||||||
(loop (cdr forms)
|
(loop (cdr forms)
|
||||||
(if (and guard? (not scm)) acc
|
(if (and guard? (not scm)) acc
|
||||||
(cons (if guard? (string-append "(guard (e (#t #f))\n " scm ")") scm) acc)))))))))))
|
(cons (if guard? (string-append "(guard (e (#t #f))\n " scm ")") scm) acc))))))))))
|
||||||
|
|
||||||
(define (ei-emit-ns ns-name src) (ei-emit-ns* ns-name src #f #t))
|
(define (ei-emit-ns ns-name src) (ei-emit-ns* ns-name src #f #t))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -35,56 +35,15 @@
|
||||||
((jolt-atom? x) "clojure.lang.Atom")
|
((jolt-atom? x) "clojure.lang.Atom")
|
||||||
((char? x) "java.lang.Character")
|
((char? x) "java.lang.Character")
|
||||||
((regex-t? x) "java.util.regex.Pattern")
|
((regex-t? x) "java.util.regex.Pattern")
|
||||||
;; an anonymous / unregistered fn — like the JVM, where (class #(..)) is a
|
((procedure? x) "clojure.lang.IFn")
|
||||||
;; 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
|
;; an exception value (ex-info / host-constructed throwable) reports its JVM
|
||||||
;; class, so (= clojure.lang.ExceptionInfo (class e)) and clojure.test's
|
;; class, so (= clojure.lang.ExceptionInfo (class e)) and clojure.test's
|
||||||
;; (thrown? Class …) match (records.ss ex-info-map?/ex-info-class).
|
;; (thrown? Class …) match (records.ss ex-info-map?/ex-info-class).
|
||||||
((ex-info-map? x) (ex-info-class x))
|
((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)))))
|
(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
|
;; 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
|
;; value (make-class-obj, host-static-classes.ss) so it renders like a JVM Class
|
||||||
;; while staying = its name string.
|
;; 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)
|
(define (jolt-class-name x)
|
||||||
(let loop ((as jolt-class-arms))
|
(let loop ((as jolt-class-arms))
|
||||||
(cond ((null? as) (jolt-class-base x))
|
(cond ((null? as) (jolt-class-base x))
|
||||||
|
|
@ -96,25 +55,11 @@
|
||||||
|
|
||||||
(def-var! "clojure.core" "class" jolt-class)
|
(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.
|
;; bare class-name tokens -> canonical JVM class-name strings.
|
||||||
(define class-token-alist
|
(define class-token-alist
|
||||||
'(("String" . "java.lang.String") ("Number" . "java.lang.Number")
|
'(("String" . "java.lang.String") ("Number" . "java.lang.Number")
|
||||||
("Boolean" . "java.lang.Boolean") ("Long" . "java.lang.Long")
|
("Boolean" . "java.lang.Boolean") ("Long" . "java.lang.Long")
|
||||||
("Integer" . "java.lang.Integer") ("Double" . "java.lang.Double")
|
("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")
|
("Object" . "java.lang.Object") ("Character" . "java.lang.Character")
|
||||||
("InputStream" . "java.io.InputStream") ("OutputStream" . "java.io.OutputStream")
|
("InputStream" . "java.io.InputStream") ("OutputStream" . "java.io.OutputStream")
|
||||||
("File" . "java.io.File") ("Reader" . "java.io.Reader") ("Writer" . "java.io.Writer")
|
("File" . "java.io.File") ("Reader" . "java.io.Reader") ("Writer" . "java.io.Writer")
|
||||||
|
|
@ -126,7 +71,6 @@
|
||||||
("Charset" . "java.nio.charset.Charset") ("Base64" . "java.util.Base64")
|
("Charset" . "java.nio.charset.Charset") ("Base64" . "java.util.Base64")
|
||||||
("Exception" . "java.lang.Exception")
|
("Exception" . "java.lang.Exception")
|
||||||
("IllegalArgumentException" . "java.lang.IllegalArgumentException")
|
("IllegalArgumentException" . "java.lang.IllegalArgumentException")
|
||||||
("ArityException" . "clojure.lang.ArityException")
|
|
||||||
("IllegalStateException" . "java.lang.IllegalStateException")
|
("IllegalStateException" . "java.lang.IllegalStateException")
|
||||||
("RuntimeException" . "java.lang.RuntimeException")
|
("RuntimeException" . "java.lang.RuntimeException")
|
||||||
("UnsupportedOperationException" . "java.lang.UnsupportedOperationException")
|
("UnsupportedOperationException" . "java.lang.UnsupportedOperationException")
|
||||||
|
|
@ -149,20 +93,7 @@
|
||||||
("IndexOutOfBoundsException" . "java.lang.IndexOutOfBoundsException")
|
("IndexOutOfBoundsException" . "java.lang.IndexOutOfBoundsException")
|
||||||
("UnsupportedEncodingException" . "java.io.UnsupportedEncodingException")
|
("UnsupportedEncodingException" . "java.io.UnsupportedEncodingException")
|
||||||
("FileNotFoundException" . "java.io.FileNotFoundException")
|
("FileNotFoundException" . "java.io.FileNotFoundException")
|
||||||
("Throwable" . "java.lang.Throwable")
|
("Throwable" . "java.lang.Throwable")))
|
||||||
;; clojure.lang / java.util types that class-based multimethods dispatch on.
|
|
||||||
("Fn" . "clojure.lang.Fn") ("IFn" . "clojure.lang.IFn")
|
|
||||||
("Namespace" . "clojure.lang.Namespace") ("Named" . "clojure.lang.Named")
|
|
||||||
("Set" . "java.util.Set") ("List" . "java.util.List") ("Map" . "java.util.Map")
|
|
||||||
("Collection" . "java.util.Collection") ("Iterable" . "java.lang.Iterable")
|
|
||||||
("CharSequence" . "java.lang.CharSequence") ("Comparable" . "java.lang.Comparable")
|
|
||||||
("Runnable" . "java.lang.Runnable") ("Callable" . "java.util.concurrent.Callable")
|
|
||||||
("IPersistentSet" . "clojure.lang.IPersistentSet")
|
|
||||||
("IPersistentVector" . "clojure.lang.IPersistentVector")
|
|
||||||
("IPersistentMap" . "clojure.lang.IPersistentMap")
|
|
||||||
("IPersistentCollection" . "clojure.lang.IPersistentCollection")
|
|
||||||
("Sequential" . "clojure.lang.Sequential") ("Seqable" . "clojure.lang.Seqable")
|
|
||||||
("Associative" . "clojure.lang.Associative")))
|
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (pair) (def-var! "clojure.core" (car pair) (cdr pair)))
|
(lambda (pair) (def-var! "clojure.core" (car pair) (cdr pair)))
|
||||||
class-token-alist)
|
class-token-alist)
|
||||||
|
|
@ -184,7 +115,6 @@
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (nm) (def-var! "clojure.core" nm nm))
|
(lambda (nm) (def-var! "clojure.core" nm nm))
|
||||||
'("java.lang.Long" "java.lang.Integer" "java.lang.Double" "java.lang.Float"
|
'("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.Number" "java.lang.String" "java.lang.Boolean" "java.lang.Character"
|
||||||
"java.lang.Object"
|
"java.lang.Object"
|
||||||
;; exception classes compared against (class e): (= java.net.SocketTimeoutException (class e))
|
;; exception classes compared against (class e): (= java.net.SocketTimeoutException (class e))
|
||||||
|
|
@ -199,7 +129,7 @@
|
||||||
"java.lang.IndexOutOfBoundsException" "java.io.FileNotFoundException"
|
"java.lang.IndexOutOfBoundsException" "java.io.FileNotFoundException"
|
||||||
"java.io.UnsupportedEncodingException"
|
"java.io.UnsupportedEncodingException"
|
||||||
;; clojure.lang.ExceptionInfo / IExceptionInfo compared against (class e)
|
;; clojure.lang.ExceptionInfo / IExceptionInfo compared against (class e)
|
||||||
"clojure.lang.ExceptionInfo" "clojure.lang.IExceptionInfo" "clojure.lang.ArityException"
|
"clojure.lang.ExceptionInfo" "clojure.lang.IExceptionInfo"
|
||||||
"java.util.regex.Pattern" "java.net.URI" "java.util.UUID"
|
"java.util.regex.Pattern" "java.net.URI" "java.util.UUID"
|
||||||
"clojure.lang.PersistentQueue"
|
"clojure.lang.PersistentQueue"
|
||||||
"clojure.lang.Keyword" "clojure.lang.Symbol" "clojure.lang.Ratio" "clojure.lang.Atom"))
|
"clojure.lang.Keyword" "clojure.lang.Symbol" "clojure.lang.Ratio" "clojure.lang.Atom"))
|
||||||
|
|
@ -46,9 +46,7 @@
|
||||||
;; ANY non-empty seq is a list form for analysis (a macro/eval form built via
|
;; 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
|
;; concat/map/cons is a lazy cseq with list?=#f, but evaluating it still means
|
||||||
;; calling its head) — not just reader-built lists.
|
;; 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
|
(define (hc-list? x) (or (empty-list-t? x) (cseq? x)))
|
||||||
;; (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-vec? x) (pvec? x))
|
||||||
(define (hc-map? x) (and (pmap? x) (jolt-nil? (jolt-get x hc-kw-jolt-type))))
|
(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
|
;; A set form is the reader's tagged map {:jolt/type :jolt/set :value <pvec>} OR a
|
||||||
|
|
@ -76,17 +74,6 @@
|
||||||
;; reconstruct it by name at the call site.
|
;; reconstruct it by name at the call site.
|
||||||
(define (hc-ns-value? x) (jns? x))
|
(define (hc-ns-value? x) (jns? x))
|
||||||
(define (hc-ns-value-name x) (jns-name 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 ---------------------------------------------------------
|
;; --- form accessors ---------------------------------------------------------
|
||||||
(define (hc-char-code x) (char->integer x)) ; native Chez char -> codepoint
|
(define (hc-char-code x) (char->integer x)) ; native Chez char -> codepoint
|
||||||
|
|
@ -108,7 +95,7 @@
|
||||||
;; list items -> jolt vector (pvec); the analyzer mapv's over the result.
|
;; list items -> jolt vector (pvec); the analyzer mapv's over the result.
|
||||||
(define (hc-elements x)
|
(define (hc-elements x)
|
||||||
(cond ((empty-list-t? x) empty-pvec)
|
(cond ((empty-list-t? x) empty-pvec)
|
||||||
((or (cseq? x) (jolt-lazyseq? x)) (make-pvec (list->vector (seq->list x))))
|
((cseq? x) (make-pvec (list->vector (seq->list x))))
|
||||||
(else empty-pvec)))
|
(else empty-pvec)))
|
||||||
(define (hc-vec-items x) x) ; already a pvec
|
(define (hc-vec-items x) x) ; already a pvec
|
||||||
(define (hc-set-items x)
|
(define (hc-set-items x)
|
||||||
|
|
@ -132,22 +119,8 @@
|
||||||
(define (hc-inst-source x) (jolt-get x hc-kw-form))
|
(define (hc-inst-source x) (jolt-get x hc-kw-form))
|
||||||
(define (hc-uuid-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
|
;; The Chez reader does not record source offsets yet.
|
||||||
;; compiling a file) into the form's metadata. Return a clean {:line :column
|
(define (hc-form-position x) jolt-nil)
|
||||||
;; :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 ----------------------------------------------------------
|
;; --- special forms ----------------------------------------------------------
|
||||||
;; Mirrors host_iface special-names + interop-head? — forms the analyzer marks
|
;; Mirrors host_iface special-names + interop-head? — forms the analyzer marks
|
||||||
|
|
@ -184,12 +157,7 @@
|
||||||
;; a qualified ns may be a require :as alias (s/split -> clojure.string/split)
|
;; 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)))
|
(let ((target (or (chez-resolve-alias (chez-actx-cns ctx) qualified) qualified)))
|
||||||
(var-cell-lookup target nm))
|
(var-cell-lookup target nm))
|
||||||
(or (let ((c (var-cell-lookup (chez-actx-cns ctx) nm)))
|
(or (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
|
;; a :refer'd name resolves to its source ns
|
||||||
(let ((ref (chez-resolve-refer (chez-actx-cns ctx) nm)))
|
(let ((ref (chez-resolve-refer (chez-actx-cns ctx) nm)))
|
||||||
(and ref (var-cell-lookup ref nm)))
|
(and ref (var-cell-lookup ref nm)))
|
||||||
|
|
@ -202,54 +170,12 @@
|
||||||
;; of the list), and the analyzer re-analyzes the returned form.
|
;; of the list), and the analyzer re-analyzes the returned form.
|
||||||
(define (hc-macro? ctx sym)
|
(define (hc-macro? ctx sym)
|
||||||
(macro-var? (hc-resolve-cell ctx sym)))
|
(macro-var? (hc-resolve-cell ctx sym)))
|
||||||
;; Clojure parity: a macro expansion inherits the call form's source position, so
|
(define (hc-expand-1 ctx form)
|
||||||
;; 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))
|
(let* ((items (seq->list form))
|
||||||
(head (car items))
|
(head (car items))
|
||||||
(args (map hc-macro-arg (cdr items)))
|
(args (cdr items))
|
||||||
(expander (var-cell-root (hc-resolve-cell ctx head)))
|
(expander (var-cell-root (hc-resolve-cell ctx head))))
|
||||||
(amp-env (if (pair? maybe-env) (car maybe-env) (jolt-hash-map))))
|
(apply jolt-invoke expander args)))
|
||||||
(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:
|
;; 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 :var :ns NS :name NAME} — a defined var (compile ns / clojure.core)
|
||||||
|
|
@ -327,15 +253,10 @@
|
||||||
;; Any seq counts, not just a proper list: a macro that builds the template with
|
;; 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
|
;; map/for (e.g. deftype's rewrite-set) yields a LAZY seq, and its ~unquotes must
|
||||||
;; still be recognized.
|
;; 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)
|
(define (hc-head-is? x nm)
|
||||||
(and (cseq? x)
|
(and (cseq? x)
|
||||||
(let ((h (seq-first x)))
|
(let ((h (seq-first x)))
|
||||||
(and (symbol-t? h) (string=? (symbol-t-name h) nm)
|
(and (symbol-t? h) (jolt-nil? (hc-sym-ns 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-second x) (seq-first (jolt-seq (seq-more x))))
|
||||||
|
|
||||||
(define (hc-sq-symbol ctx form gsmap)
|
(define (hc-sq-symbol ctx form gsmap)
|
||||||
|
|
@ -354,16 +275,6 @@
|
||||||
;; a class token, not a var to namespace-qualify — leave it bare, as
|
;; a class token, not a var to namespace-qualify — leave it bare, as
|
||||||
;; Clojure's syntax-quote resolves it to the class.
|
;; Clojure's syntax-quote resolves it to the class.
|
||||||
((hc-fq-class-name? nm) form)
|
((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))
|
((var-cell-lookup "clojure.core" nm) (jolt-symbol "clojure.core" nm))
|
||||||
;; a name referred into the compile ns (:require :refer / :use :only)
|
;; a name referred into the compile ns (:require :refer / :use :only)
|
||||||
;; qualifies to its SOURCE ns, not the compile ns — so a macro that
|
;; qualifies to its SOURCE ns, not the compile ns — so a macro that
|
||||||
|
|
@ -417,36 +328,9 @@
|
||||||
|
|
||||||
(define (hc-syntax-quote-lower ctx inner)
|
(define (hc-syntax-quote-lower ctx inner)
|
||||||
(hc-sq-lower ctx inner (make-hashtable string-hash string=?)))
|
(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
|
(define (hc-record-type? ctx name) #f)
|
||||||
;; against the record registry (records.ss) so the inference seeds the param as
|
(define (hc-record-ctor-key ctx name) jolt-nil)
|
||||||
;; that record — the open-world / cross-ns path where no caller type is inferred.
|
(define (hc-record-shapes ctx) (jolt-hash-map))
|
||||||
(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
|
;; Optimization gate. Off for ordinary runs (open world, redefinition); `jolt
|
||||||
;; build` flips it on during app emission for release/optimized modes (closed
|
;; build` flips it on during app emission for release/optimized modes (closed
|
||||||
;; world), turning on the inference + flatten + scalar-replace passes.
|
;; world), turning on the inference + flatten + scalar-replace passes.
|
||||||
|
|
@ -494,10 +378,6 @@
|
||||||
(def-var! "jolt.host" "form-uuid?" hc-uuid?)
|
(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?" hc-ns-value?)
|
||||||
(def-var! "jolt.host" "form-ns-value-name" hc-ns-value-name)
|
(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?" hc-bigdec?)
|
||||||
(def-var! "jolt.host" "form-bigdec-source" hc-bigdec-source)
|
(def-var! "jolt.host" "form-bigdec-source" hc-bigdec-source)
|
||||||
(def-var! "jolt.host" "form-elements" hc-elements)
|
(def-var! "jolt.host" "form-elements" hc-elements)
|
||||||
|
|
@ -518,9 +398,7 @@
|
||||||
(def-var! "jolt.host" "form-syntax-quote-lower" hc-syntax-quote-lower)
|
(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-type?" hc-record-type?)
|
||||||
(def-var! "jolt.host" "record-ctor-key" hc-record-ctor-key)
|
(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" "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-enabled?" hc-inline-enabled?)
|
||||||
(def-var! "jolt.host" "inline-ir" hc-inline-ir)
|
(def-var! "jolt.host" "inline-ir" hc-inline-ir)
|
||||||
(def-var! "jolt.host" "stash-inline!" hc-stash-inline!))
|
(def-var! "jolt.host" "stash-inline!" hc-stash-inline!))
|
||||||
|
|
|
||||||
|
|
@ -50,7 +50,7 @@
|
||||||
(cond ((null? args) (make-arraylist '()))
|
(cond ((null? args) (make-arraylist '()))
|
||||||
((number? (car args)) (make-arraylist '()))
|
((number? (car args)) (make-arraylist '()))
|
||||||
(else (make-arraylist (seq->list (jolt-seq (car args))))))))
|
(else (make-arraylist (seq->list (jolt-seq (car args))))))))
|
||||||
(define arraylist-methods
|
(register-host-methods! "arraylist"
|
||||||
(list
|
(list
|
||||||
(cons "add" (lambda (self . a)
|
(cons "add" (lambda (self . a)
|
||||||
;; (.add x) -> append+true; (.add i x) -> insert at i, returns nil.
|
;; (.add x) -> append+true; (.add i x) -> insert at i, returns nil.
|
||||||
|
|
@ -58,14 +58,6 @@
|
||||||
(begin (al-push! self (car a)) #t)
|
(begin (al-push! self (car a)) #t)
|
||||||
(begin (al-insert-at! self (jnum->exact (car a)) (cadr a)) jolt-nil))))
|
(begin (al-insert-at! self (jnum->exact (car a)) (cadr a)) jolt-nil))))
|
||||||
(cons "add!" (lambda (self x) (al-push! self x) #t))
|
(cons "add!" (lambda (self x) (al-push! self x) #t))
|
||||||
(cons "addAll" (lambda (self . a)
|
|
||||||
;; (.addAll coll) appends; (.addAll i coll) inserts at i.
|
|
||||||
(let* ((at-i (= 2 (length a)))
|
|
||||||
(i (if at-i (jnum->exact (car a)) (al-cnt self)))
|
|
||||||
(coll (if at-i (cadr a) (car a))))
|
|
||||||
(let loop ((xs (seq->list (jolt-seq coll))) (k i))
|
|
||||||
(if (null? xs) (pair? (seq->list (jolt-seq coll)))
|
|
||||||
(begin (al-insert-at! self k (car xs)) (loop (cdr xs) (fx+ k 1))))))))
|
|
||||||
(cons "get" (lambda (self i) (vector-ref (al-vec self) (jnum->exact i))))
|
(cons "get" (lambda (self i) (vector-ref (al-vec self) (jnum->exact i))))
|
||||||
(cons "set" (lambda (self i x)
|
(cons "set" (lambda (self i x)
|
||||||
(let* ((idx (jnum->exact i)) (old (vector-ref (al-vec self) idx)))
|
(let* ((idx (jnum->exact i)) (old (vector-ref (al-vec self) idx)))
|
||||||
|
|
@ -80,43 +72,6 @@
|
||||||
(cons "toArray" (lambda (self . _) (apply jolt-vector (al->list self))))
|
(cons "toArray" (lambda (self . _) (apply jolt-vector (al->list self))))
|
||||||
(cons "iterator" (lambda (self) (make-jiterator (list->cseq (al->list self)))))
|
(cons "iterator" (lambda (self) (make-jiterator (list->cseq (al->list self)))))
|
||||||
(cons "toString" (lambda (self) (jolt-pr-str (list->cseq (al->list self)))))))
|
(cons "toString" (lambda (self) (jolt-pr-str (list->cseq (al->list self)))))))
|
||||||
(register-host-methods! "arraylist" arraylist-methods)
|
|
||||||
|
|
||||||
;; java.util.LinkedList: the ArrayList backing plus the Deque surface
|
|
||||||
;; (addFirst/addLast/removeFirst/removeLast/getFirst/getLast/peek/push/pop).
|
|
||||||
;; tools.reader holds pending splice forms in one and (seq)s / .remove(0)s it.
|
|
||||||
(define (al-first self) (vector-ref (al-vec self) 0))
|
|
||||||
(define (al-last self) (vector-ref (al-vec self) (fx- (al-cnt self) 1)))
|
|
||||||
(define linkedlist-methods
|
|
||||||
(append arraylist-methods
|
|
||||||
(list
|
|
||||||
(cons "addFirst" (lambda (self x) (al-insert-at! self 0 x) jolt-nil))
|
|
||||||
(cons "addLast" (lambda (self x) (al-push! self x) jolt-nil))
|
|
||||||
(cons "offer" (lambda (self x) (al-push! self x) #t))
|
|
||||||
(cons "removeFirst" (lambda (self) (let ((o (al-first self))) (al-remove-at! self 0) o)))
|
|
||||||
(cons "removeLast" (lambda (self) (let ((o (al-last self))) (al-remove-at! self (fx- (al-cnt self) 1)) o)))
|
|
||||||
(cons "getFirst" al-first) (cons "getLast" al-last)
|
|
||||||
(cons "peek" (lambda (self) (if (fx=? 0 (al-cnt self)) jolt-nil (al-first self))))
|
|
||||||
(cons "poll" (lambda (self) (if (fx=? 0 (al-cnt self)) jolt-nil (let ((o (al-first self))) (al-remove-at! self 0) o))))
|
|
||||||
(cons "push" (lambda (self x) (al-insert-at! self 0 x) jolt-nil))
|
|
||||||
(cons "pop" (lambda (self) (let ((o (al-first self))) (al-remove-at! self 0) o))))))
|
|
||||||
(define (make-linkedlist xs)
|
|
||||||
(let ((al (make-arraylist xs))) (make-jhost "linkedlist" (jhost-state al))))
|
|
||||||
(register-host-methods! "linkedlist" linkedlist-methods)
|
|
||||||
(let ((ctor (lambda args
|
|
||||||
(cond ((null? args) (make-linkedlist '()))
|
|
||||||
(else (make-linkedlist (seq->list (jolt-seq (car args)))))))))
|
|
||||||
(register-class-ctor! "LinkedList" ctor)
|
|
||||||
(register-class-ctor! "java.util.LinkedList" ctor))
|
|
||||||
|
|
||||||
;; ArrayList / LinkedList are Iterable: (seq al) walks the elements (nil if empty),
|
|
||||||
;; so (seq pending-forms) and reduce/into over one work like the JVM.
|
|
||||||
(define %al-seq jolt-seq)
|
|
||||||
(set! jolt-seq
|
|
||||||
(lambda (x)
|
|
||||||
(if (and (jhost? x) (or (string=? (jhost-tag x) "arraylist") (string=? (jhost-tag x) "linkedlist")))
|
|
||||||
(list->cseq (al->list x))
|
|
||||||
(%al-seq x))))
|
|
||||||
|
|
||||||
;; Appendable.append text: append(x) renders x; append(csq,start,end) appends the
|
;; Appendable.append text: append(x) renders x; append(csq,start,end) appends the
|
||||||
;; subsequence csq[start,end) (data.json's writer appends string runs this way).
|
;; subsequence csq[start,end) (data.json's writer appends string runs this way).
|
||||||
|
|
@ -154,9 +109,6 @@
|
||||||
(cons "flush" (lambda (self) jolt-nil))
|
(cons "flush" (lambda (self) jolt-nil))
|
||||||
(cons "close" (lambda (self) jolt-nil))
|
(cons "close" (lambda (self) jolt-nil))
|
||||||
(cons "toString" (lambda (self) (sb-str self)))))
|
(cons "toString" (lambda (self) (sb-str self)))))
|
||||||
;; (str sw) / print a StringWriter -> its accumulated content, like the JVM
|
|
||||||
;; (str calls toString) — data.csv writes CSV to a StringWriter and reads it back.
|
|
||||||
(register-str-render! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "writer"))) sb-str)
|
|
||||||
|
|
||||||
;; a file-backed writer (clojure.java.io/writer of a File/path): accumulates like
|
;; a file-backed writer (clojure.java.io/writer of a File/path): accumulates like
|
||||||
;; StringWriter, then persists to the path on flush/close, so
|
;; StringWriter, then persists to the path on flush/close, so
|
||||||
|
|
@ -176,26 +128,14 @@
|
||||||
;; push to the port (so (.write *out* s) and (binding [*out* *err*] …) work);
|
;; push to the port (so (.write *out* s) and (binding [*out* *err*] …) work);
|
||||||
;; it isn't a buffer, so toString is empty. Lets libraries that touch *out*/*err*
|
;; it isn't a buffer, so toString is empty. Lets libraries that touch *out*/*err*
|
||||||
;; (tools.logging, selmer) compile and run.
|
;; (tools.logging, selmer) compile and run.
|
||||||
;; *out*/*err* resolve their port LIVE — 'out -> (current-output-port), 'err ->
|
|
||||||
;; (current-error-port) — so a (.write *out* …) / (.flush *out*) follows a
|
|
||||||
;; with-out-str redirect (with-output-to-string rebinds current-output-port) the
|
|
||||||
;; same way print/__write do. Storing the startup port instead pinned *out* to the
|
|
||||||
;; real stdout, so rewrite-clj's (z/print) — which writes via *out* — escaped the
|
|
||||||
;; capture. A stored port object (should any other code make a port-writer) is used
|
|
||||||
;; as-is.
|
|
||||||
(define (port-writer-port self)
|
|
||||||
(let ((p (vector-ref (jhost-state self) 0)))
|
|
||||||
(cond ((eq? p 'out) (current-output-port))
|
|
||||||
((eq? p 'err) (current-error-port))
|
|
||||||
(else p))))
|
|
||||||
(register-host-methods! "port-writer"
|
(register-host-methods! "port-writer"
|
||||||
(list (cons "write" (lambda (self x) (display (writer-piece x) (port-writer-port self)) jolt-nil))
|
(list (cons "write" (lambda (self x) (display (writer-piece x) (vector-ref (jhost-state self) 0)) jolt-nil))
|
||||||
(cons "append" (lambda (self x . rest) (display (append-text x rest) (port-writer-port self)) self))
|
(cons "append" (lambda (self x . rest) (display (append-text x rest) (vector-ref (jhost-state self) 0)) self))
|
||||||
(cons "flush" (lambda (self) (flush-output-port (port-writer-port self)) jolt-nil))
|
(cons "flush" (lambda (self) (flush-output-port (vector-ref (jhost-state self) 0)) jolt-nil))
|
||||||
(cons "close" (lambda (self) jolt-nil))
|
(cons "close" (lambda (self) jolt-nil))
|
||||||
(cons "toString" (lambda (self) ""))))
|
(cons "toString" (lambda (self) ""))))
|
||||||
(def-var! "clojure.core" "*out*" (make-jhost "port-writer" (vector 'out)))
|
(def-var! "clojure.core" "*out*" (make-jhost "port-writer" (vector (current-output-port))))
|
||||||
(def-var! "clojure.core" "*err*" (make-jhost "port-writer" (vector 'err)))
|
(def-var! "clojure.core" "*err*" (make-jhost "port-writer" (vector (current-error-port))))
|
||||||
|
|
||||||
;; PrintWriter — a thin wrapper over a target writer. write/append/print forward
|
;; PrintWriter — a thin wrapper over a target writer. write/append/print forward
|
||||||
;; the rendered text to the target. clojure.data.json's pretty printer builds
|
;; the rendered text to the target. clojure.data.json's pretty printer builds
|
||||||
|
|
@ -387,11 +327,6 @@
|
||||||
;; state: a vector #(wrapped-reader pushed-list)
|
;; state: a vector #(wrapped-reader pushed-list)
|
||||||
(register-class-ctor! "PushbackReader"
|
(register-class-ctor! "PushbackReader"
|
||||||
(lambda (rdr . _) (make-jhost "pushback-reader" (vector rdr '()))))
|
(lambda (rdr . _) (make-jhost "pushback-reader" (vector rdr '()))))
|
||||||
;; Fully-qualified aliases so (java.io.PushbackReader. …) / (java.io.StringReader. …)
|
|
||||||
;; resolve to these built-ins even when a library defines a deftype of the same
|
|
||||||
;; simple name (tools.reader), which would otherwise take the bare-name slot.
|
|
||||||
(register-class-ctor! "java.io.PushbackReader" (lookup-class class-ctors-tbl "PushbackReader"))
|
|
||||||
(register-class-ctor! "java.io.StringReader" (lookup-class class-ctors-tbl "StringReader"))
|
|
||||||
;; LineNumberingPushbackReader: a pushback-reader (jolt doesn't track line
|
;; LineNumberingPushbackReader: a pushback-reader (jolt doesn't track line
|
||||||
;; numbers; getLineNumber is a stub for error-reporting paths that read it).
|
;; numbers; getLineNumber is a stub for error-reporting paths that read it).
|
||||||
(register-class-ctor! "LineNumberingPushbackReader"
|
(register-class-ctor! "LineNumberingPushbackReader"
|
||||||
|
|
@ -455,15 +390,7 @@
|
||||||
(let ((toks (vector-ref (jhost-state self) 0)) (p (vector-ref (jhost-state self) 1)))
|
(let ((toks (vector-ref (jhost-state self) 0)) (p (vector-ref (jhost-state self) 1)))
|
||||||
(if (< p (length toks))
|
(if (< p (length toks))
|
||||||
(begin (vector-set! (jhost-state self) 1 (+ p 1)) (list-ref toks p))
|
(begin (vector-set! (jhost-state self) 1 (+ p 1)) (list-ref toks p))
|
||||||
(jolt-throw (jolt-host-throwable "java.util.NoSuchElementException" "no more tokens"))))))
|
(error #f "NoSuchElementException")))))))
|
||||||
;; StringTokenizer implements java.util.Enumeration — enumeration-seq drives
|
|
||||||
;; it through these, so alias them onto the token methods.
|
|
||||||
(cons "hasMoreElements" (lambda (self) (< (vector-ref (jhost-state self) 1) (length (vector-ref (jhost-state self) 0)))))
|
|
||||||
(cons "nextElement" (lambda (self)
|
|
||||||
(let ((toks (vector-ref (jhost-state self) 0)) (p (vector-ref (jhost-state self) 1)))
|
|
||||||
(if (< p (length toks))
|
|
||||||
(begin (vector-set! (jhost-state self) 1 (+ p 1)) (list-ref toks p))
|
|
||||||
(jolt-throw (jolt-host-throwable "java.util.NoSuchElementException" "no more tokens"))))))))
|
|
||||||
|
|
||||||
;; ---- String / BigInteger / MapEntry constructors ----------------------------
|
;; ---- String / BigInteger / MapEntry constructors ----------------------------
|
||||||
;; (String. bytes [charset]) decodes bytes (a bytevector OR a jolt byte-array)
|
;; (String. bytes [charset]) decodes bytes (a bytevector OR a jolt byte-array)
|
||||||
|
|
@ -506,12 +433,8 @@
|
||||||
(list->string (vector->list v)))))
|
(list->string (vector->list v)))))
|
||||||
((string? x) x)
|
((string? x) x)
|
||||||
(else (jolt-str-render-one x)))))
|
(else (jolt-str-render-one x)))))
|
||||||
;; (BigInteger. s) | (BigInteger. s radix) — parse a string in the given radix
|
|
||||||
;; (default 10). tools.reader's integer parser builds (BigInteger. digits radix).
|
|
||||||
(register-class-ctor! "BigInteger"
|
(register-class-ctor! "BigInteger"
|
||||||
(lambda (v . r) (parse-int-or-throw v (if (null? r) 10 (jnum->exact (car r))) "BigInteger")))
|
(lambda (v) (parse-int-or-throw v 10 "BigInteger")))
|
||||||
(register-class-ctor! "java.math.BigInteger"
|
|
||||||
(lambda (v . r) (parse-int-or-throw v (if (null? r) 10 (jnum->exact (car r))) "BigInteger")))
|
|
||||||
(register-class-ctor! "MapEntry" (lambda (k v) (make-map-entry k v)))
|
(register-class-ctor! "MapEntry" (lambda (k v) (make-map-entry k v)))
|
||||||
;; JVM exception ctors -> a typed host throwable carrying the canonical :jolt/class
|
;; JVM exception ctors -> a typed host throwable carrying the canonical :jolt/class
|
||||||
;; (so class / instance? / getMessage / ex-message reflect the real type) and the
|
;; (so class / instance? / getMessage / ex-message reflect the real type) and the
|
||||||
|
|
@ -533,8 +456,7 @@
|
||||||
'("Throwable" "Exception" "RuntimeException" "IllegalArgumentException" "IllegalStateException"
|
'("Throwable" "Exception" "RuntimeException" "IllegalArgumentException" "IllegalStateException"
|
||||||
"InterruptedException" "UnsupportedOperationException" "IOException" "NumberFormatException"
|
"InterruptedException" "UnsupportedOperationException" "IOException" "NumberFormatException"
|
||||||
"ArithmeticException" "NullPointerException" "ClassCastException" "IndexOutOfBoundsException"
|
"ArithmeticException" "NullPointerException" "ClassCastException" "IndexOutOfBoundsException"
|
||||||
"FileNotFoundException" "UnsupportedEncodingException" "EOFException" "java.io.EOFException"
|
"FileNotFoundException" "UnsupportedEncodingException" "EOFException" "java.io.EOFException"))
|
||||||
"Error" "AssertionError"))
|
|
||||||
|
|
||||||
;; ---- URLEncoder / URLDecoder (www-form-urlencoded) --------------------------
|
;; ---- URLEncoder / URLDecoder (www-form-urlencoded) --------------------------
|
||||||
(define (url-unreserved? b)
|
(define (url-unreserved? b)
|
||||||
|
|
@ -642,31 +564,20 @@
|
||||||
;; record-method-dispatch already routes string? -> jolt-string-method. Add a
|
;; record-method-dispatch already routes string? -> jolt-string-method. Add a
|
||||||
;; regex-t arm (Pattern .split / .matcher-less surface used by corpus) by wrapping
|
;; regex-t arm (Pattern .split / .matcher-less surface used by corpus) by wrapping
|
||||||
;; once more — a regex-t isn't a jhost.
|
;; once more — a regex-t isn't a jhost.
|
||||||
(register-method-arm! 42
|
(define %hs-rmd2 record-method-dispatch)
|
||||||
|
(set! record-method-dispatch
|
||||||
(lambda (obj method-name rest-args)
|
(lambda (obj method-name rest-args)
|
||||||
(let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
|
(if (regex-t? obj)
|
||||||
(cond
|
(let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
|
||||||
((regex-t? obj)
|
(cond ((string=? method-name "split")
|
||||||
(cond ((string=? method-name "split")
|
;; .split returns a String[] — a seq (prints
|
||||||
;; .split returns a String[] — a seq (prints
|
;; (a b c), not a vector). re-split with no limit; drop trailing
|
||||||
;; (a b c), not a vector). re-split with no limit; drop trailing
|
;; empties (JVM default).
|
||||||
;; empties (JVM default).
|
(let ((parts (re-split (regex-t-irx obj) (car rest) #f)))
|
||||||
(let ((parts (re-split (regex-t-irx obj) (car rest) #f)))
|
(list->cseq (str-split-drop-trailing parts))))
|
||||||
(list->cseq (str-split-drop-trailing parts))))
|
((string=? method-name "pattern") (regex-t-source obj))
|
||||||
((string=? method-name "pattern") (regex-t-source obj))
|
(else (error #f (string-append "No method " method-name " on Pattern")))))
|
||||||
((or (string=? method-name "toString")) (regex-t-source obj))
|
(%hs-rmd2 obj method-name rest-args))))
|
||||||
;; (.matcher pattern s) -> a Matcher (matcher-t) for stepping matches.
|
|
||||||
((string=? method-name "matcher") (jolt-re-matcher obj (car rest)))
|
|
||||||
(else (error #f (string-append "No method " method-name " on Pattern")))))
|
|
||||||
;; java.util.regex.Matcher: .matches (anchored whole-region), .find
|
|
||||||
;; (next match), .group [n], .groupCount.
|
|
||||||
((jolt-matcher? obj)
|
|
||||||
(cond ((string=? method-name "matches") (jolt-matcher-matches obj))
|
|
||||||
((string=? method-name "find") (not (jolt-nil? (jolt-re-find obj))))
|
|
||||||
((string=? method-name "group") (apply jolt-matcher-group obj rest))
|
|
||||||
((string=? method-name "groupCount") (jolt-matcher-group-count obj))
|
|
||||||
(else (error #f (string-append "No method " method-name " on Matcher")))))
|
|
||||||
(else 'pass)))))
|
|
||||||
|
|
||||||
;; ---- def-var! the registry entry points so emit can also reach them ---------
|
;; ---- def-var! the registry entry points so emit can also reach them ---------
|
||||||
(def-var! "clojure.core" "host-static-ref" host-static-ref)
|
(def-var! "clojure.core" "host-static-ref" host-static-ref)
|
||||||
|
|
@ -708,34 +619,19 @@
|
||||||
|
|
||||||
;; htable arm: dispatch (.method obj a*) through the table's tag method registry;
|
;; htable arm: dispatch (.method obj a*) through the table's tag method registry;
|
||||||
;; an unregistered method falls through (sorted colls are htables too).
|
;; an unregistered method falls through (sorted colls are htables too).
|
||||||
(register-method-arm! 43
|
(define %hs-rmd-htable record-method-dispatch)
|
||||||
|
(set! record-method-dispatch
|
||||||
(lambda (obj method-name rest-args)
|
(lambda (obj method-name rest-args)
|
||||||
(let ((tag (and (htable? obj) (hashtable-ref (htable-h obj) "jolt/type" #f))))
|
(let ((tag (and (htable? obj) (hashtable-ref (htable-h obj) "jolt/type" #f))))
|
||||||
(let* ((mh (and tag (hashtable-ref tagged-methods-tbl (tag->method-key tag) #f)))
|
(let* ((mh (and tag (hashtable-ref tagged-methods-tbl (tag->method-key tag) #f)))
|
||||||
(f (and mh (hashtable-ref mh method-name #f))))
|
(f (and mh (hashtable-ref mh method-name #f))))
|
||||||
(if f
|
(if f
|
||||||
(apply f obj (if (jolt-nil? rest-args) '() (seq->list rest-args)))
|
(apply f obj (if (jolt-nil? rest-args) '() (seq->list rest-args)))
|
||||||
'pass)))))
|
(%hs-rmd-htable obj method-name rest-args))))))
|
||||||
|
|
||||||
(def-var! "clojure.core" "__register-class-methods!"
|
(def-var! "clojure.core" "__register-class-methods!"
|
||||||
(lambda (tag members) (register-tagged-methods! tag (jmap->static-alist members)) jolt-nil))
|
(lambda (tag members) (register-tagged-methods! tag (jmap->static-alist members)) jolt-nil))
|
||||||
|
|
||||||
;; java.lang.ThreadLocal via a Chez thread-parameter: real per-thread storage with
|
|
||||||
;; a lazy initialValue (the proxy macro lowers (proxy [ThreadLocal] …) to this).
|
|
||||||
;; .get returns the thread's value, computing initialValue once; .set / .remove.
|
|
||||||
(define tl-unset (list 'tl-unset))
|
|
||||||
(define (jolt-make-thread-local init-thunk)
|
|
||||||
(make-jhost "threadlocal" (vector (make-thread-parameter tl-unset) init-thunk)))
|
|
||||||
(register-host-methods! "threadlocal"
|
|
||||||
(list (cons "get" (lambda (self)
|
|
||||||
(let* ((st (jhost-state self)) (tp (vector-ref st 0)) (v (tp)))
|
|
||||||
(if (eq? v tl-unset)
|
|
||||||
(let ((nv (jolt-invoke (vector-ref st 1)))) (tp nv) nv)
|
|
||||||
v))))
|
|
||||||
(cons "set" (lambda (self v) ((vector-ref (jhost-state self) 0) v) jolt-nil))
|
|
||||||
(cons "remove" (lambda (self) ((vector-ref (jhost-state self) 0) tl-unset) jolt-nil))))
|
|
||||||
(def-var! "jolt.host" "make-thread-local" jolt-make-thread-local)
|
|
||||||
|
|
||||||
;; Pluggable instance? — a library registers (fn [class-name-string val] -> true
|
;; Pluggable instance? — a library registers (fn [class-name-string val] -> true
|
||||||
;; | false | nil); nil means "not my class, fall through". First non-nil wins.
|
;; | false | nil); nil means "not my class, fall through". First non-nil wins.
|
||||||
(define user-instance-checks '())
|
(define user-instance-checks '())
|
||||||
|
|
@ -765,12 +661,6 @@
|
||||||
(register-instance-check-arm!
|
(register-instance-check-arm!
|
||||||
(lambda (type-sym val)
|
(lambda (type-sym val)
|
||||||
(let ((iface (hsc-last-segment (symbol-t-name type-sym))))
|
(let ((iface (hsc-last-segment (symbol-t-name type-sym))))
|
||||||
;; the value's own class-graph tags (value-host-tags) are authoritative — the
|
|
||||||
;; SAME source protocol dispatch reads, so instance? and extend-protocol can't
|
|
||||||
;; disagree about the interfaces a builtin implements.
|
|
||||||
(if (let ((tags (value-host-tags val)))
|
|
||||||
(or (member (symbol-t-name type-sym) tags) (member iface tags)))
|
|
||||||
#t
|
|
||||||
(let ((hit (cond
|
(let ((hit (cond
|
||||||
((or (string=? iface "IObj") (string=? iface "IMeta")) (hsc-imeta? val))
|
((or (string=? iface "IObj") (string=? iface "IMeta")) (hsc-imeta? val))
|
||||||
((or (string=? iface "IMapEntry") (string=? iface "MapEntry")) (jolt-map-entry? val))
|
((or (string=? iface "IMapEntry") (string=? iface "MapEntry")) (jolt-map-entry? val))
|
||||||
|
|
@ -778,15 +668,8 @@
|
||||||
((string=? iface "IPersistentMap") (or (pmap? val) (htable-sorted-map? val)))
|
((string=? iface "IPersistentMap") (or (pmap? val) (htable-sorted-map? val)))
|
||||||
((string=? iface "IPersistentVector") (and (pvec? val) (not (jolt-map-entry? val))))
|
((string=? iface "IPersistentVector") (and (pvec? val) (not (jolt-map-entry? val))))
|
||||||
((string=? iface "IPersistentSet") (or (pset? val) (htable-sorted-set? val)))
|
((string=? iface "IPersistentSet") (or (pset? val) (htable-sorted-set? val)))
|
||||||
((string=? iface "ISeq")
|
((or (string=? iface "ISeq") (string=? iface "Seqable"))
|
||||||
(or (cseq? val) (empty-list-t? val) (jolt-lazyseq? val)))
|
(or (cseq? val) (empty-list-t? val) (jolt-lazyseq? val)))
|
||||||
((string=? iface "LazySeq") (jolt-lazyseq? val))
|
|
||||||
;; Seqable is anything (seq x) works on — every persistent
|
|
||||||
;; collection, not just seqs (a vector IS Seqable, not an ISeq).
|
|
||||||
((string=? iface "Seqable")
|
|
||||||
(or (cseq? val) (empty-list-t? val) (jolt-lazyseq? val)
|
|
||||||
(pvec? val) (pmap? val) (pset? val)
|
|
||||||
(htable-sorted-map? val) (htable-sorted-set? val)))
|
|
||||||
((string=? iface "Sequential")
|
((string=? iface "Sequential")
|
||||||
(or (pvec? val) (cseq? val) (empty-list-t? val) (jolt-lazyseq? val)))
|
(or (pvec? val) (cseq? val) (empty-list-t? val) (jolt-lazyseq? val)))
|
||||||
((string=? iface "IFn")
|
((string=? iface "IFn")
|
||||||
|
|
@ -831,7 +714,7 @@
|
||||||
((or (string=? iface "Reader") (string=? iface "BufferedReader"))
|
((or (string=? iface "Reader") (string=? iface "BufferedReader"))
|
||||||
(reader-jhost? val))
|
(reader-jhost? val))
|
||||||
(else 'none))))
|
(else 'none))))
|
||||||
(if (eq? hit 'none) 'pass (if hit #t #f)))))))
|
(if (eq? hit 'none) 'pass (if hit #t #f))))))
|
||||||
|
|
||||||
;; java.lang.Class value: (class x) / (.getClass x) return one. It renders like
|
;; java.lang.Class value: (class x) / (.getClass x) return one. It renders like
|
||||||
;; the JVM — str/.toString -> "class <name>", pr -> "<name>", .getName -> "<name>"
|
;; the JVM — str/.toString -> "class <name>", pr -> "<name>", .getName -> "<name>"
|
||||||
|
|
@ -841,12 +724,7 @@
|
||||||
(define (make-class-obj name) (make-jhost "class" (vector name)))
|
(define (make-class-obj name) (make-jhost "class" (vector name)))
|
||||||
(define (jclass? x) (and (jhost? x) (string=? (jhost-tag x) "class")))
|
(define (jclass? x) (and (jhost? x) (string=? (jhost-tag x) "class")))
|
||||||
(define (jclass-name x) (vector-ref (jhost-state x) 0))
|
(define (jclass-name x) (vector-ref (jhost-state x) 0))
|
||||||
(define (class-key x)
|
(define (class-key x) (cond ((jclass? x) (jclass-name x)) ((string? x) x) (else #f)))
|
||||||
(cond ((jclass? x) (jclass-name x))
|
|
||||||
((string? x) x)
|
|
||||||
;; a deftype/defrecord NAME var holds its ctor; treat it as the class
|
|
||||||
((procedure? x) (hashtable-ref chez-deftype-ctor-tag x #f))
|
|
||||||
(else #f)))
|
|
||||||
(register-eq-arm! (lambda (a b) (or (jclass? a) (jclass? b)))
|
(register-eq-arm! (lambda (a b) (or (jclass? a) (jclass? b)))
|
||||||
(lambda (a b) (let ((ka (class-key a)) (kb (class-key b)))
|
(lambda (a b) (let ((ka (class-key a)) (kb (class-key b)))
|
||||||
(and ka kb (string=? ka kb) #t))))
|
(and ka kb (string=? ka kb) #t))))
|
||||||
|
|
@ -860,254 +738,7 @@
|
||||||
(cons "toString" (lambda (self) (string-append "class " (jclass-name self))))
|
(cons "toString" (lambda (self) (string-append "class " (jclass-name self))))
|
||||||
(cons "isArray" (lambda (self) (let ((n (jclass-name self)))
|
(cons "isArray" (lambda (self) (let ((n (jclass-name self)))
|
||||||
(and (fx>? (string-length n) 0) (char=? (string-ref n 0) #\[)))))
|
(and (fx>? (string-length n) 0) (char=? (string-ref n 0) #\[)))))
|
||||||
;; Class.isInstance(o) == (instance? class o); core.logic's deftype .equals
|
|
||||||
;; uses (.. this getClass (isInstance o)).
|
|
||||||
(cons "isInstance" (lambda (self o) (if (instance-check self o) #t #f)))
|
|
||||||
(cons "getClass" (lambda (self) (make-class-obj "java.lang.Class")))))
|
(cons "getClass" (lambda (self) (make-class-obj "java.lang.Class")))))
|
||||||
|
|
||||||
;; (jolt.host/table? x) — is x a host tagged-table?
|
;; (jolt.host/table? x) — is x a host tagged-table?
|
||||||
(def-var! "jolt.host" "table?" (lambda (x) (if (htable? x) #t #f)))
|
(def-var! "jolt.host" "table?" (lambda (x) (if (htable? x) #t #f)))
|
||||||
|
|
||||||
;; --- java.util.Arrays -------------------------------------------------------
|
|
||||||
(let ((arrays-statics
|
|
||||||
(list
|
|
||||||
(cons "equals" (lambda (a b)
|
|
||||||
(cond ((and (jolt-nil? a) (jolt-nil? b)) #t)
|
|
||||||
((or (jolt-nil? a) (jolt-nil? b)) #f)
|
|
||||||
(else (equal? (jolt-array-vec a) (jolt-array-vec b))))))
|
|
||||||
(cons "fill" (lambda (a v) (vector-fill! (jolt-array-vec a) v) jolt-nil))
|
|
||||||
(cons "copyOf" (lambda (a n)
|
|
||||||
(let* ((src (jolt-array-vec a)) (len (jnum->exact n))
|
|
||||||
(out (make-vector len 0)))
|
|
||||||
(do ((i 0 (fx+ i 1))) ((fx=? i (min len (vector-length src))))
|
|
||||||
(vector-set! out i (vector-ref src i)))
|
|
||||||
(make-jolt-array out (jolt-array-kind a)))))
|
|
||||||
(cons "copyOfRange" (lambda (a from to)
|
|
||||||
(let* ((src (jolt-array-vec a)) (f (jnum->exact from)) (tt (jnum->exact to))
|
|
||||||
(len (- tt f)) (out (make-vector len 0)))
|
|
||||||
(do ((i 0 (fx+ i 1))) ((fx=? i len))
|
|
||||||
(vector-set! out i (vector-ref src (+ f i))))
|
|
||||||
(make-jolt-array out (jolt-array-kind a)))))
|
|
||||||
(cons "toString" (lambda (a) (jolt-pr-str (apply jolt-vector (vector->list (jolt-array-vec a)))))))))
|
|
||||||
(register-class-statics! "Arrays" arrays-statics)
|
|
||||||
(register-class-statics! "java.util.Arrays" arrays-statics))
|
|
||||||
|
|
||||||
;; --- java.util.Random -------------------------------------------------------
|
|
||||||
;; A non-cryptographic PRNG over Chez's `random`. A seed argument is accepted but
|
|
||||||
;; not honored for reproducibility (jolt has no seedable Random state); callers
|
|
||||||
;; that need determinism use SecureRandom or their own generator.
|
|
||||||
(for-each
|
|
||||||
(lambda (nm) (register-class-ctor! nm (lambda args (make-jhost "random" (vector)))))
|
|
||||||
'("Random" "java.util.Random"))
|
|
||||||
(register-host-methods! "random"
|
|
||||||
(list
|
|
||||||
(cons "nextBytes" (lambda (self ba)
|
|
||||||
(let ((v (jolt-array-vec ba)))
|
|
||||||
(do ((i 0 (fx+ i 1))) ((fx=? i (vector-length v)))
|
|
||||||
(vector-set! v i (random 256))))
|
|
||||||
jolt-nil))
|
|
||||||
(cons "nextInt" (lambda (self . a)
|
|
||||||
(->num (if (pair? a) (random (jnum->exact (car a))) (- (random 4294967296) 2147483648)))))
|
|
||||||
(cons "nextLong" (lambda (self) (->num (- (random 18446744073709551616) 9223372036854775808))))
|
|
||||||
(cons "nextDouble" (lambda (self) (random 1.0)))
|
|
||||||
(cons "nextFloat" (lambda (self) (random 1.0)))
|
|
||||||
(cons "nextBoolean" (lambda (self) (fx=? 0 (random 2))))))
|
|
||||||
|
|
||||||
;; --- java.util.Optional -----------------------------------------------------
|
|
||||||
;; Returned by getters across java.time / java.net.http (e.g. HttpRequest.timeout,
|
|
||||||
;; HttpClient.connectTimeout). Value-equal so (= (Optional/of x) (Optional/of x)).
|
|
||||||
(define (jt-optional present? value) (make-jhost "optional" (vector present? value)))
|
|
||||||
(define jt-optional-empty (jt-optional #f jolt-nil))
|
|
||||||
(define (opt? x) (and (jhost? x) (string=? (jhost-tag x) "optional")))
|
|
||||||
(define (opt-present? o) (vector-ref (jhost-state o) 0))
|
|
||||||
(define (opt-value o) (vector-ref (jhost-state o) 1))
|
|
||||||
(let ((statics (list (cons "of" (lambda (v) (if (jolt-nil? v) (error #f "Optional.of(null)") (jt-optional #t v))))
|
|
||||||
(cons "ofNullable" (lambda (v) (if (jolt-nil? v) jt-optional-empty (jt-optional #t v))))
|
|
||||||
(cons "empty" (lambda _ jt-optional-empty)))))
|
|
||||||
(register-class-statics! "Optional" statics)
|
|
||||||
(register-class-statics! "java.util.Optional" statics))
|
|
||||||
(register-host-methods! "optional"
|
|
||||||
(list (cons "isPresent" (lambda (o) (opt-present? o)))
|
|
||||||
(cons "isEmpty" (lambda (o) (not (opt-present? o))))
|
|
||||||
(cons "get" (lambda (o) (if (opt-present? o) (opt-value o) (error #f "Optional.get() on empty Optional"))))
|
|
||||||
(cons "orElse" (lambda (o d) (if (opt-present? o) (opt-value o) d)))
|
|
||||||
(cons "orElseGet" (lambda (o f) (if (opt-present? o) (opt-value o) (jolt-invoke f))))
|
|
||||||
(cons "ifPresent" (lambda (o f) (when (opt-present? o) (jolt-invoke f (opt-value o))) jolt-nil))
|
|
||||||
(cons "toString" (lambda (o) (if (opt-present? o)
|
|
||||||
(string-append "Optional[" (jolt-str-render-one (opt-value o)) "]")
|
|
||||||
"Optional.empty")))))
|
|
||||||
(register-eq-arm! (lambda (a b) (or (opt? a) (opt? b)))
|
|
||||||
(lambda (a b) (and (opt? a) (opt? b) (eq? (opt-present? a) (opt-present? b))
|
|
||||||
(or (not (opt-present? a)) (jolt=2 (opt-value a) (opt-value b))))))
|
|
||||||
|
|
||||||
;; --- minimal JVM class/interface ancestry -----------------------------------
|
|
||||||
;; A handful of libraries reflect over the class hierarchy — e.g. core.memoize
|
|
||||||
;; validates its first argument with (some #{IFn AFn Runnable Callable}
|
|
||||||
;; (ancestors (class f))). jolt models a class as its name string and has no
|
|
||||||
;; reflection, so supers/ancestors return nothing on their own. This table gives
|
|
||||||
;; the common interfaces the direct supers the JVM reports, and the overlay's
|
|
||||||
;; supers/ancestors fold it in. Keyed by canonical class name; value = direct
|
|
||||||
;; supers. Extend as more interfaces are exercised.
|
|
||||||
(define class-supers-tbl (make-hashtable string-hash string=?))
|
|
||||||
(define (reg-class-supers! name supers) (hashtable-set! class-supers-tbl name supers))
|
|
||||||
(reg-class-supers! "clojure.lang.IFn" '("java.lang.Runnable" "java.util.concurrent.Callable"))
|
|
||||||
(reg-class-supers! "clojure.lang.AFn" '("clojure.lang.IFn" "java.lang.Runnable" "java.util.concurrent.Callable"))
|
|
||||||
(reg-class-supers! "clojure.lang.AFunction" '("clojure.lang.AFn" "clojure.lang.IFn" "clojure.lang.Fn"
|
|
||||||
"java.lang.Runnable" "java.util.concurrent.Callable"))
|
|
||||||
;; common exception hierarchy, so (instance? IOException e) / (catch IOException e)
|
|
||||||
;; match a more specific throwable a library threw (e.g. http-client's
|
|
||||||
;; UnknownHostException, caught by clj-http-lite's :ignore-unknown-host?).
|
|
||||||
(reg-class-supers! "java.lang.Throwable" '("java.lang.Object"))
|
|
||||||
(reg-class-supers! "java.lang.Exception" '("java.lang.Throwable" "java.lang.Object"))
|
|
||||||
(reg-class-supers! "java.lang.RuntimeException" '("java.lang.Exception" "java.lang.Throwable" "java.lang.Object"))
|
|
||||||
(reg-class-supers! "java.io.IOException" '("java.lang.Exception" "java.lang.Throwable" "java.lang.Object"))
|
|
||||||
(reg-class-supers! "java.io.InterruptedIOException" '("java.io.IOException" "java.lang.Exception" "java.lang.Throwable" "java.lang.Object"))
|
|
||||||
(reg-class-supers! "java.net.SocketException" '("java.io.IOException" "java.lang.Exception" "java.lang.Throwable" "java.lang.Object"))
|
|
||||||
(reg-class-supers! "java.net.UnknownHostException" '("java.io.IOException" "java.lang.Exception" "java.lang.Throwable" "java.lang.Object"))
|
|
||||||
(reg-class-supers! "java.net.ConnectException" '("java.net.SocketException" "java.io.IOException" "java.lang.Exception" "java.lang.Throwable" "java.lang.Object"))
|
|
||||||
(reg-class-supers! "java.net.SocketTimeoutException" '("java.io.InterruptedIOException" "java.io.IOException" "java.lang.Exception" "java.lang.Throwable" "java.lang.Object"))
|
|
||||||
;; clojure.lang / java.util ancestry for the builtins (class) reports, so a
|
|
||||||
;; class-keyed multimethod / (isa? (class x) SomeClass) dispatches like the JVM.
|
|
||||||
;; (Object is supplied universally by class-isa?, so it need not be listed.)
|
|
||||||
(reg-class-supers! "clojure.lang.IFn" '("clojure.lang.Fn" "java.lang.Runnable" "java.util.concurrent.Callable"))
|
|
||||||
;; Keyword and Symbol implement IFn (they are callable: (:k m) / ('s m)), so a
|
|
||||||
;; (class x)-dispatched multimethod with an IFn method matches them, like the JVM.
|
|
||||||
(reg-class-supers! "clojure.lang.Keyword" '("clojure.lang.Named" "java.lang.Comparable"
|
|
||||||
"clojure.lang.IFn" "clojure.lang.Fn"
|
|
||||||
"java.lang.Runnable" "java.util.concurrent.Callable"))
|
|
||||||
(reg-class-supers! "clojure.lang.Symbol" '("clojure.lang.Named" "java.lang.Comparable"
|
|
||||||
"clojure.lang.IFn" "clojure.lang.Fn"
|
|
||||||
"java.lang.Runnable" "java.util.concurrent.Callable"))
|
|
||||||
(reg-class-supers! "java.lang.String" '("java.lang.CharSequence" "java.lang.Comparable"))
|
|
||||||
(reg-class-supers! "clojure.lang.PersistentHashSet" '("clojure.lang.APersistentSet" "clojure.lang.IPersistentSet" "clojure.lang.IPersistentCollection" "java.util.Set" "java.util.Collection" "java.lang.Iterable"))
|
|
||||||
(reg-class-supers! "clojure.lang.PersistentTreeSet" '("clojure.lang.APersistentSet" "clojure.lang.IPersistentSet" "clojure.lang.IPersistentCollection" "java.util.Set" "java.util.Collection" "java.lang.Iterable"))
|
|
||||||
(reg-class-supers! "clojure.lang.PersistentVector" '("clojure.lang.APersistentVector" "clojure.lang.IPersistentVector" "clojure.lang.IPersistentCollection" "clojure.lang.Sequential" "clojure.lang.Associative" "java.util.List" "java.util.Collection" "java.lang.Iterable"))
|
|
||||||
(reg-class-supers! "clojure.lang.PersistentArrayMap" '("clojure.lang.APersistentMap" "clojure.lang.IPersistentMap" "clojure.lang.IPersistentCollection" "clojure.lang.Associative" "java.util.Map" "java.lang.Iterable"))
|
|
||||||
(reg-class-supers! "clojure.lang.PersistentHashMap" '("clojure.lang.APersistentMap" "clojure.lang.IPersistentMap" "clojure.lang.IPersistentCollection" "clojure.lang.Associative" "java.util.Map" "java.lang.Iterable"))
|
|
||||||
(reg-class-supers! "clojure.lang.PersistentList" '("clojure.lang.ASeq" "clojure.lang.ISeq" "clojure.lang.IPersistentCollection" "clojure.lang.Sequential" "clojure.lang.Seqable" "java.util.List" "java.util.Collection" "java.lang.Iterable"))
|
|
||||||
(reg-class-supers! "clojure.lang.LazySeq" '("clojure.lang.ISeq" "clojure.lang.IPersistentCollection" "clojure.lang.Sequential" "clojure.lang.Seqable" "java.lang.Iterable"))
|
|
||||||
(reg-class-supers! "clojure.lang.Cons" '("clojure.lang.ASeq" "clojure.lang.ISeq" "clojure.lang.Sequential" "clojure.lang.Seqable" "java.lang.Iterable"))
|
|
||||||
|
|
||||||
;; A munged fn class name "ns$name" (jolt-class for a def'd fn) isn't in the table;
|
|
||||||
;; like the JVM (a fn extends clojure.lang.AFunction) its super is AFunction, whose
|
|
||||||
;; registered supers give AFn / IFn / Fn / Runnable / Callable transitively.
|
|
||||||
(define (str-has-dollar? s)
|
|
||||||
(let loop ((i 0)) (and (< i (string-length s)) (or (char=? (string-ref s i) #\$) (loop (+ i 1))))))
|
|
||||||
(define (class-direct-supers name)
|
|
||||||
;; union the modeled class graph (jch, direct edges) with any legacy table entry,
|
|
||||||
;; so isa?/supers/ancestors see the single hierarchy source plus anything not yet
|
|
||||||
;; migrated. The closure below traverses these to the full transitive set.
|
|
||||||
(let ((jch (jch-direct-supers name))
|
|
||||||
(old (hashtable-ref class-supers-tbl name #f)))
|
|
||||||
(cond ((and (pair? jch) old)
|
|
||||||
(let merge ((ss old) (acc jch))
|
|
||||||
(cond ((null? ss) acc)
|
|
||||||
((member (car ss) acc) (merge (cdr ss) acc))
|
|
||||||
(else (merge (cdr ss) (append acc (list (car ss))))))))
|
|
||||||
((pair? jch) jch)
|
|
||||||
(old old)
|
|
||||||
((str-has-dollar? name) '("clojure.lang.AFunction"))
|
|
||||||
(else '()))))
|
|
||||||
;; transitive closure of direct supers (set semantics via an accumulator list)
|
|
||||||
(define (class-ancestors-list name)
|
|
||||||
(let loop ((pending (class-direct-supers name)) (seen '()))
|
|
||||||
(cond ((null? pending) (reverse seen))
|
|
||||||
((member (car pending) seen) (loop (cdr pending) seen))
|
|
||||||
(else (loop (append (class-direct-supers (car pending)) (cdr pending))
|
|
||||||
(cons (car pending) seen))))))
|
|
||||||
|
|
||||||
;; (instance? Class e) on a throwable tagged-table carrying a JVM :class matches the
|
|
||||||
;; carried class or any of its ancestors (full name or last segment), so a library's
|
|
||||||
;; (catch UnknownHostException e …) / (catch IOException e …) matches the ex-info
|
|
||||||
;; envelope it threw. Mirrors the (class e) arm (host-table.ss) for catch dispatch,
|
|
||||||
;; which lowers to (instance? C e). Non-match returns 'pass so other arms still run.
|
|
||||||
(register-instance-check-arm!
|
|
||||||
(lambda (type-sym val)
|
|
||||||
(if (and (htable? val) (string? (hashtable-ref (htable-h val) "class" #f)))
|
|
||||||
(let* ((cls (hashtable-ref (htable-h val) "class" #f))
|
|
||||||
(want (symbol-t-name type-sym))
|
|
||||||
(want-seg (hsc-last-segment want)))
|
|
||||||
(let loop ((names (cons cls (class-ancestors-list cls))))
|
|
||||||
(cond ((null? names) 'pass)
|
|
||||||
((or (string=? want (car names))
|
|
||||||
(string=? want-seg (hsc-last-segment (car names)))) #t)
|
|
||||||
(else (loop (cdr names))))))
|
|
||||||
'pass)))
|
|
||||||
|
|
||||||
;; JVM class assignability for isa? (20-coll): true when child and parent are both
|
|
||||||
;; class values and parent is child, java.lang.Object (every class's root), or a
|
|
||||||
;; modeled ancestor of child (full name or last segment). nil for non-class args, so
|
|
||||||
;; isa? falls through to its hierarchy/vector logic.
|
|
||||||
(def-var! "jolt.host" "class-isa?"
|
|
||||||
(lambda (child parent)
|
|
||||||
(let ((cc (class-key child)) (pp (class-key parent)))
|
|
||||||
(if (and cc pp)
|
|
||||||
(let ((pseg (hsc-last-segment pp)))
|
|
||||||
(if (let loop ((names (cons cc (class-ancestors-list cc))))
|
|
||||||
(cond ((string=? pp "java.lang.Object") #t)
|
|
||||||
((null? names) #f)
|
|
||||||
((or (string=? pp (car names))
|
|
||||||
(string=? pseg (hsc-last-segment (car names)))) #t)
|
|
||||||
(else (loop (cdr names)))))
|
|
||||||
#t jolt-nil))
|
|
||||||
jolt-nil))))
|
|
||||||
|
|
||||||
;; is NAME a class the host models (registered in the class graph, a legacy
|
|
||||||
;; supers-table entry, or a fn class)? Object itself is modeled.
|
|
||||||
(define (hsc-class-known? name)
|
|
||||||
(or (string=? name "java.lang.Object")
|
|
||||||
(jch-known? name)
|
|
||||||
(and (hashtable-ref class-supers-tbl name #f) #t)
|
|
||||||
(str-has-dollar? name)))
|
|
||||||
|
|
||||||
;; transitive ancestry, rooted at Object for a concrete class like (supers c);
|
|
||||||
;; an interface's chain has no Object (its getSuperclass is null). '() for
|
|
||||||
;; Object itself and for a name the host doesn't model.
|
|
||||||
(define (class-ancestors-rooted name)
|
|
||||||
(if (or (string=? name "java.lang.Object") (jch-interface? name))
|
|
||||||
(class-ancestors-list name)
|
|
||||||
(let ((as (class-ancestors-list name)))
|
|
||||||
(cond ((member "java.lang.Object" as) as)
|
|
||||||
((null? as) (if (hsc-class-known? name) '("java.lang.Object") '()))
|
|
||||||
(else (append as '("java.lang.Object")))))))
|
|
||||||
|
|
||||||
;; (jolt.host/class-supers name) / (jolt.host/class-ancestors name) — a jolt seq of
|
|
||||||
;; super / ancestor class-name strings (transitive, Object-rooted), or nil when
|
|
||||||
;; jolt models no hierarchy for it. class-bases is the DIRECT supers (clojure.core
|
|
||||||
;; `bases` / the class arm of `parents`).
|
|
||||||
(def-var! "jolt.host" "class-supers"
|
|
||||||
(lambda (x)
|
|
||||||
(let ((name (class-key x)))
|
|
||||||
(if name
|
|
||||||
(let ((as (class-ancestors-rooted name)))
|
|
||||||
(if (null? as) jolt-nil (list->cseq as)))
|
|
||||||
jolt-nil))))
|
|
||||||
(def-var! "jolt.host" "class-ancestors"
|
|
||||||
(lambda (x)
|
|
||||||
(let ((name (class-key x)))
|
|
||||||
(if name
|
|
||||||
(let ((as (class-ancestors-rooted name)))
|
|
||||||
(if (null? as) jolt-nil (list->cseq as)))
|
|
||||||
jolt-nil))))
|
|
||||||
(def-var! "jolt.host" "class-bases"
|
|
||||||
(lambda (x)
|
|
||||||
(let ((name (class-key x)))
|
|
||||||
(if name
|
|
||||||
(let* ((ds (class-direct-supers name))
|
|
||||||
;; a concrete class's bases include its superclass — Object when
|
|
||||||
;; nothing more specific is modeled (interfaces have none).
|
|
||||||
(ds (if (or (string=? name "java.lang.Object")
|
|
||||||
(jch-interface? name)
|
|
||||||
(member "java.lang.Object" ds))
|
|
||||||
ds
|
|
||||||
(append ds '("java.lang.Object")))))
|
|
||||||
(if (null? ds) jolt-nil (list->cseq ds)))
|
|
||||||
jolt-nil))))
|
|
||||||
;; is X a class value — a jclass, a deftype ctor, or a name string the host
|
|
||||||
;; graph models?
|
|
||||||
(def-var! "jolt.host" "class-value?"
|
|
||||||
(lambda (x)
|
|
||||||
(if (jclass? x)
|
|
||||||
#t
|
|
||||||
(let ((n (class-key x)))
|
|
||||||
(if (and n (hsc-class-known? n)) #t jolt-nil)))))
|
|
||||||
|
|
@ -21,11 +21,6 @@
|
||||||
(cons "acos" (lambda (x) (->dbl (acos x)))) (cons "atan" (lambda (x) (->dbl (atan 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 "log" (lambda (x) (->dbl (log x)))) (cons "log10" (lambda (x) (->dbl (/ (log x) (log 10)))))
|
||||||
(cons "exp" (lambda (x) (->dbl (exp x))))
|
(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 "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 "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 "PI" (->dbl (* 4 (atan 1)))) (cons "E" (->dbl (exp 1)))
|
||||||
|
|
@ -55,7 +50,9 @@
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(unless tried?
|
(unless tried?
|
||||||
(set! tried? #t)
|
(set! tried? #t)
|
||||||
(set! fp (jolt-foreign-proc-safe "sched_yield" '() 'int)))
|
(set! fp (guard (e (#t #f))
|
||||||
|
(load-shared-object #f)
|
||||||
|
(foreign-procedure "sched_yield" () int))))
|
||||||
(if fp (fp) (sleep (make-time 'time-duration 0 0)))
|
(if fp (fp) (sleep (make-time 'time-duration 0 0)))
|
||||||
jolt-nil)))
|
jolt-nil)))
|
||||||
|
|
||||||
|
|
@ -99,70 +96,6 @@
|
||||||
(register-class-statics! "PersistentArrayMap" (list (cons "createWithCheck" pam-create-with-check)))
|
(register-class-statics! "PersistentArrayMap" (list (cons "createWithCheck" pam-create-with-check)))
|
||||||
(register-class-statics! "clojure.lang.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)
|
(define (now-millis)
|
||||||
(let ((t (current-time 'time-utc)))
|
(let ((t (current-time 'time-utc)))
|
||||||
(+ (* 1000 (time-second t)) (quotient (time-nanosecond t) 1000000))))
|
(+ (* 1000 (time-second t)) (quotient (time-nanosecond t) 1000000))))
|
||||||
|
|
@ -183,29 +116,9 @@
|
||||||
(cons "getProperties" (lambda () (sys-properties-map)))
|
(cons "getProperties" (lambda () (sys-properties-map)))
|
||||||
(cons "getenv" (lambda k (apply sys-getenv k)))))
|
(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"
|
(register-class-statics! "Long"
|
||||||
(list (cons "TYPE" "long")
|
(list (cons "MAX_VALUE" (->num 9223372036854775807))
|
||||||
(cons "MAX_VALUE" (->num 9223372036854775807))
|
|
||||||
(cons "MIN_VALUE" (->num -9223372036854775808))
|
(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 "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")))))
|
(cons "valueOf" (lambda (s . r) (parse-int-or-throw s (if (null? r) 10 (jnum->exact (car r))) "valueOf")))))
|
||||||
|
|
||||||
|
|
@ -213,8 +126,6 @@
|
||||||
(define (int->u32 n) (if (< n 0) (+ n 4294967296) n))
|
(define (int->u32 n) (if (< n 0) (+ n 4294967296) n))
|
||||||
(register-class-statics! "Integer"
|
(register-class-statics! "Integer"
|
||||||
(list (cons "MAX_VALUE" (->num 2147483647)) (cons "MIN_VALUE" (->num -2147483648))
|
(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)
|
(cons "valueOf" (lambda (x . r)
|
||||||
(if (number? x) (->num x)
|
(if (number? x) (->num x)
|
||||||
(parse-int-or-throw x (if (null? r) 10 (jnum->exact (car r))) "valueOf"))))
|
(parse-int-or-throw x (if (null? r) 10 (jnum->exact (car r))) "valueOf"))))
|
||||||
|
|
@ -225,40 +136,14 @@
|
||||||
(cons "toBinaryString" (lambda (x) (number->string (int->u32 (jnum->exact x)) 2)))
|
(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))))))))
|
(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"
|
(register-class-statics! "Boolean"
|
||||||
(list (cons "TYPE" "boolean")
|
(list (cons "parseBoolean" (lambda (s) (string=? "true" (ascii-string-down (if (string? s) s (jolt-str-render-one s))))))
|
||||||
(cons "parseBoolean" (lambda (s) (string=? "true" (ascii-string-down (if (string? s) s (jolt-str-render-one s))))))
|
|
||||||
(cons "TRUE" #t) (cons "FALSE" #f)))
|
(cons "TRUE" #t) (cons "FALSE" #f)))
|
||||||
|
|
||||||
(register-class-ctor! "Double" ->double)
|
(register-class-ctor! "Double" ->double)
|
||||||
(register-class-ctor! "Float" ->double)
|
(register-class-ctor! "Float" ->double)
|
||||||
(register-class-statics! "Double"
|
(register-class-statics! "Double"
|
||||||
(list (cons "TYPE" "double")
|
(list (cons "parseDouble" parse-double-or-throw)
|
||||||
(cons "parseDouble" parse-double-or-throw)
|
|
||||||
(cons "valueOf" ->double)
|
(cons "valueOf" ->double)
|
||||||
(cons "toString" (lambda (x) (jolt-str-render-one (->double x))))
|
(cons "toString" (lambda (x) (jolt-str-render-one (->double x))))
|
||||||
(cons "isNaN" (lambda (x) (and (flonum? x) (nan? x))))
|
(cons "isNaN" (lambda (x) (and (flonum? x) (nan? x))))
|
||||||
|
|
@ -266,21 +151,14 @@
|
||||||
(cons "MAX_VALUE" 1.7976931348623157e308) (cons "MIN_VALUE" 4.9e-324)
|
(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)))
|
(cons "POSITIVE_INFINITY" +inf.0) (cons "NEGATIVE_INFINITY" -inf.0) (cons "NaN" +nan.0)))
|
||||||
(register-class-statics! "Float"
|
(register-class-statics! "Float"
|
||||||
(list (cons "TYPE" "float")
|
(list (cons "parseFloat" parse-double-or-throw) (cons "valueOf" ->double)))
|
||||||
(cons "parseFloat" parse-double-or-throw) (cons "valueOf" ->double)))
|
|
||||||
|
|
||||||
;; Character: ASCII predicates (the engine is byte/ASCII oriented).
|
;; Character: ASCII predicates (the engine is byte/ASCII oriented).
|
||||||
(register-class-statics! "Character"
|
(register-class-statics! "Character"
|
||||||
(list (cons "TYPE" "char")
|
(list (cons "isUpperCase" (lambda (c) (let ((n (char-code c))) (and (>= n 65) (<= n 90)))))
|
||||||
(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 "isLowerCase" (lambda (c) (let ((n (char-code c))) (and (>= n 97) (<= n 122)))))
|
||||||
(cons "isDigit" (lambda (c) (let ((n (char-code c))) (and (>= n 48) (<= n 57)))))
|
(cons "isDigit" (lambda (c) (let ((n (char-code c))) (and (>= n 48) (<= n 57)))))
|
||||||
;; JVM Character.isWhitespace: Unicode whitespace (so U+2028 line separator
|
(cons "isWhitespace" (lambda (c) (char<=? (integer->char (char-code c)) #\space)))))
|
||||||
;; 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/valueOf(Object): "null" for nil, else jolt's str semantics.
|
||||||
;; String/format(fmt args…) / (locale fmt args…) -> the clojure.core format engine.
|
;; String/format(fmt args…) / (locale fmt args…) -> the clojure.core format engine.
|
||||||
|
|
@ -336,22 +214,12 @@
|
||||||
;; class object; anything else throws a catchable ClassNotFoundException, like the
|
;; class object; anything else throws a catchable ClassNotFoundException, like the
|
||||||
;; JVM — so the common `(try (Class/forName "optional.Dep") (catch …))` probe a
|
;; 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).
|
;; 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)
|
(define (forname-known? nm)
|
||||||
;; exact lookups only — lookup-class would fall back to the short class name, so
|
(or (lookup-class class-statics-tbl nm)
|
||||||
;; any "x.y.Class" would spuriously match the registered java.lang.Class.
|
(lookup-class class-ctors-tbl nm)
|
||||||
(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))
|
(let ((pre? (lambda (p) (and (>= (string-length nm) (string-length p))
|
||||||
(string=? (substring nm 0 (string-length p)) p)))))
|
(string=? (substring nm 0 (string-length p)) p)))))
|
||||||
(and (or (pre? "java.") (pre? "clojure.") (pre? "jolt."))
|
(or (pre? "java.") (pre? "clojure.") (pre? "jolt.")))))
|
||||||
(not (exists pre? forname-absent-prefixes))))))
|
|
||||||
(register-class-statics! "Class"
|
(register-class-statics! "Class"
|
||||||
(list (cons "forName"
|
(list (cons "forName"
|
||||||
(lambda (nm . _)
|
(lambda (nm . _)
|
||||||
|
|
@ -56,56 +56,26 @@
|
||||||
|
|
||||||
;; record-method-dispatch (records.ss) gets a jhost arm: dispatch (.method obj a*)
|
;; record-method-dispatch (records.ss) gets a jhost arm: dispatch (.method obj a*)
|
||||||
;; through the tag's method table.
|
;; through the tag's method table.
|
||||||
;; clojure.lang.Sorted on jolt's sorted-map / sorted-set: comparator / entryKey /
|
(define %hs-record-method-dispatch record-method-dispatch)
|
||||||
;; seqFrom / seq. data.priority-map's subseq/rsubseq reach for these (its
|
(set! record-method-dispatch
|
||||||
;; 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)
|
(lambda (obj method-name rest-args)
|
||||||
(cond
|
(cond
|
||||||
|
;; (.getClass x) is universal — the class token for any value (incl. numbers
|
||||||
|
;; / jhost) — before the per-type arms that would otherwise reject it.
|
||||||
|
((string=? method-name "getClass") (jolt-class obj))
|
||||||
((jhost? obj)
|
((jhost? obj)
|
||||||
(let ((mh (hashtable-ref host-methods-tbl (jhost-tag obj) #f)))
|
(let ((mh (hashtable-ref host-methods-tbl (jhost-tag obj) #f)))
|
||||||
(let ((f (and mh (hashtable-ref mh method-name #f))))
|
(let ((f (and mh (hashtable-ref mh method-name #f))))
|
||||||
(if f
|
(if f
|
||||||
(apply f obj (if (jolt-nil? rest-args) '() (seq->list rest-args)))
|
(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)))))))
|
(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))))
|
((number? obj) (number-method method-name obj))
|
||||||
(else 'pass))))
|
(else (%hs-record-method-dispatch obj method-name rest-args)))))
|
||||||
|
|
||||||
;; java.lang.Number method surface (the boxed-number methods cljc code calls). The
|
;; java.lang.Number method surface (the boxed-number methods cljc code calls). The
|
||||||
;; integer projections wrap modulo their width (ring-codec relies on byteValue
|
;; integer projections wrap modulo their width (ring-codec relies on byteValue
|
||||||
;; overflow: (.byteValue 255) => -1); the float projections are identity flonums.
|
;; overflow: (.byteValue 255) => -1); the float projections are identity flonums.
|
||||||
(define (number-method method n . args)
|
(define (number-method method n)
|
||||||
(cond
|
(cond
|
||||||
((string=? method "byteValue") (let ((b (modulo (jnum->exact n) 256))) (->num (if (>= b 128) (- b 256) b))))
|
((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 "shortValue") (let ((b (modulo (jnum->exact n) 65536))) (->num (if (>= b 32768) (- b 65536) b))))
|
||||||
|
|
@ -113,27 +83,11 @@
|
||||||
((string=? method "longValue") (->num (jnum->exact n)))
|
((string=? method "longValue") (->num (jnum->exact n)))
|
||||||
((string=? method "doubleValue") (->num n))
|
((string=? method "doubleValue") (->num n))
|
||||||
((string=? method "floatValue") (->num n))
|
((string=? method "floatValue") (->num n))
|
||||||
;; .toString(radix) — BigInteger/Integer render in a base, lowercase like the
|
((string=? method "toString") (jolt-num->string n))
|
||||||
;; 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)))
|
((string=? method "hashCode") (->num (jnum->exact n)))
|
||||||
;; Double/Float .isNaN / .isInfinite (a non-flonum is neither).
|
;; Double/Float .isNaN / .isInfinite (a non-flonum is neither).
|
||||||
((string=? method "isNaN") (and (flonum? n) (not (= n n))))
|
((string=? method "isNaN") (and (flonum? n) (not (= n n))))
|
||||||
((string=? method "isInfinite") (and (flonum? n) (infinite? 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")))))
|
(else (error #f (string-append "No method " method " for number")))))
|
||||||
|
|
||||||
;; Mutable static fields: "Class" -> (member -> 1-vector cell). A library that
|
;; Mutable static fields: "Class" -> (member -> 1-vector cell). A library that
|
||||||
|
|
@ -194,9 +148,8 @@
|
||||||
(and n (integer? n) (->num n))))
|
(and n (integer? n) (->num n))))
|
||||||
(define (parse-int-or-throw s radix what)
|
(define (parse-int-or-throw s radix what)
|
||||||
(or (parse-int-str s radix)
|
(or (parse-int-str s radix)
|
||||||
(jolt-throw (jolt-host-throwable "java.lang.NumberFormatException"
|
(error #f (string-append "NumberFormatException: For input string: \""
|
||||||
(string-append "For input string: \""
|
(if (string? s) s (jolt-str-render-one s)) "\""))))
|
||||||
(if (string? s) s (jolt-str-render-one s)) "\"")))))
|
|
||||||
(define (char-code c) (if (char? c) (char->integer c) (jnum->exact c)))
|
(define (char-code c) (if (char? c) (char->integer c) (jnum->exact c)))
|
||||||
|
|
||||||
;; parse a double string (Double/parseDouble, (Double. s)); JVM accepts NaN /
|
;; parse a double string (Double/parseDouble, (Double. s)); JVM accepts NaN /
|
||||||
|
|
@ -210,8 +163,7 @@
|
||||||
(else (let ((n (string->number t))) (and n (real? n) (exact->inexact n)))))))
|
(else (let ((n (string->number t))) (and n (real? n) (exact->inexact n)))))))
|
||||||
(define (parse-double-or-throw s)
|
(define (parse-double-or-throw s)
|
||||||
(or (parse-double-str s)
|
(or (parse-double-str s)
|
||||||
(jolt-throw (jolt-host-throwable "java.lang.NumberFormatException"
|
(error #f (string-append "NumberFormatException: For input string: \""
|
||||||
(string-append "For input string: \""
|
(if (string? s) s (jolt-str-render-one s)) "\""))))
|
||||||
(if (string? s) s (jolt-str-render-one s)) "\"")))))
|
|
||||||
(define (->double x) (if (number? x) (exact->inexact x) (parse-double-or-throw x)))
|
(define (->double x) (if (number? x) (exact->inexact x) (parse-double-or-throw x)))
|
||||||
|
|
||||||
|
|
@ -113,7 +113,7 @@
|
||||||
(define %h-set? jolt-set?)
|
(define %h-set? jolt-set?)
|
||||||
(set! jolt-set? (lambda (x) (or (htable-sorted-set? x) (%h-set? x))))
|
(set! jolt-set? (lambda (x) (or (htable-sorted-set? x) (%h-set? x))))
|
||||||
(def-var! "clojure.core" "set?" jolt-set?)
|
(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))))
|
(def-var! "clojure.core" "coll?" (lambda (x) (or (htable-sorted? x) (jrec? x) (jolt-coll-pred? x))))
|
||||||
|
|
||||||
;; --- equality / hash ---------------------------------------------------------
|
;; --- equality / hash ---------------------------------------------------------
|
||||||
;; A sorted coll canonicalizes like its unordered counterpart:
|
;; A sorted coll canonicalizes like its unordered counterpart:
|
||||||
|
|
|
||||||
|
|
@ -179,12 +179,8 @@
|
||||||
(else (loop (+ i 1)))))))
|
(else (loop (+ i 1)))))))
|
||||||
(define (parse-ms pattern input)
|
(define (parse-ms pattern input)
|
||||||
(let ((pn (string-length pattern)) (inn (string-length 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))
|
(y 1970) (mo 1) (d 1) (hh 0) (mi 0) (ss 0) (pm 'none))
|
||||||
;; a parse failure is a java.time.format.DateTimeParseException (typed, so a
|
(define (pfail) (error #f (string-append "ParseException: unparseable date \"" input "\"")))
|
||||||
;; (catch DateTimeParseException …) over a bad date matches), like the JVM.
|
|
||||||
(define (pfail)
|
|
||||||
(jolt-throw (jolt-host-throwable "java.time.format.DateTimeParseException"
|
|
||||||
(string-append "unparseable date \"" input "\"") jolt-nil)))
|
|
||||||
(define (run-len i c) (let loop ((j i)) (if (and (< j pn) (char=? (string-ref pattern j) c)) (loop (+ j 1)) (- j i))))
|
(define (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.
|
;; 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.
|
;; HHmm) caps the read at its run length so adjacent numeric fields split.
|
||||||
|
|
@ -208,7 +204,7 @@
|
||||||
(begin
|
(begin
|
||||||
(when (eq? pm 'pm) (when (< hh 12) (set! hh (+ hh 12))))
|
(when (eq? pm 'pm) (when (< hh 12) (set! hh (+ hh 12))))
|
||||||
(when (eq? pm 'am) (when (= hh 12) (set! hh 0)))
|
(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)))
|
(make-jinst (* 1000 (+ (* (days-from-civil y mo d) 86400) (* hh 3600) (* mi 60) ss))))
|
||||||
(let ((c (string-ref pattern pi)))
|
(let ((c (string-ref pattern pi)))
|
||||||
(cond
|
(cond
|
||||||
((char-alphabetic? c)
|
((char-alphabetic? c)
|
||||||
|
|
@ -225,25 +221,7 @@
|
||||||
((char=? c #\d) (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! d (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))))
|
((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 #\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))))
|
((char=? c #\s) (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! ss (car r)) (loop (+ pi k) (cdr r))))
|
||||||
(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 #\E) (loop (+ pi k) (cdr (read-alpha ii))))
|
||||||
((char=? c #\a) (let ((r (read-alpha ii)))
|
((char=? c #\a) (let ((r (read-alpha ii)))
|
||||||
(set! pm (if (string=? (ascii-string-down (car r)) "pm") 'pm 'am))
|
(set! pm (if (string=? (ascii-string-down (car r)) "pm") 'pm 'am))
|
||||||
|
|
@ -280,10 +258,6 @@
|
||||||
|
|
||||||
(register-hash-arm! jinst? (lambda (x) (jolt-hash (jinst-ms x))))
|
(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
|
;; 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).
|
;; 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")))
|
(define (jt-instant-tag? x) (and (jhost? x) (string=? (jhost-tag x) "instant")))
|
||||||
|
|
@ -307,6 +281,7 @@
|
||||||
|
|
||||||
(define %it-type jolt-type)
|
(define %it-type jolt-type)
|
||||||
(set! jolt-type (lambda (x) (if (jinst? x) inst-type-kw (%it-type x))))
|
(set! jolt-type (lambda (x) (if (jinst? x) inst-type-kw (%it-type x))))
|
||||||
|
(def-var! "clojure.core" "type" jolt-type)
|
||||||
|
|
||||||
;; instance? java.util.Date -> a jinst; java.time.Instant/LocalDateTime -> the
|
;; instance? java.util.Date -> a jinst; java.time.Instant/LocalDateTime -> the
|
||||||
;; matching jhost tag. The instance? macro passes the class-name symbol.
|
;; matching jhost tag. The instance? macro passes the class-name symbol.
|
||||||
|
|
@ -562,7 +537,8 @@
|
||||||
(cons "format" (lambda (self d) (format-ms (vector-ref (jhost-state self) 0) (ms-of d))))))
|
(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).
|
;; a jinst's java.util.Date method surface (record-method-dispatch arm).
|
||||||
(register-method-arm! 40
|
(define %it-rmd record-method-dispatch)
|
||||||
|
(set! record-method-dispatch
|
||||||
(lambda (obj method-name rest-args)
|
(lambda (obj method-name rest-args)
|
||||||
(cond
|
(cond
|
||||||
((jinst? obj)
|
((jinst? obj)
|
||||||
|
|
@ -585,7 +561,7 @@
|
||||||
((string=? method-name "before") (< (jinst-ms obj) (ms-of (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)))))
|
((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 (error #f (string-append "No method " method-name " on Date")))))
|
||||||
(else 'pass))))
|
(else (%it-rmd obj method-name rest-args)))))
|
||||||
|
|
||||||
;; Clojure's built-in data readers, so a library that merges default-data-readers
|
;; 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.
|
;; or binds *data-readers* (e.g. aero's reader opts) resolves #inst / #uuid.
|
||||||
|
|
@ -29,70 +29,6 @@
|
||||||
(hashtable-set! embedded-resources name content))
|
(hashtable-set! embedded-resources name content))
|
||||||
(define-record-type embedded-res (fields name content) (nongenerative jolt-embres-v1))
|
(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
|
;; 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
|
;; 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
|
;; cwd-relative. (io/resource builds jfiles from the source roots directly, so it
|
||||||
|
|
@ -245,13 +181,14 @@
|
||||||
(else (loop (- i 1))))))
|
(else (loop (- i 1))))))
|
||||||
(else #f))))
|
(else #f))))
|
||||||
|
|
||||||
(register-method-arm! 41
|
(define %io-rmd record-method-dispatch)
|
||||||
|
(set! record-method-dispatch
|
||||||
(lambda (obj method-name rest-args)
|
(lambda (obj method-name rest-args)
|
||||||
(if (jfile? obj)
|
(if (jfile? obj)
|
||||||
(let* ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args)))
|
(let* ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args)))
|
||||||
(r (jfile-method obj method-name rest)))
|
(r (jfile-method obj method-name rest)))
|
||||||
(if r (car r) (error #f "no File method" method-name)))
|
(if r (car r) (error #f "no File method" method-name)))
|
||||||
'pass)))
|
(%io-rmd obj method-name rest-args))))
|
||||||
|
|
||||||
;; .isDirectory / .listFiles emit to jolt-host-call (rt.ss), not record-method-
|
;; .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
|
;; dispatch — the shims there assume a path STRING target. Make them jfile-aware
|
||||||
|
|
@ -382,6 +319,7 @@
|
||||||
(define io-kw-file (keyword "jolt" "file"))
|
(define io-kw-file (keyword "jolt" "file"))
|
||||||
(define %io-type jolt-type)
|
(define %io-type jolt-type)
|
||||||
(set! jolt-type (lambda (x) (if (jfile? x) io-kw-file (%io-type x))))
|
(set! jolt-type (lambda (x) (if (jfile? x) io-kw-file (%io-type x))))
|
||||||
|
(def-var! "clojure.core" "type" jolt-type)
|
||||||
|
|
||||||
;; (instance? java.io.File f): the instance? macro passes the class-name symbol;
|
;; (instance? java.io.File f): the instance? macro passes the class-name symbol;
|
||||||
;; match "File" / "java.io.File" (and any *.File) against a jfile.
|
;; match "File" / "java.io.File" (and any *.File) against a jfile.
|
||||||
|
|
@ -416,11 +354,6 @@
|
||||||
;; method (a no-op for in-memory streams); absent method -> no-op.
|
;; 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)
|
((htable? x) (guard (e (#t jolt-nil)) (record-method-dispatch x "close" jolt-nil)) jolt-nil)
|
||||||
((jfile? x) 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
|
(else
|
||||||
(let ((closef (jolt-get x (keyword #f "close") jolt-nil)))
|
(let ((closef (jolt-get x (keyword #f "close") jolt-nil)))
|
||||||
(if (and (not (jolt-nil? closef)) (procedure? closef))
|
(if (and (not (jolt-nil? closef)) (procedure? closef))
|
||||||
|
|
@ -524,29 +457,6 @@
|
||||||
(if (jolt-nil? u) jolt-nil (host-new "StringReader" (jolt-slurp (url-strip-scheme (url-spec u))))))))))
|
(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! "ClassLoader" (list (cons "getSystemClassLoader" (lambda () the-classloader))))
|
||||||
(register-class-statics! "java.lang.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
|
;; Thread/currentThread -> a fresh thread jhost wrapping THIS thread's interrupt
|
||||||
;; flag (the box from current-interrupt-box, host-static.ss), so .interrupt from
|
;; 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
|
;; any thread sets the target thread's flag and .isInterrupted reads it without
|
||||||
|
|
@ -555,11 +465,6 @@
|
||||||
(register-host-methods! "thread"
|
(register-host-methods! "thread"
|
||||||
(list (cons "getContextClassLoader" (lambda (self) the-classloader))
|
(list (cons "getContextClassLoader" (lambda (self) the-classloader))
|
||||||
(cons "getName" (lambda (self) "main"))
|
(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)
|
(cons "interrupt" (lambda (self)
|
||||||
(when (box? (jhost-state self)) (set-box! (jhost-state self) #t))
|
(when (box? (jhost-state self)) (set-box! (jhost-state self) #t))
|
||||||
jolt-nil))
|
jolt-nil))
|
||||||
|
|
@ -609,51 +514,7 @@
|
||||||
(register-class-statics! "java.util.UUID"
|
(register-class-statics! "java.util.UUID"
|
||||||
(list (cons "randomUUID" (lambda () (jolt-random-uuid)))
|
(list (cons "randomUUID" (lambda () (jolt-random-uuid)))
|
||||||
(cons "fromString" (lambda (s) (jolt-parse-uuid (jolt-str-render-one s))))))
|
(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
|
(register-class-ctor! "UUID" (lambda (s) (jolt-parse-uuid (jolt-str-render-one 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 -----------------------------------------------------------
|
;; --- java.net.URI -----------------------------------------------------------
|
||||||
;; A minimal RFC-3986 split into scheme/authority/host/port/path/query/fragment,
|
;; A minimal RFC-3986 split into scheme/authority/host/port/path/query/fragment,
|
||||||
|
|
@ -722,9 +583,6 @@
|
||||||
(define (uri-field u k) (let ((p (assq k (jhost-state u)))) (if p (cdr p) 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! "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))))
|
(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"
|
(register-host-methods! "uri"
|
||||||
(list (cons "toString" (lambda (u) (uri-field u 'string)))
|
(list (cons "toString" (lambda (u) (uri-field u 'string)))
|
||||||
(cons "toASCIIString" (lambda (u) (uri-field u 'string)))
|
(cons "toASCIIString" (lambda (u) (uri-field u 'string)))
|
||||||
|
|
@ -741,14 +599,6 @@
|
||||||
(cons "hashCode" (lambda (u) (string-hash (uri-field u 'string))))
|
(cons "hashCode" (lambda (u) (string-hash (uri-field u 'string))))
|
||||||
(cons "equals" (lambda (u o) (and (jhost? o) (string=? (jhost-tag o) "uri")
|
(cons "equals" (lambda (u o) (and (jhost? o) (string=? (jhost-tag o) "uri")
|
||||||
(string=? (uri-field u 'string) (uri-field o 'string)))))))
|
(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.
|
;; str / pr-str of a uri -> its string form.
|
||||||
(register-str-render! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "uri")))
|
(register-str-render! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "uri")))
|
||||||
(lambda (x) (uri-field x 'string)))
|
(lambda (x) (uri-field x 'string)))
|
||||||
|
|
@ -1116,37 +1116,20 @@
|
||||||
((string=? f "PROLEPTIC_MONTH") (+ (* y 12) (- m 1)))
|
((string=? f "PROLEPTIC_MONTH") (+ (* y 12) (- m 1)))
|
||||||
((string=? f "YEAR_OF_ERA") (if (>= y 1) y (- 1 y)))
|
((string=? f "YEAR_OF_ERA") (if (>= y 1) y (- 1 y)))
|
||||||
((string=? f "ERA") (if (>= y 1) 1 0))
|
((string=? f "ERA") (if (>= y 1) 1 0))
|
||||||
;; aligned-* group the day-of-month/year into 7-day blocks from the
|
|
||||||
;; 1st (java.time): the within-block weekday is ((n-1) mod 7)+1, the
|
|
||||||
;; block number is ((n-1) quotient 7)+1.
|
|
||||||
((string=? f "ALIGNED_DAY_OF_WEEK_IN_MONTH") (+ (modulo (- d 1) 7) 1))
|
|
||||||
((string=? f "ALIGNED_WEEK_OF_MONTH") (+ (quotient (- d 1) 7) 1))
|
|
||||||
((string=? f "ALIGNED_DAY_OF_WEEK_IN_YEAR")
|
|
||||||
(+ (modulo (- (ld-day-of-year (ld-epoch-day t)) 1) 7) 1))
|
|
||||||
((string=? f "ALIGNED_WEEK_OF_YEAR")
|
|
||||||
(+ (quotient (- (ld-day-of-year (ld-epoch-day t)) 1) 7) 1))
|
|
||||||
(else (error #f (string-append "LocalDate has no field " f)))))))
|
(else (error #f (string-append "LocalDate has no field " f)))))))
|
||||||
((jt-time? t)
|
((jt-time? t)
|
||||||
(cond ((string=? f "HOUR_OF_DAY") (lt-hour t)) ((string=? f "MINUTE_OF_HOUR") (lt-minute t))
|
(cond ((string=? f "HOUR_OF_DAY") (lt-hour t)) ((string=? f "MINUTE_OF_HOUR") (lt-minute t))
|
||||||
((string=? f "SECOND_OF_MINUTE") (lt-second t)) ((string=? f "NANO_OF_SECOND") (lt-nano t))
|
((string=? f "SECOND_OF_MINUTE") (lt-second t)) ((string=? f "NANO_OF_SECOND") (lt-nano t))
|
||||||
((string=? f "NANO_OF_DAY") (lt-nano-of-day t))
|
((string=? f "NANO_OF_DAY") (lt-nano-of-day t))
|
||||||
((string=? f "MILLI_OF_DAY") (quotient (lt-nano-of-day t) 1000000))
|
((string=? f "MILLI_OF_DAY") (quotient (lt-nano-of-day t) 1000000))
|
||||||
((string=? f "MICRO_OF_DAY") (quotient (lt-nano-of-day t) 1000))
|
|
||||||
((string=? f "SECOND_OF_DAY") (quotient (lt-nano-of-day t) nanos-per-sec))
|
((string=? f "SECOND_OF_DAY") (quotient (lt-nano-of-day t) nanos-per-sec))
|
||||||
((string=? f "MINUTE_OF_DAY") (quotient (lt-nano-of-day t) (* 60 nanos-per-sec)))
|
((string=? f "MINUTE_OF_DAY") (quotient (lt-nano-of-day t) (* 60 nanos-per-sec)))
|
||||||
((string=? f "MILLI_OF_SECOND") (quotient (lt-nano t) 1000000))
|
((string=? f "MILLI_OF_SECOND") (quotient (lt-nano t) 1000000))
|
||||||
((string=? f "MICRO_OF_SECOND") (quotient (lt-nano t) 1000))
|
((string=? f "MICRO_OF_SECOND") (quotient (lt-nano t) 1000))
|
||||||
;; CLOCK_HOUR_OF_DAY is 1..24 (midnight is 24), HOUR_OF_AMPM 0..11,
|
|
||||||
;; CLOCK_HOUR_OF_AMPM 1..12, AMPM_OF_DAY 0 (AM) / 1 (PM).
|
|
||||||
((string=? f "CLOCK_HOUR_OF_DAY") (let ((h (lt-hour t))) (if (= h 0) 24 h)))
|
|
||||||
((string=? f "HOUR_OF_AMPM") (modulo (lt-hour t) 12))
|
|
||||||
((string=? f "CLOCK_HOUR_OF_AMPM") (let ((h (modulo (lt-hour t) 12))) (if (= h 0) 12 h)))
|
|
||||||
((string=? f "AMPM_OF_DAY") (quotient (lt-hour t) 12))
|
((string=? f "AMPM_OF_DAY") (quotient (lt-hour t) 12))
|
||||||
(else (error #f (string-append "LocalTime has no field " f)))))
|
(else (error #f (string-append "LocalTime has no field " f)))))
|
||||||
((jt-dt? t)
|
((jt-dt? t)
|
||||||
;; route a field to whichever part supports it (date fields incl. the
|
(if (member f '("YEAR" "MONTH_OF_YEAR" "DAY_OF_MONTH" "DAY_OF_WEEK" "DAY_OF_YEAR" "EPOCH_DAY" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "ERA"))
|
||||||
;; aligned-* group to the date, the rest to the time).
|
|
||||||
(if (temporal-supports-field? (ldt-date t) f)
|
|
||||||
(temporal-get-field (ldt-date t) f)
|
(temporal-get-field (ldt-date t) f)
|
||||||
(temporal-get-field (ldt-time t) f)))
|
(temporal-get-field (ldt-time t) f)))
|
||||||
((jt-instant? t)
|
((jt-instant? t)
|
||||||
|
|
@ -1155,17 +1138,6 @@
|
||||||
((string=? f "MILLI_OF_SECOND") (jt-floor-div (jt-floor-mod (inst-nanos t) nanos-per-sec) 1000000))
|
((string=? f "MILLI_OF_SECOND") (jt-floor-div (jt-floor-mod (inst-nanos t) nanos-per-sec) 1000000))
|
||||||
((string=? f "MICRO_OF_SECOND") (jt-floor-div (jt-floor-mod (inst-nanos t) nanos-per-sec) 1000))
|
((string=? f "MICRO_OF_SECOND") (jt-floor-div (jt-floor-mod (inst-nanos t) nanos-per-sec) 1000))
|
||||||
(else (error #f (string-append "Instant has no field " f)))))
|
(else (error #f (string-append "Instant has no field " f)))))
|
||||||
((and (jhost? t) (string=? (jhost-tag t) "year"))
|
|
||||||
(let ((y (year-val t)))
|
|
||||||
(cond ((string=? f "YEAR") y) ((string=? f "YEAR_OF_ERA") (if (>= y 1) y (- 1 y)))
|
|
||||||
((string=? f "ERA") (if (>= y 1) 1 0))
|
|
||||||
(else (error #f (string-append "Year has no field " f))))))
|
|
||||||
((and (jhost? t) (string=? (jhost-tag t) "year-month"))
|
|
||||||
(let ((y (ym-year t)) (m (ym-month t)))
|
|
||||||
(cond ((string=? f "YEAR") y) ((string=? f "MONTH_OF_YEAR") m)
|
|
||||||
((string=? f "PROLEPTIC_MONTH") (+ (* y 12) (- m 1)))
|
|
||||||
((string=? f "YEAR_OF_ERA") (if (>= y 1) y (- 1 y))) ((string=? f "ERA") (if (>= y 1) 1 0))
|
|
||||||
(else (error #f (string-append "YearMonth has no field " f))))))
|
|
||||||
(else (error #f "get(field): unsupported temporal")))))
|
(else (error #f "get(field): unsupported temporal")))))
|
||||||
|
|
||||||
;; field set: (with temporal ChronoField value) -> a new temporal.
|
;; field set: (with temporal ChronoField value) -> a new temporal.
|
||||||
|
|
@ -1196,17 +1168,10 @@
|
||||||
(else #f))))
|
(else #f))))
|
||||||
(define (temporal-supports-field? t field)
|
(define (temporal-supports-field? t field)
|
||||||
(let ((f (string-upcase field)))
|
(let ((f (string-upcase field)))
|
||||||
(cond ((jt-date? t) (and (member f '("YEAR" "MONTH_OF_YEAR" "DAY_OF_MONTH" "DAY_OF_WEEK" "DAY_OF_YEAR" "EPOCH_DAY" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "ERA"
|
(cond ((jt-date? t) (and (member f '("YEAR" "MONTH_OF_YEAR" "DAY_OF_MONTH" "DAY_OF_WEEK" "DAY_OF_YEAR" "EPOCH_DAY" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "ERA")) #t))
|
||||||
"ALIGNED_DAY_OF_WEEK_IN_MONTH" "ALIGNED_DAY_OF_WEEK_IN_YEAR" "ALIGNED_WEEK_OF_MONTH" "ALIGNED_WEEK_OF_YEAR")) #t))
|
((jt-time? t) (and (member f '("HOUR_OF_DAY" "MINUTE_OF_HOUR" "SECOND_OF_MINUTE" "NANO_OF_SECOND" "NANO_OF_DAY" "MILLI_OF_DAY" "SECOND_OF_DAY" "MINUTE_OF_DAY" "MILLI_OF_SECOND" "MICRO_OF_SECOND" "AMPM_OF_DAY")) #t))
|
||||||
((jt-time? t) (and (member f '("HOUR_OF_DAY" "CLOCK_HOUR_OF_DAY" "HOUR_OF_AMPM" "CLOCK_HOUR_OF_AMPM" "AMPM_OF_DAY"
|
|
||||||
"MINUTE_OF_HOUR" "MINUTE_OF_DAY" "SECOND_OF_MINUTE" "SECOND_OF_DAY"
|
|
||||||
"MILLI_OF_SECOND" "MILLI_OF_DAY" "MICRO_OF_SECOND" "MICRO_OF_DAY"
|
|
||||||
"NANO_OF_SECOND" "NANO_OF_DAY")) #t))
|
|
||||||
((jt-dt? t) (or (temporal-supports-field? (ldt-date t) field) (temporal-supports-field? (ldt-time t) field)))
|
((jt-dt? t) (or (temporal-supports-field? (ldt-date t) field) (temporal-supports-field? (ldt-time t) field)))
|
||||||
((jt-instant? t) (and (member f '("INSTANT_SECONDS" "NANO_OF_SECOND" "MILLI_OF_SECOND" "MICRO_OF_SECOND")) #t))
|
((jt-instant? t) (and (member f '("INSTANT_SECONDS" "NANO_OF_SECOND" "MILLI_OF_SECOND" "MICRO_OF_SECOND")) #t))
|
||||||
((and (jhost? t) (string=? (jhost-tag t) "year")) (and (member f '("YEAR" "YEAR_OF_ERA" "ERA")) #t))
|
|
||||||
((and (jhost? t) (string=? (jhost-tag t) "year-month"))
|
|
||||||
(and (member f '("YEAR" "MONTH_OF_YEAR" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "ERA")) #t))
|
|
||||||
(else #f))))
|
(else #f))))
|
||||||
|
|
||||||
;; isSupported / get / getLong / with / range / plus / minus / until accept a
|
;; isSupported / get / getLong / with / range / plus / minus / until accept a
|
||||||
|
|
@ -1248,16 +1213,6 @@
|
||||||
(register-host-methods! "local-date" (mk-temporal-methods))
|
(register-host-methods! "local-date" (mk-temporal-methods))
|
||||||
(register-host-methods! "local-time" (mk-temporal-methods))
|
(register-host-methods! "local-time" (mk-temporal-methods))
|
||||||
(register-host-methods! "local-date-time" (mk-temporal-methods))
|
(register-host-methods! "local-date-time" (mk-temporal-methods))
|
||||||
;; Year/YearMonth answer the field accessors too (a fields-over-all-temporals walk
|
|
||||||
;; queries them); their own plus/minus/with stay the specific methods above.
|
|
||||||
(let ((field-methods
|
|
||||||
(list (cons "isSupported" (lambda (t x) (cond ((arg-is-unit? x) (temporal-supports-unit? t (cu-name x)))
|
|
||||||
((arg-is-field? x) (temporal-supports-field? t (cf-name x)))
|
|
||||||
(else #f))))
|
|
||||||
(cons "get" (lambda (t f) (temporal-get-field t (arg-field-name f))))
|
|
||||||
(cons "getLong" (lambda (t f) (temporal-get-field t (arg-field-name f)))))))
|
|
||||||
(register-host-methods! "year" field-methods)
|
|
||||||
(register-host-methods! "year-month" field-methods))
|
|
||||||
(register-host-methods! "instant" (mk-temporal-methods))
|
(register-host-methods! "instant" (mk-temporal-methods))
|
||||||
|
|
||||||
;; --- TemporalAdjuster: a date->date transform applied via (.with t adjuster) --
|
;; --- TemporalAdjuster: a date->date transform applied via (.with t adjuster) --
|
||||||
|
|
@ -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,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)"
|
|
||||||
|
|
@ -49,13 +49,6 @@
|
||||||
(cseq-lazy x (lambda () (force-lazyseq coll)))
|
(cseq-lazy x (lambda () (force-lazyseq coll)))
|
||||||
(%ls-cons x 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
|
;; 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
|
;; 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
|
;; compares (= [1 3 5] (take-nth 2 …)) against the raw lazyseq, and jolt=2 would
|
||||||
|
|
@ -72,15 +65,10 @@
|
||||||
(set! jolt-nth (case-lambda
|
(set! jolt-nth (case-lambda
|
||||||
((coll i) (if (jolt-lazyseq? coll) (%ls-nth (jolt-seq coll) i) (%ls-nth coll i)))
|
((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)))))
|
((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
|
;; a lazy seq prints as its realized seq — force, then re-dispatch through the printer.
|
||||||
;; printer. An empty realized lazy seq is still a sequence, printing "()" (like a
|
(register-pr-str-arm! jolt-lazyseq? (lambda (x) (jolt-pr-str (jolt-seq x))))
|
||||||
;; JVM LazySeq), not "nil" — so (lazy-seq nil) and (rest '(1)) render "()".
|
(register-pr-readable-arm! jolt-lazyseq? (lambda (x) (jolt-pr-readable (jolt-seq x))))
|
||||||
(register-pr-str-arm! jolt-lazyseq?
|
(register-str-render! jolt-lazyseq? (lambda (x) (jolt-str-render-one (jolt-seq x))))
|
||||||
(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
|
;; 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
|
;; record). Unlike the native-op dispatchers above (called via a direct top-level
|
||||||
|
|
|
||||||
|
|
@ -57,25 +57,9 @@
|
||||||
((and (pmap? x) (eq? (jolt-get x rdr-kw-jolt-type) rdr-kw-jolt-tagged))
|
((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)))
|
(let ((rdr (data-reader-symbol (jolt-get x rdr-kw-tag)))
|
||||||
(inner (ldr-apply-readers (jolt-get x rdr-kw-form))))
|
(inner (ldr-apply-readers (jolt-get x rdr-kw-form))))
|
||||||
(cond
|
(cond (rdr (jolt-list rdr (jolt-list (jolt-symbol #f "quote") inner)))
|
||||||
(rdr
|
((eq? inner (jolt-get x rdr-kw-form)) x)
|
||||||
;; Clojure applies a data reader at read time and substitutes its result
|
(else (rdr-make-tagged (jolt-get x rdr-kw-tag) inner)))))
|
||||||
;; 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)
|
((rdr-set-form? x)
|
||||||
(let-values (((items changed) (ldr-conv-each (seq->list (jolt-get x rdr-kw-value)))))
|
(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)))
|
(if changed (rdr-carry-meta x (rdr-make-set items)) x)))
|
||||||
|
|
@ -138,31 +122,14 @@
|
||||||
(else (loop (cdr cs) (cons (car cs) 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.
|
;; 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)
|
(define (resolve-on-roots rel)
|
||||||
(let ((eclj (string-append rel ".clj")) (ecljc (string-append rel ".cljc")))
|
(let loop ((roots source-roots))
|
||||||
(cond
|
(if (null? roots) #f
|
||||||
((string? (hashtable-ref embedded-resources eclj #f)) eclj)
|
(let ((clj (string-append (car roots) "/" rel ".clj"))
|
||||||
((string? (hashtable-ref embedded-resources ecljc #f)) ecljc)
|
(cljc (string-append (car roots) "/" rel ".cljc")))
|
||||||
(else
|
(cond ((file-exists? clj) clj)
|
||||||
(let loop ((roots source-roots))
|
((file-exists? cljc) cljc)
|
||||||
(if (null? roots) #f
|
(else (loop (cdr roots))))))))
|
||||||
(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)))
|
(define (find-ns-file name) (resolve-on-roots (ns-name->rel name)))
|
||||||
|
|
||||||
|
|
@ -174,14 +141,6 @@
|
||||||
(vector-for-each (lambda (c) (hashtable-set! loaded-ns (var-cell-ns c) #t))
|
(vector-for-each (lambda (c) (hashtable-set! loaded-ns (var-cell-ns c) #t))
|
||||||
(hashtable-values var-table))
|
(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
|
;; 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`
|
;; 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
|
;; binary — exists in memory with no source file; a later `require` of it must
|
||||||
|
|
@ -209,21 +168,18 @@
|
||||||
;; more forms", which would silently drop the entire rest of the file; here we
|
;; 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.
|
;; skip the no-op form and continue to true end-of-string.
|
||||||
(define (load-jolt-file path)
|
(define (load-jolt-file path)
|
||||||
(let* ((src (ldr-read-source path)) (end (string-length src)))
|
(let* ((src (read-file-string path)) (end (string-length src)))
|
||||||
;; parameterize (not a bare set!) so a require nested in this file's ns form
|
(let loop ((i 0))
|
||||||
;; restores path when control returns to the rest of this file.
|
(when (< i end)
|
||||||
(parameterize ((rdr-source-file path)) ; list forms read here carry :file = path
|
(let-values (((form j) (rdr-read-form src i end)))
|
||||||
(let loop ((i 0))
|
(when (> j i)
|
||||||
(when (< i end)
|
(unless (rdr-eof? form)
|
||||||
(let-values (((form j) (rdr-read-form src i end)))
|
(when (getenv "JOLT_TRACE_LOAD")
|
||||||
(when (> j i)
|
(display " [load-form] " (current-error-port))
|
||||||
(unless (rdr-eof? form)
|
(display (jolt-pr-str form) (current-error-port)) (newline (current-error-port)))
|
||||||
(when (getenv "JOLT_TRACE_LOAD")
|
(jolt-compile-eval-form (if data-readers-active (ldr-apply-readers form) form)
|
||||||
(display " [load-form] " (current-error-port))
|
(chez-current-ns)))
|
||||||
(display (jolt-pr-str form) (current-error-port)) (newline (current-error-port)))
|
(loop j)))))))
|
||||||
(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
|
;; 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
|
;; dependency cycle terminates (Clojure's behavior). The caller's current ns is
|
||||||
|
|
@ -260,93 +216,50 @@
|
||||||
(else '()))))
|
(else '()))))
|
||||||
(and (pair? items) (symbol-t? (car items)) (symbol-t-name (car items)))))
|
(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 ---------------------------------------------------
|
;; --- require/use that LOAD ---------------------------------------------------
|
||||||
;; Override the alias-only versions from natives-str.ss. Load each spec's target
|
;; 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
|
;; (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).
|
;; ns (chez-register-spec! reads the current ns, restored by load-namespace).
|
||||||
(define (loader-require . specs)
|
(define (loader-require . specs)
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (s0)
|
(lambda (s)
|
||||||
(for-each
|
(let ((target (spec-target-name s)))
|
||||||
(lambda (s)
|
(when target (load-namespace target)))
|
||||||
(let ((target (spec-target-name s)))
|
(chez-register-spec! (chez-current-ns) s))
|
||||||
(when target (load-namespace target)))
|
|
||||||
(chez-register-spec! (chez-current-ns) s))
|
|
||||||
(expand-spec s0)))
|
|
||||||
specs)
|
specs)
|
||||||
jolt-nil)
|
jolt-nil)
|
||||||
(def-var! "clojure.core" "require" loader-require)
|
(def-var! "clojure.core" "require" loader-require)
|
||||||
|
|
||||||
(define (loader-use . specs0)
|
(define (loader-use . specs)
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (spec0)
|
(lambda (spec)
|
||||||
(for-each
|
(let ((target (spec-target-name spec)))
|
||||||
(lambda (spec)
|
(when target (load-namespace target)))
|
||||||
(let ((target (spec-target-name spec)))
|
(chez-register-spec! (chez-current-ns) spec)
|
||||||
(when target (load-namespace target)))
|
(let* ((items (cond ((pvec? spec) (seq->list spec))
|
||||||
(chez-register-spec! (chez-current-ns) spec)
|
((or (cseq? spec) (empty-list-t? spec)) (seq->list spec))
|
||||||
(let* ((items (cond ((pvec? spec) (seq->list spec))
|
((symbol-t? spec) (list spec))
|
||||||
((symbol-t? spec) (list spec))
|
(else '())))
|
||||||
(else '())))
|
(target (and (pair? items) (symbol-t? (car items)) (symbol-t-name (car items))))
|
||||||
(target (and (pair? items) (symbol-t? (car items)) (symbol-t-name (car items))))
|
(filtered (let scan ((xs (if (pair? items) (cdr items) '())))
|
||||||
(filtered (let scan ((xs (if (pair? items) (cdr items) '())))
|
(cond ((null? xs) #f)
|
||||||
(cond ((null? xs) #f)
|
((and (keyword? (car xs))
|
||||||
((and (keyword? (car xs))
|
(member (keyword-t-name (car xs)) '("only" "refer"))) #t)
|
||||||
(member (keyword-t-name (car xs)) '("only" "refer"))) #t)
|
(else (scan (cdr xs)))))))
|
||||||
(else (scan (cdr xs)))))))
|
(when (and target (not filtered))
|
||||||
(when (and target (not filtered))
|
(chez-register-refer-all! (chez-current-ns) target))))
|
||||||
(chez-register-refer-all! (chez-current-ns) target))))
|
specs)
|
||||||
(expand-spec spec0)))
|
|
||||||
specs0)
|
|
||||||
jolt-nil)
|
jolt-nil)
|
||||||
(def-var! "clojure.core" "use" loader-use)
|
(def-var! "clojure.core" "use" loader-use)
|
||||||
|
|
||||||
(def-var! "clojure.core" "load-file" jolt-load-file)
|
(def-var! "clojure.core" "load-file" jolt-load-file)
|
||||||
|
;; load: each arg is a "/"-rooted resource path like "/app/extra"; load the file
|
||||||
;; The directory of a namespace's resource path: "clojure.tools.reader-test" ->
|
;; for it relative to the search roots (strip the leading slash, try .clj/.cljc).
|
||||||
;; "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)
|
(define (jolt-load . paths)
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (p)
|
(lambda (p)
|
||||||
(let* ((rel (cond
|
(let* ((rel (if (and (> (string-length p) 0) (char=? (string-ref p 0) #\/))
|
||||||
((and (> (string-length p) 0) (char=? (string-ref p 0) #\/))
|
(substring p 1 (string-length p)) p))
|
||||||
(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)))
|
(f (resolve-on-roots rel)))
|
||||||
(if f (load-jolt-file f)
|
(if f (load-jolt-file f)
|
||||||
(error #f "Could not locate resource on source roots" p))))
|
(error #f "Could not locate resource on source roots" p))))
|
||||||
|
|
@ -384,14 +297,3 @@
|
||||||
(def-var! "jolt.host" "load-namespace" (lambda (n) (load-namespace n) jolt-nil))
|
(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" "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))))
|
(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")))
|
|
||||||
|
|
|
||||||
|
|
@ -61,36 +61,26 @@
|
||||||
|
|
||||||
(define (jolt-defmulti-setup name-sym dispatch . opts)
|
(define (jolt-defmulti-setup name-sym dispatch . opts)
|
||||||
(let-values (((dk h) (parse-mm-opts opts)))
|
(let-values (((dk h) (parse-mm-opts opts)))
|
||||||
(let* ((sns (symbol-t-ns name-sym))
|
(let ((mf (make-jolt-multifn (symbol-t-name name-sym) dispatch
|
||||||
;; the macro qualifies the name with its EXPANSION ns, so a defmulti
|
(new-mm-table) dk h (new-mm-table))))
|
||||||
;; deferred inside a fn (a deftest body) still defines in the ns it
|
(def-var! (chez-current-ns) (symbol-t-name name-sym) mf)
|
||||||
;; 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)))
|
mf)))
|
||||||
|
|
||||||
;; (defmethod-setup 'mm dispatch-val impl) — add a method. Auto-creates the multifn
|
;; (defmethod-setup 'mm dispatch-val impl) — add a method. Auto-creates the multifn
|
||||||
;; if absent (defmethod before defmulti — rare; identity dispatch as a fallback).
|
;; if absent (defmethod before defmulti — rare; identity dispatch as a fallback).
|
||||||
(define (jolt-defmethod-setup mm-sym dval impl . rest)
|
(define (jolt-defmethod-setup mm-sym dval impl)
|
||||||
(let* ((nm (symbol-t-name mm-sym))
|
(let* ((nm (symbol-t-name mm-sym))
|
||||||
(sns (symbol-t-ns mm-sym))
|
(sns (symbol-t-ns mm-sym))
|
||||||
(qns (and sns (not (jolt-nil? sns)) (not (null? sns)) sns))
|
(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);
|
;; 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
|
;; unqualified resolves in the current ns, else a :refer's home ns (so a
|
||||||
;; defmethod on a referred multifn lands on the real one), else stays in
|
;; defmethod on a referred multifn lands on the real one), else stays in
|
||||||
;; the writing ns (a shadow, as before).
|
;; the current ns (a shadow, as before).
|
||||||
(mns (cond
|
(mns (cond
|
||||||
(qns (or (chez-resolve-alias here qns) qns))
|
(qns (or (chez-resolve-alias (chez-current-ns) qns) qns))
|
||||||
((var-cell-lookup here nm) here)
|
((var-cell-lookup (chez-current-ns) nm) (chez-current-ns))
|
||||||
((chez-resolve-refer here nm) => values)
|
((chez-resolve-refer (chez-current-ns) nm) => values)
|
||||||
(else here)))
|
(else (chez-current-ns))))
|
||||||
(cur (var-deref mns nm))
|
(cur (var-deref mns nm))
|
||||||
(mf (if (jolt-multifn? cur) cur
|
(mf (if (jolt-multifn? cur) cur
|
||||||
;; auto-create: copy the dispatch fn + default from a same-named
|
;; auto-create: copy the dispatch fn + default from a same-named
|
||||||
|
|
|
||||||
|
|
@ -85,22 +85,42 @@
|
||||||
(define (na-bytes x) (if (and (jolt-array? x) (eq? (jolt-array-kind x) 'byte)) x (na-byte-array x)))
|
(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-bytes? x) (and (jolt-array? x) (eq? (jolt-array-kind x) 'byte)))
|
||||||
(define (na-identity x) x)
|
(define (na-identity x) x)
|
||||||
(define (na-byte x) (jolt-byte-cast x))
|
(define (na-byte x)
|
||||||
(define (na-short x) (jolt-short-cast x))
|
(let ((b (bitwise-and (exact (floor x)) #xff))) (if (>= b 128) (- b 256) b)))
|
||||||
|
(define (na-short x)
|
||||||
|
(let ((s (bitwise-and (exact (floor x)) #xffff))) (if (>= s #x8000) (- s #x10000) s)))
|
||||||
|
|
||||||
;; --- chunked seqs -----------------------------------------------------------
|
;; --- chunked seqs -----------------------------------------------------------
|
||||||
;; The chunked-seq accessors (chunked-seq? / chunk-first / chunk-rest / chunk-next)
|
;; A vector's seq is a REAL chunked-seq: (seq v) carries its backing vector +
|
||||||
;; live in seq.ss with the cseq core they read; here we only bind them plus the
|
;; element index (seq.ss cseq-vec), so chunked-seq? is true and chunk-first hands
|
||||||
;; chunk-builder API (clojure.lang.ChunkBuffer + chunk-cons). chunk-buffer collects
|
;; out a 32-element block (a pvec slice) while chunk-rest is the seq at the next
|
||||||
;; appended items, chunk seals them into a pvec chunk, and chunk-cons prepends that
|
;; block boundary — the Clojure/CLJS ChunkedSeq contract (chunk-first ++
|
||||||
;; chunk onto a rest seq as a real ChunkedCons (cseq-chunked) — empty chunk == just
|
;; chunk-rest == the seq). The eager buffer model (chunk-buffer/chunk-append/
|
||||||
;; the rest, like clojure.core/chunk-cons.
|
;; chunk) builds a plain cseq; chunk-cons/first/rest fall back to seq ops over it.
|
||||||
|
(define na-chunk-size 32)
|
||||||
(define-record-type jolt-chunkbuf (fields (mutable items)) (nongenerative jolt-chunkbuf-v1))
|
(define-record-type jolt-chunkbuf (fields (mutable items)) (nongenerative jolt-chunkbuf-v1))
|
||||||
(define (na-chunk-buffer cap) (make-jolt-chunkbuf '()))
|
(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-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 b) (list->cseq (jolt-chunkbuf-items b)))
|
||||||
(define (na-chunk-cons chunk rest)
|
(define (na-chunk-cons chunk rest) (jolt-concat chunk rest))
|
||||||
(if (fx=? 0 (pvec-count chunk)) rest (cseq-chunked chunk 0 rest)))
|
;; backing (vector . end-of-block index) for a vector-seq cell, or #f.
|
||||||
|
(define (na-vblock s)
|
||||||
|
(and (cseq? s) (cseq-cvec s)
|
||||||
|
(let* ((v (cseq-cvec s)) (i (cseq-ci s)))
|
||||||
|
(cons v (fxmin (fx+ i na-chunk-size) (pvec-count v))))))
|
||||||
|
(define (na-chunked-seq? x) (and (na-vblock x) #t))
|
||||||
|
(define (na-chunk-first s)
|
||||||
|
(let ((vb (na-vblock s)))
|
||||||
|
(if vb (make-pvec (vec-copy-range (pvec-v (car vb)) (cseq-ci s) (cdr vb)))
|
||||||
|
(jolt-first s)))) ; eager-buffer fallback
|
||||||
|
(define (na-chunk-rest s)
|
||||||
|
(let ((vb (na-vblock s)))
|
||||||
|
(if vb (if (fx>=? (cdr vb) (pvec-count (car vb))) jolt-empty-list (vec->seq (car vb) (cdr vb)))
|
||||||
|
(jolt-rest s))))
|
||||||
|
(define (na-chunk-next s)
|
||||||
|
(let ((vb (na-vblock s)))
|
||||||
|
(if vb (if (fx>=? (cdr vb) (pvec-count (car vb))) jolt-nil (vec->seq (car vb) (cdr vb)))
|
||||||
|
(jolt-next s))))
|
||||||
|
|
||||||
;; --- extend the collection dispatchers to see a jolt-array ------------------
|
;; --- extend the collection dispatchers to see a jolt-array ------------------
|
||||||
(define %na-count jolt-count)
|
(define %na-count jolt-count)
|
||||||
|
|
@ -115,11 +135,10 @@
|
||||||
(let ((v (jolt-array-vec c)) (j (exact (na-idx i))))
|
(let ((v (jolt-array-vec c)) (j (exact (na-idx i))))
|
||||||
(if (and (>= j 0) (< j (vector-length v))) (vector-ref v j) d))
|
(if (and (>= j 0) (< j (vector-length v))) (vector-ref v j) d))
|
||||||
(%na-nth c i 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)
|
(define %na-get jolt-get)
|
||||||
(set! jolt-get
|
(set! jolt-get
|
||||||
(case-lambda
|
(case-lambda
|
||||||
((c k) (if (jolt-array? c) (jolt-nth c k jolt-nil) (%na-get c k)))
|
((c k) (if (jolt-array? c) (jolt-nth c k) (%na-get c k)))
|
||||||
((c k d) (if (jolt-array? c) (jolt-nth c k d) (%na-get c k d)))))
|
((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.
|
;; 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/
|
;; count/nth/seq/get above are NATIVE-OPS (inlined at call sites), so aget/alength/
|
||||||
|
|
@ -137,6 +156,7 @@
|
||||||
;; (jolt-type …) for arrays, so extending jolt-type covers both.
|
;; (jolt-type …) for arrays, so extending jolt-type covers both.
|
||||||
(define %na-type jolt-type)
|
(define %na-type jolt-type)
|
||||||
(set! jolt-type (lambda (x) (if (jolt-array? x) (na-array-class-name x) (%na-type x))))
|
(set! jolt-type (lambda (x) (if (jolt-array? x) (na-array-class-name x) (%na-type x))))
|
||||||
|
(def-var! "clojure.core" "type" jolt-type)
|
||||||
|
|
||||||
;; instance? over an array class token ([I, [C, …). An array token reaches us as
|
;; 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
|
;; a string ("[C", from (Class/forName "[C")) — the dispatcher leaves it a string
|
||||||
|
|
@ -4,16 +4,15 @@
|
||||||
;; binds the public clojure.core names to them. Loaded after def-var! (rt.ss) +
|
;; 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.
|
;; the collections + seq tiers. hash-map/array-map/hash-set/set/rand semantics.
|
||||||
|
|
||||||
;; array-map: insertion-ordered, any size (Clojure's PersistentArrayMap, via
|
;; hash-map / hash-set: variadic kvs / elems straight onto the existing ctors.
|
||||||
;; createAsIfByAssoc). hash-map: hash order (PersistentHashMap). The map LITERAL
|
;; array-map: Clojure preserves insertion order, but jolt's `=` is structural and
|
||||||
;; ctor (jolt-hash-map, emitted for {...}) is array-ordered up to 8 entries and
|
;; the parity corpus compares by value, so a pmap is observationally equal for
|
||||||
;; hash beyond, matching RT.map.
|
;; the tested cases; keys-ordering is a separate (untested-here) concern.
|
||||||
(define (jolt-array-map . kvs) (jolt-array-map-build kvs))
|
(define (jolt-array-map . kvs) (apply jolt-hash-map 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
|
;; set: realize any seqable to a list, then dedup through the set ctor. nil -> #{}.
|
||||||
;; composition (apply hash-set (seq coll)) the compiler uses only off the emit path,
|
(define (jolt-set coll)
|
||||||
;; so the Clojure version lowers to the same code without a bootstrap cycle.
|
(if (jolt-nil? coll) (jolt-hash-set) (apply jolt-hash-set (seq->list coll))))
|
||||||
|
|
||||||
;; rand: a flonum in [0, n) (n defaults to 1.0) — jolt is all-flonum, so the
|
;; 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.
|
;; result is a double like every other number.
|
||||||
|
|
@ -21,8 +20,9 @@
|
||||||
(let ((r (random 1.0)))
|
(let ((r (random 1.0)))
|
||||||
(if (null? n) r (* r (exact->inexact (car n))))))
|
(if (null? n) r (* r (exact->inexact (car n))))))
|
||||||
|
|
||||||
(def-var! "clojure.core" "hash-map" jolt-hash-map-fn)
|
(def-var! "clojure.core" "hash-map" jolt-hash-map)
|
||||||
(def-var! "clojure.core" "hash-set" jolt-hash-set)
|
(def-var! "clojure.core" "hash-set" jolt-hash-set)
|
||||||
(def-var! "clojure.core" "array-map" jolt-array-map)
|
(def-var! "clojure.core" "array-map" jolt-array-map)
|
||||||
|
(def-var! "clojure.core" "set" jolt-set)
|
||||||
(def-var! "clojure.core" "rand" jolt-rand)
|
(def-var! "clojure.core" "rand" jolt-rand)
|
||||||
(def-var! "clojure.core" "map-entry?" jolt-map-entry?)
|
(def-var! "clojure.core" "map-entry?" jolt-map-entry?)
|
||||||
|
|
|
||||||
|
|
@ -22,45 +22,29 @@
|
||||||
(jolt-assoc (if user user (jolt-hash-map))
|
(jolt-assoc (if user user (jolt-hash-map))
|
||||||
jolt-kw-var-ns (var-cell-ns x)
|
jolt-kw-var-ns (var-cell-ns x)
|
||||||
jolt-kw-var-name (var-cell-name x))))
|
jolt-kw-var-name (var-cell-name x))))
|
||||||
;; a deftype implementing clojure.lang.IObj stores meta in a field and threads
|
((or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jolt-lazyseq? x) (jrec? x) (jreify? x) (procedure? x))
|
||||||
;; it through its own assoc/withMeta (core.logic's Substitutions/LVar/LCons),
|
(hashtable-ref meta-table x jolt-nil))
|
||||||
;; so dispatch to its meta method rather than the identity side-table — which
|
(else jolt-nil)))
|
||||||
;; 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
|
;; 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.
|
;; the original). cseq/procedure can't be copied meaningfully — keyed in place.
|
||||||
(define (meta-copy x)
|
(define (meta-copy x)
|
||||||
(cond
|
(cond
|
||||||
((pvec? x) (make-pvec (pvec-v x) (pvec-ent x)))
|
((pvec? x) (make-pvec (pvec-v x) (pvec-ent x)))
|
||||||
((pmap? x) (make-pmap (pmap-root x) (pmap-cnt x) (pmap-order x)))
|
((pmap? x) (make-pmap (pmap-root x) (pmap-cnt x)))
|
||||||
((pset? x) (make-pset (pset-m x)))
|
((pset? x) (make-pset (pset-m x)))
|
||||||
((jrec? x) (make-jrec (jrec-desc x) (jrec-vec-copy (jrec-vals x)) (jrec-ext x)))
|
((jrec? x) (make-jrec (jrec-tag x) (jrec-pairs x)))
|
||||||
;; a reify shares its (read-only) method table + protos but gets a fresh
|
;; a reify shares its (read-only) method table + protos but gets a fresh
|
||||||
;; identity, so attaching meta leaves the original's meta untouched. Every
|
;; identity, so attaching meta leaves the original's meta untouched. Every
|
||||||
;; Clojure reify implements IObj.
|
;; Clojure reify implements IObj.
|
||||||
((jreify? x) (make-jreify (jreify-methods x) (jreify-protos x)))
|
((jreify? x) (make-jreify (jreify-methods x) (jreify-protos x)))
|
||||||
;; () is a shared singleton — a fresh instance keeps meta off every other ().
|
;; () is a shared singleton — a fresh instance keeps meta off every other ().
|
||||||
((empty-list-t? x) (fresh-empty-list))
|
((empty-list-t? x) (fresh-empty-list))
|
||||||
;; a list/seq node gets a fresh identity too (Clojure's PersistentList is
|
(else x))) ; cseq / procedure
|
||||||
;; 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)
|
(define (jolt-with-meta x m)
|
||||||
(cond
|
(cond
|
||||||
((symbol-t? x) (make-symbol-t (symbol-t-ns x) (symbol-t-name x) m))
|
((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))
|
((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)))
|
(let ((c (meta-copy x)))
|
||||||
(if (jolt-nil? m) (hashtable-delete! meta-table c) (hashtable-set! meta-table c m))
|
(if (jolt-nil? m) (hashtable-delete! meta-table c) (hashtable-set! meta-table c m))
|
||||||
|
|
@ -148,10 +132,4 @@
|
||||||
((procedure? x) ty-fn)
|
((procedure? x) ty-fn)
|
||||||
(else ty-object))))
|
(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)
|
(def-var! "clojure.core" "type" jolt-type)
|
||||||
|
|
|
||||||
|
|
@ -17,12 +17,11 @@
|
||||||
(define (jolt-bit-clear x n) (bitwise-and (->int x) (bitwise-not (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-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)))))
|
(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 >>>),
|
;; unsigned-bit-shift-right: logical shift over 64-bit longs. For the common
|
||||||
;; so a negative operand shifts in zeros from its 64-bit two's-complement window
|
;; non-negative operand it equals the arithmetic shift; the negative-operand
|
||||||
;; ((>>> -1 1) = 2^63-1), not the sign. The shift count is taken mod 64.
|
;; 64-bit-window case is not modeled.
|
||||||
(define (jolt-unsigned-bit-shift-right x n)
|
(define (jolt-unsigned-bit-shift-right x n)
|
||||||
(bitwise-arithmetic-shift-right (bitwise-and (->int x) #xFFFFFFFFFFFFFFFF)
|
(bitwise-arithmetic-shift-right (->int x) (->int n)))
|
||||||
(bitwise-and (->int n) 63)))
|
|
||||||
|
|
||||||
;; ---- string->scalar parsers -------------------------------------------------
|
;; ---- string->scalar parsers -------------------------------------------------
|
||||||
(define (ascii-digit? c) (and (char>=? c #\0) (char<=? c #\9)))
|
(define (ascii-digit? c) (and (char>=? c #\0) (char<=? c #\9)))
|
||||||
|
|
|
||||||
|
|
@ -16,19 +16,20 @@
|
||||||
(seq->list (jolt-seq names))))
|
(seq->list (jolt-seq names))))
|
||||||
jolt-nil)
|
jolt-nil)
|
||||||
|
|
||||||
;; --- reader-conditional: a tagged map (reader-conditional? is an overlay
|
;; --- reader-conditional / re-matcher: tagged maps (reader-conditional? + the
|
||||||
;; tagged-value predicate that reads :jolt/type). STAYS NATIVE: building a
|
;; matcher consumers are overlay tagged-value predicates that read :jolt/type).
|
||||||
;; :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-type (keyword "jolt" "type"))
|
||||||
(define nr-kw-rc (keyword "jolt" "reader-conditional"))
|
(define nr-kw-rc (keyword "jolt" "reader-conditional"))
|
||||||
(define nr-kw-form (keyword #f "form"))
|
(define nr-kw-form (keyword #f "form"))
|
||||||
(define nr-kw-spl (keyword #f "splicing?"))
|
(define nr-kw-spl (keyword #f "splicing?"))
|
||||||
|
(define nr-kw-mat (keyword "jolt" "matcher"))
|
||||||
|
(define nr-kw-re (keyword #f "re"))
|
||||||
|
(define nr-kw-s (keyword #f "s"))
|
||||||
|
(define nr-kw-pos (keyword #f "pos"))
|
||||||
(define (nr-reader-conditional form splicing?)
|
(define (nr-reader-conditional form splicing?)
|
||||||
(jolt-hash-map nr-kw-type nr-kw-rc nr-kw-form form nr-kw-spl splicing?))
|
(jolt-hash-map nr-kw-type nr-kw-rc nr-kw-form form nr-kw-spl splicing?))
|
||||||
|
(define (nr-re-matcher re s)
|
||||||
|
(jolt-hash-map nr-kw-type nr-kw-mat nr-kw-re re nr-kw-s s nr-kw-pos 0.0))
|
||||||
|
|
||||||
;; --- macroexpand-1 / macroexpand: expand a (quoted) call form via the runtime
|
;; --- macroexpand-1 / macroexpand: expand a (quoted) call form via the runtime
|
||||||
;; macro table (host-contract hc-macro?/hc-expand-1; forward-referenced, resolved
|
;; macro table (host-contract hc-macro?/hc-expand-1; forward-referenced, resolved
|
||||||
|
|
@ -46,13 +47,6 @@
|
||||||
(def-var! "clojure.core" "__reader-features" nr-reader-features-get)
|
(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-features-set!" nr-reader-features-set!)
|
||||||
(def-var! "clojure.core" "reader-conditional" nr-reader-conditional)
|
(def-var! "clojure.core" "reader-conditional" nr-reader-conditional)
|
||||||
|
(def-var! "clojure.core" "re-matcher" nr-re-matcher)
|
||||||
(def-var! "clojure.core" "macroexpand-1" nr-macroexpand-1)
|
(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)
|
(def-var! "clojure.core" "macroexpand" nr-macroexpand)
|
||||||
|
|
|
||||||
|
|
@ -17,16 +17,13 @@
|
||||||
;; call routes through jolt-invoke. A `reduced` step stops the fold — reduce-seq
|
;; call routes through jolt-invoke. A `reduced` step stops the fold — reduce-seq
|
||||||
;; (seq.ss) already short-circuits on a jolt-reduced.
|
;; (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)
|
(define (td-map f)
|
||||||
(lambda (rf)
|
(lambda (rf)
|
||||||
(lambda a
|
(lambda a
|
||||||
(case (length a)
|
(case (length a)
|
||||||
((0) (jolt-invoke rf))
|
((0) (jolt-invoke rf))
|
||||||
((1) (jolt-invoke rf (car a)))
|
((1) (jolt-invoke rf (car a)))
|
||||||
(else (jolt-invoke rf (car a) (apply jolt-invoke f (cdr a))))))))
|
(else (jolt-invoke rf (car a) (jolt-invoke f (cadr a))))))))
|
||||||
(define (td-filter pred)
|
(define (td-filter pred)
|
||||||
(lambda (rf)
|
(lambda (rf)
|
||||||
(lambda a
|
(lambda a
|
||||||
|
|
@ -104,10 +101,7 @@
|
||||||
(define (jolt-mapcat f . colls)
|
(define (jolt-mapcat f . colls)
|
||||||
(if (null? colls)
|
(if (null? colls)
|
||||||
(td-mapcat f)
|
(td-mapcat f)
|
||||||
;; lazily concat the per-element results — no seq->list, so mapcat over an
|
(apply jolt-concat (seq->list (apply jolt-map f colls)))))
|
||||||
;; 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.
|
;; take-while / drop-while: 1-arg -> transducer; 2-arg -> a seq over the coll.
|
||||||
(define (take-while-seq pred s)
|
(define (take-while-seq pred s)
|
||||||
|
|
@ -119,7 +113,7 @@
|
||||||
(define jolt-take-while
|
(define jolt-take-while
|
||||||
(case-lambda
|
(case-lambda
|
||||||
((pred) (td-take-while pred))
|
((pred) (td-take-while pred))
|
||||||
((pred coll) (jolt-make-lazy-seq (lambda () (jolt-seq (take-while-seq pred (jolt-seq coll))))))))
|
((pred coll) (take-while-seq pred (jolt-seq coll)))))
|
||||||
(define (drop-while-seq pred coll)
|
(define (drop-while-seq pred coll)
|
||||||
(let loop ((s (jolt-seq coll)))
|
(let loop ((s (jolt-seq coll)))
|
||||||
(if (and (not (jolt-nil? s)) (jolt-truthy? (jolt-invoke pred (seq-first s))))
|
(if (and (not (jolt-nil? s)) (jolt-truthy? (jolt-invoke pred (seq-first s))))
|
||||||
|
|
@ -128,7 +122,7 @@
|
||||||
(define jolt-drop-while
|
(define jolt-drop-while
|
||||||
(case-lambda
|
(case-lambda
|
||||||
((pred) (td-drop-while pred))
|
((pred) (td-drop-while pred))
|
||||||
((pred coll) (jolt-make-lazy-seq (lambda () (jolt-seq (drop-while-seq pred coll)))))))
|
((pred coll) (drop-while-seq pred coll))))
|
||||||
|
|
||||||
;; partition: (partition n coll), (partition n step coll), or
|
;; partition: (partition n coll), (partition n step coll), or
|
||||||
;; (partition n step pad coll). Only complete partitions of size n are kept;
|
;; (partition n step pad coll). Only complete partitions of size n are kept;
|
||||||
|
|
@ -136,9 +130,9 @@
|
||||||
;; runs out). Each partition is a seq; the whole result is a lazy seq of seqs.
|
;; runs out). Each partition is a seq; the whole result is a lazy seq of seqs.
|
||||||
(define jolt-partition
|
(define jolt-partition
|
||||||
(case-lambda
|
(case-lambda
|
||||||
((n coll) (jolt-make-lazy-seq (lambda () (jolt-seq (partition* (->idx n) (->idx n) #f #f coll)))))
|
((n coll) (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 coll) (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)))))))
|
((n step pad coll) (partition* (->idx n) (->idx step) #t pad coll))))
|
||||||
(define (take-n n s) ; -> (values list-of-first-n remaining-seq taken-count)
|
(define (take-n n s) ; -> (values list-of-first-n remaining-seq taken-count)
|
||||||
(let loop ((n n) (s s) (acc '()))
|
(let loop ((n n) (s s) (acc '()))
|
||||||
(if (or (fx<=? n 0) (jolt-nil? s))
|
(if (or (fx<=? n 0) (jolt-nil? s))
|
||||||
|
|
@ -183,12 +177,9 @@
|
||||||
(if (jolt-nil? s) jolt-empty-list
|
(if (jolt-nil? s) jolt-empty-list
|
||||||
(list->cseq (list-sort less? (seq->list s))))))
|
(list->cseq (list-sort less? (seq->list s))))))
|
||||||
|
|
||||||
;; identical?: reference identity (Clojure ==). eq? gives pointer identity over
|
;; identical?: jolt reference identity, defined as (= a b) over the
|
||||||
;; the value model — interned keywords/fixnums/nil compare equal, distinct
|
;; value model, where interned keywords/small values compare equal.
|
||||||
;; collections do not. Must NOT be value equality: a deftype whose .equals calls
|
(define (jolt-identical? a b) (jolt= a b))
|
||||||
;; (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
|
;; 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
|
;; lowers (map f)/(filter p)/(take n) at the wrong arity to the bare procedure
|
||||||
|
|
@ -225,23 +216,7 @@
|
||||||
|
|
||||||
;; rseq: vectors + sorted colls only (Clojure), the reverse of the ascending seq.
|
;; rseq: vectors + sorted colls only (Clojure), the reverse of the ascending seq.
|
||||||
(define (jolt-rseq coll)
|
(define (jolt-rseq coll)
|
||||||
(cond
|
(if (or (pvec? coll) (htable-sorted? coll))
|
||||||
((or (pvec? coll) (htable-sorted? coll))
|
(list->cseq (reverse (seq->list (jolt-seq coll))))
|
||||||
(list->cseq (reverse (seq->list (jolt-seq coll)))))
|
(jolt-throw (jolt-ex-info "rseq requires a vector or sorted collection" (jolt-hash-map)))))
|
||||||
;; 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)
|
(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))
|
|
||||||
|
|
|
||||||
|
|
@ -108,30 +108,10 @@
|
||||||
((string=? cs "utf-32le") (string->utf32 s (endianness little)))
|
((string=? cs "utf-32le") (string->utf32 s (endianness little)))
|
||||||
(else (string->utf8 s)))))
|
(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 (jolt-string-method method s rest)
|
||||||
(define (arg n) (list-ref rest n))
|
(define (arg n) (list-ref rest n))
|
||||||
(cond
|
(cond
|
||||||
((string=? method "toString") s)
|
((string=? method "toString") s)
|
||||||
((string=? method "hashCode") (java-string-hash s))
|
|
||||||
((string=? method "toLowerCase") (ascii-string-down s))
|
((string=? method "toLowerCase") (ascii-string-down s))
|
||||||
((string=? method "toUpperCase") (ascii-string-up s))
|
((string=? method "toUpperCase") (ascii-string-up s))
|
||||||
((string=? method "trim") (str-trim s))
|
((string=? method "trim") (str-trim s))
|
||||||
|
|
@ -25,61 +25,28 @@
|
||||||
(def-var! "clojure.core" "volatile!" jolt-volatile!)
|
(def-var! "clojure.core" "volatile!" jolt-volatile!)
|
||||||
(def-var! "clojure.core" "deref" jolt-deref)
|
(def-var! "clojure.core" "deref" jolt-deref)
|
||||||
|
|
||||||
;; --- sequence ----------------------------------------------------------------
|
;; --- transduce / sequence ----------------------------------------------------
|
||||||
;; transduce lives in the overlay (clojure/core/22-coll.clj): it's a pure
|
;; (transduce xform f coll) / (transduce xform f init coll): build the transformed
|
||||||
;; composition (xf (reduce xf init coll)) over reduce, so the Clojure version
|
;; reducing fn (xform f), reduce it over coll (reduce-seq honors `reduced`), then
|
||||||
;; lowers to the same code the native shim did. sequence stays native (below):
|
;; run the completion (1-arg) arity. The 3-arg init defaults to (f) — the rf's
|
||||||
;; its transformer iterator drives the reduced box + lazy realization directly.
|
;; 0-arity, e.g. (+) = 0, (conj) = [].
|
||||||
|
(define jolt-transduce
|
||||||
;; (sequence coll) -> a seq; (sequence xform coll) -> a LAZY seq of coll transformed
|
(case-lambda
|
||||||
;; by xform. A transformer iterator (mirrors clojure.core's TransformerIterator):
|
((xform f coll) (jolt-transduce xform f (jolt-invoke f) coll))
|
||||||
;; pull one input at a time through (xform rf), where rf buffers each emitted value;
|
((xform f init coll)
|
||||||
;; emit the buffer lazily, pulling more input only when it drains. So an infinite or
|
(let* ((xf (jolt-invoke xform f))
|
||||||
;; expensive source is consumed incrementally — (first (sequence (map inc) (range)))
|
(res (reduce-seq xf init (jolt-seq coll))))
|
||||||
;; returns at once. Honors `reduced` (stop pulling) and runs the 1-arg completion to
|
(jolt-invoke xf res)))))
|
||||||
;; flush a stateful xform (partition-all / dedupe / a trailing partition).
|
|
||||||
(define (sequence-xf xform coll)
|
|
||||||
(let* ((buf (box '())) ; emitted values for the current step, reversed
|
|
||||||
(rf (case-lambda
|
|
||||||
(() jolt-nil)
|
|
||||||
((acc) acc)
|
|
||||||
((acc x) (set-box! buf (cons x (unbox buf))) acc)))
|
|
||||||
(xrf (jolt-invoke xform rf)))
|
|
||||||
;; advance the source until buf holds output or the input is drained+completed.
|
|
||||||
(define (fill src acc completed)
|
|
||||||
(let loop ((src src) (acc acc) (completed completed))
|
|
||||||
(cond
|
|
||||||
((pair? (unbox buf)) (values src acc completed))
|
|
||||||
(completed (values src acc #t))
|
|
||||||
((jolt-reduced? acc)
|
|
||||||
(jolt-invoke xrf (jolt-reduced-val acc)) ; completion may flush
|
|
||||||
(loop src (jolt-reduced-val acc) #t))
|
|
||||||
(else
|
|
||||||
(let ((s (jolt-seq src)))
|
|
||||||
(if (jolt-nil? s)
|
|
||||||
(begin (jolt-invoke xrf acc) (loop src acc #t)) ; complete -> flush
|
|
||||||
(loop (seq-more s) (jolt-invoke xrf acc (seq-first s)) completed)))))))
|
|
||||||
;; Resolve the next chunk now (one fill pulls just enough input to emit or to
|
|
||||||
;; exhaust), so the result is a real cseq | empty — `empty` is jolt-empty-list
|
|
||||||
;; at the top (so an empty result still prints "()") and jolt-nil inside a tail
|
|
||||||
;; (the cseq terminator). The TAILS stay lazy, so an infinite source is fine.
|
|
||||||
(define (step src acc completed empty)
|
|
||||||
(let-values (((src2 acc2 comp2) (fill src acc completed)))
|
|
||||||
(let ((out (reverse (unbox buf))))
|
|
||||||
(set-box! buf '())
|
|
||||||
(if (null? out)
|
|
||||||
empty
|
|
||||||
(let build ((o out))
|
|
||||||
(if (null? (cdr o))
|
|
||||||
(cseq-lazy (car o) (lambda () (step src2 acc2 comp2 jolt-nil)))
|
|
||||||
(cseq-lazy (car o) (lambda () (build (cdr o))))))))))
|
|
||||||
(step coll jolt-nil #f jolt-empty-list)))
|
|
||||||
|
|
||||||
|
;; (sequence coll) -> a seq; (sequence xform coll) -> coll transformed by xform.
|
||||||
|
;; Materialized eagerly through into-xform then seq'd (corpus inputs are finite; a
|
||||||
|
;; fully-lazy pull is future work). Honors reduced via into-xform/reduce-seq.
|
||||||
(define jolt-sequence
|
(define jolt-sequence
|
||||||
(case-lambda
|
(case-lambda
|
||||||
((coll) (jolt-seq coll))
|
((coll) (jolt-seq coll))
|
||||||
((xform coll) (sequence-xf xform coll))))
|
((xform coll) (jolt-seq (into-xform (jolt-vector) xform coll)))))
|
||||||
|
|
||||||
|
(def-var! "clojure.core" "transduce" jolt-transduce)
|
||||||
(def-var! "clojure.core" "sequence" jolt-sequence)
|
(def-var! "clojure.core" "sequence" jolt-sequence)
|
||||||
|
|
||||||
;; --- cat ---------------------------------------------------------------------
|
;; --- cat ---------------------------------------------------------------------
|
||||||
|
|
|
||||||
|
|
@ -74,8 +74,7 @@
|
||||||
;; :refer :all — bring in every public var (require :refer :all)
|
;; :refer :all — bring in every public var (require :refer :all)
|
||||||
((and (keyword? v) (string=? (keyword-t-name v) "all"))
|
((and (keyword? v) (string=? (keyword-t-name v) "all"))
|
||||||
(chez-register-refer-all! cns target))
|
(chez-register-refer-all! cns target))
|
||||||
;; :refer [a b] or :refer (a b) — both forms list names to bring in.
|
((pvec? v)
|
||||||
((or (pvec? v) (cseq? v) (empty-list-t? v))
|
|
||||||
(for-each (lambda (n)
|
(for-each (lambda (n)
|
||||||
(when (symbol-t? n) (chez-register-refer! cns (symbol-t-name n) target)))
|
(when (symbol-t? n) (chez-register-refer! cns (symbol-t-name n) target)))
|
||||||
(seq->list v))))))))
|
(seq->list v))))))))
|
||||||
|
|
@ -129,23 +128,17 @@
|
||||||
(list->cseq (map intern-ns! (vector->list (hashtable-keys seen))))))
|
(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
|
;; 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
|
;; the var-table for defined cells in the namespace. (Private vars are not tracked
|
||||||
;; var; ns-publics drops the ones marked ^:private (defn-/def ^:private), like the
|
;; yet, so ns-publics == ns-interns.) ns-aliases is an empty map (map? is true).
|
||||||
;; JVM. ns-aliases is an empty map (map? is true).
|
(define (ns-vars-pmap nm)
|
||||||
(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)))
|
(let ((m (jolt-hash-map)))
|
||||||
(vector-for-each
|
(vector-for-each
|
||||||
(lambda (c)
|
(lambda (c)
|
||||||
(when (and (string=? (var-cell-ns c) nm) (var-cell-defined? c) (keep? c))
|
(when (and (string=? (var-cell-ns c) nm) (var-cell-defined? c))
|
||||||
(set! m (jolt-assoc m (jolt-symbol #f (var-cell-name c)) c))))
|
(set! m (jolt-assoc m (jolt-symbol #f (var-cell-name c)) c))))
|
||||||
(hashtable-values var-table))
|
(hashtable-values var-table))
|
||||||
m))
|
m))
|
||||||
(define (ns-vars-pmap nm) (ns-vars-pmap-when nm (lambda (c) #t)))
|
(define (jolt-ns-publics desig) (ns-vars-pmap (ns-desig->name desig)))
|
||||||
(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`
|
;; ns-aliases: the {alias-sym -> ns-value} registered under `desig`
|
||||||
;; (default the current ns) via require :as / alias. Reads ns-alias-table.
|
;; (default the current ns) via require :as / alias. Reads ns-alias-table.
|
||||||
|
|
@ -260,9 +253,6 @@
|
||||||
;; intern: create/set a var ns/sym to val (or an unbound cell). Returns the var.
|
;; intern: create/set a var ns/sym to val (or an unbound cell). Returns the var.
|
||||||
(define (jolt-intern ns-desig sym . vopt)
|
(define (jolt-intern ns-desig sym . vopt)
|
||||||
(let ((nm (ns-desig->name ns-desig)) (s (symbol-t-name sym)))
|
(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))))
|
(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.
|
;; alias / ns-unalias: register/drop an :as alias under the current (or given) ns.
|
||||||
|
|
@ -285,48 +275,15 @@
|
||||||
(chez-register-refer! cns (var-cell-name c) target)))
|
(chez-register-refer! cns (var-cell-name c) target)))
|
||||||
(hashtable-values var-table))
|
(hashtable-values var-table))
|
||||||
jolt-nil))
|
jolt-nil))
|
||||||
;; (:refer-clojure :exclude [names…]) — clojure.core always resolves on Chez, so
|
(define (jolt-refer-clojure . _) jolt-nil)
|
||||||
;; 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);
|
;; alter-meta! / reset-meta!: update a var's metadata (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)
|
(define (jolt-alter-meta! ref f . args)
|
||||||
(if (var-cell? ref)
|
(let* ((cur (or (hashtable-ref var-meta-table ref #f) (jolt-hash-map)))
|
||||||
(let* ((cur (or (hashtable-ref var-meta-table ref #f) (jolt-hash-map)))
|
(new (apply jolt-invoke f cur args)))
|
||||||
(new (apply jolt-invoke f cur args)))
|
(hashtable-set! var-meta-table ref new)
|
||||||
(hashtable-set! var-meta-table ref new)
|
new))
|
||||||
new)
|
(define (jolt-reset-meta! ref m) (hashtable-set! var-meta-table ref m) m)
|
||||||
(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 -------------------------------------
|
;; --- RESOLVE FRICTION: native-op cells -------------------------------------
|
||||||
;; Native-op primitives (+ map reduce …) are INLINED at emit, so they have no
|
;; Native-op primitives (+ map reduce …) are INLINED at emit, so they have no
|
||||||
|
|
@ -365,8 +322,8 @@
|
||||||
(def-var! "clojure.core" "in-ns" jolt-in-ns)
|
(def-var! "clojure.core" "in-ns" jolt-in-ns)
|
||||||
(def-var! "clojure.core" "all-ns" jolt-all-ns)
|
(def-var! "clojure.core" "all-ns" jolt-all-ns)
|
||||||
(def-var! "clojure.core" "ns-publics" jolt-ns-publics)
|
(def-var! "clojure.core" "ns-publics" jolt-ns-publics)
|
||||||
(def-var! "clojure.core" "ns-map" jolt-ns-interns)
|
(def-var! "clojure.core" "ns-map" jolt-ns-publics)
|
||||||
(def-var! "clojure.core" "ns-interns" jolt-ns-interns)
|
(def-var! "clojure.core" "ns-interns" jolt-ns-publics)
|
||||||
(def-var! "clojure.core" "ns-aliases" jolt-ns-aliases)
|
(def-var! "clojure.core" "ns-aliases" jolt-ns-aliases)
|
||||||
(def-var! "clojure.core" "ns-refers" jolt-ns-refers)
|
(def-var! "clojure.core" "ns-refers" jolt-ns-refers)
|
||||||
(def-var! "clojure.core" "ns-imports" jolt-ns-imports)
|
(def-var! "clojure.core" "ns-imports" jolt-ns-imports)
|
||||||
|
|
|
||||||
|
|
@ -63,17 +63,6 @@
|
||||||
;; a lazy-seq carries its own realized? flag (lazy-bridge.ss). The overlay
|
;; a lazy-seq carries its own realized? flag (lazy-bridge.ss). The overlay
|
||||||
;; realized? reads :jolt/type and throws on a jolt-lazyseq record.
|
;; realized? reads :jolt/type and throws on a jolt-lazyseq record.
|
||||||
((jolt-lazyseq? x) (jolt-lazyseq-realized? x))
|
((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))))))
|
(else (jolt-invoke overlay-realized? x))))))
|
||||||
;; clojure.edn/read over a reader: drain the jhost reader, then read through the
|
;; 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.
|
;; overlay read-string so the opts map (:readers/:default/:eof) is honored.
|
||||||
|
|
@ -89,28 +78,27 @@
|
||||||
(def-var! "clojure.core" "line-seq"
|
(def-var! "clojure.core" "line-seq"
|
||||||
(lambda (rdr)
|
(lambda (rdr)
|
||||||
(if (reader-jhost? rdr) (chez-line-seq rdr) (jolt-invoke overlay-line-seq 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
|
;; JVM-parity numeric tower: the overlay (20-coll.clj) carries an
|
||||||
;; path (so they stay native) but the overlay (20-coll.clj) still carries an
|
;; all-flonum number-predicate web with no Ratio concept (ratio? -> false,
|
||||||
;; all-flonum int?/double? (int? -> integer?, double? -> not-integer) that
|
;; double? -> not-integer, float? -> double?, rational? -> int?), which
|
||||||
;; misclassifies exact rationals (e.g. (double? 1/2) -> true). Re-assert the
|
;; misclassifies exact rationals on the Chez tower (e.g. (double? 1/2) -> true).
|
||||||
;; native tower-correct versions so they win over those overlay defs. int?/double?
|
;; Re-assert the native tower-correct versions (predicates.ss) so they win over
|
||||||
;; alias integer?/float?. == is value-equality. (ratio?/rational? are now correct
|
;; the overlay defs. int?/double? alias integer?/float?. == is value-equality.
|
||||||
;; 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" "integer?" jolt-integer?)
|
||||||
(def-var! "clojure.core" "int?" jolt-integer?)
|
(def-var! "clojure.core" "int?" jolt-integer?)
|
||||||
(def-var! "clojure.core" "float?" jolt-float?)
|
(def-var! "clojure.core" "float?" jolt-float?)
|
||||||
(def-var! "clojure.core" "double?" jolt-float?)
|
(def-var! "clojure.core" "double?" jolt-float?)
|
||||||
;; ratio?/rational? now live (correctly) in the overlay, so they no longer need a
|
(def-var! "clojure.core" "ratio?" jolt-ratio?)
|
||||||
;; native re-assertion here. decimal? stays (bigdec re-binds it).
|
(def-var! "clojure.core" "rational?" jolt-rational?)
|
||||||
(def-var! "clojure.core" "decimal?" jolt-decimal?)
|
(def-var! "clojure.core" "decimal?" jolt-decimal?)
|
||||||
(def-var! "clojure.core" "==" jolt-num-equiv)
|
(def-var! "clojure.core" "==" jolt-num-equiv)
|
||||||
;; chunked-seq? is true for a vector's seq (a real chunked-seq); the overlay's
|
;; 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.
|
;; always-false stub loaded over the host fn, so re-assert it.
|
||||||
(def-var! "clojure.core" "chunked-seq?" na-chunked-seq?)
|
(def-var! "clojure.core" "chunked-seq?" na-chunked-seq?)
|
||||||
;; record? is a host type check — true only for a defrecord, not a bare deftype
|
;; record? is a host type check (jrec?), not the overlay's (some? (get x
|
||||||
;; (jrec-record?), matching the JVM (instance? IRecord). The overlay's
|
;; :jolt/deftype)) — the get-trick invokes a sorted-map's comparator on
|
||||||
;; (some? (get x :jolt/deftype)) get-trick would invoke a sorted-map comparator.
|
;; :jolt/deftype and throws. Matches the JVM (instance? IRecord).
|
||||||
(def-var! "clojure.core" "record?" (lambda (x) (jrec-record? x)))
|
(def-var! "clojure.core" "record?" (lambda (x) (jrec? x)))
|
||||||
|
|
||||||
;; read / read+string over a HOST reader jhost (java.io StringReader/PushbackReader):
|
;; 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
|
;; the overlay's IReader protocol only covers the reify map-reader, so a (read
|
||||||
|
|
@ -123,13 +111,13 @@
|
||||||
((stream)
|
((stream)
|
||||||
(if (reader-jhost? stream)
|
(if (reader-jhost? stream)
|
||||||
(let-values (((form found?) (host-reader-read-form stream)))
|
(let-values (((form found?) (host-reader-read-form stream)))
|
||||||
(if found? form (jolt-throw (jolt-ex-info "EOF while reading" empty-pmap))))
|
(if found? form (jolt-throw (jolt-ex-info "EOF while reading" (empty-pmap)))))
|
||||||
(jolt-invoke ov-read stream)))
|
(jolt-invoke ov-read stream)))
|
||||||
((stream e? ev)
|
((stream e? ev)
|
||||||
(if (reader-jhost? stream)
|
(if (reader-jhost? stream)
|
||||||
(let-values (((form found?) (host-reader-read-form stream)))
|
(let-values (((form found?) (host-reader-read-form stream)))
|
||||||
(cond (found? form)
|
(cond (found? form)
|
||||||
((jolt-truthy? e?) (jolt-throw (jolt-ex-info "EOF while reading" empty-pmap)))
|
((jolt-truthy? e?) (jolt-throw (jolt-ex-info "EOF while reading" (empty-pmap))))
|
||||||
(else ev)))
|
(else ev)))
|
||||||
(jolt-invoke ov-read stream e? ev))))))
|
(jolt-invoke ov-read stream e? ev))))))
|
||||||
(let ((ov-rps (var-deref "clojure.core" "read+string")))
|
(let ((ov-rps (var-deref "clojure.core" "read+string")))
|
||||||
|
|
@ -142,7 +130,7 @@
|
||||||
(let* ((s (drain-reader stream)) (pr (jolt-parse-next s)))
|
(let* ((s (drain-reader stream)) (pr (jolt-parse-next s)))
|
||||||
(if (jolt-nil? pr)
|
(if (jolt-nil? pr)
|
||||||
(begin (reader-refill! stream "")
|
(begin (reader-refill! stream "")
|
||||||
(if (jolt-truthy? e?) (jolt-throw (jolt-ex-info "EOF while reading" empty-pmap))
|
(if (jolt-truthy? e?) (jolt-throw (jolt-ex-info "EOF while reading" (empty-pmap)))
|
||||||
(jolt-vector ev "")))
|
(jolt-vector ev "")))
|
||||||
(let ((rest (jolt-nth pr 1)))
|
(let ((rest (jolt-nth pr 1)))
|
||||||
(reader-refill! stream rest)
|
(reader-refill! stream rest)
|
||||||
|
|
|
||||||
|
|
@ -12,9 +12,11 @@
|
||||||
(define (jolt-vector? x) (pvec? x))
|
(define (jolt-vector? x) (pvec? x))
|
||||||
(define (jolt-set? x) (pset? x))
|
(define (jolt-set? x) (pset? x))
|
||||||
(define (jolt-seq? x) (or (cseq? x) (empty-list-t? 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.
|
;; (list? x): a list-marked cseq node or the empty list (). A lazy/vector-backed
|
||||||
|
;; seq, (rest list), (seq coll), (map …) are seqs but not lists.
|
||||||
|
(define (jolt-list-pred? x) (or (and (cseq? x) (cseq-list? x)) (empty-list-t? x)))
|
||||||
(define (jolt-coll-pred? x)
|
(define (jolt-coll-pred? x)
|
||||||
(or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jolt-lazyseq? x)))
|
(or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x)))
|
||||||
(define (jolt-number? x) (number? x))
|
(define (jolt-number? x) (number? x))
|
||||||
(define (jolt-string? x) (string? x))
|
(define (jolt-string? x) (string? x))
|
||||||
(define (jolt-char-pred? x) (char? x))
|
(define (jolt-char-pred? x) (char? x))
|
||||||
|
|
@ -25,18 +27,13 @@
|
||||||
;; BigDecimal). decimal? is always false (no BigDecimal type).
|
;; BigDecimal). decimal? is always false (no BigDecimal type).
|
||||||
(define (jolt-integer? x) (and (number? x) (exact? x) (integer? x)))
|
(define (jolt-integer? x) (and (number? x) (exact? x) (integer? x)))
|
||||||
(define (jolt-float? x) (and (number? x) (flonum? x)))
|
(define (jolt-float? x) (and (number? x) (flonum? x)))
|
||||||
;; ratio?/rational? live in the overlay (clojure/core/20-coll.clj), built on the
|
(define (jolt-ratio? x) (and (number? x) (exact? x) (rational? x) (not (integer? x))))
|
||||||
;; jolt.host tower tests. decimal? stays native: the optional bigdec module
|
(define (jolt-rational? x) (and (number? x) (exact? x)))
|
||||||
;; (java/bigdec.ss) re-binds it to jbigdec?, so it can't be a static overlay const.
|
|
||||||
(define (jolt-decimal? x) #f)
|
(define (jolt-decimal? x) #f)
|
||||||
(define (jolt-fn? x) (procedure? x))
|
(define (jolt-fn? x) (procedure? x))
|
||||||
(define (jolt-boolean-pred? x) (boolean? x))
|
(define (jolt-boolean-pred? x) (boolean? x))
|
||||||
|
|
||||||
;; (boolean x) coerces truthiness (nil/false -> false, else true). MUST stay native:
|
;; (boolean x) coerces truthiness (nil/false -> false, else true).
|
||||||
;; 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))
|
(define (jolt-boolean x) (if (jolt-truthy? x) #t #f))
|
||||||
|
|
||||||
;; (name x): keyword/symbol -> name string; string -> itself.
|
;; (name x): keyword/symbol -> name string; string -> itself.
|
||||||
|
|
@ -60,6 +57,8 @@
|
||||||
(def-var! "clojure.core" "char?" jolt-char-pred?)
|
(def-var! "clojure.core" "char?" jolt-char-pred?)
|
||||||
(def-var! "clojure.core" "integer?" jolt-integer?)
|
(def-var! "clojure.core" "integer?" jolt-integer?)
|
||||||
(def-var! "clojure.core" "float?" jolt-float?)
|
(def-var! "clojure.core" "float?" jolt-float?)
|
||||||
|
(def-var! "clojure.core" "ratio?" jolt-ratio?)
|
||||||
|
(def-var! "clojure.core" "rational?" jolt-rational?)
|
||||||
(def-var! "clojure.core" "decimal?" jolt-decimal?)
|
(def-var! "clojure.core" "decimal?" jolt-decimal?)
|
||||||
;; == numeric value-equality (ignores exactness, unlike =): (== 3 3.0) -> true.
|
;; == numeric value-equality (ignores exactness, unlike =): (== 3 3.0) -> true.
|
||||||
;; 1-arity is trivially true; 2+ args must all be numbers (Numbers.equiv throws
|
;; 1-arity is trivially true; 2+ args must all be numbers (Numbers.equiv throws
|
||||||
|
|
@ -81,30 +80,10 @@
|
||||||
(def-var! "clojure.core" "vector?" jolt-vector?)
|
(def-var! "clojure.core" "vector?" jolt-vector?)
|
||||||
(def-var! "clojure.core" "set?" jolt-set?)
|
(def-var! "clojure.core" "set?" jolt-set?)
|
||||||
(def-var! "clojure.core" "seq?" jolt-seq?)
|
(def-var! "clojure.core" "seq?" jolt-seq?)
|
||||||
|
(def-var! "clojure.core" "list?" jolt-list-pred?)
|
||||||
(def-var! "clojure.core" "coll?" jolt-coll-pred?)
|
(def-var! "clojure.core" "coll?" jolt-coll-pred?)
|
||||||
(def-var! "clojure.core" "fn?" jolt-fn?)
|
(def-var! "clojure.core" "fn?" jolt-fn?)
|
||||||
(def-var! "clojure.core" "boolean?" jolt-boolean-pred?)
|
(def-var! "clojure.core" "boolean?" jolt-boolean-pred?)
|
||||||
(def-var! "clojure.core" "boolean" jolt-boolean)
|
(def-var! "clojure.core" "boolean" jolt-boolean)
|
||||||
(def-var! "clojure.core" "name" jolt-name)
|
(def-var! "clojure.core" "name" jolt-name)
|
||||||
(def-var! "clojure.core" "namespace" jolt-namespace)
|
(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?)
|
|
||||||
|
|
|
||||||
|
|
@ -47,22 +47,25 @@
|
||||||
((jolt-transient? x)
|
((jolt-transient? x)
|
||||||
(case (jolt-transient-kind x)
|
(case (jolt-transient-kind x)
|
||||||
((vec) "#<transient vector>") ((set) "#<transient set>") (else "#<transient map>")))
|
((vec) "#<transient vector>") ((set) "#<transient set>") (else "#<transient map>")))
|
||||||
((pvec? x) (if (jolt-print-hash?) "#"
|
((pvec? x)
|
||||||
(with-deeper-print
|
(let ((acc '()))
|
||||||
(string-append "[" (jolt-str-join (jolt-limited-vec-strs x jolt-pr-readable)) "]"))))
|
(let loop ((i (fx- (pvec-count x) 1)))
|
||||||
((pset? x) (if (jolt-print-hash?) "#"
|
(when (fx>=? i 0)
|
||||||
(with-deeper-print
|
(set! acc (cons (jolt-pr-readable (pvec-nth-d x i jolt-nil)) acc))
|
||||||
(string-append "#{" (jolt-str-join (jolt-limited-list-strs
|
(loop (fx- i 1))))
|
||||||
(pset-fold x (lambda (e a) (cons (jolt-pr-readable e) a)) '()))) "}"))))
|
(string-append "[" (jolt-str-join acc) "]")))
|
||||||
((pmap? x) (if (jolt-print-hash?) "#"
|
((pset? x)
|
||||||
(with-deeper-print
|
(string-append "#{" (jolt-str-join (pset-fold x (lambda (e a) (cons (jolt-pr-readable e) a)) '())) "}"))
|
||||||
(string-append "{" (jolt-str-join (jolt-limited-list-strs
|
((pmap? x)
|
||||||
(pmap-fold x (lambda (k v a)
|
(string-append "{" (jolt-str-join
|
||||||
(cons (string-append (jolt-pr-readable k) " " (jolt-pr-readable v)) a)) '()))) "}"))))
|
(pmap-fold x (lambda (k v a)
|
||||||
((empty-list-t? x) (if (jolt-print-hash?) "#" "()"))
|
(cons (string-append (jolt-pr-readable k) " " (jolt-pr-readable v)) a)) '())) "}"))
|
||||||
((cseq? x) (if (jolt-print-hash?) "#"
|
((empty-list-t? x) "()")
|
||||||
(with-deeper-print
|
((cseq? x)
|
||||||
(string-append "(" (jolt-str-join (jolt-limited-seq-strs x jolt-pr-readable)) ")"))))
|
(string-append "(" (jolt-str-join
|
||||||
|
(let loop ((s x) (acc '()))
|
||||||
|
(if (jolt-nil? s) (reverse acc)
|
||||||
|
(loop (jolt-seq (seq-more s)) (cons (jolt-pr-readable (seq-first s)) acc))))) ")"))
|
||||||
(else (jolt-pr-str x))))
|
(else (jolt-pr-str x))))
|
||||||
(define (jolt-pr-readable-dispatch x)
|
(define (jolt-pr-readable-dispatch x)
|
||||||
(let loop ((as jolt-pr-readable-arms))
|
(let loop ((as jolt-pr-readable-arms))
|
||||||
|
|
|
||||||
|
|
@ -47,25 +47,8 @@
|
||||||
(memv c '(#\( #\) #\[ #\] #\{ #\} #\" #\; #\@ #\^ #\` #\~ #\\))))
|
(memv c '(#\( #\) #\[ #\] #\{ #\} #\" #\; #\@ #\^ #\` #\~ #\\))))
|
||||||
|
|
||||||
(define (rdr-digit? c) (and (char>=? c #\0) (char<=? c #\9)))
|
(define (rdr-digit? c) (and (char>=? c #\0) (char<=? c #\9)))
|
||||||
(define (rdr-octal? c) (and (char>=? c #\0) (char<=? c #\7)))
|
|
||||||
(define (rdr-all-digits? s from to)
|
|
||||||
(and (> to from)
|
|
||||||
(let loop ((i from))
|
|
||||||
(cond ((>= i to) #t)
|
|
||||||
((rdr-digit? (string-ref s i)) (loop (+ i 1)))
|
|
||||||
(else #f)))))
|
|
||||||
;; every char of s in [from,to) is an octal digit (and the span is non-empty).
|
|
||||||
(define (rdr-all-octal? s from to)
|
|
||||||
(and (fx<? from to)
|
|
||||||
(let loop ((i from)) (cond ((fx=? i to) #t) ((rdr-octal? (string-ref s i)) (loop (fx+ i 1))) (else #f)))))
|
|
||||||
|
|
||||||
;; Advance past whitespace, commas, and ;-to-end-of-line comments.
|
;; Advance past whitespace, commas, and ;-to-end-of-line comments.
|
||||||
;; EDN strict mode (clojure.edn): auto-resolved keywords are invalid, and each
|
|
||||||
;; discarded (#_) form is handed to rdr-discard-cb so the edn layer validates
|
|
||||||
;; its tagged elements through :readers/:default like the JVM.
|
|
||||||
(define rdr-edn-mode (make-parameter #f))
|
|
||||||
(define rdr-discard-cb (make-parameter #f))
|
|
||||||
|
|
||||||
(define (rdr-skip-ws s i end)
|
(define (rdr-skip-ws s i end)
|
||||||
(let loop ((i i))
|
(let loop ((i i))
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -73,8 +56,7 @@
|
||||||
((rdr-ws? (string-ref s i)) (loop (+ i 1)))
|
((rdr-ws? (string-ref s i)) (loop (+ i 1)))
|
||||||
((char=? (string-ref s i) #\;)
|
((char=? (string-ref s i) #\;)
|
||||||
(let eol ((j (+ i 1)))
|
(let eol ((j (+ i 1)))
|
||||||
(if (or (>= j end) (char=? (string-ref s j) #\newline)
|
(if (or (>= j end) (char=? (string-ref s j) #\newline))
|
||||||
(char=? (string-ref s j) #\return))
|
|
||||||
(loop j)
|
(loop j)
|
||||||
(eol (+ j 1)))))
|
(eol (+ j 1)))))
|
||||||
(else i))))
|
(else i))))
|
||||||
|
|
@ -128,17 +110,12 @@
|
||||||
(slash (rdr-string-index-char body #\/)))
|
(slash (rdr-string-index-char body #\/)))
|
||||||
(cond
|
(cond
|
||||||
;; ratio a/b -> exact rational (= JVM Ratio); reduces to an exact integer
|
;; ratio a/b -> exact rational (= JVM Ratio); reduces to an exact integer
|
||||||
;; when d divides n. Both parts must be plain digit runs (1/-1 is an
|
;; when d divides n.
|
||||||
;; invalid token); a zero denominator is the JVM's divide error.
|
|
||||||
(slash
|
(slash
|
||||||
(let ((ns (substring body 0 slash))
|
(let ((n (string->number (substring body 0 slash)))
|
||||||
(ds (substring body (+ slash 1) blen)))
|
(d (string->number (substring body (+ slash 1) blen))))
|
||||||
(and (rdr-all-digits? ns 0 (string-length ns))
|
(and (integer? n) (integer? d) (not (= d 0))
|
||||||
(rdr-all-digits? ds 0 (string-length ds))
|
(* sign (/ n d)))))
|
||||||
(let ((n (string->number ns)) (d (string->number ds)))
|
|
||||||
(when (= d 0)
|
|
||||||
(jolt-throw (jolt-host-throwable "java.lang.ArithmeticException" "Divide by zero")))
|
|
||||||
(* sign (/ n d))))))
|
|
||||||
;; hex 0x..
|
;; hex 0x..
|
||||||
((and (>= blen 2) (char=? (string-ref body 0) #\0)
|
((and (>= blen 2) (char=? (string-ref body 0) #\0)
|
||||||
(or (char=? (string-ref body 1) #\x) (char=? (string-ref body 1) #\X)))
|
(or (char=? (string-ref body 1) #\x) (char=? (string-ref body 1) #\X)))
|
||||||
|
|
@ -152,16 +129,6 @@
|
||||||
(and radix (integer? radix) (>= radix 2) (<= radix 36)
|
(and radix (integer? radix) (>= radix 2) (<= radix 36)
|
||||||
(let ((v (rdr-parse-radix (substring body (+ ri 1) blen) radix)))
|
(let ((v (rdr-parse-radix (substring body (+ ri 1) blen) radix)))
|
||||||
(and v (* sign v)))))))
|
(and v (* sign v)))))))
|
||||||
;; octal 0NNN: a leading 0 followed by octal digits (Clojure reads 042 as 34,
|
|
||||||
;; not decimal 42). "0" alone, 0x.., 0r.. and a float "0.5" are handled
|
|
||||||
;; elsewhere or fall through (a non-octal digit fails rdr-all-octal?).
|
|
||||||
((and (>= blen 2) (char=? (string-ref body 0) #\0) (rdr-all-octal? body 1 blen))
|
|
||||||
(let ((o (rdr-parse-radix (substring body 1 blen) 8))) (and o (* sign o))))
|
|
||||||
;; a leading zero on a plain multi-digit integer is invalid (the octal
|
|
||||||
;; branch above accepted real octals; 08/09 match the JVM's trailing
|
|
||||||
;; "invalid number" alternative)
|
|
||||||
((and (>= blen 2) (char=? (string-ref body 0) #\0) (rdr-all-digits? body 1 blen))
|
|
||||||
#f)
|
|
||||||
;; bigint suffix N
|
;; bigint suffix N
|
||||||
((and (> blen 1) (char=? (string-ref body (- blen 1)) #\N))
|
((and (> blen 1) (char=? (string-ref body (- blen 1)) #\N))
|
||||||
(let ((n (string->number (substring body 0 (- blen 1)))))
|
(let ((n (string->number (substring body 0 (- blen 1)))))
|
||||||
|
|
@ -193,7 +160,7 @@
|
||||||
;; opening quote already consumed; read to the closing quote, processing escapes.
|
;; opening quote already consumed; read to the closing quote, processing escapes.
|
||||||
(define (rdr-read-string-lit s i end)
|
(define (rdr-read-string-lit s i end)
|
||||||
(let loop ((i i) (acc '()))
|
(let loop ((i i) (acc '()))
|
||||||
(when (>= i end) (jolt-throw (jolt-ex-info "EOF while reading string" empty-pmap)))
|
(when (>= i end) (jolt-throw (jolt-ex-info "EOF while reading string" (empty-pmap))))
|
||||||
(let ((c (string-ref s i)))
|
(let ((c (string-ref s i)))
|
||||||
(cond
|
(cond
|
||||||
((char=? c #\") (values (list->string (reverse acc)) (+ i 1)))
|
((char=? c #\") (values (list->string (reverse acc)) (+ i 1)))
|
||||||
|
|
@ -207,16 +174,7 @@
|
||||||
((#\") (loop (+ i 2) (cons #\" acc)))
|
((#\") (loop (+ i 2) (cons #\" acc)))
|
||||||
((#\b) (loop (+ i 2) (cons #\backspace acc)))
|
((#\b) (loop (+ i 2) (cons #\backspace acc)))
|
||||||
((#\f) (loop (+ i 2) (cons #\page acc)))
|
((#\f) (loop (+ i 2) (cons #\page acc)))
|
||||||
;; octal escape \ooo: 1-3 octal digits (Clojure's \0..\377), so \000
|
((#\0) (loop (+ i 2) (cons #\nul acc)))
|
||||||
;; is one null char, not \0 + literal "00".
|
|
||||||
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)
|
|
||||||
(let oct ((j (+ i 1)) (val 0) (cnt 0))
|
|
||||||
(if (and (fx<? cnt 3) (fx<? j end) (rdr-octal? (string-ref s j)))
|
|
||||||
(oct (fx+ j 1) (fx+ (fx* val 8) (fx- (char->integer (string-ref s j)) 48)) (fx+ cnt 1))
|
|
||||||
(begin
|
|
||||||
(when (> val 255)
|
|
||||||
(jolt-throw (jolt-ex-info "Octal escape sequence must be in range [0, 377]" empty-pmap)))
|
|
||||||
(loop j (cons (integer->char val) acc))))))
|
|
||||||
((#\u)
|
((#\u)
|
||||||
(let-values (((cp j) (rdr-hex->int s (+ i 2) 4)))
|
(let-values (((cp j) (rdr-hex->int s (+ i 2) 4)))
|
||||||
;; A \u escape is a UTF-16 code unit. jolt chars are Unicode scalars,
|
;; A \u escape is a UTF-16 code unit. jolt chars are Unicode scalars,
|
||||||
|
|
@ -234,13 +192,12 @@
|
||||||
(loop j (cons #\xFFFD acc)))))
|
(loop j (cons #\xFFFD acc)))))
|
||||||
((and (fx>=? cp #xD800) (fx<=? cp #xDFFF)) (loop j (cons #\xFFFD acc)))
|
((and (fx>=? cp #xD800) (fx<=? cp #xDFFF)) (loop j (cons #\xFFFD acc)))
|
||||||
(else (loop j (cons (integer->char cp) acc))))))
|
(else (loop j (cons (integer->char cp) acc))))))
|
||||||
(else (jolt-throw (jolt-ex-info (string-append "Unsupported escape character: \\" (string e))
|
(else (loop (+ i 2) (cons e acc))))))
|
||||||
empty-pmap))))))
|
|
||||||
(else (loop (+ i 1) (cons c acc)))))))
|
(else (loop (+ i 1) (cons c acc)))))))
|
||||||
|
|
||||||
;; backslash already consumed; read a Clojure character literal.
|
;; backslash already consumed; read a Clojure character literal.
|
||||||
(define (rdr-read-char s i end)
|
(define (rdr-read-char s i end)
|
||||||
(when (>= i end) (jolt-throw (jolt-ex-info "EOF while reading char" empty-pmap)))
|
(when (>= i end) (jolt-throw (jolt-ex-info "EOF while reading char" (empty-pmap))))
|
||||||
(let ((c0 (string-ref s i)))
|
(let ((c0 (string-ref s i)))
|
||||||
(if (char-alphabetic? c0)
|
(if (char-alphabetic? c0)
|
||||||
;; named / unicode / single-letter: collect the alnum run
|
;; named / unicode / single-letter: collect the alnum run
|
||||||
|
|
@ -267,12 +224,9 @@
|
||||||
((char=? (string-ref name 0) #\u)
|
((char=? (string-ref name 0) #\u)
|
||||||
(integer->char (string->number (substring name 1 (string-length name)) 16)))
|
(integer->char (string->number (substring name 1 (string-length name)) 16)))
|
||||||
((char=? (string-ref name 0) #\o)
|
((char=? (string-ref name 0) #\o)
|
||||||
(let ((v (string->number (substring name 1 (string-length name)) 8)))
|
(integer->char (string->number (substring name 1 (string-length name)) 8)))
|
||||||
(when (or (not v) (> v 255))
|
|
||||||
(jolt-throw (jolt-ex-info "Octal escape sequence must be in range [0, 377]" empty-pmap)))
|
|
||||||
(integer->char v)))
|
|
||||||
(else (jolt-throw (jolt-ex-info (string-append "Unsupported character: \\" name)
|
(else (jolt-throw (jolt-ex-info (string-append "Unsupported character: \\" name)
|
||||||
empty-pmap)))))
|
(empty-pmap))))))
|
||||||
|
|
||||||
;; --- token (symbol / keyword / number / nil|true|false) ---------------------
|
;; --- token (symbol / keyword / number / nil|true|false) ---------------------
|
||||||
(define (rdr-read-token s i end)
|
(define (rdr-read-token s i end)
|
||||||
|
|
@ -288,39 +242,14 @@
|
||||||
(values #f tok)
|
(values #f tok)
|
||||||
(values (substring tok 0 slash) (substring tok (+ slash 1) (string-length tok))))))
|
(values (substring tok 0 slash) (substring tok (+ slash 1) (string-length tok))))))
|
||||||
|
|
||||||
(define (rdr-numeric-lead? tok)
|
|
||||||
(let ((len (string-length tok)))
|
|
||||||
(and (> len 0)
|
|
||||||
(let ((c0 (string-ref tok 0)))
|
|
||||||
(or (rdr-digit? c0)
|
|
||||||
(and (or (char=? c0 #\+) (char=? c0 #\-)) (> len 1)
|
|
||||||
(rdr-digit? (string-ref tok 1))))))))
|
|
||||||
(define (rdr-invalid-token tok)
|
|
||||||
(jolt-throw (jolt-host-throwable "java.lang.RuntimeException"
|
|
||||||
(string-append "Invalid token: " tok))))
|
|
||||||
(define (rdr-token->value tok)
|
(define (rdr-token->value tok)
|
||||||
(let ((n (rdr-try-number tok)))
|
(let ((n (rdr-try-number tok)))
|
||||||
(cond
|
(cond
|
||||||
(n n)
|
(n n)
|
||||||
;; a token that starts like a number but doesn't parse as one is an
|
|
||||||
;; invalid number (1a, 08, 0x2g, 2r2), never a symbol — like the JVM.
|
|
||||||
((rdr-numeric-lead? tok)
|
|
||||||
(jolt-throw (jolt-host-throwable "java.lang.NumberFormatException"
|
|
||||||
(string-append "Invalid number: " tok))))
|
|
||||||
((string=? tok "nil") jolt-nil)
|
((string=? tok "nil") jolt-nil)
|
||||||
((string=? tok "true") #t)
|
((string=? tok "true") #t)
|
||||||
((string=? tok "false") #f)
|
((string=? tok "false") #f)
|
||||||
(else
|
(else (let-values (((ns name) (rdr-sym-parts tok))) (jolt-symbol ns name))))))
|
||||||
(let ((len (string-length tok)))
|
|
||||||
;; a lone "/" is the division symbol, and "ns//" names it in a
|
|
||||||
;; namespace (clojure.core//); otherwise a leading or trailing slash
|
|
||||||
;; leaves an empty ns/name part — an invalid token.
|
|
||||||
(when (and (> len 1)
|
|
||||||
(or (char=? (string-ref tok 0) #\/)
|
|
||||||
(and (char=? (string-ref tok (- len 1)) #\/)
|
|
||||||
(not (and (> len 2) (char=? (string-ref tok (- len 2)) #\/))))))
|
|
||||||
(rdr-invalid-token tok))
|
|
||||||
(let-values (((ns name) (rdr-sym-parts tok))) (jolt-symbol ns name)))))))
|
|
||||||
|
|
||||||
;; --- collections ------------------------------------------------------------
|
;; --- collections ------------------------------------------------------------
|
||||||
;; Read forms until the close delimiter; returns (values reversed?-no list j).
|
;; Read forms until the close delimiter; returns (values reversed?-no list j).
|
||||||
|
|
@ -328,7 +257,7 @@
|
||||||
(let loop ((i i) (acc '()))
|
(let loop ((i i) (acc '()))
|
||||||
(let ((i (rdr-skip-ws s i end)))
|
(let ((i (rdr-skip-ws s i end)))
|
||||||
(cond
|
(cond
|
||||||
((>= i end) (jolt-throw (jolt-ex-info "EOF while reading" empty-pmap)))
|
((>= i end) (jolt-throw (jolt-ex-info "EOF while reading" (empty-pmap))))
|
||||||
((char=? (string-ref s i) close) (values (reverse acc) (+ i 1)))
|
((char=? (string-ref s i) close) (values (reverse acc) (+ i 1)))
|
||||||
(else
|
(else
|
||||||
(let-values (((form j) (rdr-read-form s i end)))
|
(let-values (((form j) (rdr-read-form s i end)))
|
||||||
|
|
@ -344,14 +273,6 @@
|
||||||
;; sequence in a weak side-table the host contract's form-map-pairs consults.
|
;; sequence in a weak side-table the host contract's form-map-pairs consults.
|
||||||
(define rdr-map-order (make-weak-eq-hashtable))
|
(define rdr-map-order (make-weak-eq-hashtable))
|
||||||
(define (rdr-make-map es)
|
(define (rdr-make-map es)
|
||||||
;; the JVM reader rejects duplicate literal keys before building the map
|
|
||||||
(let dupchk ((kvs es) (seen empty-pset))
|
|
||||||
(when (pair? kvs)
|
|
||||||
(let ((k (car kvs)))
|
|
||||||
(when (jolt-truthy? (jolt-contains? seen k))
|
|
||||||
(jolt-throw (jolt-host-throwable "java.lang.IllegalArgumentException"
|
|
||||||
(string-append "Duplicate key: " (jolt-pr-str k)))))
|
|
||||||
(dupchk (cddr kvs) (pset-conj seen k)))))
|
|
||||||
(let ((m (apply jolt-hash-map es)))
|
(let ((m (apply jolt-hash-map es)))
|
||||||
(when (pair? es) (hashtable-set! rdr-map-order m es))
|
(when (pair? es) (hashtable-set! rdr-map-order m es))
|
||||||
m))
|
m))
|
||||||
|
|
@ -378,7 +299,7 @@
|
||||||
|
|
||||||
(define (rdr-merge-meta old new)
|
(define (rdr-merge-meta old new)
|
||||||
(if (pmap? old)
|
(if (pmap? old)
|
||||||
(pmap-fold-fwd new (lambda (k v acc) (jolt-assoc1 acc k v)) old)
|
(pmap-fold new (lambda (k v acc) (jolt-assoc1 acc k v)) old)
|
||||||
new))
|
new))
|
||||||
|
|
||||||
(define (rdr-attach-meta target meta)
|
(define (rdr-attach-meta target meta)
|
||||||
|
|
@ -386,6 +307,7 @@
|
||||||
((symbol-t? target)
|
((symbol-t? target)
|
||||||
(make-symbol-t (symbol-t-ns target) (symbol-t-name target)
|
(make-symbol-t (symbol-t-ns target) (symbol-t-name target)
|
||||||
(rdr-merge-meta (symbol-t-meta target) meta)))
|
(rdr-merge-meta (symbol-t-meta target) meta)))
|
||||||
|
((empty-list-t? target) target)
|
||||||
;; Lists/vectors/maps/sets attach metadata to the value itself, as Clojure's
|
;; Lists/vectors/maps/sets attach metadata to the value itself, as Clojure's
|
||||||
;; reader does. Reading DATA (read-string, edn) then preserves it. A list form
|
;; reader does. Reading DATA (read-string, edn) then preserves it. A list form
|
||||||
;; is code: ^Type (expr) is a compile-time hint on the FORM, read off the form
|
;; is code: ^Type (expr) is a compile-time hint on the FORM, read off the form
|
||||||
|
|
@ -394,11 +316,7 @@
|
||||||
;; (with-meta form meta) for a meta-carrying collection literal in code, so
|
;; (with-meta form meta) for a meta-carrying collection literal in code, so
|
||||||
;; (meta ^{:tag :int} [1 2]) / ^:foo {} still works.
|
;; (meta ^{:tag :int} [1 2]) / ^:foo {} still works.
|
||||||
(else
|
(else
|
||||||
;; Merge onto any metadata the target already carries (a list form picks up
|
(let ((c (jolt-with-meta target meta)))
|
||||||
;; :line/:column first, then ^meta folds its keys on top).
|
|
||||||
(let* ((old (jolt-meta target))
|
|
||||||
(merged (rdr-merge-meta (if (jolt-nil? old) jolt-nil old) meta))
|
|
||||||
(c (jolt-with-meta target merged)))
|
|
||||||
;; jolt-with-meta copies a pmap, giving it a fresh identity the rdr-map-order
|
;; jolt-with-meta copies a pmap, giving it a fresh identity the rdr-map-order
|
||||||
;; side-table (source key order for left-to-right map-literal eval) loses —
|
;; side-table (source key order for left-to-right map-literal eval) loses —
|
||||||
;; carry the order entry over to the copy.
|
;; carry the order entry over to the copy.
|
||||||
|
|
@ -406,45 +324,6 @@
|
||||||
(when order (hashtable-set! rdr-map-order c order)))
|
(when order (hashtable-set! rdr-map-order c order)))
|
||||||
c))))
|
c))))
|
||||||
|
|
||||||
;; --- source position --------------------------------------------------------
|
|
||||||
;; List forms (code) carry 1-based :line/:column, plus :file when the compiler
|
|
||||||
;; bound rdr-source-file. read-string leaves the file unset. The analyzer reads
|
|
||||||
;; this back via jolt.host/form-position to stamp :pos on call nodes; macros and
|
|
||||||
;; (meta (read-string "(…)")) see it too.
|
|
||||||
(define rdr-source-file (make-thread-parameter #f))
|
|
||||||
(define rdr-kw-line (keyword #f "line"))
|
|
||||||
(define rdr-kw-column (keyword #f "column"))
|
|
||||||
(define rdr-kw-file (keyword #f "file"))
|
|
||||||
|
|
||||||
;; Forms are read left-to-right, so the indices queried are non-decreasing within
|
|
||||||
;; one source string — keep a cursor and count newlines only over the delta
|
|
||||||
;; (O(n) total, not O(n^2)). A different string or a backward index resets it.
|
|
||||||
(define rdr-pos-cursor (make-thread-parameter #f)) ; #f | (vector s i line col)
|
|
||||||
(define (rdr-line-col-at s i)
|
|
||||||
(let* ((cur (rdr-pos-cursor))
|
|
||||||
(reuse (and (vector? cur) (eq? (vector-ref cur 0) s)
|
|
||||||
(fx<=? (vector-ref cur 1) i)))
|
|
||||||
(k0 (if reuse (vector-ref cur 1) 0))
|
|
||||||
(l0 (if reuse (vector-ref cur 2) 1))
|
|
||||||
(c0 (if reuse (vector-ref cur 3) 1)))
|
|
||||||
(let loop ((k k0) (line l0) (col c0))
|
|
||||||
(if (fx>=? k i)
|
|
||||||
(begin (rdr-pos-cursor (vector s k line col)) (values line col))
|
|
||||||
(if (char=? (string-ref s k) #\newline)
|
|
||||||
(loop (fx+ k 1) (fx+ line 1) 1)
|
|
||||||
(loop (fx+ k 1) line (fx+ col 1)))))))
|
|
||||||
|
|
||||||
(define (rdr-pos-meta line col)
|
|
||||||
(let ((f (rdr-source-file)))
|
|
||||||
(if f
|
|
||||||
(jolt-hash-map rdr-kw-line line rdr-kw-column col rdr-kw-file f)
|
|
||||||
(jolt-hash-map rdr-kw-line line rdr-kw-column col))))
|
|
||||||
|
|
||||||
(define (rdr-attach-pos lst line col)
|
|
||||||
(if (empty-list-t? lst) ; () is interned, can't carry meta (= Clojure)
|
|
||||||
lst
|
|
||||||
(rdr-attach-meta lst (rdr-pos-meta line col))))
|
|
||||||
|
|
||||||
;; --- # dispatch -------------------------------------------------------------
|
;; --- # dispatch -------------------------------------------------------------
|
||||||
;; #(...) anonymous fn shorthand: % -> p1, %N -> pN, %& -> rest. The
|
;; #(...) anonymous fn shorthand: % -> p1, %N -> pN, %& -> rest. The
|
||||||
;; fixed arity is the MAX positional used (Clojure: #(do %2 %&) -> [p1 p2 & rest]).
|
;; fixed arity is the MAX positional used (Clojure: #(do %2 %&) -> [p1 p2 & rest]).
|
||||||
|
|
@ -515,7 +394,7 @@
|
||||||
(let* ((splice (and (< i end) (char=? (string-ref s i) #\@)))
|
(let* ((splice (and (< i end) (char=? (string-ref s i) #\@)))
|
||||||
(start (if splice (+ i 1) i)))
|
(start (if splice (+ i 1) i)))
|
||||||
(let-values (((form j) (rdr-read-form s start end)))
|
(let-values (((form j) (rdr-read-form s start end)))
|
||||||
(when (rdr-eof? form) (jolt-throw (jolt-ex-info "EOF after #?" empty-pmap)))
|
(when (rdr-eof? form) (jolt-throw (jolt-ex-info "EOF after #?" (empty-pmap))))
|
||||||
(let ((items (cond ((pvec? form) (seq->list form))
|
(let ((items (cond ((pvec? form) (seq->list form))
|
||||||
((or (cseq? form) (empty-list-t? form)) (seq->list form))
|
((or (cseq? form) (empty-list-t? form)) (seq->list form))
|
||||||
(else '()))))
|
(else '()))))
|
||||||
|
|
@ -534,69 +413,8 @@
|
||||||
(values (cadr xs) j)))
|
(values (cadr xs) j)))
|
||||||
(else (loop (cddr xs)))))))))
|
(else (loop (cddr xs)))))))))
|
||||||
|
|
||||||
(define (rdr-string-rindex-char str c)
|
|
||||||
(let loop ((i (- (string-length str) 1)))
|
|
||||||
(cond ((< i 0) #f) ((char=? (string-ref str i) c) i) (else (loop (- i 1))))))
|
|
||||||
|
|
||||||
;; A record/type literal tag (#ns.Type{..} / #ns.Type[..]) is any tag containing
|
|
||||||
;; a dot — Clojure routes those to a constructor instead of a data reader.
|
|
||||||
(define (rdr-record-tag? tok) (and (rdr-string-rindex-char tok #\.) #t))
|
|
||||||
|
|
||||||
;; #a.b.C{..} -> (a.b/map->C {..}); #a.b.C[..] -> (a.b/->C ..). The factory call
|
|
||||||
;; compiles like any invoke; defrecord interns map->C/->C in the type's ns.
|
|
||||||
(define (rdr-record-ctor-form tok form)
|
|
||||||
(let* ((di (rdr-string-rindex-char tok #\.))
|
|
||||||
(ns (substring tok 0 di))
|
|
||||||
(simple (substring tok (+ di 1) (string-length tok))))
|
|
||||||
(cond
|
|
||||||
((pmap? form)
|
|
||||||
(jolt-list (jolt-symbol ns (string-append "map->" simple)) form))
|
|
||||||
((pvec? form)
|
|
||||||
(apply jolt-list (jolt-symbol ns (string-append "->" simple))
|
|
||||||
(vector->list (pvec-v form))))
|
|
||||||
(else (jolt-throw (jolt-ex-info
|
|
||||||
(string-append "Unreadable constructor form: #" tok)
|
|
||||||
empty-pmap))))))
|
|
||||||
|
|
||||||
;; #:ns{…} namespaced map literal: a bare keyword/symbol key gets `ns`, a `:_/x`
|
|
||||||
;; key is un-namespaced, an already-qualified key stays. #::{…} uses the current
|
|
||||||
;; ns; #::alias{…} resolves the alias.
|
|
||||||
(define (rdr-nsmap-key mapns k)
|
|
||||||
(cond
|
|
||||||
((keyword? k)
|
|
||||||
(let ((kns (keyword-t-ns k)) (kn (keyword-t-name k)))
|
|
||||||
(cond ((and (string? kns) (string=? kns "_")) (keyword #f kn))
|
|
||||||
(kns k)
|
|
||||||
(else (keyword mapns kn)))))
|
|
||||||
((symbol-t? k)
|
|
||||||
(let ((kns (symbol-t-ns k)) (kn (symbol-t-name k)))
|
|
||||||
(cond ((and (string? kns) (string=? kns "_")) (jolt-symbol #f kn))
|
|
||||||
(kns k)
|
|
||||||
(else (jolt-symbol mapns kn)))))
|
|
||||||
(else k)))
|
|
||||||
(define (rdr-nsmap-kvs mapns es)
|
|
||||||
(cond ((null? es) '())
|
|
||||||
((null? (cdr es)) es)
|
|
||||||
(else (cons (rdr-nsmap-key mapns (car es))
|
|
||||||
(cons (cadr es) (rdr-nsmap-kvs mapns (cddr es)))))))
|
|
||||||
(define (rdr-read-ns-map s i end) ; i points just past "#:"
|
|
||||||
(let* ((auto? (and (< i end) (char=? (string-ref s i) #\:)))
|
|
||||||
(i2 (if auto? (+ i 1) i)))
|
|
||||||
(let loop ((j i2))
|
|
||||||
(cond
|
|
||||||
((>= j end) (jolt-throw (jolt-ex-info "EOF in namespaced map literal" empty-pmap)))
|
|
||||||
((char=? (string-ref s j) #\{)
|
|
||||||
(let* ((nstok (substring s i2 j))
|
|
||||||
(mapns (if auto?
|
|
||||||
(if (string=? nstok "") (chez-current-ns)
|
|
||||||
(let ((a (chez-resolve-alias (chez-current-ns) nstok))) (if a a nstok)))
|
|
||||||
nstok)))
|
|
||||||
(let-values (((es k) (rdr-read-seq s (+ j 1) end #\})))
|
|
||||||
(values (rdr-make-map (rdr-nsmap-kvs mapns es)) k))))
|
|
||||||
(else (loop (+ j 1)))))))
|
|
||||||
|
|
||||||
(define (rdr-read-dispatch s i end) ; i points just past the '#'
|
(define (rdr-read-dispatch s i end) ; i points just past the '#'
|
||||||
(when (>= i end) (jolt-throw (jolt-ex-info "EOF after #" empty-pmap)))
|
(when (>= i end) (jolt-throw (jolt-ex-info "EOF after #" (empty-pmap))))
|
||||||
(let ((c (string-ref s i)))
|
(let ((c (string-ref s i)))
|
||||||
(cond
|
(cond
|
||||||
((char=? c #\{) ; #{...} set
|
((char=? c #\{) ; #{...} set
|
||||||
|
|
@ -611,12 +429,8 @@
|
||||||
(let-values (((src j) (rdr-read-regex s (+ i 1) end)))
|
(let-values (((src j) (rdr-read-regex s (+ i 1) end)))
|
||||||
(values (jolt-re-pattern src) j)))
|
(values (jolt-re-pattern src) j)))
|
||||||
((char=? c #\_) ; #_ discard the next form
|
((char=? c #\_) ; #_ discard the next form
|
||||||
(let-values (((d j) (rdr-read-form s (+ i 1) end)))
|
(let-values (((_ j) (rdr-read-form s (+ i 1) end)))
|
||||||
(when (rdr-eof? d) (jolt-throw (jolt-ex-info "EOF after #_" empty-pmap)))
|
(when (rdr-eof? _) (jolt-throw (jolt-ex-info "EOF after #_" (empty-pmap))))
|
||||||
;; edn validates the discarded element (its tags go through the same
|
|
||||||
;; :readers/:default pipeline; an unreadable one throws)
|
|
||||||
(let ((cb (rdr-discard-cb)))
|
|
||||||
(when cb (jolt-invoke cb d)))
|
|
||||||
(rdr-read-form s j end)))
|
(rdr-read-form s j end)))
|
||||||
((char=? c #\') ; #'x var-quote -> (var x)
|
((char=? c #\') ; #'x var-quote -> (var x)
|
||||||
(let-values (((form j) (rdr-read-form s (+ i 1) end)))
|
(let-values (((form j) (rdr-read-form s (+ i 1) end)))
|
||||||
|
|
@ -625,7 +439,7 @@
|
||||||
(let-values (((mform j) (rdr-read-form s (+ i 1) end)))
|
(let-values (((mform j) (rdr-read-form s (+ i 1) end)))
|
||||||
(let-values (((target k) (rdr-read-form s j end)))
|
(let-values (((target k) (rdr-read-form s j end)))
|
||||||
(when (rdr-eof? target)
|
(when (rdr-eof? target)
|
||||||
(jolt-throw (jolt-ex-info "EOF after #^meta" empty-pmap)))
|
(jolt-throw (jolt-ex-info "EOF after #^meta" (empty-pmap))))
|
||||||
(values (rdr-attach-meta target (rdr-meta-map mform)) k))))
|
(values (rdr-attach-meta target (rdr-meta-map mform)) k))))
|
||||||
((char=? c #\#) ; ## symbolic value: ##Inf / ##-Inf / ##NaN
|
((char=? c #\#) ; ## symbolic value: ##Inf / ##-Inf / ##NaN
|
||||||
(let-values (((tok j) (rdr-read-token s (+ i 1) end)))
|
(let-values (((tok j) (rdr-read-token s (+ i 1) end)))
|
||||||
|
|
@ -633,25 +447,21 @@
|
||||||
((string=? tok "-Inf") -inf.0)
|
((string=? tok "-Inf") -inf.0)
|
||||||
((string=? tok "NaN") +nan.0)
|
((string=? tok "NaN") +nan.0)
|
||||||
(else (jolt-throw (jolt-ex-info (string-append "unknown ## literal: " tok)
|
(else (jolt-throw (jolt-ex-info (string-append "unknown ## literal: " tok)
|
||||||
empty-pmap))))
|
(empty-pmap)))))
|
||||||
j)))
|
j)))
|
||||||
((char=? c #\?) ; #?(...) / #?@(...) reader conditional
|
((char=? c #\?) ; #?(...) / #?@(...) reader conditional
|
||||||
(rdr-read-reader-cond s (+ i 1) end))
|
(rdr-read-reader-cond s (+ i 1) end))
|
||||||
((char=? c #\:) ; #:ns{...} namespaced map literal
|
|
||||||
(rdr-read-ns-map s (+ i 1) end))
|
|
||||||
(else ; #tag form -> tagged {:tag :#tag :form ...}
|
(else ; #tag form -> tagged {:tag :#tag :form ...}
|
||||||
(let-values (((tok j) (rdr-read-token s i end)))
|
(let-values (((tok j) (rdr-read-token s i end)))
|
||||||
(let-values (((form k) (rdr-read-form s j end)))
|
(let-values (((form k) (rdr-read-form s j end)))
|
||||||
(when (rdr-eof? form) (jolt-throw (jolt-ex-info "EOF after #tag" empty-pmap)))
|
(when (rdr-eof? form) (jolt-throw (jolt-ex-info "EOF after #tag" (empty-pmap))))
|
||||||
(if (rdr-record-tag? tok) ; #ns.Type{..}/[..] record literal
|
(values (rdr-make-tagged (keyword #f (string-append "#" tok)) form) k)))))))
|
||||||
(values (rdr-record-ctor-form tok form) k)
|
|
||||||
(values (rdr-make-tagged (keyword #f (string-append "#" tok)) form) k))))))))
|
|
||||||
|
|
||||||
;; regex literal source: raw chars to the closing quote; \" is an escaped quote,
|
;; regex literal source: raw chars to the closing quote; \" is an escaped quote,
|
||||||
;; every other backslash sequence is kept verbatim (regex engine semantics).
|
;; every other backslash sequence is kept verbatim (regex engine semantics).
|
||||||
(define (rdr-read-regex s i end)
|
(define (rdr-read-regex s i end)
|
||||||
(let loop ((i i) (acc '()))
|
(let loop ((i i) (acc '()))
|
||||||
(when (>= i end) (jolt-throw (jolt-ex-info "EOF while reading regex" empty-pmap)))
|
(when (>= i end) (jolt-throw (jolt-ex-info "EOF while reading regex" (empty-pmap))))
|
||||||
(let ((c (string-ref s i)))
|
(let ((c (string-ref s i)))
|
||||||
(cond
|
(cond
|
||||||
((char=? c #\") (values (list->string (reverse acc)) (+ i 1)))
|
((char=? c #\") (values (list->string (reverse acc)) (+ i 1)))
|
||||||
|
|
@ -668,17 +478,6 @@
|
||||||
(let ((auto? (and (< i end) (char=? (string-ref s i) #\:))))
|
(let ((auto? (and (< i end) (char=? (string-ref s i) #\:))))
|
||||||
(let ((i (if auto? (+ i 1) i)))
|
(let ((i (if auto? (+ i 1) i)))
|
||||||
(let-values (((tok j) (rdr-read-token s i end)))
|
(let-values (((tok j) (rdr-read-token s i end)))
|
||||||
(let ((len (string-length tok)))
|
|
||||||
;; ":" and "::" alone, a leading or trailing slash (a name of exactly
|
|
||||||
;; "/" is fine, :ns//), or an auto-resolved keyword in edn (no
|
|
||||||
;; resolution context) are invalid tokens.
|
|
||||||
(when (or (= len 0)
|
|
||||||
(and (> len 1) (char=? (string-ref tok 0) #\/))
|
|
||||||
(and (> len 1) (char=? (string-ref tok (- len 1)) #\/)
|
|
||||||
(not (and (> len 2) (char=? (string-ref tok (- len 2)) #\/)))))
|
|
||||||
(rdr-invalid-token (string-append (if auto? "::" ":") tok)))
|
|
||||||
(when (and auto? (rdr-edn-mode))
|
|
||||||
(rdr-invalid-token (string-append "::" tok))))
|
|
||||||
(let-values (((ns name) (rdr-sym-parts tok)))
|
(let-values (((ns name) (rdr-sym-parts tok)))
|
||||||
(if auto?
|
(if auto?
|
||||||
(let* ((cur (chez-current-ns))
|
(let* ((cur (chez-current-ns))
|
||||||
|
|
@ -697,9 +496,8 @@
|
||||||
(values rdr-eof i)
|
(values rdr-eof i)
|
||||||
(let ((c (string-ref s i)))
|
(let ((c (string-ref s i)))
|
||||||
(cond
|
(cond
|
||||||
((char=? c #\() (let-values (((line col) (rdr-line-col-at s i)))
|
((char=? c #\() (let-values (((es j) (rdr-read-seq s (+ i 1) end #\))))
|
||||||
(let-values (((es j) (rdr-read-seq s (+ i 1) end #\))))
|
(values (apply jolt-list es) j)))
|
||||||
(values (rdr-attach-pos (apply jolt-list es) line col) j))))
|
|
||||||
((char=? c #\[) (let-values (((es j) (rdr-read-seq s (+ i 1) end #\])))
|
((char=? c #\[) (let-values (((es j) (rdr-read-seq s (+ i 1) end #\])))
|
||||||
(values (apply jolt-vector es) j)))
|
(values (apply jolt-vector es) j)))
|
||||||
((char=? c #\{) (let-values (((es j) (rdr-read-seq s (+ i 1) end #\})))
|
((char=? c #\{) (let-values (((es j) (rdr-read-seq s (+ i 1) end #\})))
|
||||||
|
|
@ -716,24 +514,21 @@
|
||||||
;; inert: ``42 reads as 42, ```"meow" as "meow".
|
;; inert: ``42 reads as 42, ```"meow" as "meow".
|
||||||
((char=? c #\`)
|
((char=? c #\`)
|
||||||
(let-values (((form j) (rdr-read-form s (+ i 1) end)))
|
(let-values (((form j) (rdr-read-form s (+ i 1) end)))
|
||||||
(when (rdr-eof? form) (jolt-throw (jolt-ex-info "EOF after `" empty-pmap)))
|
(when (rdr-eof? form) (jolt-throw (jolt-ex-info "EOF after `" (empty-pmap))))
|
||||||
(values (if (rdr-self-eval-literal? form)
|
(values (if (rdr-self-eval-literal? form)
|
||||||
form
|
form
|
||||||
(jolt-list (jolt-symbol #f "syntax-quote") form))
|
(jolt-list (jolt-symbol #f "syntax-quote") form))
|
||||||
j)))
|
j)))
|
||||||
((char=? c #\@) (rdr-wrap s (+ i 1) end (jolt-symbol "clojure.core" "deref")))
|
((char=? c #\@) (rdr-wrap s (+ i 1) end (jolt-symbol "clojure.core" "deref")))
|
||||||
;; ~ / ~@ read as clojure.core/unquote(-splicing), like the JVM reader —
|
|
||||||
;; so code that inspects pattern/template data (core.logic's defne) sees
|
|
||||||
;; the qualified symbol it expects.
|
|
||||||
((char=? c #\~)
|
((char=? c #\~)
|
||||||
(if (and (< (+ i 1) end) (char=? (string-ref s (+ i 1)) #\@))
|
(if (and (< (+ i 1) end) (char=? (string-ref s (+ i 1)) #\@))
|
||||||
(rdr-wrap s (+ i 2) end (jolt-symbol "clojure.core" "unquote-splicing"))
|
(rdr-wrap s (+ i 2) end (jolt-symbol #f "unquote-splicing"))
|
||||||
(rdr-wrap s (+ i 1) end (jolt-symbol "clojure.core" "unquote"))))
|
(rdr-wrap s (+ i 1) end (jolt-symbol #f "unquote"))))
|
||||||
((char=? c #\^)
|
((char=? c #\^)
|
||||||
(let-values (((mform j) (rdr-read-form s (+ i 1) end)))
|
(let-values (((mform j) (rdr-read-form s (+ i 1) end)))
|
||||||
(let-values (((target k) (rdr-read-form s j end)))
|
(let-values (((target k) (rdr-read-form s j end)))
|
||||||
(when (rdr-eof? target)
|
(when (rdr-eof? target)
|
||||||
(jolt-throw (jolt-ex-info "EOF after ^meta" empty-pmap)))
|
(jolt-throw (jolt-ex-info "EOF after ^meta" (empty-pmap))))
|
||||||
(values (rdr-attach-meta target (rdr-meta-map mform)) k))))
|
(values (rdr-attach-meta target (rdr-meta-map mform)) k))))
|
||||||
(else
|
(else
|
||||||
(let-values (((tok j) (rdr-read-token s i end)))
|
(let-values (((tok j) (rdr-read-token s i end)))
|
||||||
|
|
@ -748,7 +543,7 @@
|
||||||
(define (rdr-wrap s i end head)
|
(define (rdr-wrap s i end head)
|
||||||
(let-values (((form j) (rdr-read-form s i end)))
|
(let-values (((form j) (rdr-read-form s i end)))
|
||||||
(when (rdr-eof? form)
|
(when (rdr-eof? form)
|
||||||
(jolt-throw (jolt-ex-info "EOF while reading reader macro" empty-pmap)))
|
(jolt-throw (jolt-ex-info "EOF while reading reader macro" (empty-pmap))))
|
||||||
(values (jolt-list head form) j)))
|
(values (jolt-list head form) j)))
|
||||||
|
|
||||||
;; --- form -> data -----------------------------------------------------------
|
;; --- form -> data -----------------------------------------------------------
|
||||||
|
|
@ -768,11 +563,8 @@
|
||||||
(let ((c (rdr-form->data (car xs))))
|
(let ((c (rdr-form->data (car xs))))
|
||||||
(loop (cdr xs) (cons c acc) (or changed (not (eq? c (car xs)))))))))
|
(loop (cdr xs) (cons c acc) (or changed (not (eq? c (car xs)))))))))
|
||||||
|
|
||||||
;; carry the reader metadata, converting its nested forms too — a set/tagged
|
|
||||||
;; literal inside a ^{…} map (^{:k #{…}}) must become a value like the rest of
|
|
||||||
;; the data, not stay the tagged set-form.
|
|
||||||
(define (rdr-carry-meta src dst)
|
(define (rdr-carry-meta src dst)
|
||||||
(let ((m (jolt-meta src))) (if (jolt-nil? m) dst (jolt-with-meta dst (rdr-form->data m)))))
|
(let ((m (jolt-meta src))) (if (jolt-nil? m) dst (jolt-with-meta dst m))))
|
||||||
|
|
||||||
;; tag keyword (:#time/date) -> its *data-readers* reader fn, or #f. The fn's
|
;; tag keyword (:#time/date) -> its *data-readers* reader fn, or #f. The fn's
|
||||||
;; namespace must already be loaded (the loader requires them when a project's
|
;; namespace must already be loaded (the loader requires them when a project's
|
||||||
|
|
@ -795,173 +587,52 @@
|
||||||
(guard (e (#t #f))
|
(guard (e (#t #f))
|
||||||
(let ((fn (var-deref (symbol-t-ns v) (symbol-t-name v))))
|
(let ((fn (var-deref (symbol-t-ns v) (symbol-t-name v))))
|
||||||
(and (procedure? fn) fn)))))))))
|
(and (procedure? fn) fn)))))))))
|
||||||
;; the bare tag SYMBOL for a :#name / :#ns/name reader keyword (strip the leading
|
|
||||||
;; #, split a qualified tag on /). *default-data-reader-fn* receives it.
|
|
||||||
(define (rdr-tag->symbol tag)
|
|
||||||
(let* ((nm (keyword-t-name tag))
|
|
||||||
(bare (if (and (> (string-length nm) 0) (char=? (string-ref nm 0) #\#))
|
|
||||||
(substring nm 1 (string-length nm)) nm)))
|
|
||||||
(let loop ((i 0))
|
|
||||||
(cond ((>= i (string-length bare)) (jolt-symbol #f bare))
|
|
||||||
((char=? (string-ref bare i) #\/)
|
|
||||||
(jolt-symbol (substring bare 0 i) (substring bare (+ i 1) (string-length bare))))
|
|
||||||
(else (loop (+ i 1)))))))
|
|
||||||
;; *default-data-reader-fn* — a (fn [tag value]) consulted for an unregistered
|
|
||||||
;; tag, or #f when unset/nil. Honors a `binding` (var-deref reads the stack).
|
|
||||||
(define (rdr-default-data-reader-fn)
|
|
||||||
(guard (e (#t #f))
|
|
||||||
(let ((v (var-deref "clojure.core" "*default-data-reader-fn*")))
|
|
||||||
(and (not (jolt-nil? v)) (procedure? v) v))))
|
|
||||||
|
|
||||||
;; strict #inst validation: RFC-3339 calendar fields must be real (month 1-12,
|
|
||||||
;; day valid for the month incl. leap years, hour < 24, minute/second < 60).
|
|
||||||
(define (rdr-2dig s i)
|
|
||||||
(and (< (+ i 1) (string-length s))
|
|
||||||
(rdr-digit? (string-ref s i)) (rdr-digit? (string-ref s (+ i 1)))
|
|
||||||
(+ (* 10 (- (char->integer (string-ref s i)) 48))
|
|
||||||
(- (char->integer (string-ref s (+ i 1))) 48))))
|
|
||||||
(define (rdr-leap? y) (and (= 0 (modulo y 4)) (or (not (= 0 (modulo y 100))) (= 0 (modulo y 400)))))
|
|
||||||
(define (rdr-inst-throw s)
|
|
||||||
(jolt-throw (jolt-host-throwable "java.lang.RuntimeException"
|
|
||||||
(string-append "Unrecognized date/time syntax: " s))))
|
|
||||||
(define (rdr-validate-inst! s)
|
|
||||||
;; progressive RFC-3339 like clojure.instant: yyyy[-MM[-dd[Thh[:mm[:ss[.f]]]]]]
|
|
||||||
;; with an optional Z/±hh:mm offset; each present field must be in range
|
|
||||||
;; (months 1-12, day valid for the month incl. leap years, hour < 24, min < 60).
|
|
||||||
(let* ((len (string-length s))
|
|
||||||
(y (and (>= len 4) (rdr-all-digits? s 0 4) (string->number (substring s 0 4)))))
|
|
||||||
(unless y (rdr-inst-throw s))
|
|
||||||
(when (>= len 5)
|
|
||||||
(unless (char=? (string-ref s 4) #\-) (rdr-inst-throw s))
|
|
||||||
(let ((mo (rdr-2dig s 5)))
|
|
||||||
(unless (and mo (>= mo 1) (<= mo 12)) (rdr-inst-throw s))
|
|
||||||
(when (>= len 8)
|
|
||||||
(unless (char=? (string-ref s 7) #\-) (rdr-inst-throw s))
|
|
||||||
(let ((d (rdr-2dig s 8)))
|
|
||||||
(unless (and d (>= d 1)
|
|
||||||
(<= d (vector-ref (if (rdr-leap? y)
|
|
||||||
'#(31 29 31 30 31 30 31 31 30 31 30 31)
|
|
||||||
'#(31 28 31 30 31 30 31 31 30 31 30 31))
|
|
||||||
(- mo 1))))
|
|
||||||
(rdr-inst-throw s))
|
|
||||||
(when (>= len 11)
|
|
||||||
(unless (char=? (string-ref s 10) #\T) (rdr-inst-throw s))
|
|
||||||
(let ((h (rdr-2dig s 11)))
|
|
||||||
(unless (and h (<= h 23)) (rdr-inst-throw s))
|
|
||||||
(when (>= len 14)
|
|
||||||
(when (char=? (string-ref s 13) #\:)
|
|
||||||
(let ((mi (rdr-2dig s 14)))
|
|
||||||
(unless (and mi (<= mi 59)) (rdr-inst-throw s)))))))))))))
|
|
||||||
;; strict #uuid: canonical 8-4-4-4-12 hex groups.
|
|
||||||
(define (rdr-validate-uuid! s)
|
|
||||||
(define (hexrun? from to)
|
|
||||||
(let loop ((i from))
|
|
||||||
(cond ((>= i to) #t)
|
|
||||||
((let ((c (char-downcase (string-ref s i))))
|
|
||||||
(or (rdr-digit? c) (and (char>=? c #\a) (char<=? c #\f))))
|
|
||||||
(loop (+ i 1)))
|
|
||||||
(else #f))))
|
|
||||||
(unless (and (= (string-length s) 36)
|
|
||||||
(char=? (string-ref s 8) #\-) (char=? (string-ref s 13) #\-)
|
|
||||||
(char=? (string-ref s 18) #\-) (char=? (string-ref s 23) #\-)
|
|
||||||
(hexrun? 0 8) (hexrun? 9 13) (hexrun? 14 18) (hexrun? 19 23) (hexrun? 24 36))
|
|
||||||
(jolt-throw (jolt-host-throwable "java.lang.IllegalArgumentException"
|
|
||||||
(string-append "Invalid UUID string: " s)))))
|
|
||||||
|
|
||||||
;; read-string / read data seam: construct the value for a #tag literal. #inst,
|
;; read-string / read data seam: construct the value for a #tag literal. #inst,
|
||||||
;; #uuid and #"regex" are built in; any other tag is applied from *data-readers*,
|
;; #uuid and #"regex" are built in; any other tag is applied from *data-readers*.
|
||||||
;; then *default-data-reader-fn*. An unregistered tag with no default handler stays
|
;; An unregistered tag stays a tagged FORM (lenient — clojure.edn raises instead).
|
||||||
;; a tagged FORM (lenient — clojure.edn raises instead).
|
|
||||||
(define (rdr-construct-tag tag inner)
|
(define (rdr-construct-tag tag inner)
|
||||||
(cond
|
(cond
|
||||||
((eq? tag (keyword #f "#inst"))
|
((eq? tag (keyword #f "#inst")) (jolt-inst-from-string inner))
|
||||||
(when (string? inner) (rdr-validate-inst! inner))
|
((eq? tag (keyword #f "#uuid")) (jolt-uuid-from-string inner))
|
||||||
(jolt-inst-from-string inner))
|
|
||||||
((eq? tag (keyword #f "#uuid"))
|
|
||||||
(when (string? inner) (rdr-validate-uuid! inner))
|
|
||||||
(jolt-uuid-from-string inner))
|
|
||||||
((eq? tag (keyword #f "regex")) (jolt-re-pattern inner))
|
((eq? tag (keyword #f "regex")) (jolt-re-pattern inner))
|
||||||
;; the M-literal form: construct the BigDecimal from its numeric text
|
|
||||||
((eq? tag (keyword #f "bigdec")) (jolt-bigdec-from-string inner))
|
|
||||||
(else (let ((fn (rdr-data-reader-fn tag)))
|
(else (let ((fn (rdr-data-reader-fn tag)))
|
||||||
(if fn (jolt-invoke fn inner)
|
(if fn (jolt-invoke fn inner) (rdr-make-tagged tag inner))))))
|
||||||
(let ((dfn (rdr-default-data-reader-fn)))
|
|
||||||
(if dfn (jolt-invoke dfn (rdr-tag->symbol tag) inner)
|
|
||||||
;; no reader for the tag: a proper tagged-literal value, like
|
|
||||||
;; Clojure's *default-data-reader-fn* (tagged-literal), so
|
|
||||||
;; tagged-literal? / :tag / :form / printing all work — not the
|
|
||||||
;; internal reader form. clojure.edn reads raw forms via
|
|
||||||
;; __read-form-raw, so its :readers/:default path is unaffected.
|
|
||||||
(jolt-tagged-literal (rdr-tag->symbol tag) inner))))))))
|
|
||||||
|
|
||||||
;; rdr-form->data*: convert the VALUE structure (set/tagged/nested forms). The
|
(define (rdr-form->data x)
|
||||||
;; wrapper below adds the metadata, so the unchanged branches return x bare.
|
|
||||||
(define (rdr-form->data* x)
|
|
||||||
(cond
|
(cond
|
||||||
((and (pmap? x) (eq? (jolt-get x rdr-kw-jolt-type) rdr-kw-jolt-tagged))
|
((and (pmap? x) (eq? (jolt-get x rdr-kw-jolt-type) rdr-kw-jolt-tagged))
|
||||||
(rdr-construct-tag (jolt-get x rdr-kw-tag) (rdr-form->data (jolt-get x rdr-kw-form))))
|
(rdr-construct-tag (jolt-get x rdr-kw-tag) (rdr-form->data (jolt-get x rdr-kw-form))))
|
||||||
((rdr-set-form? x)
|
((rdr-set-form? x)
|
||||||
(let ((items (jolt-get x rdr-kw-value)))
|
(let ((items (jolt-get x rdr-kw-value)))
|
||||||
(let loop ((i 0) (s empty-pset))
|
(rdr-carry-meta x
|
||||||
(if (fx>=? i (pvec-count items)) s
|
(let loop ((i 0) (s empty-pset))
|
||||||
(let ((v (rdr-form->data (pvec-nth-d items i jolt-nil))))
|
(if (fx>=? i (pvec-count items)) s
|
||||||
(when (jolt-truthy? (jolt-contains? s v))
|
(loop (fx+ i 1) (pset-conj s (rdr-form->data (pvec-nth-d items i jolt-nil)))))))))
|
||||||
(jolt-throw (jolt-host-throwable "java.lang.IllegalArgumentException"
|
|
||||||
(string-append "Duplicate key: " (jolt-pr-str v)))))
|
|
||||||
(loop (fx+ i 1) (pset-conj s v)))))))
|
|
||||||
((pvec? x)
|
((pvec? x)
|
||||||
(let-values (((items changed) (rdr-conv-each (vector->list (pvec-v x)))))
|
(let-values (((items changed) (rdr-conv-each (vector->list (pvec-v x)))))
|
||||||
(if changed (apply jolt-vector items) x)))
|
(if changed (rdr-carry-meta x (apply jolt-vector items)) x)))
|
||||||
((pmap? x)
|
((pmap? x)
|
||||||
(let ((order (hashtable-ref rdr-map-order x #f)))
|
(let ((order (hashtable-ref rdr-map-order x #f)))
|
||||||
(if order
|
(if order
|
||||||
(let-values (((kvs changed) (rdr-conv-each order)))
|
(let-values (((kvs changed) (rdr-conv-each order)))
|
||||||
(if changed (rdr-make-map kvs) x))
|
(if changed
|
||||||
|
(let ((m (rdr-make-map kvs))) (rdr-carry-meta x m))
|
||||||
|
x))
|
||||||
(let-values (((kvs changed)
|
(let-values (((kvs changed)
|
||||||
(rdr-conv-each (pmap-fold x (lambda (k v a) (cons k (cons v a))) '()))))
|
(rdr-conv-each (pmap-fold x (lambda (k v a) (cons k (cons v a))) '()))))
|
||||||
(if changed (apply jolt-hash-map kvs) x)))))
|
(if changed (rdr-carry-meta x (apply jolt-hash-map kvs)) x)))))
|
||||||
((cseq? x)
|
((cseq? x)
|
||||||
(let-values (((items changed) (rdr-conv-each (seq->list x))))
|
(let-values (((items changed) (rdr-conv-each (seq->list x))))
|
||||||
(if changed (apply jolt-list items) x)))
|
(if changed (rdr-carry-meta x (apply jolt-list items)) x)))
|
||||||
(else x)))
|
(else x)))
|
||||||
;; Read DATA always carries metadata, converting its nested forms too — Clojure's
|
|
||||||
;; reader reads a ^{…} map with the same read() as any value, so a set/tagged
|
|
||||||
;; literal in metadata is a value, not a form. Carry it whether or not the value
|
|
||||||
;; itself changed (a set-form in the metadata of an otherwise-unchanged value).
|
|
||||||
(define (rdr-form->data x)
|
|
||||||
(let ((v (rdr-form->data* x)) (m (jolt-meta x)))
|
|
||||||
(if (jolt-nil? m) v (jolt-with-meta v (rdr-form->data m)))))
|
|
||||||
|
|
||||||
;; --- the two host seams -----------------------------------------------------
|
;; --- the two host seams -----------------------------------------------------
|
||||||
;; a top-level read: a stray close delimiter is unmatched (read-seq consumes the
|
|
||||||
;; close of an open collection; anything reaching here is unbalanced input).
|
|
||||||
(define (rdr-read-top s i end)
|
|
||||||
(let ((k (rdr-skip-ws s i end)))
|
|
||||||
(when (and (< k end)
|
|
||||||
(let ((c (string-ref s k)))
|
|
||||||
(or (char=? c #\)) (char=? c #\]) (char=? c #\}))))
|
|
||||||
(jolt-throw (jolt-ex-info (string-append "Unmatched delimiter: "
|
|
||||||
(string (string-ref s k)))
|
|
||||||
empty-pmap)))
|
|
||||||
(rdr-read-form s k end)))
|
|
||||||
|
|
||||||
;; clojure.core/read-string: first form, or nil for blank / comment-only input
|
;; clojure.core/read-string: first form, or nil for blank / comment-only input
|
||||||
;; (parse-string wart, matched deliberately). jolt-read-form-raw keeps set FORMS
|
;; (parse-string wart, matched deliberately). jolt-read-form-raw keeps set FORMS
|
||||||
;; for the compiler spine (compile-eval); the data seam converts them to sets.
|
;; for the compiler spine (compile-eval); the data seam converts them to sets.
|
||||||
(define (jolt-read-form-raw s)
|
(define (jolt-read-form-raw s)
|
||||||
(let-values (((form j) (rdr-read-top s 0 (string-length s))))
|
(let-values (((form j) (rdr-read-form s 0 (string-length s))))
|
||||||
(if (rdr-eof? form) jolt-nil form)))
|
(if (rdr-eof? form) jolt-nil form)))
|
||||||
|
|
||||||
;; the edn seam: strict mode (no auto-resolved keywords), each #_ discard handed
|
|
||||||
;; to the callback for tag validation, and a distinct EOF sentinel so the edn
|
|
||||||
;; layer can honor its :eof option (nil input is a plain EOF).
|
|
||||||
(define (jolt-read-form-edn s cb)
|
|
||||||
(if (jolt-nil? s)
|
|
||||||
(keyword "jolt" "reader-eof")
|
|
||||||
(parameterize ((rdr-edn-mode #t)
|
|
||||||
(rdr-discard-cb (if (jolt-nil? cb) #f cb)))
|
|
||||||
(let-values (((form j) (rdr-read-top s 0 (string-length s))))
|
|
||||||
(if (rdr-eof? form) (keyword "jolt" "reader-eof") form)))))
|
|
||||||
(define (jolt-read-string s)
|
(define (jolt-read-string s)
|
||||||
(let ((form (jolt-read-form-raw s)))
|
(let ((form (jolt-read-form-raw s)))
|
||||||
(if (jolt-nil? form) form (rdr-form->data form))))
|
(if (jolt-nil? form) form (rdr-form->data form))))
|
||||||
|
|
@ -969,7 +640,7 @@
|
||||||
;; __parse-next: [form rest-of-string] or nil when only whitespace/comments left.
|
;; __parse-next: [form rest-of-string] or nil when only whitespace/comments left.
|
||||||
(define (jolt-parse-next s)
|
(define (jolt-parse-next s)
|
||||||
(let ((end (string-length s)))
|
(let ((end (string-length s)))
|
||||||
(let-values (((form j) (rdr-read-top s 0 end)))
|
(let-values (((form j) (rdr-read-form s 0 end)))
|
||||||
(if (rdr-eof? form)
|
(if (rdr-eof? form)
|
||||||
jolt-nil
|
jolt-nil
|
||||||
(jolt-vector (rdr-form->data form) (substring s j end))))))
|
(jolt-vector (rdr-form->data form) (substring s j end))))))
|
||||||
|
|
@ -978,30 +649,16 @@
|
||||||
;; is the :#name keyword the reader produced; #uuid/#inst reuse the inst-time ctors.
|
;; is the :#name keyword the reader produced; #uuid/#inst reuse the inst-time ctors.
|
||||||
(define (jolt-read-tagged tag form)
|
(define (jolt-read-tagged tag form)
|
||||||
(cond
|
(cond
|
||||||
((eq? tag (keyword #f "#uuid"))
|
((eq? tag (keyword #f "#uuid")) (jolt-uuid-from-string form))
|
||||||
(when (string? form) (rdr-validate-uuid! form))
|
((eq? tag (keyword #f "#inst")) (jolt-inst-from-string form))
|
||||||
(jolt-uuid-from-string form))
|
;; No registered reader: throw a clean, catchable ex-info naming the tag, like
|
||||||
((eq? tag (keyword #f "#inst"))
|
;; the JVM's "No reader function for tag foobar" (empty-pmap is a VALUE — the
|
||||||
(when (string? form) (rdr-validate-inst! form))
|
;; old (empty-pmap) applied it as a procedure and crashed the Chez VM).
|
||||||
(jolt-inst-from-string form))
|
(else (let* ((nm (keyword-t-name tag))
|
||||||
((eq? tag (keyword #f "bigdec")) (jolt-bigdec-from-string form))
|
(bare (if (and (> (string-length nm) 0) (char=? (string-ref nm 0) #\#))
|
||||||
;; No registered reader: consult *default-data-reader-fn*, else throw a clean,
|
(substring nm 1 (string-length nm)) nm)))
|
||||||
;; catchable ex-info naming the tag, like the JVM's "No reader function for tag
|
(jolt-throw (jolt-ex-info (string-append "No reader function for tag " bare) empty-pmap))))))
|
||||||
;; foobar" (empty-pmap is a VALUE — the old (empty-pmap) applied it as a
|
|
||||||
;; procedure and crashed the Chez VM).
|
|
||||||
(else (let ((dfn (rdr-default-data-reader-fn)))
|
|
||||||
(if dfn (jolt-invoke dfn (rdr-tag->symbol tag) form)
|
|
||||||
(let* ((nm (keyword-t-name tag))
|
|
||||||
(bare (if (and (> (string-length nm) 0) (char=? (string-ref nm 0) #\#))
|
|
||||||
(substring nm 1 (string-length nm)) nm)))
|
|
||||||
(jolt-throw (jolt-ex-info (string-append "No reader function for tag " bare) empty-pmap))))))))
|
|
||||||
|
|
||||||
(def-var! "clojure.core" "read-string" jolt-read-string)
|
(def-var! "clojure.core" "read-string" jolt-read-string)
|
||||||
(def-var! "clojure.core" "__parse-next" jolt-parse-next)
|
(def-var! "clojure.core" "__parse-next" jolt-parse-next)
|
||||||
(def-var! "clojure.core" "__read-tagged" jolt-read-tagged)
|
(def-var! "clojure.core" "__read-tagged" jolt-read-tagged)
|
||||||
;; __read-form-raw: the read form WITHOUT building values — set/tagged literals
|
|
||||||
;; stay FORMS. clojure.edn reads this so it applies a #tag through its :readers/
|
|
||||||
;; :default (a #inst can be overridden to defer), rather than read-string building
|
|
||||||
;; the built-in #inst eagerly (which fails on a non-string like #inst ^:ref […]).
|
|
||||||
(def-var! "clojure.core" "__read-form-raw" jolt-read-form-raw)
|
|
||||||
(def-var! "clojure.core" "__read-form-edn" jolt-read-form-edn)
|
|
||||||
|
|
|
||||||
|
|
@ -10,42 +10,44 @@
|
||||||
(define (ex-info-class v)
|
(define (ex-info-class v)
|
||||||
(let ((c (jolt-get v jolt-kw-class jolt-nil)))
|
(let ((c (jolt-get v jolt-kw-class jolt-nil)))
|
||||||
(if (string? c) c "clojure.lang.ExceptionInfo")))
|
(if (string? c) c "clojure.lang.ExceptionInfo")))
|
||||||
;; Is `wanted` (simple name) `cls` or a supertype of it? The exception hierarchy
|
;; immediate-parent chain of the JVM exception hierarchy (simple names). Drives
|
||||||
;; lives in the one class graph (class-hierarchy.ss) — resolve the simple name to
|
;; instance? across exception supertypes — (instance? Throwable (ex-info …)) etc.
|
||||||
;; its graph key and ask jch-isa?, so exceptions and every other class share a
|
(define exception-parent
|
||||||
;; single source of truth (ExceptionInfo -> IExceptionInfo is a graph edge).
|
'(("ExceptionInfo" . "RuntimeException")
|
||||||
|
("RuntimeException" . "Exception")
|
||||||
|
("IllegalArgumentException" . "RuntimeException")
|
||||||
|
("NumberFormatException" . "IllegalArgumentException")
|
||||||
|
("IllegalStateException" . "RuntimeException")
|
||||||
|
("UnsupportedOperationException" . "RuntimeException")
|
||||||
|
("ArithmeticException" . "RuntimeException")
|
||||||
|
("NullPointerException" . "RuntimeException")
|
||||||
|
("ClassCastException" . "RuntimeException")
|
||||||
|
("IndexOutOfBoundsException" . "RuntimeException")
|
||||||
|
("ConcurrentModificationException" . "RuntimeException")
|
||||||
|
("NoSuchElementException" . "RuntimeException")
|
||||||
|
("UncheckedIOException" . "RuntimeException")
|
||||||
|
("InterruptedException" . "Exception")
|
||||||
|
("IOException" . "Exception")
|
||||||
|
("FileNotFoundException" . "IOException")
|
||||||
|
("UnsupportedEncodingException" . "IOException")
|
||||||
|
("UnknownHostException" . "IOException")
|
||||||
|
("SocketException" . "IOException")
|
||||||
|
("ConnectException" . "IOException")
|
||||||
|
("SocketTimeoutException" . "IOException")
|
||||||
|
("MalformedURLException" . "IOException")
|
||||||
|
("SSLException" . "IOException")
|
||||||
|
("Exception" . "Throwable")
|
||||||
|
("Error" . "Throwable")
|
||||||
|
("AssertionError" . "Error")
|
||||||
|
("Throwable" . "Object")))
|
||||||
|
;; Is `wanted` (simple name) `cls` or a supertype of it? ExceptionInfo also
|
||||||
|
;; implements the IExceptionInfo interface.
|
||||||
(define (exception-isa? cls wanted)
|
(define (exception-isa? cls wanted)
|
||||||
(jch-isa? (jch-fqn-of-simple cls) wanted))
|
(let loop ((c cls))
|
||||||
|
(cond ((not c) #f)
|
||||||
;; A raw Chez condition (an arity or non-seqable error Chez itself raised, not a
|
((string=? c wanted) #t)
|
||||||
;; jolt ex-info) carries no jolt exception class. Map the ones Clojure raises a
|
((and (string=? c "ExceptionInfo") (string=? wanted "IExceptionInfo")) #t)
|
||||||
;; specific class for, by message, so (class e) and (instance? C e) match the JVM.
|
(else (let ((p (assoc c exception-parent))) (loop (and p (cdr p))))))))
|
||||||
;; 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
|
;; instance-check: (type-sym val) — type/protocol membership. Host shims loaded
|
||||||
;; later (io, inst-time, natives-array, natives-queue, host-static-classes)
|
;; later (io, inst-time, natives-array, natives-queue, host-static-classes)
|
||||||
|
|
@ -57,35 +59,14 @@
|
||||||
(define (register-instance-check-arm! f) ; f: (type-sym val) -> #t | #f | 'pass
|
(define (register-instance-check-arm! f) ; f: (type-sym val) -> #t | #f | 'pass
|
||||||
(set! instance-check-registry (cons f instance-check-registry)))
|
(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)
|
(define (instance-check-base type-sym val)
|
||||||
(let ((tname (symbol-t-name type-sym)))
|
(let ((tname (symbol-t-name type-sym)))
|
||||||
(cond
|
(cond
|
||||||
((jrec? val)
|
((jrec? val)
|
||||||
(let ((tag (jrec-tag val)))
|
(let ((tag (jrec-tag val)))
|
||||||
(or (string=? tag tname)
|
(or (string=? tag tname)
|
||||||
;; a simple name matches a qualified tag only at a `.` boundary:
|
(and (> (string-length tag) (string-length tname))
|
||||||
;; "a.b.IntervalFD" is an IntervalFD, but "a.b.MultiIntervalFD" is NOT
|
(string=? (substring tag (- (string-length tag) (string-length tname)) (string-length tag)) tname))
|
||||||
;; (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
|
;; a protocol/interface the type implements (defprotocol generates an
|
||||||
;; interface; (instance? SomeProtocol record) is true when the record
|
;; interface; (instance? SomeProtocol record) is true when the record
|
||||||
;; implements it — core.match dispatches on instance? IPatternCompile).
|
;; implements it — core.match dispatches on instance? IPatternCompile).
|
||||||
|
|
@ -138,26 +119,3 @@
|
||||||
;; records.ss, so this set! sees the registry — forward refs resolve at call time.
|
;; records.ss, so this set! sees the registry — forward refs resolve at call time.
|
||||||
|
|
||||||
(def-var! "clojure.core" "instance-check" instance-check)
|
(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,13 +1,9 @@
|
||||||
;; records + protocols — the deftype/defrecord + defprotocol/extend-type
|
;; records + protocols — the deftype/defrecord + defprotocol/extend-type
|
||||||
;; subsystem.
|
;; subsystem.
|
||||||
;;
|
;;
|
||||||
;; A record is a `jrec`: a shared per-type descriptor + a flat vector of field
|
;; A record is a `jrec`: a type tag ("ns.Name") + an alist of (kw . val) in
|
||||||
;; values in declared order, plus an extension map for any non-field keys assoc'd
|
;; declared field order. It is map?/coll?, equal to another jrec of the same tag
|
||||||
;; on (jolt-nil when there are none — the common case). This lays fields out like a
|
;; with equal fields (never equal to a plain map), and prints as #ns.Name{...}.
|
||||||
;; native struct: construction allocates one vector, not a chain of cons cells, and
|
|
||||||
;; a field read is an index lookup, not a list scan. It is map?/coll?, equal to
|
|
||||||
;; another jrec of the same type with equal fields (never equal to a plain map),
|
|
||||||
;; and prints as #ns.Name{...}.
|
|
||||||
;; The collection dispatchers (jolt-get/count/keys/vals/seq/assoc/contains?/=/
|
;; The collection dispatchers (jolt-get/count/keys/vals/seq/assoc/contains?/=/
|
||||||
;; hash/conj + the printers) are set!-extended with a jrec arm that delegates to
|
;; hash/conj + the printers) are set!-extended with a jrec arm that delegates to
|
||||||
;; the original — the transients.ss pattern — so all record logic lives here and
|
;; the original — the transients.ss pattern — so all record logic lives here and
|
||||||
|
|
@ -17,261 +13,53 @@
|
||||||
;; Loaded after collections/seq/values/converters/printing/transients/multimethods
|
;; Loaded after collections/seq/values/converters/printing/transients/multimethods
|
||||||
;; (the dispatchers it wraps + chez-current-ns).
|
;; (the dispatchers it wraps + chez-current-ns).
|
||||||
|
|
||||||
;; The per-type descriptor: built once at deftype/defrecord definition and shared
|
(define-record-type jrec (fields tag pairs) (nongenerative chez-jrec-v1))
|
||||||
;; by every instance. Holds the tag, the field keywords in declared order, and an
|
|
||||||
;; eq?-keyed keyword->index table (field keys are interned, so identity lookup).
|
|
||||||
(define-record-type (jrdesc make-jrdesc-rec jrdesc?)
|
|
||||||
(fields tag fkeys index) (nongenerative chez-jrdesc-v1))
|
|
||||||
(define (make-jrdesc tag fkey-list)
|
|
||||||
(let ((index (make-eq-hashtable)))
|
|
||||||
(let loop ((ks fkey-list) (i 0))
|
|
||||||
(unless (null? ks) (hashtable-set! index (car ks) i) (loop (cdr ks) (+ i 1))))
|
|
||||||
(make-jrdesc-rec tag (list->vector fkey-list) index)))
|
|
||||||
;; An instance: the shared descriptor, the field-value vector, and an extension
|
|
||||||
;; map (jolt-nil unless non-field keys have been assoc'd on).
|
|
||||||
(define-record-type (jrec make-jrec jrec?) (fields desc vals ext) (nongenerative chez-jrec-v2))
|
|
||||||
(define (jrec-tag r) (jrdesc-tag (jrec-desc r)))
|
|
||||||
|
|
||||||
;; defrecord vs deftype: a defrecord IS a map (map?/seq/keys/assoc over its
|
|
||||||
;; fields); a bare deftype is an opaque object with only its declared interfaces,
|
|
||||||
;; never a map (Clojure semantics). defrecord registers its type tag here; the
|
|
||||||
;; default jrec-as-map behaviour (map?/record?/field-seq) is gated on it, while
|
|
||||||
;; method dispatch (a deftype implementing ISeq/Counted/…) stays open to any jrec.
|
|
||||||
(define chez-record-type-tbl (make-hashtable string-hash string=?))
|
|
||||||
(define (jrec-record? x) (and (jrec? x) (hashtable-ref chez-record-type-tbl (jrec-tag x) #f) #t))
|
|
||||||
;; every deftype/defrecord tag, and a simple-name -> tag index. An extend-protocol
|
|
||||||
;; in a DIFFERENT ns names the type bare (it is :import-ed), so register-method
|
|
||||||
;; resolves "Raw" to its real tag "a.util.Raw" here instead of prepending the
|
|
||||||
;; calling ns. The local ns is preferred, so a same-named local type still wins.
|
|
||||||
(define chez-deftype-tag-set (make-hashtable string-hash string=?))
|
|
||||||
;; ctor procedure -> its class tag: the type NAME var holds the ctor (a jolt-ism;
|
|
||||||
;; the JVM resolves it to the class), so class-key maps the ctor back to the
|
|
||||||
;; class for (ancestors TypeName) / (isa? x TypeName) / derive on the type.
|
|
||||||
(define chez-deftype-ctor-tag (make-weak-eq-hashtable))
|
|
||||||
(define chez-simple-name-tag (make-hashtable string-hash string=?))
|
|
||||||
;; a jrec that is coll? — a record, or a deftype implementing a collection
|
|
||||||
;; interface (its seq/count/nth/valAt/cons method is registered). find-method-any-
|
|
||||||
;; protocol is defined later; resolved at call time. An opaque deftype is not coll?.
|
|
||||||
(define (jrec-collection? x)
|
|
||||||
(and (jrec? x)
|
|
||||||
(or (jrec-record? x)
|
|
||||||
(let ((tag (jrec-tag x)))
|
|
||||||
;; coll? is instance? IPersistentCollection — its marker is `cons`
|
|
||||||
;; (and ISeq's `first`). ILookup(valAt) / Indexed(nth) / Counted(count)
|
|
||||||
;; / Seqable(seq) alone do NOT make a value coll?, matching the JVM
|
|
||||||
;; (e.g. core.logic's LVar implements only valAt and is not coll?).
|
|
||||||
(or (find-method-any-protocol tag "cons")
|
|
||||||
(find-method-any-protocol tag "first"))))
|
|
||||||
#t))
|
|
||||||
;; a jrec that is map? — a record, or a deftype implementing clojure.lang
|
|
||||||
;; .IPersistentMap (clojure.core.cache's caches do). `without` (dissoc) is the
|
|
||||||
;; map-distinctive method: vectors/sets implement Associative/ILookup but not it.
|
|
||||||
(define (jrec-maplike? x)
|
|
||||||
(and (jrec? x)
|
|
||||||
(or (jrec-record? x)
|
|
||||||
(find-method-any-protocol (jrec-tag x) "without"))
|
|
||||||
#t))
|
|
||||||
(define jolt-deftype-kw (keyword "jolt" "deftype"))
|
(define jolt-deftype-kw (keyword "jolt" "deftype"))
|
||||||
;; unique present-vs-absent sentinel for extension-map lookups (so a present nil
|
|
||||||
;; in the extension map is distinguished from a genuine miss).
|
|
||||||
(define jrec-absent (list 'jrec-absent))
|
|
||||||
|
|
||||||
;; --- whole-program inference registries -------------------------------------
|
|
||||||
;; Populated at definition/load time (deftype/defrecord and defprotocol forms run
|
|
||||||
;; before `jolt build` re-emits), read by the inference driver to seed record and
|
|
||||||
;; protocol-method types across fn boundaries. A no-op for the runtime itself; the
|
|
||||||
;; tables just accumulate. jolt.host/record-shapes and /protocol-methods (host-
|
|
||||||
;; contract.ss) materialize them into the shape jolt.passes.types expects.
|
|
||||||
|
|
||||||
;; ctor-key "ns/->Name" -> (vector field-kw-list field-tag-list type-tag).
|
|
||||||
;; field-tag-list parallels the fields: "num", a record simple-name string, or #f.
|
|
||||||
(define chez-record-shapes-tbl (make-hashtable string-hash string=?))
|
|
||||||
;; method var-key "ns/method" -> (cons proto-name method-name).
|
|
||||||
(define chez-protocol-methods-tbl (make-hashtable string-hash string=?))
|
|
||||||
;; type-tag "ns.Name" -> #(bool ...) marking which fields are ^double, so the ctor
|
|
||||||
;; and set! coerce them to flonums (JVM primitive-field semantics, and what makes
|
|
||||||
;; reading the field back as :double sound for fl-ops).
|
|
||||||
(define chez-record-dbl-tbl (make-hashtable string-hash string=?))
|
|
||||||
(define (chez-double-tag? t) (and (string? t) (string=? t "double")))
|
|
||||||
|
|
||||||
(define (register-record-shape! ctor-key field-kws field-tags type-tag)
|
|
||||||
(hashtable-set! chez-record-shapes-tbl ctor-key
|
|
||||||
(vector field-kws field-tags type-tag))
|
|
||||||
(hashtable-set! chez-record-dbl-tbl type-tag
|
|
||||||
(list->vector (map chez-double-tag? field-tags))))
|
|
||||||
|
|
||||||
;; simple name of a dotted/slashed string: the segment after the last . or /.
|
|
||||||
(define (chez-shape-simple-name s)
|
|
||||||
(let loop ((i (- (string-length s) 1)))
|
|
||||||
(cond ((< i 0) s)
|
|
||||||
((or (char=? (string-ref s i) #\.) (char=? (string-ref s i) #\/))
|
|
||||||
(substring s (+ i 1) (string-length s)))
|
|
||||||
(else (loop (- i 1))))))
|
|
||||||
|
|
||||||
;; resolve a field's declared type tag to what jolt.passes.types wants: "num"
|
|
||||||
;; passes through; a record name (simple "Vec3" or qualified "ns.Vec3") resolves
|
|
||||||
;; to its ctor-key (so the field reads back as that record); anything else -> nil.
|
|
||||||
(define (chez-resolve-field-tag tag by-name)
|
|
||||||
(cond ((or (not tag) (jolt-nil-t? tag)) jolt-nil)
|
|
||||||
((string=? tag "num") "num")
|
|
||||||
((string=? tag "double") "double") ; a ^double field reads back as a flonum
|
|
||||||
(else (let ((ck (hashtable-ref by-name (chez-shape-simple-name tag) #f)))
|
|
||||||
(if ck ck jolt-nil)))))
|
|
||||||
|
|
||||||
;; materialize chez-record-shapes-tbl into "ns/->Name" -> {:fields :tags :type},
|
|
||||||
;; the shape record-type-from-entry consumes.
|
|
||||||
(define (chez-record-shapes-map)
|
|
||||||
(let ((by-name (make-hashtable string-hash string=?))
|
|
||||||
(kw-fields (keyword #f "fields")) (kw-tags (keyword #f "tags")) (kw-type (keyword #f "type"))
|
|
||||||
(out (jolt-hash-map)))
|
|
||||||
;; index simple record name (from the type tag "ns.Name") -> ctor-key for
|
|
||||||
;; nested-field-tag resolution.
|
|
||||||
(let-values (((ks vs) (hashtable-entries chez-record-shapes-tbl)))
|
|
||||||
(vector-for-each
|
|
||||||
(lambda (k v) (hashtable-set! by-name (chez-shape-simple-name (vector-ref v 2)) k)) ks vs)
|
|
||||||
(vector-for-each
|
|
||||||
(lambda (k v)
|
|
||||||
(let* ((fields (vector-ref v 0)) (tags (vector-ref v 1)) (type-tag (vector-ref v 2))
|
|
||||||
(rtags (map (lambda (t) (chez-resolve-field-tag t by-name)) tags)))
|
|
||||||
(set! out (jolt-assoc out k
|
|
||||||
(jolt-hash-map kw-fields (apply jolt-vector fields)
|
|
||||||
kw-tags (apply jolt-vector rtags)
|
|
||||||
kw-type type-tag)))))
|
|
||||||
ks vs))
|
|
||||||
out))
|
|
||||||
|
|
||||||
;; resolve a record TYPE name (a ^Type param hint's tag) to the ctor-key
|
|
||||||
;; "ns/->Name" the inference seeds with. Prefer the ctor in `ns` (the compile ns);
|
|
||||||
;; else any registered record with that simple name (cross-ns / imported). #f if
|
|
||||||
;; the name isn't a record type (so a ^double/^String hint resolves to nil).
|
|
||||||
(define (chez-find-ctor-key name ns)
|
|
||||||
(let* ((simple (chez-shape-simple-name name))
|
|
||||||
(target (string-append "->" simple))
|
|
||||||
(preferred (string-append ns "/->" simple)))
|
|
||||||
(if (hashtable-ref chez-record-shapes-tbl preferred #f)
|
|
||||||
preferred
|
|
||||||
(let loop ((ks (vector->list (hashtable-keys chez-record-shapes-tbl))))
|
|
||||||
(cond ((null? ks) #f)
|
|
||||||
((string=? (chez-shape-simple-name (car ks)) target) (car ks))
|
|
||||||
(else (loop (cdr ks))))))))
|
|
||||||
|
|
||||||
;; materialize chez-protocol-methods-tbl into "ns/method" -> [proto method].
|
|
||||||
(define (chez-protocol-methods-map)
|
|
||||||
(let ((out (jolt-hash-map)))
|
|
||||||
(let-values (((ks vs) (hashtable-entries chez-protocol-methods-tbl)))
|
|
||||||
(vector-for-each
|
|
||||||
(lambda (k v) (set! out (jolt-assoc out k (jolt-vector (car v) (cdr v)))))
|
|
||||||
ks vs))
|
|
||||||
out))
|
|
||||||
|
|
||||||
;; index of a declared field key, or #f (only an interned keyword can be one).
|
|
||||||
(define (jrec-field-index r k) (hashtable-ref (jrdesc-index (jrec-desc r)) k #f))
|
|
||||||
;; a vector-copy that doesn't depend on the optional rnrs vector-copy being present.
|
|
||||||
(define (jrec-vec-copy v)
|
|
||||||
(let* ((n (vector-length v)) (out (make-vector n)))
|
|
||||||
(let loop ((i 0)) (when (< i n) (vector-set! out i (vector-ref v i)) (loop (+ i 1))))
|
|
||||||
out))
|
|
||||||
;; extension-map entries as an (k . v) alist in iteration order.
|
|
||||||
(define (jrec-ext-pairs ext)
|
|
||||||
(let loop ((s (jolt-seq ext)) (acc '()))
|
|
||||||
(if (jolt-nil? s) (reverse acc)
|
|
||||||
(let ((e (seq-first s)))
|
|
||||||
(loop (jolt-seq (seq-more s)) (cons (cons (jolt-nth e 0) (jolt-nth e 1)) acc))))))
|
|
||||||
|
|
||||||
;; lookup with default d: a declared field reads index+vector-ref (a present nil
|
|
||||||
;; returns nil), then the extension map, then d.
|
|
||||||
(define (jrec-lookup r k d)
|
(define (jrec-lookup r k d)
|
||||||
(if (eq? k jolt-deftype-kw)
|
(if (jolt=2 k jolt-deftype-kw)
|
||||||
(jrec-tag r)
|
(jrec-tag r)
|
||||||
(let ((i (jrec-field-index r k)))
|
(let loop ((ps (jrec-pairs r)))
|
||||||
(if i (vector-ref (jrec-vals r) i)
|
(cond ((null? ps) d)
|
||||||
(let ((ext (jrec-ext r)))
|
((jolt=2 (caar ps) k) (cdar ps))
|
||||||
(if (jolt-nil? ext) d
|
(else (loop (cdr ps)))))))
|
||||||
(let ((v (jolt-get ext k jrec-absent)))
|
|
||||||
(if (eq? v jrec-absent) d v))))))))
|
|
||||||
(define (jrec-has? r k)
|
(define (jrec-has? r k)
|
||||||
(and (not (eq? k jolt-deftype-kw))
|
(let loop ((ps (jrec-pairs r)))
|
||||||
(or (and (jrec-field-index r k) #t)
|
(cond ((null? ps) #f) ((jolt=2 (caar ps) k) #t) (else (loop (cdr ps))))))
|
||||||
(let ((ext (jrec-ext r)))
|
;; mutate a deftype's mutable field in place: the pairs are runtime cons cells,
|
||||||
(and (not (jolt-nil? ext))
|
;; so set-cdr! updates the field. (set! field v) inside a method
|
||||||
(not (eq? jrec-absent (jolt-get ext k jrec-absent))))))))
|
;; lowers to this; returns v, as set! does.
|
||||||
;; The get path: like jrec-lookup, but a deftype's ILookup valAt runs when a key
|
|
||||||
;; is genuinely missing from both the fields and the extension map.
|
|
||||||
(define (jrec-ref coll k d)
|
|
||||||
(if (eq? k jolt-deftype-kw)
|
|
||||||
(jrec-tag coll)
|
|
||||||
(let ((i (jrec-field-index coll k)))
|
|
||||||
(if i (vector-ref (jrec-vals coll) i)
|
|
||||||
(let* ((ext (jrec-ext coll))
|
|
||||||
(v (if (jolt-nil? ext) jrec-absent (jolt-get ext k jrec-absent))))
|
|
||||||
(if (eq? v jrec-absent)
|
|
||||||
(cond ((find-method-any-protocol (jrec-tag coll) "valAt")
|
|
||||||
=> (lambda (m) (jolt-invoke m coll k d)))
|
|
||||||
(else d))
|
|
||||||
v))))))
|
|
||||||
;; bare-index field read for a statically-known record field — emitted by `jolt
|
|
||||||
;; build --opt` for a struct-typed receiver, where i is the field's declared slot.
|
|
||||||
;; When r is the expected record it reads the value vector directly: no field-key
|
|
||||||
;; hashtable lookup, no jolt-get dispatch. Falls back to jolt-get otherwise (a map
|
|
||||||
;; downgraded by dissoc, or a value the inference mistyped), so it stays correct
|
|
||||||
;; even if the static type is wrong.
|
|
||||||
(define (jrec-field-at r i k)
|
|
||||||
(if (and (jrec? r) (fx< i (vector-length (jrec-vals r))))
|
|
||||||
(vector-ref (jrec-vals r) i)
|
|
||||||
(jolt-get r k)))
|
|
||||||
|
|
||||||
;; mutate a deftype's mutable field in place: the value vector is mutable, so
|
|
||||||
;; vector-set! updates the field. (set! field v) inside a method lowers to this;
|
|
||||||
;; returns v, as set! does.
|
|
||||||
(define (jolt-set-field! inst k v)
|
(define (jolt-set-field! inst k v)
|
||||||
(if (jrec? inst)
|
(if (jrec? inst)
|
||||||
(let ((i (jrec-field-index inst k)))
|
(let loop ((ps (jrec-pairs inst)))
|
||||||
(if i (let* ((flags (hashtable-ref chez-record-dbl-tbl (jrec-tag inst) #f))
|
(cond ((null? ps) (error #f "set! of an unknown field" k))
|
||||||
;; a ^double field stays a flonum across set!, like the ctor —
|
((jolt=2 (caar ps) k) (set-cdr! (car ps) v) v)
|
||||||
;; keeps a later field read sound to unbox.
|
(else (loop (cdr ps)))))
|
||||||
(v2 (if (and flags (fx< i (vector-length flags)) (vector-ref flags i)
|
|
||||||
(number? v) (not (flonum? v)))
|
|
||||||
(exact->inexact v) v)))
|
|
||||||
(vector-set! (jrec-vals inst) i v2) v2)
|
|
||||||
(error #f "set! of an unknown field" k)))
|
|
||||||
(error #f "set! of a field on a non-record" inst)))
|
(error #f "set! of a field on a non-record" inst)))
|
||||||
(define (jrec-ext=? ea eb)
|
(define (jrec-replace pairs k v) ; replace existing field (keep order) or append
|
||||||
(cond ((and (jolt-nil? ea) (jolt-nil? eb)) #t)
|
(let loop ((ps pairs) (acc '()) (hit #f))
|
||||||
((or (jolt-nil? ea) (jolt-nil? eb)) #f)
|
(cond ((null? ps) (reverse (if hit acc (cons (cons k v) acc))))
|
||||||
(else (jolt=2 ea eb))))
|
((jolt=2 (caar ps) k) (loop (cdr ps) (cons (cons k v) acc) #t))
|
||||||
|
(else (loop (cdr ps) (cons (car ps) acc) hit)))))
|
||||||
(define (jrec=? a b)
|
(define (jrec=? a b)
|
||||||
(and (string=? (jrec-tag a) (jrec-tag b))
|
(and (string=? (jrec-tag a) (jrec-tag b))
|
||||||
(= (vector-length (jrec-vals a)) (vector-length (jrec-vals b)))
|
(= (length (jrec-pairs a)) (length (jrec-pairs b)))
|
||||||
(let ((va (jrec-vals a)) (vb (jrec-vals b)) (n (vector-length (jrec-vals a))))
|
(let loop ((ps (jrec-pairs a)))
|
||||||
(let loop ((i 0))
|
(or (null? ps)
|
||||||
(or (= i n)
|
(and (jrec-has? b (caar ps))
|
||||||
(and (jolt=2 (vector-ref va i) (vector-ref vb i)) (loop (+ i 1))))))
|
(jolt=2 (cdar ps) (jrec-lookup b (caar ps) jolt-nil))
|
||||||
(jrec-ext=? (jrec-ext a) (jrec-ext b))))
|
(loop (cdr ps)))))))
|
||||||
(define (jrec-hash r)
|
(define (jrec-hash r)
|
||||||
(let* ((fkeys (jrdesc-fkeys (jrec-desc r))) (vals (jrec-vals r)) (n (vector-length vals))
|
(fold-left (lambda (acc p) (+ acc (jolt-hash (car p)) (jolt-hash (cdr p))))
|
||||||
(base (let loop ((i 0) (acc (string-hash (jrec-tag r))))
|
(string-hash (jrec-tag r)) (jrec-pairs r)))
|
||||||
(if (= i n) acc
|
|
||||||
(loop (+ i 1) (+ acc (jolt-hash (vector-ref fkeys i))
|
|
||||||
(jolt-hash (vector-ref vals i))))))))
|
|
||||||
(let ((ext (jrec-ext r)))
|
|
||||||
(if (jolt-nil? ext) base (+ base (jolt-hash ext))))))
|
|
||||||
(define (jrec-pr r) ; #ns.Name{:k v, :k v}
|
(define (jrec-pr r) ; #ns.Name{:k v, :k v}
|
||||||
(let ((fkeys (jrdesc-fkeys (jrec-desc r))) (vals (jrec-vals r)))
|
(string-append "#" (jrec-tag r) "{"
|
||||||
(string-append "#" (jrec-tag r) "{"
|
(let loop ((ps (jrec-pairs r)) (first #t) (acc ""))
|
||||||
(let ((n (vector-length vals)))
|
(if (null? ps) acc
|
||||||
(let loop ((i 0) (first #t) (acc ""))
|
(loop (cdr ps) #f
|
||||||
(if (= i n)
|
(string-append acc (if first "" ", ")
|
||||||
(let ((ext (jrec-ext r)))
|
(jolt-pr-readable (caar ps)) " " (jolt-pr-readable (cdar ps))))))
|
||||||
(if (jolt-nil? ext) acc
|
"}"))
|
||||||
(let eloop ((es (jrec-ext-pairs ext)) (first first) (acc acc))
|
|
||||||
(if (null? es) acc
|
|
||||||
(eloop (cdr es) #f
|
|
||||||
(string-append acc (if first "" ", ")
|
|
||||||
(jolt-pr-readable (caar es)) " " (jolt-pr-readable (cdar es))))))))
|
|
||||||
(loop (+ i 1) #f
|
|
||||||
(string-append acc (if first "" ", ")
|
|
||||||
(jolt-pr-readable (vector-ref fkeys i)) " " (jolt-pr-readable (vector-ref vals i)))))))
|
|
||||||
"}")))
|
|
||||||
|
|
||||||
;; ---- extend the collection dispatchers with a jrec arm ----------------------
|
;; ---- extend the collection dispatchers with a jrec arm ----------------------
|
||||||
;; equality for a jrec: a deftype implementing IPersistentCollection/equiv (e.g.
|
;; equality for a jrec: a deftype implementing IPersistentCollection/equiv (e.g.
|
||||||
|
|
@ -282,56 +70,28 @@
|
||||||
(lambda (a b)
|
(lambda (a b)
|
||||||
(cond ((and (jrec? a) (jrec-cl a "equiv")) => (lambda (m) (if (jolt-truthy? (jolt-invoke m a b)) #t #f)))
|
(cond ((and (jrec? a) (jrec-cl a "equiv")) => (lambda (m) (if (jolt-truthy? (jolt-invoke m a b)) #t #f)))
|
||||||
((and (jrec? b) (jrec-cl b "equiv")) => (lambda (m) (if (jolt-truthy? (jolt-invoke m b a)) #t #f)))
|
((and (jrec? b) (jrec-cl b "equiv")) => (lambda (m) (if (jolt-truthy? (jolt-invoke m b a)) #t #f)))
|
||||||
;; a deftype with a custom Object.equals (but no equiv) governs
|
|
||||||
;; its own value equality and map-key identity — core.logic's
|
|
||||||
;; LVar/LCons key substitutions on id, ignoring metadata, so
|
|
||||||
;; structural jrec=? (which sees the meta field) is wrong here.
|
|
||||||
((and (jrec? a) (jrec-cl a "equals")) => (lambda (m) (if (jolt-truthy? (jolt-invoke m a b)) #t #f)))
|
|
||||||
((and (jrec? b) (jrec-cl b "equals")) => (lambda (m) (if (jolt-truthy? (jolt-invoke m b a)) #t #f)))
|
|
||||||
((and (jrec? a) (jrec? b)) (jrec=? a b))
|
((and (jrec? a) (jrec? b)) (jrec=? a b))
|
||||||
(else #f))))
|
(else #f))))
|
||||||
;; a deftype's declared hashCode governs its map/set hashing (paired with the
|
(register-hash-arm! jrec? jrec-hash)
|
||||||
;; equals/equiv above so the hash/eq contract holds); a plain record hashes its
|
|
||||||
;; fields structurally via jrec-hash.
|
|
||||||
(register-hash-arm! jrec?
|
|
||||||
(lambda (x) (let ((m (jrec-cl x "hashCode")))
|
|
||||||
(if m (jolt-invoke m x) (jrec-hash x)))))
|
|
||||||
;; get on a jrec: a real field reads raw (so a deftype method's own field bindings,
|
;; get on a jrec: a real field reads raw (so a deftype method's own field bindings,
|
||||||
;; compiled to (get inst :field), never recurse); a NON-field key on a deftype that
|
;; compiled to (get inst :field), never recurse); a NON-field key on a deftype that
|
||||||
;; implements clojure.lang.ILookup routes to its valAt (core.match's pattern types
|
;; implements clojure.lang.ILookup routes to its valAt (core.match's pattern types
|
||||||
;; compute ::tag in valAt), else the default.
|
;; compute ::tag in valAt), else the default.
|
||||||
;; jrec is the hottest get target (every record field read); jolt-get-dispatch
|
(register-get-arm! jrec?
|
||||||
;; (collections.ss) checks jrec? directly and calls jrec-ref, skipping the get-arm
|
(lambda (coll k d)
|
||||||
;; walk. This registration is the equivalent fallback for any other caller.
|
(cond ((jrec-has? coll k) (jrec-lookup coll k d))
|
||||||
(register-get-arm! jrec? jrec-ref)
|
((find-method-any-protocol (jrec-tag coll) "valAt")
|
||||||
|
=> (lambda (m) (jolt-invoke m coll k d)))
|
||||||
|
(else d))))
|
||||||
;; A jrec is a defrecord (map of fields) by default, BUT a deftype that
|
;; A jrec is a defrecord (map of fields) by default, BUT a deftype that
|
||||||
;; implements a clojure.lang collection interface carries the op as an inline
|
;; implements a clojure.lang collection interface carries the op as an inline
|
||||||
;; method — prefer that method, else fall back to the field/map behavior. (jrec-cl
|
;; method — prefer that method, else fall back to the field/map behavior. (jrec-cl
|
||||||
;; finds the method; find-method-any-protocol / jolt-invoke resolve at call time.)
|
;; finds the method; find-method-any-protocol / jolt-invoke resolve at call time.)
|
||||||
;; Same lookup as collections.ss rec-coll-method — one definition, aliased here.
|
(define (jrec-cl coll name) (and (jrec? coll) (find-method-any-protocol (jrec-tag coll) name)))
|
||||||
(define jrec-cl rec-coll-method)
|
|
||||||
|
|
||||||
;; iface-method: the single deftype/reify interface-method lookup. Returns the
|
|
||||||
;; impl fn for METHOD declared by V (a deftype/record OR a reify), or #f. NARGS
|
|
||||||
;; (including `this`) selects the matching arity for a deftype; #f means any
|
|
||||||
;; arity. Core fns route interface dispatch through this instead of each
|
|
||||||
;; re-deriving jrec-vs-reify lookup and arity handling.
|
|
||||||
(define (iface-method v method nargs)
|
|
||||||
(cond ((jrec? v)
|
|
||||||
(if nargs (find-method-any-protocol-arity (jrec-tag v) method nargs)
|
|
||||||
(find-method-any-protocol (jrec-tag v) method)))
|
|
||||||
((jreify? v) (let ((rm (reified-methods v))) (and rm (hashtable-ref rm method #f))))
|
|
||||||
(else #f)))
|
|
||||||
;; Call METHOD on V with ARGS (a list, `this` excluded) if V declares it, else run
|
|
||||||
;; FALLBACK. The one seam a core fn's deftype/reify arm collapses to.
|
|
||||||
(define (iface-call v method args fallback)
|
|
||||||
(let ((m (iface-method v method (+ 1 (length args)))))
|
|
||||||
(if m (apply jolt-invoke m v args) (fallback))))
|
|
||||||
(define %r-jolt-count jolt-count)
|
(define %r-jolt-count jolt-count)
|
||||||
(set! jolt-count (lambda (coll)
|
(set! jolt-count (lambda (coll)
|
||||||
(cond ((jrec-cl coll "count") => (lambda (m) (jolt-invoke m coll)))
|
(cond ((jrec-cl coll "count") => (lambda (m) (jolt-invoke m coll)))
|
||||||
((jrec? coll) (+ (vector-length (jrec-vals coll))
|
((jrec? coll) (length (jrec-pairs coll)))
|
||||||
(let ((ext (jrec-ext coll))) (if (jolt-nil? ext) 0 (%r-jolt-count ext)))))
|
|
||||||
(else (%r-jolt-count coll)))))
|
(else (%r-jolt-count coll)))))
|
||||||
;; contains?: a deftype implementing Associative/containsKey (e.g. core.cache's
|
;; contains?: a deftype implementing Associative/containsKey (e.g. core.cache's
|
||||||
;; caches) answers through that; a plain defrecord checks its fields.
|
;; caches) answers through that; a plain defrecord checks its fields.
|
||||||
|
|
@ -340,48 +100,21 @@
|
||||||
(cond ((jrec-cl coll "containsKey") => (lambda (m) (if (jolt-truthy? (jolt-invoke m coll k)) #t #f)))
|
(cond ((jrec-cl coll "containsKey") => (lambda (m) (if (jolt-truthy? (jolt-invoke m coll k)) #t #f)))
|
||||||
((jrec? coll) (jrec-has? coll k))
|
((jrec? coll) (jrec-has? coll k))
|
||||||
(else (%r-jolt-contains? coll k)))))
|
(else (%r-jolt-contains? coll k)))))
|
||||||
;; assoc: replacing a declared field copies the value vector; any other key grows
|
|
||||||
;; the extension map (the value vector is shared — fields are immutable).
|
|
||||||
(define %r-jolt-assoc1 jolt-assoc1)
|
(define %r-jolt-assoc1 jolt-assoc1)
|
||||||
(set! jolt-assoc1 (lambda (coll k v)
|
(set! jolt-assoc1 (lambda (coll k v)
|
||||||
(cond ((jrec-cl coll "assoc") => (lambda (m) (jolt-invoke m coll k v)))
|
(cond ((jrec-cl coll "assoc") => (lambda (m) (jolt-invoke m coll k v)))
|
||||||
((jrec? coll)
|
((jrec? coll) (make-jrec (jrec-tag coll) (jrec-replace (jrec-pairs coll) k v)))
|
||||||
(let ((i (and (keyword? k) (jrec-field-index coll k))))
|
|
||||||
(if i
|
|
||||||
(let ((nv (jrec-vec-copy (jrec-vals coll))))
|
|
||||||
(vector-set! nv i v)
|
|
||||||
(make-jrec (jrec-desc coll) nv (jrec-ext coll)))
|
|
||||||
(let ((ext (jrec-ext coll)))
|
|
||||||
(make-jrec (jrec-desc coll) (jrec-vals coll)
|
|
||||||
(%r-jolt-assoc1 (if (jolt-nil? ext) empty-pmap ext) k v))))))
|
|
||||||
(else (%r-jolt-assoc1 coll k v)))))
|
(else (%r-jolt-assoc1 coll k v)))))
|
||||||
;; dissoc: a deftype implementing IPersistentMap/without answers through it.
|
;; dissoc: a deftype implementing IPersistentMap/without answers through it; a
|
||||||
;; Removing a declared field downgrades a plain record to a map (JVM parity); an
|
;; plain defrecord drops the field pair.
|
||||||
;; extension key drops from the ext map (normalized back to jolt-nil when empty).
|
|
||||||
(define (jrec->map-without r drop-k)
|
|
||||||
(let* ((fkeys (jrdesc-fkeys (jrec-desc r))) (vals (jrec-vals r)) (n (vector-length vals)))
|
|
||||||
(let loop ((i 0) (m empty-pmap))
|
|
||||||
(if (= i n)
|
|
||||||
(let ((ext (jrec-ext r)))
|
|
||||||
(if (jolt-nil? ext) m
|
|
||||||
(fold-left (lambda (mm p) (%r-jolt-assoc1 mm (car p) (cdr p))) m (jrec-ext-pairs ext))))
|
|
||||||
(let ((fk (vector-ref fkeys i)))
|
|
||||||
(loop (+ i 1) (if (eq? fk drop-k) m (%r-jolt-assoc1 m fk (vector-ref vals i)))))))))
|
|
||||||
(define %r-jolt-dissoc jolt-dissoc)
|
(define %r-jolt-dissoc jolt-dissoc)
|
||||||
(define (jrec-dissoc1 coll k)
|
|
||||||
(if (not (jrec? coll))
|
|
||||||
(%r-jolt-dissoc coll k) ; an earlier declared-field dissoc downgraded it
|
|
||||||
(let ((i (and (keyword? k) (jrec-field-index coll k))))
|
|
||||||
(if i (jrec->map-without coll k)
|
|
||||||
(let ((ext (jrec-ext coll)))
|
|
||||||
(if (jolt-nil? ext) coll
|
|
||||||
(let ((ne (%r-jolt-dissoc ext k)))
|
|
||||||
(make-jrec (jrec-desc coll) (jrec-vals coll)
|
|
||||||
(if (= 0 (%r-jolt-count ne)) jolt-nil ne)))))))))
|
|
||||||
(set! jolt-dissoc (lambda (coll . ks)
|
(set! jolt-dissoc (lambda (coll . ks)
|
||||||
(cond ((jrec-cl coll "without")
|
(cond ((jrec-cl coll "without")
|
||||||
=> (lambda (m) (fold-left (lambda (c k) (jolt-invoke m c k)) coll ks)))
|
=> (lambda (m) (fold-left (lambda (c k) (jolt-invoke m c k)) coll ks)))
|
||||||
((jrec? coll) (fold-left jrec-dissoc1 coll ks))
|
((jrec? coll)
|
||||||
|
(fold-left (lambda (c k) (make-jrec (jrec-tag c)
|
||||||
|
(filter (lambda (p) (not (jolt=2 (car p) k))) (jrec-pairs c))))
|
||||||
|
coll ks))
|
||||||
(else (apply %r-jolt-dissoc coll ks)))))
|
(else (apply %r-jolt-dissoc coll ks)))))
|
||||||
;; keys/vals over a jrec read its entry seq (jolt-seq is method-first, so a
|
;; keys/vals over a jrec read its entry seq (jolt-seq is method-first, so a
|
||||||
;; map-like deftype delegates to its Seqable; a defrecord's seq is its fields, so
|
;; map-like deftype delegates to its Seqable; a defrecord's seq is its fields, so
|
||||||
|
|
@ -394,22 +127,10 @@
|
||||||
(set! jolt-keys (lambda (m) (if (jrec? m) (jrec-seq-col m 0) (%r-jolt-keys m))))
|
(set! jolt-keys (lambda (m) (if (jrec? m) (jrec-seq-col m 0) (%r-jolt-keys m))))
|
||||||
(define %r-jolt-vals jolt-vals)
|
(define %r-jolt-vals jolt-vals)
|
||||||
(set! jolt-vals (lambda (m) (if (jrec? m) (jrec-seq-col m 1) (%r-jolt-vals m))))
|
(set! jolt-vals (lambda (m) (if (jrec? m) (jrec-seq-col m 1) (%r-jolt-vals m))))
|
||||||
;; a record's seq is its field map-entries in declared order, then any extensions.
|
|
||||||
(define (jrec-entry-list r)
|
|
||||||
(let* ((fkeys (jrdesc-fkeys (jrec-desc r))) (vals (jrec-vals r)) (n (vector-length vals)))
|
|
||||||
(let loop ((i 0) (acc '()))
|
|
||||||
(if (= i n)
|
|
||||||
(let ((ext (jrec-ext r)))
|
|
||||||
(append (reverse acc)
|
|
||||||
(if (jolt-nil? ext) '()
|
|
||||||
(map (lambda (p) (make-map-entry (car p) (cdr p))) (jrec-ext-pairs ext)))))
|
|
||||||
(loop (+ i 1) (cons (make-map-entry (vector-ref fkeys i) (vector-ref vals i)) acc))))))
|
|
||||||
(define %r-jolt-seq jolt-seq)
|
(define %r-jolt-seq jolt-seq)
|
||||||
(set! jolt-seq (lambda (x)
|
(set! jolt-seq (lambda (x)
|
||||||
(cond ((jrec-cl x "seq") => (lambda (m) (jolt-seq (jolt-invoke m x))))
|
(cond ((jrec-cl x "seq") => (lambda (m) (jolt-seq (jolt-invoke m x))))
|
||||||
;; a record seqs its fields; a bare deftype is not seqable (falls through
|
((jrec? x) (list->cseq (map (lambda (p) (make-map-entry (car p) (cdr p))) (jrec-pairs x))))
|
||||||
;; to %r-jolt-seq, which errors like the JVM).
|
|
||||||
((jrec-record? x) (list->cseq (jrec-entry-list x)))
|
|
||||||
(else (%r-jolt-seq x)))))
|
(else (%r-jolt-seq x)))))
|
||||||
(define %r-jolt-conj1 jolt-conj1)
|
(define %r-jolt-conj1 jolt-conj1)
|
||||||
(set! jolt-conj1 (lambda (coll x)
|
(set! jolt-conj1 (lambda (coll x)
|
||||||
|
|
@ -421,8 +142,7 @@
|
||||||
;; empty? over a jrec: a map-like deftype is empty iff its entry seq is (data
|
;; empty? over a jrec: a map-like deftype is empty iff its entry seq is (data
|
||||||
;; .priority-map's peek calls (.isEmpty this) -> empty?). jolt-seq is method-first.
|
;; .priority-map's peek calls (.isEmpty this) -> empty?). jolt-seq is method-first.
|
||||||
(define %r-jolt-empty? jolt-empty?)
|
(define %r-jolt-empty? jolt-empty?)
|
||||||
(set! jolt-empty? (lambda (coll)
|
(set! jolt-empty? (lambda (coll) (if (jrec? coll) (jolt-nil? (jolt-seq coll)) (%r-jolt-empty? coll))))
|
||||||
(if (jrec-collection? coll) (jolt-nil? (jolt-seq coll)) (%r-jolt-empty? coll))))
|
|
||||||
(define %r-jolt-peek jolt-peek)
|
(define %r-jolt-peek jolt-peek)
|
||||||
(set! jolt-peek (lambda (coll)
|
(set! jolt-peek (lambda (coll)
|
||||||
(cond ((jrec-cl coll "peek") => (lambda (m) (jolt-invoke m coll)))
|
(cond ((jrec-cl coll "peek") => (lambda (m) (jolt-invoke m coll)))
|
||||||
|
|
@ -437,13 +157,10 @@
|
||||||
;; predicates.ss vars hold a snapshot, so re-def-var! after extending. record? is
|
;; predicates.ss vars hold a snapshot, so re-def-var! after extending. record? is
|
||||||
;; the overlay's (some? (get x :jolt/deftype)) — works for free since the get
|
;; the overlay's (some? (get x :jolt/deftype)) — works for free since the get
|
||||||
;; override returns the tag for that key.
|
;; override returns the tag for that key.
|
||||||
;; only a defrecord is a map (Clojure: a record IS an associative map); a bare
|
|
||||||
;; deftype is not. coll? additionally covers a deftype implementing a collection
|
|
||||||
;; interface. predicates.ss vars hold a snapshot, so re-def-var! after extending.
|
|
||||||
(define %r-jolt-map? jolt-map?)
|
(define %r-jolt-map? jolt-map?)
|
||||||
(set! jolt-map? (lambda (x) (or (jrec-maplike? x) (%r-jolt-map? x))))
|
(set! jolt-map? (lambda (x) (or (jrec? x) (%r-jolt-map? x))))
|
||||||
(def-var! "clojure.core" "map?" jolt-map?)
|
(def-var! "clojure.core" "map?" jolt-map?)
|
||||||
(def-var! "clojure.core" "coll?" (lambda (x) (or (jrec-collection? x) (jolt-coll-pred? x))))
|
(def-var! "clojure.core" "coll?" (lambda (x) (or (jrec? x) (jolt-coll-pred? x))))
|
||||||
|
|
||||||
;; ---- protocol registry ------------------------------------------------------
|
;; ---- protocol registry ------------------------------------------------------
|
||||||
;; type-tag -> (proto-name -> (method-name -> fn))
|
;; type-tag -> (proto-name -> (method-name -> fn))
|
||||||
|
|
@ -463,28 +180,9 @@
|
||||||
(and (pair? protos)
|
(and (pair? protos)
|
||||||
(let ((f (hashtable-ref (hashtable-ref ti (car protos) #f) method #f)))
|
(let ((f (hashtable-ref (hashtable-ref ti (car protos) #f) method #f)))
|
||||||
(or f (loop (cdr protos)))))))))
|
(or f (loop (cdr protos)))))))))
|
||||||
;; A deftype can implement a method NAME at two arities from two interfaces (e.g.
|
|
||||||
;; data.priority-map's seq: Seqable.seq[this] and Sorted.seq[this ascending]),
|
|
||||||
;; registered under different protocols. Pick the impl whose procedure accepts
|
|
||||||
;; the call's arg count (this + args); fall back to any same-named impl.
|
|
||||||
(define (proc-accepts? f n)
|
|
||||||
(and (procedure? f) (bitwise-bit-set? (procedure-arity-mask f) n)))
|
|
||||||
(define (find-method-any-protocol-arity type-tag method nargs)
|
|
||||||
(let ((ti (hashtable-ref type-registry type-tag #f)))
|
|
||||||
(and ti (let loop ((protos (vector->list (hashtable-keys ti))) (fallback #f))
|
|
||||||
(if (null? protos)
|
|
||||||
fallback
|
|
||||||
(let ((f (hashtable-ref (hashtable-ref ti (car protos) #f) method #f)))
|
|
||||||
(cond ((and f (proc-accepts? f nargs)) f)
|
|
||||||
(else (loop (cdr protos) (or fallback f))))))))))
|
|
||||||
(define (type-satisfies? type-tag proto)
|
(define (type-satisfies? type-tag proto)
|
||||||
(let ((ti (hashtable-ref type-registry type-tag #f)))
|
(let ((ti (hashtable-ref type-registry type-tag #f)))
|
||||||
(and ti (hashtable-ref ti proto #f) #t)))
|
(and ti (hashtable-ref ti proto #f) #t)))
|
||||||
;; True when a deftype/record instance DECLARES a method by this name (an inline
|
|
||||||
;; protocol impl), so clojure.core can prefer it over generic collection behavior
|
|
||||||
;; — e.g. (empty priority-map) must use the type's own empty, not return {}.
|
|
||||||
(def-var! "jolt.host" "jrec-method?"
|
|
||||||
(lambda (v name) (if (and (jrec? v) (find-method-any-protocol (jrec-tag v) name)) #t #f)))
|
|
||||||
|
|
||||||
;; host type-tag candidates for a non-record value (extend-protocol on builtins).
|
;; host type-tag candidates for a non-record value (extend-protocol on builtins).
|
||||||
(define (value-host-tags obj)
|
(define (value-host-tags obj)
|
||||||
|
|
@ -495,43 +193,16 @@
|
||||||
((number? obj) '("Long" "Integer" "BigInteger" "BigInt" "Number" "Object"))
|
((number? obj) '("Long" "Integer" "BigInteger" "BigInt" "Number" "Object"))
|
||||||
((string? obj) '("String" "CharSequence" "Object"))
|
((string? obj) '("String" "CharSequence" "Object"))
|
||||||
((boolean? obj) '("Boolean" "Object"))
|
((boolean? obj) '("Boolean" "Object"))
|
||||||
((keyword? obj) (jch-tags "clojure.lang.Keyword"))
|
((keyword? obj) '("Keyword" "Named" "Object"))
|
||||||
((jolt-symbol? obj) (jch-tags "clojure.lang.Symbol"))
|
((jolt-symbol? obj) '("Symbol" "Named" "Object"))
|
||||||
((pvec? obj) (jch-tags "clojure.lang.PersistentVector"))
|
((pvec? obj) '("PersistentVector" "APersistentVector" "IPersistentVector" "IPersistentCollection"
|
||||||
((pmap? obj) (jch-tags "clojure.lang.PersistentArrayMap"))
|
"List" "java.util.List" "Sequential" "Collection" "Iterable" "java.lang.Iterable" "Object"))
|
||||||
((pset? obj) (jch-tags "clojure.lang.PersistentHashSet"))
|
((pmap? obj) '("PersistentArrayMap" "APersistentMap" "IPersistentMap" "Associative"
|
||||||
;; jolt models every seq as a list (no distinct LazySeq), so a seq also
|
"Map" "java.util.Map" "Iterable" "java.lang.Iterable" "Object"))
|
||||||
;; reports PersistentList / IPersistentList / IPersistentStack — extend-protocol
|
((pset? obj) '("PersistentHashSet" "APersistentSet" "IPersistentSet" "Set" "java.util.Set" "Collection" "Iterable" "java.lang.Iterable" "Object"))
|
||||||
;; clojure.lang.IPersistentList (algo.monads' writer monad) dispatches on one.
|
((or (cseq? obj) (empty-list-t? obj)) '("ASeq" "ISeq" "IPersistentCollection" "Sequential" "Collection" "Iterable" "java.lang.Iterable" "Object"))
|
||||||
((or (cseq? obj) (empty-list-t? obj)) (jch-tags "clojure.lang.PersistentList"))
|
|
||||||
;; a lazy seq (map/filter/… result) is clojure.lang.LazySeq: a Sequential
|
|
||||||
;; ISeq, but not a PersistentList — matching the JVM so extend-protocol /
|
|
||||||
;; instance? on a deferred seq dispatch like an eager one where they should.
|
|
||||||
((jolt-lazyseq? obj) (jch-tags "clojure.lang.LazySeq"))
|
|
||||||
;; a var is clojure.lang.Var (also IDeref / IFn) — reitit's Expand protocol
|
|
||||||
;; extends to Var so a #'handler route dispatches.
|
|
||||||
((var-cell? obj) (jch-tags "clojure.lang.Var"))
|
|
||||||
;; java.net.URI jhost — extend-protocol java.net.URI (hiccup ToURI/ToStr).
|
;; java.net.URI jhost — extend-protocol java.net.URI (hiccup ToURI/ToStr).
|
||||||
((and (jhost? obj) (string=? (jhost-tag obj) "uri")) '("URI" "java.net.URI" "Object"))
|
((and (jhost? obj) (string=? (jhost-tag obj) "uri")) '("URI" "java.net.URI" "Object"))
|
||||||
;; a ByteBuffer — extend-protocol java.nio.ByteBuffer (aws-api util).
|
|
||||||
((and (jhost? obj) (string=? (jhost-tag obj) "byte-buffer")) '("ByteBuffer" "java.nio.ByteBuffer" "Object"))
|
|
||||||
;; java.io readers/writers — so (extend-protocol java.io.Reader …) (data.csv)
|
|
||||||
;; and the like dispatch on one. A PushbackReader is also a Reader.
|
|
||||||
((and (jhost? obj) (string=? (jhost-tag obj) "string-reader"))
|
|
||||||
'("StringReader" "java.io.StringReader" "Reader" "java.io.Reader" "Object"))
|
|
||||||
((and (jhost? obj) (string=? (jhost-tag obj) "pushback-reader"))
|
|
||||||
'("PushbackReader" "java.io.PushbackReader" "FilterReader" "java.io.FilterReader" "Reader" "java.io.Reader" "Object"))
|
|
||||||
((and (jhost? obj) (string=? (jhost-tag obj) "char-reader"))
|
|
||||||
'("Reader" "java.io.Reader" "Object"))
|
|
||||||
((and (jhost? obj) (string=? (jhost-tag obj) "char-writer"))
|
|
||||||
'("Writer" "java.io.Writer" "Object"))
|
|
||||||
((and (jhost? obj) (string=? (jhost-tag obj) "writer"))
|
|
||||||
'("Writer" "java.io.Writer" "Object"))
|
|
||||||
;; arrays dispatch by their JVM array-class name — extend-protocol to
|
|
||||||
;; (Class/forName "[B") for byte[] (data.json, aws-api), "[C" for char[].
|
|
||||||
((and (jolt-array? obj) (eq? (jolt-array-kind obj) 'byte)) '("[B" "Object"))
|
|
||||||
((and (jolt-array? obj) (eq? (jolt-array-kind obj) 'char)) '("[C" "Object"))
|
|
||||||
((jolt-array? obj) '("[Ljava.lang.Object;" "Object"))
|
|
||||||
;; a regex VALUE — extend-protocol java.util.regex.Pattern (core.match.regex).
|
;; a regex VALUE — extend-protocol java.util.regex.Pattern (core.match.regex).
|
||||||
((regex-t? obj) '("Pattern" "java.util.regex.Pattern" "Object"))
|
((regex-t? obj) '("Pattern" "java.util.regex.Pattern" "Object"))
|
||||||
;; host value types a library may extend a protocol to by class (data.json
|
;; host value types a library may extend a protocol to by class (data.json
|
||||||
|
|
@ -561,23 +232,8 @@
|
||||||
;; extended to both (data.json's JSONWriter) routes a sql.Date to its impl.
|
;; extended to both (data.json's JSONWriter) routes a sql.Date to its impl.
|
||||||
((and (jhost? obj) (string=? (jhost-tag obj) "sql-date")) '("java.sql.Date" "Date" "java.util.Date" "Object"))
|
((and (jhost? obj) (string=? (jhost-tag obj) "sql-date")) '("java.sql.Date" "Date" "java.util.Date" "Object"))
|
||||||
;; a bare procedure (fn) — extend-protocol to clojure.lang.{Fn,IFn,AFn}.
|
;; a bare procedure (fn) — extend-protocol to clojure.lang.{Fn,IFn,AFn}.
|
||||||
((procedure? obj) (jch-tags "clojure.lang.AFunction"))
|
((procedure? obj) '("Fn" "IFn" "AFn" "Object"))
|
||||||
((jolt-nil? obj) '("nil"))
|
((jolt-nil? obj) '("nil"))
|
||||||
;; a defrecord IS the clojure.lang map/record interfaces, so a protocol
|
|
||||||
;; extended to IRecord / IPersistentMap / Associative / Seqable / … (and not
|
|
||||||
;; to the record's own type) dispatches to it — e.g. core.logic extends
|
|
||||||
;; IWalkTerm to clojure.lang.IRecord, and walking a record value must hit
|
|
||||||
;; that, not the Object default (which would recur forever). The record's
|
|
||||||
;; own type is tried first (dispatch checks jrec-tag before these tags).
|
|
||||||
((jrec-record? obj)
|
|
||||||
(cons (jrec-tag obj)
|
|
||||||
'("IRecord" "clojure.lang.IRecord" "IPersistentMap" "clojure.lang.IPersistentMap"
|
|
||||||
"APersistentMap" "Associative" "ILookup" "Seqable" "Counted"
|
|
||||||
"IPersistentCollection" "IObj" "IMeta" "Map" "java.util.Map"
|
|
||||||
"Iterable" "java.lang.Iterable" "Object")))
|
|
||||||
;; a bare deftype is opaque — its declared interfaces dispatch via the
|
|
||||||
;; inline methods registered under its own tag (tried before these tags).
|
|
||||||
((jrec? obj) (list (jrec-tag obj) "Object"))
|
|
||||||
(else '("Object"))))
|
(else '("Object"))))
|
||||||
|
|
||||||
(define (record-tag obj) (and (jrec? obj) (jrec-tag obj)))
|
(define (record-tag obj) (and (jrec? obj) (jrec-tag obj)))
|
||||||
|
|
@ -585,52 +241,19 @@
|
||||||
;; ---- the native that handles the analyzer/overlay call ----------------------
|
;; ---- the native that handles the analyzer/overlay call ----------------------
|
||||||
;; make-deftype-ctor: (name-sym field-kws field-tags field-muts) -> ctor closure.
|
;; make-deftype-ctor: (name-sym field-kws field-tags field-muts) -> ctor closure.
|
||||||
;; The tag is baked at definition time in the type's ns (chez-current-ns).
|
;; The tag is baked at definition time in the type's ns (chez-current-ns).
|
||||||
(define (make-deftype-ctor name-sym field-kws . rest-args)
|
(define (make-deftype-ctor name-sym field-kws . _ignored)
|
||||||
(let* ((tag (string-append (chez-current-ns) "." (symbol-t-name name-sym)))
|
(let* ((tag (string-append (chez-current-ns) "." (symbol-t-name name-sym)))
|
||||||
(kws (seq->list field-kws))
|
(kws (seq->list field-kws))
|
||||||
(field-tags (if (pair? rest-args) (seq->list (car rest-args)) '()))
|
|
||||||
;; which fields are ^double — coerced to a flonum on construction (JVM
|
|
||||||
;; primitive-field parity), so reading them back is a genuine flonum.
|
|
||||||
(dbl-flags (list->vector (map chez-double-tag? field-tags)))
|
|
||||||
(ndbl (vector-length dbl-flags))
|
|
||||||
(desc (make-jrdesc tag kws))
|
|
||||||
(nf (length kws))
|
|
||||||
(ctor (lambda args
|
(ctor (lambda args
|
||||||
;; fill the value vector from the positional args, padding missing
|
(make-jrec tag (let loop ((ks kws) (as args) (acc '()))
|
||||||
;; trailing fields with nil and ignoring any extras.
|
(if (null? ks) (reverse acc)
|
||||||
(let ((v (make-vector nf jolt-nil)))
|
(loop (cdr ks) (if (null? as) '() (cdr as))
|
||||||
(let loop ((as args) (i 0))
|
(cons (cons (car ks) (if (null? as) jolt-nil (car as))) acc))))))))
|
||||||
(if (or (null? as) (= i nf)) (make-jrec desc v jolt-nil)
|
;; Register the ctor globally by simple class name (like StringBuilder) so
|
||||||
(let ((a (car as)))
|
;; (Name. …) interop resolves ns-agnostically: a deftype used across files works
|
||||||
(vector-set! v i
|
;; even when the runtime current ns is the caller's, not the defining ns
|
||||||
(if (and (fx< i ndbl) (vector-ref dbl-flags i)
|
;; (host-new checks class-ctors-tbl before the current-ns var fallback).
|
||||||
(number? a) (not (flonum? a)))
|
(register-class-ctor! (symbol-t-name name-sym) ctor)
|
||||||
(exact->inexact a) a))
|
|
||||||
(loop (cdr as) (+ i 1)))))))))
|
|
||||||
;; Register the ctor under its fully-qualified tag ("ns.Name") — a bare
|
|
||||||
;; (Name. …) in the DEFINING ns is qualified to this by the analyzer, so a
|
|
||||||
;; deftype whose simple name collides with a built-in host class (tools.reader's
|
|
||||||
;; PushbackReader vs java.io.PushbackReader) still resolves correctly there.
|
|
||||||
(register-class-ctor! tag ctor)
|
|
||||||
;; Also register the simple name so (Name. …) resolves ns-agnostically across
|
|
||||||
;; files — BUT never clobber a built-in host class of the same simple name (an
|
|
||||||
;; unrelated ns's bare (Name. …) must still reach the built-in). A prior deftype
|
|
||||||
;; (tracked in chez-simple-name-tag) is fine to overwrite (last def wins / redef).
|
|
||||||
(when (or (not (hashtable-ref class-ctors-tbl (symbol-t-name name-sym) #f))
|
|
||||||
(hashtable-ref chez-simple-name-tag (symbol-t-name name-sym) #f))
|
|
||||||
(register-class-ctor! (symbol-t-name name-sym) ctor))
|
|
||||||
;; index the tag so a cross-ns extend-protocol resolves the bare type name.
|
|
||||||
(hashtable-set! chez-deftype-tag-set tag #t)
|
|
||||||
(hashtable-set! chez-simple-name-tag (symbol-t-name name-sym) tag)
|
|
||||||
;; graft the type onto the class graph so isa?/supers/ancestors see it. A
|
|
||||||
;; bare deftype is an IType; defrecord (which runs register-record-type!
|
|
||||||
;; right after) replaces the row with the record interface set.
|
|
||||||
(jch-set-supers! tag '("clojure.lang.IType"))
|
|
||||||
(hashtable-set! chez-deftype-ctor-tag ctor tag)
|
|
||||||
;; record the shape for whole-program inference, keyed by the positional
|
|
||||||
;; ctor var "ns/->Name" the analyzer resolves a (->Name …) call to.
|
|
||||||
(register-record-shape! (string-append (chez-current-ns) "/->" (symbol-t-name name-sym))
|
|
||||||
kws field-tags tag)
|
|
||||||
ctor))
|
ctor))
|
||||||
|
|
||||||
;; make-protocol: a protocol value the overlay reads via (get p :name)/(get p :methods).
|
;; make-protocol: a protocol value the overlay reads via (get p :name)/(get p :methods).
|
||||||
|
|
@ -639,18 +262,10 @@
|
||||||
(keyword #f "name") (jolt-symbol jolt-nil name-str)
|
(keyword #f "name") (jolt-symbol jolt-nil name-str)
|
||||||
(keyword #f "methods") methods))
|
(keyword #f "methods") methods))
|
||||||
|
|
||||||
;; register-protocol-methods!: record each method's var-key -> [proto method] for
|
;; register-protocol-methods!: intentional no-op. Chez dispatches a protocol method
|
||||||
;; the inference driver (devirtualization). Dispatch itself is by the receiver's
|
;; by the receiver's type tag at call time, so there is no method table to register;
|
||||||
;; type tag at call time, so this table is read only by `jolt build` inference.
|
;; this binding exists only because defprotocol-emitted code calls it.
|
||||||
;; Called by defprotocol-emitted code in the protocol's ns.
|
(define (register-protocol-methods! proto-name method-names) jolt-nil)
|
||||||
(define (register-protocol-methods! proto-name method-names)
|
|
||||||
(let ((ns (chez-current-ns)))
|
|
||||||
(for-each (lambda (mn)
|
|
||||||
(let ((m (if (symbol-t? mn) (symbol-t-name mn) mn)))
|
|
||||||
(hashtable-set! chez-protocol-methods-tbl
|
|
||||||
(string-append ns "/" m) (cons proto-name m))))
|
|
||||||
(seq->list method-names)))
|
|
||||||
jolt-nil)
|
|
||||||
|
|
||||||
;; register-method: extend-type/extend register an impl. Host type names keep a
|
;; register-method: extend-type/extend register an impl. Host type names keep a
|
||||||
;; bare canonical tag; record names qualify to the current ns.
|
;; bare canonical tag; record names qualify to the current ns.
|
||||||
|
|
@ -660,12 +275,11 @@
|
||||||
'("Long" "Integer" "Number" "Double" "Ratio" "BigInt" "BigInteger"
|
'("Long" "Integer" "Number" "Double" "Ratio" "BigInt" "BigInteger"
|
||||||
"String" "CharSequence" "Boolean" "Character"
|
"String" "CharSequence" "Boolean" "Character"
|
||||||
"Keyword" "Symbol" "Named" "Object" "nil"
|
"Keyword" "Symbol" "Named" "Object" "nil"
|
||||||
"Fn" "IFn" "AFn" "URI" "Var" "IDeref"
|
"Fn" "IFn" "AFn" "URI"
|
||||||
"PersistentVector" "APersistentVector" "IPersistentVector"
|
"PersistentVector" "APersistentVector" "IPersistentVector"
|
||||||
"PersistentArrayMap" "APersistentMap" "IPersistentMap"
|
"PersistentArrayMap" "APersistentMap" "IPersistentMap"
|
||||||
"PersistentHashSet" "APersistentSet" "IPersistentSet"
|
"PersistentHashSet" "APersistentSet" "IPersistentSet"
|
||||||
"ASeq" "ISeq" "IPersistentCollection" "Associative" "Sequential"
|
"ASeq" "ISeq" "IPersistentCollection" "Associative" "Sequential"
|
||||||
"PersistentList" "IPersistentList" "IPersistentStack"
|
|
||||||
"Map" "java.util.Map" "List" "java.util.List" "Set" "java.util.Set"
|
"Map" "java.util.Map" "List" "java.util.List" "Set" "java.util.Set"
|
||||||
"Collection" "java.util.Collection" "Iterable" "java.lang.Iterable"
|
"Collection" "java.util.Collection" "Iterable" "java.lang.Iterable"
|
||||||
"UUID" "BigDecimal" "Date" "Timestamp" "Instant" "java.sql.Date"
|
"UUID" "BigDecimal" "Date" "Timestamp" "Instant" "java.sql.Date"
|
||||||
|
|
@ -674,15 +288,7 @@
|
||||||
"Duration" "Period" "LocalDate" "LocalTime" "LocalDateTime"
|
"Duration" "Period" "LocalDate" "LocalTime" "LocalDateTime"
|
||||||
"ZonedDateTime" "OffsetDateTime" "OffsetTime" "ZoneId" "ZoneOffset"
|
"ZonedDateTime" "OffsetDateTime" "OffsetTime" "ZoneId" "ZoneOffset"
|
||||||
"Clock" "Year" "YearMonth" "Month" "DayOfWeek"
|
"Clock" "Year" "YearMonth" "Month" "DayOfWeek"
|
||||||
"ChronoUnit" "ChronoField" "TemporalAmount" "TemporalUnit" "TemporalField"
|
"ChronoUnit" "ChronoField" "TemporalAmount" "TemporalUnit" "TemporalField"))
|
||||||
;; ByteBuffer + JVM array classes (extend-protocol to (Class/forName "[B"))
|
|
||||||
"ByteBuffer" "java.nio.ByteBuffer"
|
|
||||||
"[B" "[C" "[I" "[J" "[D" "[Ljava.lang.Object;"
|
|
||||||
;; java.io readers/writers — extend-protocol java.io.Reader (data.csv)
|
|
||||||
"Reader" "java.io.Reader" "Writer" "java.io.Writer"
|
|
||||||
"StringReader" "java.io.StringReader" "PushbackReader" "java.io.PushbackReader"
|
|
||||||
"BufferedReader" "java.io.BufferedReader" "FilterReader" "java.io.FilterReader"
|
|
||||||
"InputStream" "java.io.InputStream" "OutputStream" "java.io.OutputStream"))
|
|
||||||
h))
|
h))
|
||||||
(define (strip-prefix s p)
|
(define (strip-prefix s p)
|
||||||
(let ((pl (string-length p)))
|
(let ((pl (string-length p)))
|
||||||
|
|
@ -696,17 +302,7 @@
|
||||||
(strip-prefix type-name "java.time.")
|
(strip-prefix type-name "java.time.")
|
||||||
(strip-prefix type-name "clojure.lang.")
|
(strip-prefix type-name "clojure.lang.")
|
||||||
type-name)))
|
type-name)))
|
||||||
;; a host class if the literal set lists it OR the class graph models it — both
|
(and (hashtable-ref host-type-set base #f) base)))
|
||||||
;; feed value-host-tags (which emits the same bare segment), so a protocol
|
|
||||||
;; extended to any modeled class keys under a tag the value reports. A
|
|
||||||
;; deftype/defrecord is in the graph too (its ancestry), but its VALUES report
|
|
||||||
;; the ns-qualified tag, not the bare segment — so a name that resolves to a
|
|
||||||
;; deftype never canonicalizes through the graph arm.
|
|
||||||
(and (or (hashtable-ref host-type-set base #f)
|
|
||||||
(and (not (hashtable-ref chez-simple-name-tag type-name #f))
|
|
||||||
(not (hashtable-ref chez-deftype-tag-set type-name #f))
|
|
||||||
(or (jch-known? base) (jch-known? type-name))))
|
|
||||||
base)))
|
|
||||||
;; An extend/extend-type/extend-protocol registration marks the tag as an
|
;; An extend/extend-type/extend-protocol registration marks the tag as an
|
||||||
;; extender of the protocol (recorded inside type-registry so the per-case prune
|
;; extender of the protocol (recorded inside type-registry so the per-case prune
|
||||||
;; restores it). deftype/defrecord inline impls go through register-inline-method
|
;; restores it). deftype/defrecord inline impls go through register-inline-method
|
||||||
|
|
@ -719,14 +315,7 @@
|
||||||
(when pi (hashtable-set! pi extend-mark #t))))))
|
(when pi (hashtable-set! pi extend-mark #t))))))
|
||||||
(define (register-method type-name proto-name method-name fn)
|
(define (register-method type-name proto-name method-name fn)
|
||||||
(let* ((host (canonical-host-tag type-name))
|
(let* ((host (canonical-host-tag type-name))
|
||||||
(local (string-append (chez-current-ns) "." type-name))
|
(tag (or host (string-append (chez-current-ns) "." type-name))))
|
||||||
;; a host class -> its canonical tag; a deftype defined in THIS ns -> the
|
|
||||||
;; local tag; an :import-ed deftype from another ns -> its real tag via the
|
|
||||||
;; simple-name index; otherwise the local tag (a forward extend).
|
|
||||||
(tag (cond (host host)
|
|
||||||
((hashtable-ref chez-deftype-tag-set local #f) local)
|
|
||||||
((hashtable-ref chez-simple-name-tag type-name #f))
|
|
||||||
(else local))))
|
|
||||||
(register-protocol-method tag proto-name method-name fn)
|
(register-protocol-method tag proto-name method-name fn)
|
||||||
(mark-extend! tag proto-name)
|
(mark-extend! tag proto-name)
|
||||||
jolt-nil))
|
jolt-nil))
|
||||||
|
|
@ -745,60 +334,34 @@
|
||||||
(let ((h (make-hashtable string-hash string=?))) (hashtable-set! type-registry tag h) h))))
|
(let ((h (make-hashtable string-hash string=?))) (hashtable-set! type-registry tag h) h))))
|
||||||
(unless (hashtable-ref ti proto-name #f)
|
(unless (hashtable-ref ti proto-name #f)
|
||||||
(hashtable-set! ti proto-name (make-hashtable string-hash string=?))))
|
(hashtable-set! ti proto-name (make-hashtable string-hash string=?))))
|
||||||
;; the protocol's interface joins the type's class ancestry, spelled like the
|
|
||||||
;; JVM interface (munged ns; the defining ns is assumed to be the current one —
|
|
||||||
;; the macro passes only the simple protocol name).
|
|
||||||
(let ((iface (string-append (jch-munge-segments (chez-current-ns)) "." proto-name)))
|
|
||||||
(jch-mark-interface! iface)
|
|
||||||
(jch-register-supers! (string-append (chez-current-ns) "." type-name) (list iface)))
|
|
||||||
jolt-nil)
|
jolt-nil)
|
||||||
|
|
||||||
;; protocol-resolve: the impl procedure for obj — by record type tag, a reify's
|
;; protocol-dispatch: look up the impl by the value's type tag (record) or host
|
||||||
;; instance-local method, or the protocol's extended impls over obj's host tags.
|
;; candidates, invoke it; reified objects carry instance-local methods.
|
||||||
;; Raises if none implements the method. The dispatchN entry points apply it
|
|
||||||
;; directly so a protocol call doesn't cons a rest-list (the impl fn is always a
|
|
||||||
;; procedure, registered by register-(inline-)method/extend).
|
|
||||||
(define (protocol-resolve proto-name method-name obj)
|
|
||||||
(cond
|
|
||||||
((and (jrec? obj) (find-protocol-method (jrec-tag obj) proto-name method-name)))
|
|
||||||
((reified-methods obj)
|
|
||||||
=> (lambda (rm)
|
|
||||||
(or (hashtable-ref rm method-name #f)
|
|
||||||
;; not implemented on the reify — fall back to the protocol's
|
|
||||||
;; extended impls over the reify's host tags (e.g. an Object/default
|
|
||||||
;; extension). malli reifies some protocols and leans on the default.
|
|
||||||
(let loop ((tags (value-host-tags obj)))
|
|
||||||
(cond ((null? tags) (error #f (string-append "No reified method " method-name)))
|
|
||||||
((find-protocol-method (car tags) proto-name method-name))
|
|
||||||
(else (loop (cdr tags))))))))
|
|
||||||
(else
|
|
||||||
(let loop ((tags (value-host-tags obj)))
|
|
||||||
(cond ((null? tags) (error #f (string-append "No method " method-name " in " proto-name)))
|
|
||||||
((find-protocol-method (car tags) proto-name method-name))
|
|
||||||
(else (loop (cdr tags))))))))
|
|
||||||
;; Fixed-arity entry points the protocol-method shims call: no rest-list, no seq
|
|
||||||
;; round-trip — apply the resolved impl directly. defprotocol emits one clause per
|
|
||||||
;; declared arity that calls the matching dispatchN.
|
|
||||||
(define (protocol-dispatch1 proto-name method-name obj)
|
|
||||||
((protocol-resolve proto-name method-name obj) obj))
|
|
||||||
(define (protocol-dispatch2 proto-name method-name obj a)
|
|
||||||
((protocol-resolve proto-name method-name obj) obj a))
|
|
||||||
(define (protocol-dispatch3 proto-name method-name obj a b)
|
|
||||||
((protocol-resolve proto-name method-name obj) obj a b))
|
|
||||||
;; the variadic fallback (a declared arity of 4+ args) takes a seqable rest.
|
|
||||||
(define (protocol-dispatch proto-name method-name obj rest-args)
|
(define (protocol-dispatch proto-name method-name obj rest-args)
|
||||||
(let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
|
(let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
|
||||||
(apply (protocol-resolve proto-name method-name obj) obj rest)))
|
(cond
|
||||||
|
((and (jrec? obj) (find-protocol-method (jrec-tag obj) proto-name method-name))
|
||||||
;; devirt-resolve: the impl for a call the inference proved monomorphic. Try the
|
=> (lambda (f) (apply jolt-invoke f obj rest)))
|
||||||
;; static type tag directly (the fast path that skips receiver-type computation),
|
((reified-methods obj)
|
||||||
;; and fall back to ordinary dispatch when it misses — a record can satisfy a
|
=> (lambda (rm) (let ((f (hashtable-ref rm method-name #f)))
|
||||||
;; protocol via an Object/host-tag default rather than a direct impl, which
|
(if f (apply jolt-invoke f obj rest)
|
||||||
;; find-protocol-method on its own tag wouldn't see. Mirrors jrec-field-at falling
|
;; not implemented on the reify — fall back to the
|
||||||
;; back to jolt-get: correct regardless of how precise the inference was.
|
;; protocol's extended impls over the reify's host tags
|
||||||
(define (devirt-resolve type-tag proto-name method-name obj)
|
;; (e.g. an Object/default extension). malli reifies some
|
||||||
(or (find-protocol-method type-tag proto-name method-name)
|
;; protocols and relies on a protocol's default for the
|
||||||
(protocol-resolve proto-name method-name obj)))
|
;; rest.
|
||||||
|
(let loop ((tags (value-host-tags obj)))
|
||||||
|
(cond ((null? tags) (error #f (string-append "No reified method " method-name)))
|
||||||
|
((find-protocol-method (car tags) proto-name method-name)
|
||||||
|
=> (lambda (g) (apply jolt-invoke g obj rest)))
|
||||||
|
(else (loop (cdr tags)))))))))
|
||||||
|
(else
|
||||||
|
(let loop ((tags (value-host-tags obj)))
|
||||||
|
(cond ((null? tags) (error #f (string-append "No method " method-name " in " proto-name)))
|
||||||
|
((find-protocol-method (car tags) proto-name method-name)
|
||||||
|
=> (lambda (f) (apply jolt-invoke f obj rest)))
|
||||||
|
(else (loop (cdr tags)))))))))
|
||||||
|
|
||||||
;; dot-dispatch fallback used by emit for (.method record args): find the method
|
;; dot-dispatch fallback used by emit for (.method record args): find the method
|
||||||
;; in ANY protocol the record's type implements.
|
;; in ANY protocol the record's type implements.
|
||||||
|
|
@ -835,38 +398,21 @@
|
||||||
;; "#<compound condition>".
|
;; "#<compound condition>".
|
||||||
(def-var! "jolt.host" "condition-message"
|
(def-var! "jolt.host" "condition-message"
|
||||||
(lambda (c) (if (condition? c) (condition->message-string c) jolt-nil)))
|
(lambda (c) (if (condition? c) (condition->message-string c) jolt-nil)))
|
||||||
(define (record-method-dispatch-base obj method-name rest-args)
|
(define (record-method-dispatch obj method-name rest-args)
|
||||||
(let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
|
(let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
|
||||||
(cond
|
(cond
|
||||||
((and (jrec? obj) (find-method-any-protocol-arity (jrec-tag obj) method-name (+ 1 (length rest))))
|
;; (.getClass x): universal Object method — the class token for any value
|
||||||
|
;; (jolt has no Class objects; the token is the canonical name string, on
|
||||||
|
;; which .getName/.getSimpleName work via the String method shim).
|
||||||
|
((and (string=? method-name "getClass") (not (jrec? obj)) (not (jreify? obj)))
|
||||||
|
(jolt-class obj))
|
||||||
|
((and (jrec? obj) (find-method-any-protocol (jrec-tag obj) method-name))
|
||||||
=> (lambda (f) (apply jolt-invoke f obj rest)))
|
=> (lambda (f) (apply jolt-invoke f obj rest)))
|
||||||
;; (.field inst): a deftype/record field read with no matching method.
|
;; (.field inst): a deftype/record field read with no matching method.
|
||||||
;; Clojure reads the field for (.q x) just like (.-q x); a declared method
|
;; Clojure reads the field for (.q x) just like (.-q x); a declared method
|
||||||
;; (above) wins, this is the field-accessor fallback.
|
;; (above) wins, this is the field-accessor fallback.
|
||||||
((and (jrec? obj) (null? rest) (jrec-has? obj (keyword #f method-name)))
|
((and (jrec? obj) (null? rest) (jrec-has? obj (keyword #f method-name)))
|
||||||
(jrec-lookup obj (keyword #f method-name) jolt-nil))
|
(jrec-lookup obj (keyword #f method-name) jolt-nil))
|
||||||
;; a defrecord is Associative / ILookup / IPersistentMap / Seqable / Counted,
|
|
||||||
;; so its clojure.lang interface methods delegate to the map fns when not
|
|
||||||
;; overridden by a declared method — reitit's impl calls (.assoc match k v),
|
|
||||||
;; (.valAt …), (.without …) directly. A bare deftype implements these via its
|
|
||||||
;; own declared methods (handled above), so this is record-only.
|
|
||||||
((and (jrec-record? obj)
|
|
||||||
(member method-name '("valAt" "assoc" "without" "containsKey" "cons"
|
|
||||||
"count" "seq" "equiv" "entryAt" "empty")))
|
|
||||||
(cond
|
|
||||||
((string=? method-name "valAt")
|
|
||||||
(if (null? (cdr rest)) (jolt-get obj (car rest) jolt-nil) (jolt-get obj (car rest) (cadr rest))))
|
|
||||||
((string=? method-name "assoc") (jolt-assoc1 obj (car rest) (cadr rest)))
|
|
||||||
((string=? method-name "without") (jolt-dissoc obj (car rest)))
|
|
||||||
((string=? method-name "containsKey") (if (jolt-truthy? (jolt-contains? obj (car rest))) #t #f))
|
|
||||||
((string=? method-name "cons") (jolt-conj1 obj (car rest)))
|
|
||||||
((string=? method-name "count") (jolt-count obj))
|
|
||||||
((string=? method-name "seq") (jolt-seq obj))
|
|
||||||
((string=? method-name "equiv") (if (jolt= obj (car rest)) #t #f))
|
|
||||||
((string=? method-name "entryAt")
|
|
||||||
(if (jolt-truthy? (jolt-contains? obj (car rest)))
|
|
||||||
(make-map-entry (car rest) (jolt-get obj (car rest) jolt-nil)) jolt-nil))
|
|
||||||
(else jolt-nil))) ; .empty of a record is nil on the JVM
|
|
||||||
((reified-methods obj)
|
((reified-methods obj)
|
||||||
=> (lambda (rm) (let ((f (hashtable-ref rm method-name #f)))
|
=> (lambda (rm) (let ((f (hashtable-ref rm method-name #f)))
|
||||||
(if f (apply jolt-invoke f obj rest) (error #f (string-append "No method " method-name))))))
|
(if f (apply jolt-invoke f obj rest) (error #f (string-append "No method " method-name))))))
|
||||||
|
|
@ -903,8 +449,6 @@
|
||||||
(string-append (if (symbol-t-ns obj) (string-append (symbol-t-ns obj) "/") "")
|
(string-append (if (symbol-t-ns obj) (string-append (symbol-t-ns obj) "/") "")
|
||||||
(symbol-t-name obj)))
|
(symbol-t-name obj)))
|
||||||
((string=? method-name "equals") (and (pair? rest) (jolt=2 obj (car rest))))
|
((string=? method-name "equals") (and (pair? rest) (jolt=2 obj (car rest))))
|
||||||
((string=? method-name "hashCode")
|
|
||||||
(java-symbol-hash (symbol-t-name obj) (symbol-t-ns obj)))
|
|
||||||
(else (error #f (string-append "No method " method-name " on Symbol")))))
|
(else (error #f (string-append "No method " method-name " on Symbol")))))
|
||||||
;; clojure.lang.Namespace: name/getName yield the ns name as a Symbol (JVM:
|
;; clojure.lang.Namespace: name/getName yield the ns name as a Symbol (JVM:
|
||||||
;; Namespace.name is a Symbol). clojure.spec.alpha reads (.name *ns*).
|
;; Namespace.name is a Symbol). clojure.spec.alpha reads (.name *ns*).
|
||||||
|
|
@ -954,14 +498,6 @@
|
||||||
((jolt=2 (seq-first s) target)
|
((jolt=2 (seq-first s) target)
|
||||||
(if last? (loop (jolt-seq (seq-more s)) (fx+ i 1) i) i))
|
(if last? (loop (jolt-seq (seq-more s)) (fx+ i 1) i) i))
|
||||||
(else (loop (jolt-seq (seq-more s)) (fx+ i 1) found))))))
|
(else (loop (jolt-seq (seq-more s)) (fx+ i 1) found))))))
|
||||||
;; java.util.Collection.contains over a list/seq (vectors/sets handle it in
|
|
||||||
;; dot-coll-method): value membership, like the JVM.
|
|
||||||
((string=? method-name "contains")
|
|
||||||
(let ((target (car rest)))
|
|
||||||
(let loop ((s (jolt-seq obj)))
|
|
||||||
(cond ((jolt-nil? s) #f)
|
|
||||||
((jolt=2 (seq-first s) target) #t)
|
|
||||||
(else (loop (jolt-seq (seq-more s))))))))
|
|
||||||
;; universal Object methods on any remaining value (boolean, etc.).
|
;; universal Object methods on any remaining value (boolean, etc.).
|
||||||
((string=? method-name "toString") (jolt-str-render-one obj))
|
((string=? method-name "toString") (jolt-str-render-one obj))
|
||||||
((string=? method-name "hashCode") (jolt-hash obj))
|
((string=? method-name "hashCode") (jolt-hash obj))
|
||||||
|
|
@ -969,46 +505,10 @@
|
||||||
(else (error #f (string-append "No method " method-name " for value: "
|
(else (error #f (string-append "No method " method-name " for value: "
|
||||||
(jolt-pr-str obj)))))))
|
(jolt-pr-str obj)))))))
|
||||||
|
|
||||||
;; ---- method-dispatch arm registry ------------------------------------------
|
|
||||||
;; A .method call (record-method-dispatch) is resolved by an ordered list of arms
|
|
||||||
;; (ascending priority), each (obj method-name rest-args) -> result | 'pass.
|
|
||||||
;; This replaces a stack of (set! record-method-dispatch ...) rebindings across
|
|
||||||
;; six files whose precedence was implicit in load order — priority is now
|
|
||||||
;; explicit data. record-method-dispatch-base is the final fallback (the
|
|
||||||
;; string/keyword/symbol/Object-method surface). A host shim / library registers
|
|
||||||
;; an arm with register-method-arm! instead of set!-wrapping the dispatcher.
|
|
||||||
(define method-dispatch-arms '()) ; list of (priority . arm), ascending priority
|
|
||||||
(define (register-method-arm! priority arm)
|
|
||||||
(set! method-dispatch-arms
|
|
||||||
(let ins ((as method-dispatch-arms))
|
|
||||||
(cond ((null? as) (list (cons priority arm)))
|
|
||||||
((< priority (caar as)) (cons (cons priority arm) as))
|
|
||||||
(else (cons (car as) (ins (cdr as))))))))
|
|
||||||
(define (record-method-dispatch obj method-name rest-args)
|
|
||||||
(let loop ((as method-dispatch-arms))
|
|
||||||
(if (null? as)
|
|
||||||
(record-method-dispatch-base obj method-name rest-args)
|
|
||||||
(let ((r ((cdar as) obj method-name rest-args)))
|
|
||||||
(if (eq? r 'pass) (loop (cdr as)) r)))))
|
|
||||||
|
|
||||||
;; (.getClass x): a universal Object method reached by EVERY value before any
|
|
||||||
;; per-type arm — the class token for the value (jolt has no Class objects; the
|
|
||||||
;; token is the canonical name string, on which .getName/.getSimpleName work).
|
|
||||||
;; One arm, so a type arm that only whitelists its own methods can't steal it.
|
|
||||||
(register-method-arm! 5
|
|
||||||
(lambda (obj method-name rest-args)
|
|
||||||
(if (string=? method-name "getClass") (jolt-class obj) 'pass)))
|
|
||||||
|
|
||||||
;; reify: instance-local method table. obj is a jreify carrying a method ht +
|
;; reify: instance-local method table. obj is a jreify carrying a method ht +
|
||||||
;; the protocol short-names it implements (for satisfies?/instance?).
|
;; the protocol short-names it implements (for satisfies?/instance?).
|
||||||
(define-record-type jreify (fields methods protos) (nongenerative chez-jreify-v1))
|
(define-record-type jreify (fields methods protos) (nongenerative chez-jreify-v1))
|
||||||
(define (reified-methods obj) (and (jreify? obj) (jreify-methods obj)))
|
(define (reified-methods obj) (and (jreify? obj) (jreify-methods obj)))
|
||||||
;; (get reify k) / (:k reify) routes to a reify's ILookup valAt — clojure.spec.alpha
|
|
||||||
;; reifies fspec/regex specs as clojure.lang.ILookup and reads (:args spec) off them.
|
|
||||||
(register-get-arm! jreify?
|
|
||||||
(lambda (coll k d)
|
|
||||||
(let ((m (and (reified-methods coll) (hashtable-ref (reified-methods coll) "valAt" #f))))
|
|
||||||
(if m (jolt-invoke m coll k d) d))))
|
|
||||||
(define (make-reified methods-map . proto-names)
|
(define (make-reified methods-map . proto-names)
|
||||||
(let ((ht (make-hashtable string-hash string=?))
|
(let ((ht (make-hashtable string-hash string=?))
|
||||||
(protos (if (and (pair? proto-names) (null? (cdr proto-names)) (jolt-coll-pred? (car proto-names)))
|
(protos (if (and (pair? proto-names) (null? (cdr proto-names)) (jolt-coll-pred? (car proto-names)))
|
||||||
|
|
@ -1066,24 +566,6 @@
|
||||||
;; yields (jolt-symbol #f (jrec-tag x)), the ns.Name class-name symbol.
|
;; yields (jolt-symbol #f (jrec-tag x)), the ns.Name class-name symbol.
|
||||||
|
|
||||||
(def-var! "clojure.core" "make-deftype-ctor" make-deftype-ctor)
|
(def-var! "clojure.core" "make-deftype-ctor" make-deftype-ctor)
|
||||||
|
|
||||||
;; defrecord marks its type a record (deftype does not), keyed by the same
|
|
||||||
;; "ns.Name" tag make-deftype-ctor bakes — so jrec-record? distinguishes the two.
|
|
||||||
(define (register-record-type! name-sym)
|
|
||||||
(let ((tag (string-append (chez-current-ns) "." (symbol-t-name name-sym))))
|
|
||||||
(hashtable-set! chez-record-type-tbl tag #t)
|
|
||||||
;; a defrecord's class ancestry: replace the deftype IType row with the
|
|
||||||
;; record interfaces (their closure supplies Associative/Seqable/ILookup/…),
|
|
||||||
;; keeping any protocol interfaces already grafted by the inline
|
|
||||||
;; registrations that ran between the deftype ctor and this call.
|
|
||||||
(let ((protos (filter (lambda (s) (not (string=? s "clojure.lang.IType")))
|
|
||||||
(jch-direct-supers tag))))
|
|
||||||
(jch-set-supers! tag (append protos
|
|
||||||
'("clojure.lang.IRecord" "clojure.lang.IObj"
|
|
||||||
"clojure.lang.IPersistentMap" "java.util.Map"
|
|
||||||
"clojure.lang.IHashEq" "java.io.Serializable")))))
|
|
||||||
jolt-nil)
|
|
||||||
(def-var! "clojure.core" "register-record-type!" register-record-type!)
|
|
||||||
(def-var! "clojure.core" "make-protocol" make-protocol)
|
(def-var! "clojure.core" "make-protocol" make-protocol)
|
||||||
(def-var! "clojure.core" "register-protocol-methods!" register-protocol-methods!)
|
(def-var! "clojure.core" "register-protocol-methods!" register-protocol-methods!)
|
||||||
(def-var! "clojure.core" "register-method" register-method)
|
(def-var! "clojure.core" "register-method" register-method)
|
||||||
|
|
@ -1091,9 +573,6 @@
|
||||||
(def-var! "clojure.core" "register-inline-protocol!" register-inline-protocol!)
|
(def-var! "clojure.core" "register-inline-protocol!" register-inline-protocol!)
|
||||||
(def-var! "jolt.host" "set-field!" jolt-set-field!)
|
(def-var! "jolt.host" "set-field!" jolt-set-field!)
|
||||||
(def-var! "clojure.core" "protocol-dispatch" (lambda (pn mn obj rest) (protocol-dispatch pn mn obj rest)))
|
(def-var! "clojure.core" "protocol-dispatch" (lambda (pn mn obj rest) (protocol-dispatch pn mn obj rest)))
|
||||||
(def-var! "clojure.core" "protocol-dispatch1" (lambda (pn mn obj) (protocol-dispatch1 pn mn obj)))
|
|
||||||
(def-var! "clojure.core" "protocol-dispatch2" (lambda (pn mn obj a) (protocol-dispatch2 pn mn obj a)))
|
|
||||||
(def-var! "clojure.core" "protocol-dispatch3" (lambda (pn mn obj a b) (protocol-dispatch3 pn mn obj a b)))
|
|
||||||
(def-var! "clojure.core" "satisfies?" jolt-satisfies?)
|
(def-var! "clojure.core" "satisfies?" jolt-satisfies?)
|
||||||
(def-var! "clojure.core" "extenders" extenders)
|
(def-var! "clojure.core" "extenders" extenders)
|
||||||
(def-var! "clojure.core" "make-reified" (lambda (mm . rest) (apply make-reified mm rest)))
|
(def-var! "clojure.core" "make-reified" (lambda (mm . rest) (apply make-reified mm rest)))
|
||||||
|
|
|
||||||
|
|
@ -33,14 +33,6 @@
|
||||||
(apply %chez-error args)))
|
(apply %chez-error args)))
|
||||||
(load "vendor/irregex/irregex.scm")
|
(load "vendor/irregex/irregex.scm")
|
||||||
|
|
||||||
;; irregex rejects a quantifier applied to anything that already contains one —
|
|
||||||
;; including a GROUP like (a+)* — because sre-repeater? recurses through submatch.
|
|
||||||
;; Java only rejects a DANGLING double quantifier (a**); it allows a quantifier on
|
|
||||||
;; a group whose body is quantified. Restrict the check to a bare leading * / + so
|
|
||||||
;; a** still errors but (a+)* parses (cuerdas's format tokenizer needs this).
|
|
||||||
(set! sre-repeater?
|
|
||||||
(lambda (sre) (and (pair? sre) (memq (car sre) '(* +)) #t)))
|
|
||||||
|
|
||||||
;; Unicode property classes \p{...}: irregex's string syntax has no
|
;; Unicode property classes \p{...}: irregex's string syntax has no
|
||||||
;; \p{...}, so translate a fixed set of property names
|
;; \p{...}, so translate a fixed set of property names
|
||||||
;; to ASCII char classes before compiling. ASCII-only — \p{L} would need
|
;; to ASCII char classes before compiling. ASCII-only — \p{L} would need
|
||||||
|
|
@ -100,36 +92,6 @@
|
||||||
(write-char c out) (loop (fx+ i 1) #f))
|
(write-char c out) (loop (fx+ i 1) #f))
|
||||||
(else (write-char c out) (loop (fx+ i 1) in-class))))))))
|
(else (write-char c out) (loop (fx+ i 1) in-class))))))))
|
||||||
|
|
||||||
;; Inside a [...] class, irregex reads a '-' that follows a shorthand class
|
|
||||||
;; (\w \d \s \W \D \S) as the start of a range and errors ("bad char-set"); Java
|
|
||||||
;; reads it as a literal hyphen (a shorthand can't be a range endpoint). Escape
|
|
||||||
;; such a '-' to \- so the class parses. Only a '-' right after a shorthand and
|
|
||||||
;; not the class terminator is touched; a '-' after a plain char (a real range
|
|
||||||
;; like [a-z]) is left alone.
|
|
||||||
(define (escape-class-shorthand-dash src)
|
|
||||||
(let ((len (string-length src)) (out (open-output-string)))
|
|
||||||
(let loop ((i 0) (in-class #f) (after-shorthand #f))
|
|
||||||
(if (fx>=? i len)
|
|
||||||
(get-output-string out)
|
|
||||||
(let ((c (string-ref src i)))
|
|
||||||
(cond
|
|
||||||
;; an escape pair: \w-style shorthand sets after-shorthand inside a class
|
|
||||||
((and (char=? c #\\) (fx<? (fx+ i 1) len))
|
|
||||||
(let ((n (string-ref src (fx+ i 1))))
|
|
||||||
(write-char c out) (write-char n out)
|
|
||||||
(loop (fx+ i 2) in-class
|
|
||||||
(and in-class (memv n '(#\w #\d #\s #\W #\D #\S)) #t))))
|
|
||||||
((and (not in-class) (char=? c #\[))
|
|
||||||
(write-char c out) (loop (fx+ i 1) #t #f))
|
|
||||||
((and in-class (char=? c #\]))
|
|
||||||
(write-char c out) (loop (fx+ i 1) #f #f))
|
|
||||||
;; the case Java reads as a literal hyphen
|
|
||||||
((and in-class after-shorthand (char=? c #\-)
|
|
||||||
(fx<? (fx+ i 1) len) (not (char=? (string-ref src (fx+ i 1)) #\])))
|
|
||||||
(write-char #\\ out) (write-char #\- out)
|
|
||||||
(loop (fx+ i 1) in-class #f))
|
|
||||||
(else (write-char c out) (loop (fx+ i 1) in-class #f))))))))
|
|
||||||
|
|
||||||
;; Java/Clojure inline flags: a leading (?imsx…) group sets a flag over the whole
|
;; Java/Clojure inline flags: a leading (?imsx…) group sets a flag over the whole
|
||||||
;; pattern. irregex has the same semantics but as constructor OPTIONS, not inline
|
;; pattern. irregex has the same semantics but as constructor OPTIONS, not inline
|
||||||
;; syntax (it rejects (?s)/(?s:…)), so peel any leading flag groups off the source
|
;; syntax (it rejects (?s)/(?s:…)), so peel any leading flag groups off the source
|
||||||
|
|
@ -159,23 +121,9 @@
|
||||||
;; A jolt regex value: the source string (for printing / str) + the compiled
|
;; A jolt regex value: the source string (for printing / str) + the compiled
|
||||||
;; irregex. regex? recognizes it; the printer renders #"source".
|
;; irregex. regex? recognizes it; the printer renders #"source".
|
||||||
(define-record-type regex-t (fields source irx) (nongenerative jolt-regex-v1))
|
(define-record-type regex-t (fields source irx) (nongenerative jolt-regex-v1))
|
||||||
;; A capturing pattern is compiled with irregex's BACKTRACKING matcher ('backtrack),
|
|
||||||
;; not its DFA. java.util.regex is itself a leftmost-first backtracking engine, so
|
|
||||||
;; this matches the JVM's submatch semantics; irregex's DFA is POSIX leftmost-longest
|
|
||||||
;; and, worse, leaks a non-participating alternation group's capture (e.g.
|
|
||||||
;; #"(?:([0-9])|([0-9])r([0-9]+))" on "2r11" left group 1 = "2"), which broke
|
|
||||||
;; tools.reader's number reader. Non-capturing patterns keep the fast DFA — with no
|
|
||||||
;; groups to read, its whole-match result is all a caller sees. The count comes from
|
|
||||||
;; a first cheap compile; a capturing pattern is recompiled once (patterns compile
|
|
||||||
;; once and cache in the regex-t).
|
|
||||||
(define (jolt-regex source)
|
(define (jolt-regex source)
|
||||||
(let-values (((opts pat) (regex-parse-flags source)))
|
(let-values (((opts pat) (regex-parse-flags source)))
|
||||||
(let* ((p (translate-prop-classes (escape-class-shorthand-dash pat)))
|
(make-regex-t source (apply irregex (translate-prop-classes pat) opts))))
|
||||||
(irx (apply irregex p opts)))
|
|
||||||
(make-regex-t source
|
|
||||||
(if (> (irregex-num-submatches irx) 0)
|
|
||||||
(apply irregex p 'backtrack opts)
|
|
||||||
irx)))))
|
|
||||||
(define (jolt-regex? x) (regex-t? x))
|
(define (jolt-regex? x) (regex-t? x))
|
||||||
(define (jolt-re-pattern x) (if (regex-t? x) x (jolt-regex x)))
|
(define (jolt-re-pattern x) (if (regex-t? x) x (jolt-regex x)))
|
||||||
|
|
||||||
|
|
@ -195,59 +143,9 @@
|
||||||
(let ((m (irregex-match (regex-t-irx (jolt-re-pattern re)) s)))
|
(let ((m (irregex-match (regex-t-irx (jolt-re-pattern re)) s)))
|
||||||
(if m (irx-result m) jolt-nil)))
|
(if m (irx-result m) jolt-nil)))
|
||||||
|
|
||||||
;; A stateful matcher (java.util.regex.Matcher): the compiled pattern, the target
|
(define (jolt-re-find re s)
|
||||||
;; string, the next search position, and the last successful irregex match. re-find
|
(let ((m (irregex-search (regex-t-irx (jolt-re-pattern re)) s)))
|
||||||
;; over a matcher steps through non-overlapping matches; re-groups returns the
|
(if m (irx-result m) jolt-nil)))
|
||||||
;; groups of the last one.
|
|
||||||
(define-record-type matcher-t
|
|
||||||
(fields irx str (mutable pos) (mutable last))
|
|
||||||
(nongenerative jolt-matcher-v1))
|
|
||||||
(define (jolt-re-matcher re s)
|
|
||||||
(make-matcher-t (regex-t-irx (jolt-re-pattern re)) s 0 #f))
|
|
||||||
(define (jolt-matcher? x) (matcher-t? x))
|
|
||||||
|
|
||||||
;; re-find: stateless over (re s), or stateful over a matcher (advance + remember).
|
|
||||||
(define jolt-re-find
|
|
||||||
(case-lambda
|
|
||||||
((re s)
|
|
||||||
(let ((m (irregex-search (regex-t-irx (jolt-re-pattern re)) s)))
|
|
||||||
(if m (irx-result m) jolt-nil)))
|
|
||||||
((m)
|
|
||||||
(let* ((str (matcher-t-str m))
|
|
||||||
(len (string-length str))
|
|
||||||
(start (matcher-t-pos m))
|
|
||||||
(mm (and (<= start len) (irregex-search (matcher-t-irx m) str start))))
|
|
||||||
(if mm
|
|
||||||
(let ((ms (irregex-match-start-index mm 0))
|
|
||||||
(e (irregex-match-end-index mm 0)))
|
|
||||||
(matcher-t-last-set! m mm)
|
|
||||||
;; advance past this match: to its end, or one past a zero-width match
|
|
||||||
;; (which may sit past the search origin, e.g. a lookahead/boundary).
|
|
||||||
(matcher-t-pos-set! m (if (> e ms) e (+ e 1)))
|
|
||||||
(irx-result mm))
|
|
||||||
(begin (matcher-t-last-set! m #f) jolt-nil))))))
|
|
||||||
|
|
||||||
;; re-groups: the groups of the matcher's last successful find. Throws when no
|
|
||||||
;; match has succeeded, like Clojure's IllegalStateException "No match found".
|
|
||||||
(define (jolt-re-groups m)
|
|
||||||
(let ((last (matcher-t-last m)))
|
|
||||||
(if last (irx-result last)
|
|
||||||
(jolt-throw (jolt-ex-info "No match found" (jolt-hash-map))))))
|
|
||||||
|
|
||||||
;; java.util.regex.Matcher methods over a matcher-t. .matches anchors a full-region
|
|
||||||
;; match and remembers it for .group; .group n returns submatch n (0 = whole) or
|
|
||||||
;; nil; .groupCount is the pattern's capturing-group count.
|
|
||||||
(define (jolt-matcher-matches m)
|
|
||||||
(let ((mm (irregex-match (matcher-t-irx m) (matcher-t-str m))))
|
|
||||||
(matcher-t-last-set! m mm)
|
|
||||||
(if mm #t #f)))
|
|
||||||
(define (jolt-matcher-group m . n)
|
|
||||||
(let ((last (matcher-t-last m)))
|
|
||||||
(if last
|
|
||||||
(let ((s (irregex-match-substring last (if (pair? n) (->idx (car n)) 0))))
|
|
||||||
(if s s jolt-nil))
|
|
||||||
(jolt-throw (jolt-ex-info "No match available" (jolt-hash-map))))))
|
|
||||||
(define (jolt-matcher-group-count m) (irregex-num-submatches (matcher-t-irx m)))
|
|
||||||
|
|
||||||
;; All non-overlapping matches, left to right. Advance past each match end (or by
|
;; All non-overlapping matches, left to right. Advance past each match end (or by
|
||||||
;; one on a zero-width match). nil when there are no matches (Clojure: seq-able as
|
;; one on a zero-width match). nil when there are no matches (Clojure: seq-able as
|
||||||
|
|
@ -258,17 +156,12 @@
|
||||||
(let loop ((start 0) (acc '()))
|
(let loop ((start 0) (acc '()))
|
||||||
(let ((m (and (<= start len) (irregex-search irx s start))))
|
(let ((m (and (<= start len) (irregex-search irx s start))))
|
||||||
(if m
|
(if m
|
||||||
(let ((ms (irregex-match-start-index m 0))
|
(let ((e (irregex-match-end-index m 0)))
|
||||||
(e (irregex-match-end-index m 0)))
|
(loop (if (> e start) e (+ start 1)) (cons (irx-result m) acc)))
|
||||||
;; to the match end, or one past a zero-width match (relative to its
|
|
||||||
;; own start, which may be past the search origin).
|
|
||||||
(loop (if (> e ms) e (+ e 1)) (cons (irx-result m) acc)))
|
|
||||||
(list->cseq (reverse acc)))))))
|
(list->cseq (reverse acc)))))))
|
||||||
|
|
||||||
(def-var! "clojure.core" "re-pattern" jolt-re-pattern)
|
(def-var! "clojure.core" "re-pattern" jolt-re-pattern)
|
||||||
(def-var! "clojure.core" "re-matches" jolt-re-matches)
|
(def-var! "clojure.core" "re-matches" jolt-re-matches)
|
||||||
(def-var! "clojure.core" "re-find" jolt-re-find)
|
(def-var! "clojure.core" "re-find" jolt-re-find)
|
||||||
(def-var! "clojure.core" "re-seq" jolt-re-seq)
|
(def-var! "clojure.core" "re-seq" jolt-re-seq)
|
||||||
(def-var! "clojure.core" "re-matcher" jolt-re-matcher)
|
|
||||||
(def-var! "clojure.core" "re-groups" jolt-re-groups)
|
|
||||||
(def-var! "clojure.core" "regex?" jolt-regex?)
|
(def-var! "clojure.core" "regex?" jolt-regex?)
|
||||||
|
|
|
||||||
308
host/chez/rt.ss
308
host/chez/rt.ss
|
|
@ -11,17 +11,6 @@
|
||||||
;; Emitted programs do `(load "host/chez/rt.ss")`; this loads values.ss in turn.
|
;; Emitted programs do `(load "host/chez/rt.ss")`; this loads values.ss in turn.
|
||||||
|
|
||||||
(load "host/chez/values.ss")
|
(load "host/chez/values.ss")
|
||||||
;; Resolve a libc entry point at RUN time. A literal (foreign-procedure "name" …)
|
|
||||||
;; in COMPILED code becomes a fasl relocation resolved when the boot loads — on a
|
|
||||||
;; platform lacking the symbol (chmod/sigaddset on Windows) that kills the boot
|
|
||||||
;; before any guard can run. eval defers the lookup to evaluation time, where the
|
|
||||||
;; guard works; returns #f when the entry doesn't exist.
|
|
||||||
(define (jolt-foreign-proc-safe name args res)
|
|
||||||
(guard (e (#t #f))
|
|
||||||
(load-shared-object #f)
|
|
||||||
(and (foreign-entry? name)
|
|
||||||
(eval `(foreign-procedure ,name ,args ,res)))))
|
|
||||||
|
|
||||||
(load "host/chez/collections.ss")
|
(load "host/chez/collections.ss")
|
||||||
(load "host/chez/seq.ss")
|
(load "host/chez/seq.ss")
|
||||||
|
|
||||||
|
|
@ -33,157 +22,20 @@
|
||||||
;; pass an exact integer through, error if it doesn't fit a fixnum or isn't a
|
;; pass an exact integer through, error if it doesn't fit a fixnum or isn't a
|
||||||
;; number. The hint is a promise the value is a fixnum-range long; the body's fx*
|
;; number. The hint is a promise the value is a fixnum-range long; the body's fx*
|
||||||
;; ops rely on it. (^double params coerce with the built-in exact->inexact.)
|
;; ops rely on it. (^double params coerce with the built-in exact->inexact.)
|
||||||
;; A ^long is a 64-bit value; a Chez fixnum is only 61-bit, so a value that
|
|
||||||
;; overflows the fixnum range (a full-width long, e.g. from unchecked / wrapping
|
|
||||||
;; arithmetic) passes through as an exact integer rather than erroring. fx ops in
|
|
||||||
;; the body still require fixnums (they raise on a bignum), but generic /
|
|
||||||
;; unchecked-* ops handle it.
|
|
||||||
(define (jolt->fx x)
|
(define (jolt->fx x)
|
||||||
(cond ((fixnum? x) x)
|
(let ((n (cond ((fixnum? x) x)
|
||||||
((and (number? x) (exact? x) (integer? x)) x)
|
((flonum? x) (exact (truncate x)))
|
||||||
((flonum? x) (exact (truncate x)))
|
((rational? x) (exact (truncate x)))
|
||||||
((rational? x) (exact (truncate x)))
|
(else (error 'jolt "^long hint: not a number" x)))))
|
||||||
(else (error 'jolt "^long hint: not a number" x))))
|
(if (fixnum? n) n (error 'jolt "^long hint: value out of fixnum range" x))))
|
||||||
;; jolt `not`: only nil and false are falsey.
|
;; jolt `not`: only nil and false are falsey.
|
||||||
(define (jolt-not x) (if (jolt-truthy? x) #f #t))
|
(define (jolt-not x) (if (jolt-truthy? x) #f #t))
|
||||||
|
|
||||||
;; --- exceptions --------------------------------------------------------------
|
;; --- exceptions --------------------------------------------------------------
|
||||||
;; throw raises a Chez condition WRAPPING the jolt value; catch (emitted as
|
;; throw raises the jolt value RAW (no envelope);
|
||||||
;; `guard`) and jolt-report-uncaught unwrap it back via jolt-unwrap-throw.
|
;; catch (emitted as `guard`) binds it directly. Chez `raise` accepts any
|
||||||
;; Raising the value RAW broke when a throw crossed the host/`eval` boundary:
|
;; object, so a thrown number/map/ex-info all work; uncaught -> non-zero exit.
|
||||||
;; Chez re-wrapped the non-condition into a compound condition whose
|
(define (jolt-throw v) (raise v))
|
||||||
;; message-extraction APPLIES the value (crashing on an empty-map :data ->
|
|
||||||
;; "attempt to apply non-procedure"), and the real message was lost. A real
|
|
||||||
;; condition propagates intact through any number of eval boundaries.
|
|
||||||
;; Capture the live continuation at the throw site (identity-tagged with the
|
|
||||||
;; thrown value) so an uncaught error can walk the native frames back to a Clojure
|
|
||||||
;; stack trace (source-registry.ss). call/cc is paid only on a throw, never per
|
|
||||||
;; call; the captured k is walked, never invoked.
|
|
||||||
(define jolt-throw-cont (make-thread-parameter #f))
|
|
||||||
|
|
||||||
;; --- tail-frame history: a ring of rings (opt-in) ----------------------------
|
|
||||||
;; TCO erases tail-called frames from the native continuation, so an uncaught
|
|
||||||
;; error's backtrace shows only the surviving non-tail spine — the immediate error
|
|
||||||
;; site is often a tail call and is missing. When tracing is enabled (JOLT_TRACE,
|
|
||||||
;; wired in compile-eval.ss), each compiled fn records its frame-name on entry, and
|
|
||||||
;; the reporter reads this history to recover TCO-elided frames.
|
|
||||||
;;
|
|
||||||
;; The store is MIT-Scheme's "history" shape — a ring of rings. The OUTER ring
|
|
||||||
;; holds one RIB per non-tail subproblem (the real call spine); each rib's INNER
|
|
||||||
;; ring holds the recent tail-calls made AT that subproblem. A non-tail entry
|
|
||||||
;; advances the outer ring (a fresh rib); a tail entry rotates the current rib's
|
|
||||||
;; inner ring. So a tight tail loop (mutual recursion, a non-recur self-tail-call)
|
|
||||||
;; churns ONE rib's small inner ring instead of flushing the outer spine — the
|
|
||||||
;; caller context that led into the loop survives. Both rings are fixed-size, so
|
|
||||||
;; the whole history is bounded: a constant space factor, NOT a change to the
|
|
||||||
;; asymptotic space TCO guarantees.
|
|
||||||
;;
|
|
||||||
;; Whether an entry is tail or non-tail is set by the CALLER: the emitter marks a
|
|
||||||
;; tail call with (jolt-trace-mark! #t) right before it; a non-tail entry is the
|
|
||||||
;; default. NOTE this is best-effort: a tail call routed through jolt-invoke to a
|
|
||||||
;; target that has no entry prologue (a core/native fn, an anonymous fn held in a
|
|
||||||
;; var) does not consume the mark, so a following non-tail frame can be mislabeled
|
|
||||||
;; as a tail rotation — a cosmetic mis-grouping in the trace, never a wrong result.
|
|
||||||
(define jolt-trace-outer-size 48) ; ribs (non-tail spine depth kept)
|
|
||||||
(define jolt-trace-inner-size 6) ; tail-calls kept per subproblem
|
|
||||||
;; A history: #(ribs-vector outer-head outer-count). A rib: #(name-vector head count).
|
|
||||||
(define (jolt-make-rib) (vector (make-vector jolt-trace-inner-size #f) 0 0))
|
|
||||||
(define (jolt-make-history)
|
|
||||||
(let ((ribs (make-vector jolt-trace-outer-size #f)))
|
|
||||||
(let loop ((i 0))
|
|
||||||
(when (fx<? i jolt-trace-outer-size)
|
|
||||||
(vector-set! ribs i (jolt-make-rib)) (loop (fx+ i 1))))
|
|
||||||
(vector ribs 0 0)))
|
|
||||||
;; A global switch (all threads) plus a per-thread ring, lazily created on first
|
|
||||||
;; use — so code run on a spawned thread (a future/agent) records into ITS OWN
|
|
||||||
;; history, not the enabling thread's (make-thread-parameter hands a new thread the
|
|
||||||
;; initial #f, so we can't rely on inheritance).
|
|
||||||
(define jolt-trace-on? #f)
|
|
||||||
(define jolt-trace-ring (make-thread-parameter #f))
|
|
||||||
(define jolt-trace-tail? (make-thread-parameter #f)) ; caller-set, consumed per entry
|
|
||||||
(define (jolt-trace-enable!) (set! jolt-trace-on? #t) (jolt-trace-ring (jolt-make-history)))
|
|
||||||
;; this thread's ring, created on demand while tracing is on
|
|
||||||
(define (jolt-trace-cur-ring)
|
|
||||||
(or (jolt-trace-ring)
|
|
||||||
(and jolt-trace-on? (let ((h (jolt-make-history))) (jolt-trace-ring h) h))))
|
|
||||||
;; Drop accumulated history at a top-level boundary (compile-eval.ss calls this per
|
|
||||||
;; top-level form) so an error's trace shows only the forms that led to it, not the
|
|
||||||
;; frames of earlier, already-returned REPL/eval forms.
|
|
||||||
(define (jolt-trace-reset!)
|
|
||||||
(when (jolt-trace-ring) (jolt-trace-ring (jolt-make-history)) (jolt-trace-tail? #f)))
|
|
||||||
(define (jolt-trace-mark! t) (jolt-trace-tail? t))
|
|
||||||
|
|
||||||
;; push name into a rib's inner ring
|
|
||||||
(define (jolt-rib-push! rib name)
|
|
||||||
(let ((buf (vector-ref rib 0)) (i (vector-ref rib 1)) (cnt (vector-ref rib 2)))
|
|
||||||
(vector-set! buf i name)
|
|
||||||
(vector-set! rib 1 (fxmod (fx+ i 1) jolt-trace-inner-size))
|
|
||||||
(when (fx<? cnt jolt-trace-inner-size) (vector-set! rib 2 (fx+ cnt 1)))))
|
|
||||||
;; a non-tail entry: advance the outer ring, reset the new rib, seed it with name
|
|
||||||
(define (jolt-history-nontail! h name)
|
|
||||||
(let* ((ribs (vector-ref h 0)) (oh (vector-ref h 1)) (oc (vector-ref h 2))
|
|
||||||
(rib (vector-ref ribs oh)))
|
|
||||||
(vector-set! rib 1 0) (vector-set! rib 2 0)
|
|
||||||
(jolt-rib-push! rib name)
|
|
||||||
(vector-set! h 1 (fxmod (fx+ oh 1) jolt-trace-outer-size))
|
|
||||||
(when (fx<? oc jolt-trace-outer-size) (vector-set! h 2 (fx+ oc 1)))))
|
|
||||||
;; a tail entry: rotate the CURRENT rib's inner ring (bootstrap a rib if none yet)
|
|
||||||
(define (jolt-history-tail! h name)
|
|
||||||
(if (fx=? (vector-ref h 2) 0)
|
|
||||||
(jolt-history-nontail! h name)
|
|
||||||
(let* ((ribs (vector-ref h 0))
|
|
||||||
(cur (fxmod (fx+ (fx- (vector-ref h 1) 1) jolt-trace-outer-size)
|
|
||||||
jolt-trace-outer-size)))
|
|
||||||
(jolt-rib-push! (vector-ref ribs cur) name))))
|
|
||||||
;; Record a frame entry, routed by the caller's tail mark; then reset the mark so a
|
|
||||||
;; subsequent entry reached WITHOUT a mark (e.g. via apply) defaults to non-tail.
|
|
||||||
(define (jolt-trace-push! name)
|
|
||||||
(let ((h (jolt-trace-cur-ring)))
|
|
||||||
(when h
|
|
||||||
(if (jolt-trace-tail?) (jolt-history-tail! h name) (jolt-history-nontail! h name))
|
|
||||||
(jolt-trace-tail? #f)))
|
|
||||||
jolt-nil)
|
|
||||||
|
|
||||||
;; a rib's inner names, most-recent (deepest) tail first
|
|
||||||
(define (jolt-rib-names rib)
|
|
||||||
(let ((buf (vector-ref rib 0)) (head (vector-ref rib 1)) (cnt (vector-ref rib 2)))
|
|
||||||
(let loop ((k 1) (acc '()))
|
|
||||||
(if (fx>? k cnt)
|
|
||||||
(reverse acc)
|
|
||||||
(loop (fx+ k 1)
|
|
||||||
(cons (vector-ref buf (fxmod (fx+ (fx- head k) jolt-trace-inner-size)
|
|
||||||
jolt-trace-inner-size))
|
|
||||||
acc))))))
|
|
||||||
;; The whole history flattened to frame-names, most-recent (deepest) first:
|
|
||||||
;; current rib's tail-history, then its non-tail caller's, and so on outward.
|
|
||||||
(define (jolt-trace-snapshot)
|
|
||||||
(let ((h (jolt-trace-ring)))
|
|
||||||
(if (not h) '()
|
|
||||||
(let* ((ribs (vector-ref h 0)) (oh (vector-ref h 1)) (oc (vector-ref h 2)))
|
|
||||||
(let loop ((k 1) (acc '()))
|
|
||||||
(if (fx>? k oc)
|
|
||||||
(apply append (reverse acc))
|
|
||||||
(let ((idx (fxmod (fx+ (fx- oh k) jolt-trace-outer-size) jolt-trace-outer-size)))
|
|
||||||
(loop (fx+ k 1) (cons (jolt-rib-names (vector-ref ribs idx)) acc)))))))))
|
|
||||||
|
|
||||||
(define-condition-type &jolt-throw &condition
|
|
||||||
make-jolt-throw-condition jolt-throw-condition?
|
|
||||||
(value jolt-throw-condition-value))
|
|
||||||
;; Fallback &message for a leaked condition; the real message always comes from
|
|
||||||
;; the unwrapped value via ex-message.
|
|
||||||
(define (jolt-throw-message v)
|
|
||||||
(if (and (pmap? v)
|
|
||||||
(jolt=2 (jolt-get v jolt-kw-ex-type jolt-nil) jolt-kw-ex-info))
|
|
||||||
(let ((m (jolt-get v jolt-kw-message jolt-nil)))
|
|
||||||
(if (string? m) m "jolt error"))
|
|
||||||
"jolt error"))
|
|
||||||
(define (jolt-throw v)
|
|
||||||
(call/cc (lambda (k)
|
|
||||||
(jolt-throw-cont (cons v k))
|
|
||||||
(raise (condition (make-message-condition (jolt-throw-message v))
|
|
||||||
(make-jolt-throw-condition v))))))
|
|
||||||
(define (jolt-unwrap-throw x)
|
|
||||||
(if (jolt-throw-condition? x) (jolt-throw-condition-value x) x))
|
|
||||||
;; ex-info builds the tagged map {:jolt/type :jolt/ex-info :message :data :cause}
|
;; ex-info builds the tagged map {:jolt/type :jolt/ex-info :message :data :cause}
|
||||||
;; — a real jolt-hash-map, so the ex-data/ex-message/ex-cause tier fns read it
|
;; — a real jolt-hash-map, so the ex-data/ex-message/ex-cause tier fns read it
|
||||||
;; via jolt-get for free. Arity 2 (msg data) or 3 (msg data cause).
|
;; via jolt-get for free. Arity 2 (msg data) or 3 (msg data cause).
|
||||||
|
|
@ -251,21 +103,7 @@
|
||||||
;; evaluates to #'ns/name (a first-class var), so (var? (def x 1)) is true and
|
;; evaluates to #'ns/name (a first-class var), so (var? (def x 1)) is true and
|
||||||
;; (pr-str (def x 1)) is "#'ns/x". The prelude's def-var! forms discard the
|
;; (pr-str (def x 1)) is "#'ns/x". The prelude's def-var! forms discard the
|
||||||
;; return, so this is transparent there.
|
;; return, so this is transparent there.
|
||||||
;; proc -> (ns . name) for the var it was def'd into, so (class a-fn) can report a
|
(define (def-var! ns name v) (let ((c (jolt-var ns name))) (var-cell-root-set! c v) (var-cell-defined?-set! c #t) c))
|
||||||
;; JVM-style class name and clojure.spec.alpha's fn-sym can recover the symbol of a
|
|
||||||
;; bare-fn predicate. Weak so GC'd fns drop out. Last def of a given proc wins.
|
|
||||||
(define proc-name-tbl (make-weak-eq-hashtable))
|
|
||||||
(define (def-var! ns name v)
|
|
||||||
;; first def of a given proc wins, so an alias like (def inc' inc) — which binds
|
|
||||||
;; the SAME proc to a second var — doesn't rename inc.
|
|
||||||
(when (and (procedure? v) (not (hashtable-contains? proc-name-tbl v)))
|
|
||||||
(hashtable-set! proc-name-tbl v (cons ns name)))
|
|
||||||
(let ((c (jolt-var ns name))) (var-cell-root-set! c v) (var-cell-defined?-set! c #t) c))
|
|
||||||
;; jolt.host/throwable — build a typed throwable a library can throw so (class …),
|
|
||||||
;; instance?, .getMessage and ex-message all reflect the named JVM class (e.g. an
|
|
||||||
;; http client throwing java.net.ConnectException). Strictly better than a
|
|
||||||
;; hand-rolled :jolt/ex-info table, which carries only the class.
|
|
||||||
(def-var! "jolt.host" "throwable" jolt-host-throwable)
|
|
||||||
;; var def-time metadata: the :def emit passes the def's reader meta
|
;; var def-time metadata: the :def emit passes the def's reader meta
|
||||||
;; (^:private / ^Type tag / docstring -> {:doc}) here, stored in an eq side-table
|
;; (^:private / ^Type tag / docstring -> {:doc}) here, stored in an eq side-table
|
||||||
;; keyed by the cell. jolt-meta (natives-meta.ss) merges it onto {:ns :name},
|
;; keyed by the cell. jolt-meta (natives-meta.ss) merges it onto {:ns :name},
|
||||||
|
|
@ -341,59 +179,6 @@
|
||||||
;; bare nil renders as the empty string (a nil ELEMENT inside a collection still
|
;; bare nil renders as the empty string (a nil ELEMENT inside a collection still
|
||||||
;; prints "nil", which jolt-pr-str handles).
|
;; prints "nil", which jolt-pr-str handles).
|
||||||
(define (jolt-final-str x) (if (jolt-nil? x) "" (jolt-pr-str x)))
|
(define (jolt-final-str x) (if (jolt-nil? x) "" (jolt-pr-str x)))
|
||||||
;; --- *print-level* / *print-length* -----------------------------------------
|
|
||||||
;; Both vars default to nil (= unlimited). A non-nil number limits collection
|
|
||||||
;; nesting depth / element count in BOTH printers (jolt-pr-str here and
|
|
||||||
;; jolt-pr-readable in printing.ss). Cells captured lazily — the vars are def'd
|
|
||||||
;; after rt.ss. The nil default takes a fast path: jolt-print-hash? is #f and the
|
|
||||||
;; limited-string walkers never truncate.
|
|
||||||
(define plevel-cell #f)
|
|
||||||
(define plength-cell #f)
|
|
||||||
(define (jolt-print-level)
|
|
||||||
(unless plevel-cell (set! plevel-cell (jolt-var "clojure.core" "*print-level*")))
|
|
||||||
(let ((v (jolt-var-get plevel-cell))) (and (number? v) v)))
|
|
||||||
(define (jolt-print-length)
|
|
||||||
(unless plength-cell (set! plength-cell (jolt-var "clojure.core" "*print-length*")))
|
|
||||||
(let ((v (jolt-var-get plength-cell))) (and (number? v) v)))
|
|
||||||
(define jolt-print-depth (make-thread-parameter 0))
|
|
||||||
;; A collection at depth >= *print-level* renders as "#". The top-level collection
|
|
||||||
;; is depth 0, so *print-level* 0 collapses any collection, 1 keeps the outermost.
|
|
||||||
(define (jolt-print-hash?)
|
|
||||||
(let ((lvl (jolt-print-level))) (and lvl (fx>=? (jolt-print-depth) lvl))))
|
|
||||||
;; Rendered element strings of a vector (by index), honoring *print-length*: at
|
|
||||||
;; most N, then "...". render-one runs at the current (already bumped) depth.
|
|
||||||
(define (jolt-limited-vec-strs x render-one)
|
|
||||||
(let ((len (pvec-count x)) (lim (jolt-print-length)))
|
|
||||||
(let loop ((i 0) (acc '()))
|
|
||||||
(cond ((fx>=? i len) (reverse acc))
|
|
||||||
((and lim (fx>=? i lim)) (reverse (cons "..." acc)))
|
|
||||||
(else (loop (fx+ i 1) (cons (render-one (pvec-nth-d x i jolt-nil)) acc)))))))
|
|
||||||
;; Rendered element strings of a seq, walked lazily so an infinite seq is realized
|
|
||||||
;; only up to *print-length*.
|
|
||||||
(define (jolt-limited-seq-strs s render-one)
|
|
||||||
(let ((lim (jolt-print-length)))
|
|
||||||
(let loop ((s s) (i 0) (acc '()))
|
|
||||||
(cond ((jolt-nil? s) (reverse acc))
|
|
||||||
((and lim (fx>=? i lim)) (reverse (cons "..." acc)))
|
|
||||||
(else (loop (jolt-seq (seq-more s)) (fx+ i 1) (cons (render-one (seq-first s)) acc)))))))
|
|
||||||
;; Truncate an already-collected element-string list (set / map, finite) to
|
|
||||||
;; *print-length*, appending "..." when more remain.
|
|
||||||
(define (jolt-limited-list-strs strs)
|
|
||||||
(let ((lim (jolt-print-length)))
|
|
||||||
(if (not lim) strs
|
|
||||||
(let loop ((s strs) (i 0) (acc '()))
|
|
||||||
(cond ((null? s) (reverse acc))
|
|
||||||
((fx>=? i lim) (reverse (cons "..." acc)))
|
|
||||||
(else (loop (cdr s) (fx+ i 1) (cons (car s) acc))))))))
|
|
||||||
;; bump the print depth around a collection's element rendering — but only when
|
|
||||||
;; *print-level* is set, since depth is consulted only to enforce it. With the
|
|
||||||
;; common nil default this is a plain begin, so printing pays no parameterize.
|
|
||||||
(define-syntax with-deeper-print
|
|
||||||
(syntax-rules ()
|
|
||||||
((_ body ...) (if (jolt-print-level)
|
|
||||||
(parameterize ((jolt-print-depth (fx+ (jolt-print-depth) 1))) body ...)
|
|
||||||
(begin body ...)))))
|
|
||||||
|
|
||||||
;; A host shim registers a type's str-style rendering via register-pr-str-arm! (or
|
;; A host shim registers a type's str-style rendering via register-pr-str-arm! (or
|
||||||
;; register-pr-arm! in printing.ss for both printers at once) instead of
|
;; register-pr-arm! in printing.ss for both printers at once) instead of
|
||||||
;; set!-wrapping jolt-pr-str. Disjoint types, checked before the base cases.
|
;; set!-wrapping jolt-pr-str. Disjoint types, checked before the base cases.
|
||||||
|
|
@ -414,23 +199,18 @@
|
||||||
(if (or (jolt-nil? ns) (not ns) (eq? ns '())) (symbol-t-name x)
|
(if (or (jolt-nil? ns) (not ns) (eq? ns '())) (symbol-t-name x)
|
||||||
(string-append ns "/" (symbol-t-name x)))))
|
(string-append ns "/" (symbol-t-name x)))))
|
||||||
((regex-t? x) (string-append "#\"" (regex-t-source x) "\""))
|
((regex-t? x) (string-append "#\"" (regex-t-source x) "\""))
|
||||||
((pvec? x) (if (jolt-print-hash?) "#"
|
((pvec? x) (let ((acc '())) (let loop ((i (fx- (pvec-count x) 1)))
|
||||||
(with-deeper-print
|
(when (fx>=? i 0) (set! acc (cons (jolt-pr-str (pvec-nth-d x i jolt-nil)) acc)) (loop (fx- i 1))))
|
||||||
(string-append "[" (jolt-str-join (jolt-limited-vec-strs x jolt-pr-str)) "]"))))
|
(string-append "[" (jolt-str-join acc) "]")))
|
||||||
((pset? x) (if (jolt-print-hash?) "#"
|
((pset? x) (string-append "#{" (jolt-str-join (pset-fold x (lambda (e a) (cons (jolt-pr-str e) a)) '())) "}"))
|
||||||
(with-deeper-print
|
((pmap? x) (string-append "{" (jolt-str-join
|
||||||
(string-append "#{" (jolt-str-join (jolt-limited-list-strs
|
(pmap-fold x (lambda (k v a) (cons (string-append (jolt-pr-str k) " " (jolt-pr-str v)) a)) '())) "}"))
|
||||||
(pset-fold x (lambda (e a) (cons (jolt-pr-str e) a)) '()))) "}"))))
|
;; lists / cons / lazy seqs all print as (...) — forces a finite seq.
|
||||||
((pmap? x) (if (jolt-print-hash?) "#"
|
((empty-list-t? x) "()")
|
||||||
(with-deeper-print
|
((cseq? x) (string-append "(" (jolt-str-join
|
||||||
(string-append "{" (jolt-str-join (jolt-limited-list-strs
|
(let loop ((s x) (acc '()))
|
||||||
(pmap-fold x (lambda (k v a) (cons (string-append (jolt-pr-str k) " " (jolt-pr-str v)) a)) '()))) "}"))))
|
(if (jolt-nil? s) (reverse acc)
|
||||||
;; lists / cons / lazy seqs all print as (...) — forces a finite seq (or up to
|
(loop (jolt-seq (seq-more s)) (cons (jolt-pr-str (seq-first s)) acc))))) ")"))
|
||||||
;; *print-length* of an infinite one).
|
|
||||||
((empty-list-t? x) (if (jolt-print-hash?) "#" "()"))
|
|
||||||
((cseq? x) (if (jolt-print-hash?) "#"
|
|
||||||
(with-deeper-print
|
|
||||||
(string-append "(" (jolt-str-join (jolt-limited-seq-strs x jolt-pr-str)) ")"))))
|
|
||||||
(else (format "~a" x))))
|
(else (format "~a" x))))
|
||||||
(define (jolt-pr-str x)
|
(define (jolt-pr-str x)
|
||||||
(let loop ((as jolt-pr-str-arms))
|
(let loop ((as jolt-pr-str-arms))
|
||||||
|
|
@ -473,18 +253,13 @@
|
||||||
;; jolt-pr-str (above), and the var-cell machinery — so loaded last.
|
;; jolt-pr-str (above), and the var-cell machinery — so loaded last.
|
||||||
(load "host/chez/multimethods.ss")
|
(load "host/chez/multimethods.ss")
|
||||||
|
|
||||||
;; the single JVM class/interface graph — value-host-tags, instance?, isa?/supers,
|
|
||||||
;; and the exception hierarchy all derive from it. Before records.ss so
|
|
||||||
;; value-host-tags can build on jch-tags.
|
|
||||||
(load "host/chez/java/class-hierarchy.ss")
|
|
||||||
|
|
||||||
;; records + protocols: defrecord/deftype/defprotocol/
|
;; records + protocols: defrecord/deftype/defprotocol/
|
||||||
;; extend-type/reify. A jrec record type set!-extended into the collection
|
;; extend-type/reify. A jrec record type set!-extended into the collection
|
||||||
;; dispatchers + a protocol registry. After multimethods.ss (chez-current-ns) and
|
;; dispatchers + a protocol registry. After multimethods.ss (chez-current-ns) and
|
||||||
;; the dispatchers/printers it wraps (collections/seq/values/converters/printing/
|
;; the dispatchers/printers it wraps (collections/seq/values/converters/printing/
|
||||||
;; transients).
|
;; transients).
|
||||||
(load "host/chez/records.ss")
|
(load "host/chez/records.ss")
|
||||||
(load "host/chez/java/records-interop.ss") ; exception hierarchy + instance-check taxonomy
|
(load "host/chez/records-interop.ss") ; exception hierarchy + instance-check taxonomy
|
||||||
|
|
||||||
;; metadata: meta / with-meta over an identity-keyed
|
;; metadata: meta / with-meta over an identity-keyed
|
||||||
;; side-table. After records.ss (jrec) + the collection ctors it copies.
|
;; side-table. After records.ss (jrec) + the collection ctors it copies.
|
||||||
|
|
@ -493,7 +268,7 @@
|
||||||
;; host class tokens: bare class names (String/Keyword/File...) ->
|
;; host class tokens: bare class names (String/Keyword/File...) ->
|
||||||
;; canonical JVM class-name strings + (class x). After natives-meta.ss (jolt-type)
|
;; canonical JVM class-name strings + (class x). After natives-meta.ss (jolt-type)
|
||||||
;; and the printer (jolt-str-render-one).
|
;; and the printer (jolt-str-render-one).
|
||||||
(load "host/chez/java/host-class.ss")
|
(load "host/chez/host-class.ss")
|
||||||
|
|
||||||
;; dynamic vars: *clojure-version* / *unchecked-math* constants the host
|
;; dynamic vars: *clojure-version* / *unchecked-math* constants the host
|
||||||
;; binds natively. After collections.ss (jolt-hash-map) + def-var!.
|
;; binds natively. After collections.ss (jolt-hash-map) + def-var!.
|
||||||
|
|
@ -549,39 +324,38 @@
|
||||||
;; portable String/CharSequence surface record-method-dispatch falls through to on
|
;; portable String/CharSequence surface record-method-dispatch falls through to on
|
||||||
;; a string target. After regex.ss (jolt-re-pattern/regex-t-irx) + records.ss
|
;; a string target. After regex.ss (jolt-re-pattern/regex-t-irx) + records.ss
|
||||||
;; (which references jolt-string-method).
|
;; (which references jolt-string-method).
|
||||||
(load "host/chez/java/natives-str.ss")
|
(load "host/chez/natives-str.ss")
|
||||||
|
|
||||||
;; host class statics + constructors: host-static-ref/
|
;; host class statics + constructors: host-static-ref/
|
||||||
;; host-static-call/host-new + the jhost method registry. Loads LAST — it extends
|
;; host-static-call/host-new + the jhost method registry. Loads LAST — it extends
|
||||||
;; record-method-dispatch (records.ss) and reuses natives-str helpers (str-trim,
|
;; record-method-dispatch (records.ss) and reuses natives-str helpers (str-trim,
|
||||||
;; ascii-string-down, re-split, str-split-drop-trailing) + the regex-t accessors.
|
;; ascii-string-down, re-split, str-split-drop-trailing) + the regex-t accessors.
|
||||||
(load "host/chez/java/host-static.ss") ; registries + jhost + coercion helpers
|
(load "host/chez/host-static.ss") ; registries + jhost + coercion helpers
|
||||||
(load "host/chez/java/host-static-methods.ss") ; Class/member static methods + fields
|
(load "host/chez/host-static-methods.ss") ; Class/member static methods + fields
|
||||||
(load "host/chez/java/host-static-classes.ss") ; instantiable host object classes
|
(load "host/chez/host-static-classes.ss") ; instantiable host object classes
|
||||||
(load "host/chez/java/byte-buffer.ss") ; java.nio.ByteBuffer over a byte-array
|
|
||||||
|
|
||||||
;; generic dot-form dispatch: field access + map/vector member access
|
;; generic dot-form dispatch: field access + map/vector member access
|
||||||
;; for the `.` / `.-field` desugar. Loads after host-static.ss so it wraps every
|
;; for the `.` / `.-field` desugar. Loads after host-static.ss so it wraps every
|
||||||
;; record-method-dispatch arm (jhost/number/regex/jrec/string) and falls through.
|
;; record-method-dispatch arm (jhost/number/regex/jrec/string) and falls through.
|
||||||
(load "host/chez/java/dot-forms.ss")
|
(load "host/chez/dot-forms.ss")
|
||||||
|
|
||||||
;; java.io.File + host file I/O: path-backed jfile record, slurp/spit/
|
;; java.io.File + host file I/O: path-backed jfile record, slurp/spit/
|
||||||
;; flush, file-seq dir primitives, clojure.java.io/file. Loads LAST so its jfile
|
;; flush, file-seq dir primitives, clojure.java.io/file. Loads LAST so its jfile
|
||||||
;; arm wraps the fully-built record-method-dispatch and the str/type/instance-check
|
;; arm wraps the fully-built record-method-dispatch and the str/type/instance-check
|
||||||
;; extensions sit over every prior shim.
|
;; extensions sit over every prior shim.
|
||||||
(load "host/chez/java/io.ss")
|
(load "host/chez/io.ss")
|
||||||
|
|
||||||
;; #inst values + java.time formatting: jinst (RFC3339 ms) +
|
;; #inst values + java.time formatting: jinst (RFC3339 ms) +
|
||||||
;; DateTimeFormatter/Instant/ZoneId/LocalDateTime/FormatStyle/Locale/Date. Loads
|
;; DateTimeFormatter/Instant/ZoneId/LocalDateTime/FormatStyle/Locale/Date. Loads
|
||||||
;; LAST — it extends record-method-dispatch / jolt-get / jolt= / jolt-hash /
|
;; LAST — it extends record-method-dispatch / jolt-get / jolt= / jolt-hash /
|
||||||
;; jolt-pr-str / jolt-type / instance-check and uses host-static.ss's registries.
|
;; jolt-pr-str / jolt-type / instance-check and uses host-static.ss's registries.
|
||||||
(load "host/chez/java/inst-time.ss")
|
(load "host/chez/inst-time.ss")
|
||||||
|
|
||||||
;; java.time value types: LocalDate / LocalTime / LocalDateTime / Instant as
|
;; java.time value types: LocalDate / LocalTime / LocalDateTime / Instant as
|
||||||
;; tz-free jhost values (epoch-day / nano-of-day / epoch-ms). Loads after
|
;; tz-free jhost values (epoch-day / nano-of-day / epoch-ms). Loads after
|
||||||
;; inst-time.ss — it reuses its civil<->days helpers, the jhost registries, and
|
;; inst-time.ss — it reuses its civil<->days helpers, the jhost registries, and
|
||||||
;; re-registers a few LocalDateTime/Instant statics to use the richer reps.
|
;; re-registers a few LocalDateTime/Instant statics to use the richer reps.
|
||||||
(load "host/chez/java/java-time.ss")
|
(load "host/chez/java-time.ss")
|
||||||
|
|
||||||
;; Chez-side data reader: read-string / __parse-next /
|
;; Chez-side data reader: read-string / __parse-next /
|
||||||
;; __read-tagged. Loads after inst-time.ss — __read-tagged reuses its #uuid/#inst
|
;; __read-tagged. Loads after inst-time.ss — __read-tagged reuses its #uuid/#inst
|
||||||
|
|
@ -590,7 +364,7 @@
|
||||||
|
|
||||||
;; clojure.math: native flonum-math shims def-var!'d into the
|
;; clojure.math: native flonum-math shims def-var!'d into the
|
||||||
;; clojure.math ns. Self-contained (only def-var! + Chez math), order-independent.
|
;; clojure.math ns. Self-contained (only def-var! + Chez math), order-independent.
|
||||||
(load "host/chez/java/math.ss")
|
(load "host/chez/math.ss")
|
||||||
|
|
||||||
;; reader/macro runtime support: #?() feature set, reader-conditional + re-matcher
|
;; reader/macro runtime support: #?() feature set, reader-conditional + re-matcher
|
||||||
;; tagged-map ctors, macroexpand. After ns.ss; macroexpand call-time-refs the macro
|
;; tagged-map ctors, macroexpand. After ns.ss; macroexpand call-time-refs the macro
|
||||||
|
|
@ -600,17 +374,17 @@
|
||||||
;; Java-style arrays: object/typed array constructors + a jolt-array
|
;; Java-style arrays: object/typed array constructors + a jolt-array
|
||||||
;; backing; extends count/nth/seq/get/ref-put! so the overlay aget/aset/alength see
|
;; backing; extends count/nth/seq/get/ref-put! so the overlay aget/aset/alength see
|
||||||
;; it. After the dispatchers it chains.
|
;; it. After the dispatchers it chains.
|
||||||
(load "host/chez/java/natives-array.ss")
|
(load "host/chez/natives-array.ss")
|
||||||
|
|
||||||
;; java.io byte/char streams (FileInputStream/…/ByteArrayOutputStream/Buffered*)
|
;; java.io byte/char streams (FileInputStream/…/ByteArrayOutputStream/Buffered*)
|
||||||
;; over Chez ports. After io.ss (extends its slurp/__close/reader-jhost?) and
|
;; over Chez ports. After io.ss (extends its slurp/__close/reader-jhost?) and
|
||||||
;; natives-array.ss (the byte-array <-> bytevector bridge).
|
;; natives-array.ss (the byte-array <-> bytevector bridge).
|
||||||
(load "host/chez/java/io-streams.ss")
|
(load "host/chez/io-streams.ss")
|
||||||
|
|
||||||
;; clojure.lang.PersistentQueue: a functional queue + EMPTY static.
|
;; clojure.lang.PersistentQueue: a functional queue + EMPTY static.
|
||||||
;; Chains seq/count/empty?/peek/pop/conj/sequential?/class/instance?/printer, so
|
;; Chains seq/count/empty?/peek/pop/conj/sequential?/class/instance?/printer, so
|
||||||
;; load after natives-array (the dispatchers it extends).
|
;; load after natives-array (the dispatchers it extends).
|
||||||
(load "host/chez/java/natives-queue.ss")
|
(load "host/chez/natives-queue.ss")
|
||||||
|
|
||||||
;; syntax-quote form builders: __sqcat/__sqvec/__sqmap/__sqset/
|
;; syntax-quote form builders: __sqcat/__sqvec/__sqmap/__sqset/
|
||||||
;; __sq1, def-var!'d into clojure.core. A cross-compiled macro expander (analyzer
|
;; __sq1, def-var!'d into clojure.core. A cross-compiled macro expander (analyzer
|
||||||
|
|
@ -622,18 +396,14 @@
|
||||||
;; (JVM) semantics. Loaded LAST — chains the fully-built jolt-deref and conveys the
|
;; (JVM) semantics. Loaded LAST — chains the fully-built jolt-deref and conveys the
|
||||||
;; thread-local binding stack (dyn-binding.ss) into workers. pmap/pcalls/pvalues
|
;; thread-local binding stack (dyn-binding.ss) into workers. pmap/pcalls/pvalues
|
||||||
;; (overlay, over `future`) light up once future-call exists here.
|
;; (overlay, over `future`) light up once future-call exists here.
|
||||||
(load "host/chez/java/concurrency.ss")
|
(load "host/chez/concurrency.ss")
|
||||||
|
|
||||||
;; clojure.core.async: real-thread blocking channels + go/go-loop/
|
;; clojure.core.async: real-thread blocking channels + go/go-loop/
|
||||||
;; thread macros, def-var!'d into clojure.core.async. After concurrency.ss (reuses
|
;; thread macros, def-var!'d into clojure.core.async. After concurrency.ss (reuses
|
||||||
;; ms->duration) and the collection/seq layer.
|
;; ms->duration) and the collection/seq layer.
|
||||||
(load "host/chez/java/async.ss")
|
(load "host/chez/async.ss")
|
||||||
|
|
||||||
;; BigDecimal: the jbigdec value type + bigdec/decimal?/class/equality/
|
;; BigDecimal: the jbigdec value type + bigdec/decimal?/class/equality/
|
||||||
;; printing. Loads LAST so its set!-wraps of jolt-class/jolt=2/the printers sit
|
;; printing. Loads LAST so its set!-wraps of jolt-class/jolt=2/the printers sit
|
||||||
;; outermost over every earlier extension.
|
;; outermost over every earlier extension.
|
||||||
(load "host/chez/java/bigdec.ss")
|
(load "host/chez/bigdec.ss")
|
||||||
|
|
||||||
;; Native stack traces: jv$ns$name -> source registry + continuation frame walk +
|
|
||||||
;; uncaught-throwable renderer. After the printers/equality it relies on.
|
|
||||||
(load "host/chez/source-registry.ss")
|
|
||||||
|
|
|
||||||
|
|
@ -11,7 +11,7 @@
|
||||||
;; reset between cases so there is no leakage — same isolation a fresh process gives.
|
;; reset between cases so there is no leakage — same isolation a fresh process gives.
|
||||||
;;
|
;;
|
||||||
;; chez --script host/chez/run-corpus.ss
|
;; chez --script host/chez/run-corpus.ss
|
||||||
;; JOLT_CHEZ_ZJ_FLOOR=N override the regression floor (default 3390)
|
;; JOLT_CHEZ_ZJ_FLOOR=N override the regression floor (default 2730)
|
||||||
;; JOLT_CORPUS_LIMIT=N every-Nth stride (fast iteration; floor drops to 0)
|
;; JOLT_CORPUS_LIMIT=N every-Nth stride (fast iteration; floor drops to 0)
|
||||||
;; JOLT_DUMP_CRASH_LABELS=1 list crash + allowlisted labels
|
;; JOLT_DUMP_CRASH_LABELS=1 list crash + allowlisted labels
|
||||||
(import (chezscheme))
|
(import (chezscheme))
|
||||||
|
|
@ -196,7 +196,7 @@
|
||||||
|
|
||||||
;; Regression floor: fail on any NEW divergence or if pass drops below the floor.
|
;; Regression floor: fail on any NEW divergence or if pass drops below the floor.
|
||||||
(define base-floor (let ((s (getenv "JOLT_CHEZ_ZJ_FLOOR")))
|
(define base-floor (let ((s (getenv "JOLT_CHEZ_ZJ_FLOOR")))
|
||||||
(if s (string->number s) 3390)))
|
(if s (string->number s) 2730)))
|
||||||
(define floor (if limit 0 base-floor))
|
(define floor (if limit 0 base-floor))
|
||||||
(when (or (> (length diverged) 0) (< pass floor))
|
(when (or (> (length diverged) 0) (< pass floor))
|
||||||
(printf "REGRESSION: pass ~a < floor ~a or ~a new divergence(s)\n"
|
(printf "REGRESSION: pass ~a < floor ~a or ~a new divergence(s)\n"
|
||||||
|
|
|
||||||
|
|
@ -1,104 +0,0 @@
|
||||||
;; run-devirt.ss — protocol-call devirtualization gate (backend_scheme emit).
|
|
||||||
;;
|
|
||||||
;; The inference annotates a monomorphic protocol call with :devirt-type/-proto/
|
|
||||||
;; -method (jolt.passes.types); the back end then resolves the impl by that static
|
|
||||||
;; tag. This gate pins both halves: the emitted form uses find-protocol-method, and
|
|
||||||
;; evaluating it returns the same value the ordinary dispatch would — for a record's
|
|
||||||
;; inline impl, an extend-type impl, and across distinct receiver types.
|
|
||||||
;;
|
|
||||||
;; chez --script host/chez/run-devirt.ss
|
|
||||||
(import (chezscheme))
|
|
||||||
(load "host/chez/rt.ss")
|
|
||||||
(set-chez-ns! "clojure.core")
|
|
||||||
(load "host/chez/seed/prelude.ss")
|
|
||||||
(load "host/chez/post-prelude.ss")
|
|
||||||
(set-chez-ns! "user")
|
|
||||||
(load "host/chez/host-contract.ss")
|
|
||||||
(load "host/chez/seed/image.ss")
|
|
||||||
(load "host/chez/compile-eval.ss")
|
|
||||||
|
|
||||||
(define analyze (var-deref "jolt.analyzer" "analyze"))
|
|
||||||
(define emit (var-deref "jolt.backend-scheme" "emit"))
|
|
||||||
(define kw (lambda (n) (keyword #f n)))
|
|
||||||
|
|
||||||
(define (evals src) (jolt-compile-eval (string-append "(do " src ")") "user"))
|
|
||||||
;; define two record types implementing one protocol — Circle via an inline impl,
|
|
||||||
;; Square via extend-type — plus instances to dispatch on.
|
|
||||||
(evals "(defprotocol Shape (area [s]))")
|
|
||||||
(evals "(defrecord Circle [r] Shape (area [s] (:r s)))")
|
|
||||||
(evals "(defrecord Square [w])")
|
|
||||||
(evals "(extend-type Square Shape (area [s] (* (:w s) (:w s))))")
|
|
||||||
(evals "(def c (->Circle 7))")
|
|
||||||
(evals "(def sq (->Square 5))")
|
|
||||||
|
|
||||||
;; analyze (area RECV), annotate it as a devirt call on `type`, and emit. RECV is a
|
|
||||||
;; var name (c/sq) the emitted code resolves at eval time.
|
|
||||||
(define (devirt-emit type recv)
|
|
||||||
(let* ((ir (analyze (make-analyze-ctx "user") (jolt-ce-read (string-append "(area " recv ")"))))
|
|
||||||
(dv (jolt-assoc ir (kw "devirt-type") type (kw "devirt-proto") "Shape"
|
|
||||||
(kw "devirt-method") "area")))
|
|
||||||
(emit dv)))
|
|
||||||
|
|
||||||
(define fails 0) (define total 0)
|
|
||||||
(define (check label actual expected)
|
|
||||||
(set! total (+ total 1))
|
|
||||||
(unless (equal? actual expected)
|
|
||||||
(set! fails (+ fails 1))
|
|
||||||
(printf " FAIL ~a: got ~s expected ~s\n" label actual expected)))
|
|
||||||
(define (has-sub? s sub)
|
|
||||||
(let ((n (string-length s)) (m (string-length sub)))
|
|
||||||
(let loop ((i 0)) (cond ((> (+ i m) n) #f)
|
|
||||||
((string=? (substring s i (+ i m)) sub) #t)
|
|
||||||
(else (loop (+ i 1)))))))
|
|
||||||
;; eval an emitted Scheme string in the loaded runtime (var-deref resolves c/sq).
|
|
||||||
(define (run-emit scm) (eval (read (open-input-string scm)) (interaction-environment)))
|
|
||||||
|
|
||||||
(let ((e (devirt-emit "user.Circle" "c")))
|
|
||||||
(check "emit uses devirt-resolve" (has-sub? e "devirt-resolve") #t)
|
|
||||||
(check "devirt inline impl == dispatch" (run-emit e) (evals "(area c)"))) ; 7
|
|
||||||
|
|
||||||
(let ((e (devirt-emit "user.Square" "sq")))
|
|
||||||
(check "devirt extend-type impl == dispatch" (run-emit e) (evals "(area sq)"))) ; 25
|
|
||||||
|
|
||||||
;; a normal (no devirt) call still goes through dispatch and agrees — the path the
|
|
||||||
;; megamorphic / unknown-receiver site keeps.
|
|
||||||
(let ((e (emit (analyze (make-analyze-ctx "user") (jolt-ce-read "(area c)")))))
|
|
||||||
(check "non-devirt path no devirt-resolve" (has-sub? e "devirt-resolve") #f)
|
|
||||||
(check "non-devirt still dispatches" (run-emit e) 7))
|
|
||||||
|
|
||||||
;; a record that relies on the protocol's Object default (no direct impl): the
|
|
||||||
;; inference still types it as a concrete record and annotates devirt, so the
|
|
||||||
;; emitted call must resolve the same value dispatch would. find-protocol-method
|
|
||||||
;; on the record's own tag misses here, so the devirt path has to fall back to
|
|
||||||
;; ordinary dispatch (else it applies #f and crashes).
|
|
||||||
(evals "(extend-protocol Shape Object (area [s] :obj-default))")
|
|
||||||
(evals "(defrecord Plain [n])")
|
|
||||||
(evals "(def pl (->Plain 9))")
|
|
||||||
(let ((e (devirt-emit "user.Plain" "pl")))
|
|
||||||
(check "devirt Object-default == dispatch" (run-emit e) (evals "(area pl)"))) ; :obj-default
|
|
||||||
|
|
||||||
;; in a direct-link build a devirt site caches the resolved impl in a per-site cell
|
|
||||||
;; (resolved once, reused) instead of resolving per call. Annotate the (area x) in a
|
|
||||||
;; def body and emit the top form; the result must carry the cell and still be right.
|
|
||||||
(let* ((set-direct-link! (var-deref "jolt.backend-scheme" "set-direct-link!"))
|
|
||||||
(emit-top-form (var-deref "jolt.backend-scheme" "emit-top-form"))
|
|
||||||
(dn (analyze (make-analyze-ctx "user") (jolt-ce-read "(def usearea (fn [x] (area x)))")))
|
|
||||||
(ar0 (jolt-nth (jolt-get (jolt-get dn (kw "init")) (kw "arities")) 0))
|
|
||||||
(inv (jolt-get ar0 (kw "body")))
|
|
||||||
(inv2 (jolt-assoc inv (kw "devirt-type") "user.Circle" (kw "devirt-proto") "Shape" (kw "devirt-method") "area"))
|
|
||||||
(dn2 (jolt-assoc dn (kw "init")
|
|
||||||
(jolt-assoc (jolt-get dn (kw "init")) (kw "arities")
|
|
||||||
(jolt-vector (jolt-assoc ar0 (kw "body") inv2))))))
|
|
||||||
(set-direct-link! #t)
|
|
||||||
(let ((e (emit-top-form dn2)))
|
|
||||||
(set-direct-link! #f)
|
|
||||||
(check "devirt in a def caches in a per-site cell" (has-sub? e "_dvc$") #t)
|
|
||||||
(check "cached cell still resolves the impl" (has-sub? e "devirt-resolve") #t)
|
|
||||||
;; eval the def, then call it: caches on first call, reuses after — still 7.
|
|
||||||
(run-emit e)
|
|
||||||
(check "cached devirt == dispatch (1st call)" (jolt-invoke (var-deref "user" "usearea") (var-deref "user" "c")) 7)
|
|
||||||
(check "cached devirt == dispatch (2nd call, from cell)" (jolt-invoke (var-deref "user" "usearea") (var-deref "user" "c")) 7)))
|
|
||||||
|
|
||||||
(if (= fails 0)
|
|
||||||
(begin (printf "devirt gate: ~a/~a passed\n" total total) (exit 0))
|
|
||||||
(begin (printf "devirt gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))
|
|
||||||
|
|
@ -1,82 +0,0 @@
|
||||||
;; run-fieldnum.ss — ^double record field reads unbox to fl-ops (jolt-evr9 R2).
|
|
||||||
;;
|
|
||||||
;; A record field tagged ^double reads back as a flonum (:double in the lattice),
|
|
||||||
;; so hintless arithmetic over those fields — (* (:x a) (:x b)) — lowers to fl-ops,
|
|
||||||
;; the same machinery as a ^double param. Two halves pinned here: (1) the ctor
|
|
||||||
;; coerces a ^double field to a flonum at construction (JVM parity, and what makes
|
|
||||||
;; the fl-op sound), and (2) field-field arithmetic over a record param (typed by
|
|
||||||
;; the whole-program fixpoint) emits fl*.
|
|
||||||
;;
|
|
||||||
;; chez --script host/chez/run-fieldnum.ss
|
|
||||||
(import (chezscheme))
|
|
||||||
(load "host/chez/rt.ss")
|
|
||||||
(set-chez-ns! "clojure.core")
|
|
||||||
(load "host/chez/seed/prelude.ss")
|
|
||||||
(load "host/chez/post-prelude.ss")
|
|
||||||
(set-chez-ns! "user")
|
|
||||||
(load "host/chez/host-contract.ss")
|
|
||||||
(load "host/chez/seed/image.ss")
|
|
||||||
(load "host/chez/compile-eval.ss")
|
|
||||||
|
|
||||||
(define analyze (var-deref "jolt.analyzer" "analyze"))
|
|
||||||
(define set-record-shapes! (var-deref "jolt.passes.types" "set-record-shapes!"))
|
|
||||||
(define set-protocol-methods! (var-deref "jolt.passes.types" "set-protocol-methods!"))
|
|
||||||
(define wp-infer! (var-deref "jolt.passes.types" "wp-infer!"))
|
|
||||||
(define run-passes (var-deref "jolt.passes" "run-passes"))
|
|
||||||
(define emit (var-deref "jolt.backend-scheme" "emit"))
|
|
||||||
|
|
||||||
(define (anode src) (analyze (make-analyze-ctx "user") (jolt-ce-read src)))
|
|
||||||
(define (evals src) (jolt-compile-eval (string-append "(do " src ")") "user"))
|
|
||||||
(define (contains-sub? s sub)
|
|
||||||
(let ((n (string-length s)) (m (string-length sub)))
|
|
||||||
(let loop ((i 0))
|
|
||||||
(cond ((> (+ i m) n) #f)
|
|
||||||
((string=? (substring s i (+ i m)) sub) #t)
|
|
||||||
(else (loop (+ i 1)))))))
|
|
||||||
|
|
||||||
(define fails 0) (define total 0)
|
|
||||||
(define (check label actual expected)
|
|
||||||
(set! total (+ total 1))
|
|
||||||
(unless (equal? actual expected)
|
|
||||||
(set! fails (+ fails 1))
|
|
||||||
(printf " FAIL ~a: got ~s expected ~s\n" label actual expected)))
|
|
||||||
|
|
||||||
;; a record with ^double fields; the ctor must coerce an integer arg to a flonum.
|
|
||||||
(evals "(defrecord V [^double x ^double y])")
|
|
||||||
(check "ctor coerces ^double field to flonum" (flonum? (evals "(:x (->V 1 2))")) #t)
|
|
||||||
(check "coerced field value matches" (evals "(:x (->V 1 2))") 1.0)
|
|
||||||
(check "a flonum arg passes through" (evals "(:y (->V 1.5 2.5))") 2.5)
|
|
||||||
|
|
||||||
;; dot is hintless; its caller passes V instances, so the fixpoint types a/b as V
|
|
||||||
;; records, the ^double fields read :double, and the field-field arithmetic unboxes.
|
|
||||||
(define dot (anode "(def dot (fn [a b] (+ (* (:x a) (:x b)) (* (:y a) (:y b)))))"))
|
|
||||||
(define used (anode "(def used (fn [] (dot (->V 1.0 2.0) (->V 3.0 4.0))))"))
|
|
||||||
(set-record-shapes! (chez-record-shapes-map))
|
|
||||||
(set-protocol-methods! (jolt-hash-map))
|
|
||||||
(wp-infer! (jolt-vector dot used))
|
|
||||||
(set-optimize! #t)
|
|
||||||
(define dot-emit (emit (run-passes dot (make-analyze-ctx "user"))))
|
|
||||||
(check "field-field arithmetic unboxes to fl*" (contains-sub? dot-emit "fl*") #t)
|
|
||||||
(check "field-field arithmetic unboxes to fl+" (contains-sub? dot-emit "fl+") #t)
|
|
||||||
|
|
||||||
;; a ^V param hint types the param with no inferable caller (open-world / cross-fn:
|
|
||||||
;; the receiver isn't a ctor return). This is the record-ctor-key path — without it
|
|
||||||
;; the hint is dead and the reads fall back to generic jolt-get + boxed arithmetic.
|
|
||||||
(define hinted (anode "(def hyp (fn [^V v] (+ (* (:x v) (:x v)) (* (:y v) (:y v)))))"))
|
|
||||||
(define hint-emit (emit (run-passes hinted (make-analyze-ctx "user"))))
|
|
||||||
(check "^V param hint bare-indexes field reads" (contains-sub? hint-emit "jrec-field-at") #t)
|
|
||||||
(check "^V param hint unboxes arithmetic" (contains-sub? hint-emit "fl*") #t)
|
|
||||||
(check "^V param hint leaves no generic jolt-get" (contains-sub? hint-emit "jolt-get") #f)
|
|
||||||
|
|
||||||
;; an UNTAGGED field stays generic — no fl-op (the read is :any, not :double).
|
|
||||||
(evals "(defrecord W [p q])")
|
|
||||||
(define dotw (anode "(def dotw (fn [a b] (* (:p a) (:p b))))"))
|
|
||||||
(define usew (anode "(def usew (fn [] (dotw (->W 1.0 2.0) (->W 3.0 4.0))))"))
|
|
||||||
(set-record-shapes! (chez-record-shapes-map))
|
|
||||||
(wp-infer! (jolt-vector dotw usew))
|
|
||||||
(check "untagged field stays generic (no fl*)"
|
|
||||||
(contains-sub? (emit (run-passes dotw (make-analyze-ctx "user"))) "fl*") #f)
|
|
||||||
|
|
||||||
(if (= fails 0)
|
|
||||||
(begin (printf "fieldnum gate: ~a/~a passed\n" total total) (exit 0))
|
|
||||||
(begin (printf "fieldnum gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))
|
|
||||||
|
|
@ -1,72 +0,0 @@
|
||||||
;; run-fieldread.ss — native record field-read gate (backend_scheme emit).
|
|
||||||
;;
|
|
||||||
;; When the inference types a keyword-lookup receiver as a record (it carries the
|
|
||||||
;; field-order :shape + :hint :struct), the back end reads the field by its static
|
|
||||||
;; slot via jrec-field-at instead of jolt-get. This gate pins the emit shape and
|
|
||||||
;; that the value matches jolt-get — for a declared field, a non-field key (no
|
|
||||||
;; bare path), and a default-arg form (no bare path).
|
|
||||||
;;
|
|
||||||
;; chez --script host/chez/run-fieldread.ss
|
|
||||||
(import (chezscheme))
|
|
||||||
(load "host/chez/rt.ss")
|
|
||||||
(set-chez-ns! "clojure.core")
|
|
||||||
(load "host/chez/seed/prelude.ss")
|
|
||||||
(load "host/chez/post-prelude.ss")
|
|
||||||
(set-chez-ns! "user")
|
|
||||||
(load "host/chez/host-contract.ss")
|
|
||||||
(load "host/chez/seed/image.ss")
|
|
||||||
(load "host/chez/compile-eval.ss")
|
|
||||||
|
|
||||||
(define analyze (var-deref "jolt.analyzer" "analyze"))
|
|
||||||
(define emit (var-deref "jolt.backend-scheme" "emit"))
|
|
||||||
(define kw (lambda (n) (keyword #f n)))
|
|
||||||
(define (evals src) (jolt-compile-eval (string-append "(do " src ")") "user"))
|
|
||||||
|
|
||||||
(evals "(defrecord Vec3 [x y z])")
|
|
||||||
(evals "(def a (->Vec3 10 20 30))")
|
|
||||||
|
|
||||||
;; emit (:KEY a [default]) with arg 0 marked as a Vec3 struct receiver.
|
|
||||||
(define (mark-emit src)
|
|
||||||
(let* ((ir (analyze (make-analyze-ctx "user") (jolt-ce-read src)))
|
|
||||||
(a0 (jolt-nth (jolt-get ir (kw "args")) 0))
|
|
||||||
(marked (jolt-assoc a0 (kw "hint") (kw "struct")
|
|
||||||
(kw "shape") (jolt-vector (kw "x") (kw "y") (kw "z"))))
|
|
||||||
(args (jolt-get ir (kw "args")))
|
|
||||||
(args2 (jolt-assoc args 0 marked)))
|
|
||||||
(emit (jolt-assoc ir (kw "args") args2))))
|
|
||||||
|
|
||||||
(define (run-emit scm) (eval (read (open-input-string scm)) (interaction-environment)))
|
|
||||||
(define (has-sub? s sub)
|
|
||||||
(let ((n (string-length s)) (m (string-length sub)))
|
|
||||||
(let loop ((i 0)) (cond ((> (+ i m) n) #f)
|
|
||||||
((string=? (substring s i (+ i m)) sub) #t)
|
|
||||||
(else (loop (+ i 1)))))))
|
|
||||||
(define fails 0) (define total 0)
|
|
||||||
(define (check label actual expected)
|
|
||||||
(set! total (+ total 1))
|
|
||||||
(unless (equal? actual expected)
|
|
||||||
(set! fails (+ fails 1))
|
|
||||||
(printf " FAIL ~a: got ~s expected ~s\n" label actual expected)))
|
|
||||||
|
|
||||||
;; a declared field -> bare-index path, value matches jolt-get
|
|
||||||
(let ((e (mark-emit "(:y a)")))
|
|
||||||
(check "declared field uses jrec-field-at" (has-sub? e "jrec-field-at") #t)
|
|
||||||
(check "field 1 -> static slot 1" (has-sub? e " 1 ") #t)
|
|
||||||
(check "bare read == jolt-get" (run-emit e) (evals "(:y a)"))) ; 20
|
|
||||||
|
|
||||||
;; first/last fields too
|
|
||||||
(check "field x == jolt-get" (run-emit (mark-emit "(:x a)")) (evals "(:x a)")) ; 10
|
|
||||||
(check "field z == jolt-get" (run-emit (mark-emit "(:z a)")) (evals "(:z a)")) ; 30
|
|
||||||
|
|
||||||
;; a key that is NOT a declared field -> no bare path, still correct (nil)
|
|
||||||
(let ((e (mark-emit "(:w a)")))
|
|
||||||
(check "non-field key no jrec-field-at" (has-sub? e "jrec-field-at") #f)
|
|
||||||
(check "non-field key == jolt-get" (run-emit e) (evals "(:w a)"))) ; nil
|
|
||||||
|
|
||||||
;; a default-arg form keeps jolt-get (the bare path is no-default only)
|
|
||||||
(let ((e (mark-emit "(:y a 99)")))
|
|
||||||
(check "default-arg keeps jolt-get" (has-sub? e "jrec-field-at") #f))
|
|
||||||
|
|
||||||
(if (= fails 0)
|
|
||||||
(begin (printf "fieldread gate: ~a/~a passed\n" total total) (exit 0))
|
|
||||||
(begin (printf "fieldread gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))
|
|
||||||
|
|
@ -1,76 +0,0 @@
|
||||||
;; run-narrow.ss — nilable record types + flow-sensitive some?/nil? narrowing.
|
|
||||||
;;
|
|
||||||
;; A protocol method (or `if`) returning a record-or-nil types as a NILABLE record:
|
|
||||||
;; some?/nil? do NOT fold on it (it might be nil), so a runtime guard stays. Inside
|
|
||||||
;; (if (some? x) ..) / (if x ..) the then-branch narrows x to the non-nil record, so
|
|
||||||
;; its field reads bare-index and unbox. This is the ray tracer's
|
|
||||||
;; (let [scattered (scatter ..)] (if (some? scattered) (.. (:ray scattered) ..))).
|
|
||||||
;;
|
|
||||||
;; The load-bearing soundness check: the nil case must still take the else branch —
|
|
||||||
;; narrowing must NOT fold the guard away (else a real nil reaches the bare read).
|
|
||||||
;;
|
|
||||||
;; chez --script host/chez/run-narrow.ss
|
|
||||||
(import (chezscheme))
|
|
||||||
(load "host/chez/rt.ss")
|
|
||||||
(set-chez-ns! "clojure.core")
|
|
||||||
(load "host/chez/seed/prelude.ss")
|
|
||||||
(load "host/chez/post-prelude.ss")
|
|
||||||
(set-chez-ns! "user")
|
|
||||||
(load "host/chez/host-contract.ss")
|
|
||||||
(load "host/chez/seed/image.ss")
|
|
||||||
(load "host/chez/compile-eval.ss")
|
|
||||||
|
|
||||||
(define analyze (var-deref "jolt.analyzer" "analyze"))
|
|
||||||
(define set-record-shapes! (var-deref "jolt.passes.types" "set-record-shapes!"))
|
|
||||||
(define set-protocol-methods! (var-deref "jolt.passes.types" "set-protocol-methods!"))
|
|
||||||
(define wp-infer! (var-deref "jolt.passes.types" "wp-infer!"))
|
|
||||||
(define run-passes (var-deref "jolt.passes" "run-passes"))
|
|
||||||
(define emit (var-deref "jolt.backend-scheme" "emit"))
|
|
||||||
(define (anode src) (analyze (make-analyze-ctx "user") (jolt-ce-read src)))
|
|
||||||
(define (evals src) (jolt-compile-eval (string-append "(do " src ")") "user"))
|
|
||||||
(define (built scm) (eval (read (open-input-string scm)) (interaction-environment)))
|
|
||||||
(define (sub? s t)(let((n(string-length s))(m(string-length t)))(let loop((i 0))(cond((>(+ i m)n)#f)((string=?(substring s i(+ i m))t)#t)(else(loop(+ i 1)))))))
|
|
||||||
(define fails 0) (define total 0)
|
|
||||||
(define (check label actual expected)
|
|
||||||
(set! total (+ total 1))
|
|
||||||
(unless (equal? actual expected)
|
|
||||||
(set! fails (+ fails 1))
|
|
||||||
(printf " FAIL ~a: got ~s expected ~s\n" label actual expected)))
|
|
||||||
|
|
||||||
(evals "(defrecord R [^double k])")
|
|
||||||
(evals "(defprotocol P (m [x]))")
|
|
||||||
(evals "(defrecord A [v] P (m [x] (->R 1.0)))")
|
|
||||||
(evals "(defrecord B [v] P (m [x] (if (< (:v x) 0) (->R 2.0) nil)))") ; B.m returns R-or-nil
|
|
||||||
(set-record-shapes! (chez-record-shapes-map))
|
|
||||||
(set-protocol-methods! (chez-protocol-methods-map))
|
|
||||||
(set-optimize! #t)
|
|
||||||
(define na (anode "(defrecord A [v] P (m [x] (->R 1.0)))"))
|
|
||||||
(define nb (anode "(defrecord B [v] P (m [x] (if (< (:v x) 0) (->R 2.0) nil)))"))
|
|
||||||
;; guarded read: inside (some? s), s narrows to non-nil R -> (:k s) bare-indexes + unboxes
|
|
||||||
(define f (anode "(def f (fn [a] (let [s (m a)] (if (some? s) (* (:k s) 2.0) 0.0))))"))
|
|
||||||
(wp-infer! (jolt-vector na nb f))
|
|
||||||
(define fe (emit (run-passes f (make-analyze-ctx "user"))))
|
|
||||||
(check "guarded nullable read bare-indexes" (sub? fe "jrec-field-at") #t)
|
|
||||||
(check "guarded nullable read unboxes to fl*" (sub? fe "fl*") #t)
|
|
||||||
|
|
||||||
;; CORRECTNESS + the load-bearing soundness check: the nil case must take the else
|
|
||||||
;; branch (the guard is preserved), not run the bare read on nil.
|
|
||||||
(built fe)
|
|
||||||
(define ff (var-deref "user" "f"))
|
|
||||||
(check "non-nil (A.m -> R 1.0)" (jolt-invoke ff (evals "(->A 5)")) 2.0)
|
|
||||||
(check "non-nil (B.m v<0 -> R 2.0)" (jolt-invoke ff (evals "(->B -5)")) 4.0)
|
|
||||||
(check "nil case takes else (guard preserved, no crash)"
|
|
||||||
(jolt-invoke ff (evals "(->B 5)")) 0.0)
|
|
||||||
|
|
||||||
;; an UNGUARDED nullable read must stay safe: jrec-field-at falls back to jolt-get on
|
|
||||||
;; nil. (Its result type is conservative — no unbox — so this just checks no crash.)
|
|
||||||
(define g (anode "(def g (fn [a] (let [s (m a)] (:k s))))"))
|
|
||||||
(define ge (emit (run-passes g (make-analyze-ctx "user"))))
|
|
||||||
(built ge)
|
|
||||||
(define gg (var-deref "user" "g"))
|
|
||||||
(check "unguarded nullable read on nil returns nil" (jolt-nil? (jolt-invoke gg (evals "(->B 5)"))) #t)
|
|
||||||
(check "unguarded nullable read on non-nil returns the field" (jolt-invoke gg (evals "(->A 5)")) 1.0)
|
|
||||||
|
|
||||||
(if (= fails 0)
|
|
||||||
(begin (printf "narrow gate: ~a/~a passed\n" total total) (exit 0))
|
|
||||||
(begin (printf "narrow gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))
|
|
||||||
|
|
@ -1,108 +0,0 @@
|
||||||
;; run-numwp.ss — hintless whole-program :double inference gate (jolt-evr9 R3).
|
|
||||||
;;
|
|
||||||
;; run-wp.ss drives the structural (record) fixpoint; this drives its numeric
|
|
||||||
;; refinement: a hintless fn whose every call site passes a flonum has its param
|
|
||||||
;; typed :double, which the back end then unboxes to fl-ops — no ^double hint. The
|
|
||||||
;; bridge is a synthetic [param :double] nhint (jolt.passes/inject-wp-nhints) that
|
|
||||||
;; the existing hint-directed pass + entry coercion consume unchanged.
|
|
||||||
;;
|
|
||||||
;; Soundness pinned here: :double only (never :long — an untyped integer can be a
|
|
||||||
;; bignum), so a caller passing an integer leaves the param generic; an escaped fn
|
|
||||||
;; keeps :any.
|
|
||||||
;;
|
|
||||||
;; chez --script host/chez/run-numwp.ss
|
|
||||||
(import (chezscheme))
|
|
||||||
(load "host/chez/rt.ss")
|
|
||||||
(set-chez-ns! "clojure.core")
|
|
||||||
(load "host/chez/seed/prelude.ss")
|
|
||||||
(load "host/chez/post-prelude.ss")
|
|
||||||
(set-chez-ns! "user")
|
|
||||||
(load "host/chez/host-contract.ss")
|
|
||||||
(load "host/chez/seed/image.ss")
|
|
||||||
(load "host/chez/compile-eval.ss")
|
|
||||||
|
|
||||||
(define analyze (var-deref "jolt.analyzer" "analyze"))
|
|
||||||
(define set-record-shapes! (var-deref "jolt.passes.types" "set-record-shapes!"))
|
|
||||||
(define set-protocol-methods! (var-deref "jolt.passes.types" "set-protocol-methods!"))
|
|
||||||
(define wp-infer! (var-deref "jolt.passes.types" "wp-infer!"))
|
|
||||||
(define param-num-seeds-for (var-deref "jolt.passes.types" "param-num-seeds-for"))
|
|
||||||
(define inject-wp-nhints (var-deref "jolt.passes" "inject-wp-nhints"))
|
|
||||||
(define annotate (var-deref "jolt.passes.numeric" "annotate"))
|
|
||||||
(define run-passes (var-deref "jolt.passes" "run-passes"))
|
|
||||||
(define emit (var-deref "jolt.backend-scheme" "emit"))
|
|
||||||
(define pr-str (var-deref "clojure.core" "pr-str"))
|
|
||||||
|
|
||||||
(define (anode src) (analyze (make-analyze-ctx "user") (jolt-ce-read src)))
|
|
||||||
(define (contains-sub? s sub)
|
|
||||||
(let ((n (string-length s)) (m (string-length sub)))
|
|
||||||
(let loop ((i 0))
|
|
||||||
(cond ((> (+ i m) n) #f)
|
|
||||||
((string=? (substring s i (+ i m)) sub) #t)
|
|
||||||
(else (loop (+ i 1)))))))
|
|
||||||
|
|
||||||
(define fails 0) (define total 0)
|
|
||||||
(define (check label actual expected)
|
|
||||||
(set! total (+ total 1))
|
|
||||||
(unless (equal? actual expected)
|
|
||||||
(set! fails (+ fails 1))
|
|
||||||
(printf " FAIL ~a: got ~s expected ~s\n" label actual expected)))
|
|
||||||
|
|
||||||
(set-record-shapes! (jolt-hash-map))
|
|
||||||
(set-protocol-methods! (jolt-hash-map))
|
|
||||||
|
|
||||||
;; sq is hintless; its only caller passes a flonum literal, so the fixpoint must
|
|
||||||
;; type x :double across the fn boundary.
|
|
||||||
(define sq (anode "(def sq (fn [x] (* x x)))"))
|
|
||||||
(define usef (anode "(def usef (fn [] (sq 2.0)))"))
|
|
||||||
(wp-infer! (jolt-vector sq usef))
|
|
||||||
|
|
||||||
(define nseed (param-num-seeds-for "user/sq"))
|
|
||||||
(check "sq has a numeric param seed" (jolt-truthy? nseed) #t)
|
|
||||||
(when (jolt-truthy? nseed)
|
|
||||||
(check "x seeded :double" (contains-sub? (pr-str nseed) ":double") #t))
|
|
||||||
|
|
||||||
;; the bridge: inject the derived nhint, run the numeric pass, emit -> fl*.
|
|
||||||
(define sq-opt (annotate (inject-wp-nhints sq)))
|
|
||||||
(check "sq body unboxes to fl*" (contains-sub? (emit sq-opt) "fl*") #t)
|
|
||||||
;; and the param is coerced at entry like a ^double param (no-op on a real flonum).
|
|
||||||
(check "sq coerces param at entry" (contains-sub? (emit sq-opt) "exact->inexact") #t)
|
|
||||||
|
|
||||||
;; a caller passing an INTEGER must NOT make the param :double — an untyped integer
|
|
||||||
;; can be a bignum, so fl-ops would diverge. The param stays generic.
|
|
||||||
(define sqi (anode "(def sqi (fn [x] (* x x)))"))
|
|
||||||
(define usei (anode "(def usei (fn [] (sqi 2)))"))
|
|
||||||
(wp-infer! (jolt-vector sqi usei))
|
|
||||||
(check "integer caller leaves param generic"
|
|
||||||
(jolt-truthy? (param-num-seeds-for "user/sqi")) #f)
|
|
||||||
|
|
||||||
;; a fn used in value position (escapes) has unknown callers -> no double seed.
|
|
||||||
(define esc (anode "(def esc (fn [x] (* x x)))"))
|
|
||||||
(define hof (anode "(def hof (fn [g] (g 2.0)))"))
|
|
||||||
(define ecl (anode "(def ecaller (fn [] (hof esc)))")) ; esc escapes
|
|
||||||
(wp-infer! (jolt-vector esc hof ecl))
|
|
||||||
(check "escaped fn keeps no double seed"
|
|
||||||
(jolt-truthy? (param-num-seeds-for "user/esc")) #f)
|
|
||||||
|
|
||||||
;; :double flows through a returning helper: mag returns a flonum, so a param fed
|
|
||||||
;; only (mag _) results types :double too (cross-fn return propagation).
|
|
||||||
(define mag (anode "(def mag (fn [a] (* a 2.0)))"))
|
|
||||||
(define dist (anode "(def dist (fn [b] (+ b b)))"))
|
|
||||||
(define dcl (anode "(def dcaller (fn [] (dist (mag 3.0))))"))
|
|
||||||
(wp-infer! (jolt-vector mag dist dcl))
|
|
||||||
(check "param fed a flonum-returning call types :double"
|
|
||||||
(jolt-truthy? (param-num-seeds-for "user/dist")) #t)
|
|
||||||
|
|
||||||
;; end to end through the real build pipeline: with optimize on, run-passes wires
|
|
||||||
;; the WP fixpoint's :double seeds into the numeric pass (inject-wp-nhints) so the
|
|
||||||
;; emitted def unboxes — proves the production path fires, not just the bridge in
|
|
||||||
;; isolation.
|
|
||||||
(set-optimize! #t)
|
|
||||||
(define sq2 (anode "(def sq2 (fn [x] (* x x)))"))
|
|
||||||
(define use2 (anode "(def use2 (fn [] (sq2 4.0)))"))
|
|
||||||
(wp-infer! (jolt-vector sq2 use2))
|
|
||||||
(check "run-passes unboxes a hintless double fn"
|
|
||||||
(contains-sub? (emit (run-passes sq2 (make-analyze-ctx "user"))) "fl*") #t)
|
|
||||||
|
|
||||||
(if (= fails 0)
|
|
||||||
(begin (printf "numwp gate: ~a/~a passed\n" total total) (exit 0))
|
|
||||||
(begin (printf "numwp gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))
|
|
||||||
|
|
@ -1,70 +0,0 @@
|
||||||
;; run-protoret.ss — protocol-method return-type inference gate.
|
|
||||||
;;
|
|
||||||
;; A protocol method whose impls all return the same record type has a monomorphic
|
|
||||||
;; return: collect-pm-rets! joins the impl return types, and call-ret-type then types
|
|
||||||
;; a (method recv ..) call as that record — so a field read off the result bare-
|
|
||||||
;; indexes. This is the ray tracer's (:ray (scatter material ..)): scatter's impls
|
|
||||||
;; all return a ScatterResult, so the bounced ray types without a hint.
|
|
||||||
;;
|
|
||||||
;; chez --script host/chez/run-protoret.ss
|
|
||||||
(import (chezscheme))
|
|
||||||
(load "host/chez/rt.ss")
|
|
||||||
(set-chez-ns! "clojure.core")
|
|
||||||
(load "host/chez/seed/prelude.ss")
|
|
||||||
(load "host/chez/post-prelude.ss")
|
|
||||||
(set-chez-ns! "user")
|
|
||||||
(load "host/chez/host-contract.ss")
|
|
||||||
(load "host/chez/seed/image.ss")
|
|
||||||
(load "host/chez/compile-eval.ss")
|
|
||||||
|
|
||||||
(define analyze (var-deref "jolt.analyzer" "analyze"))
|
|
||||||
(define set-record-shapes! (var-deref "jolt.passes.types" "set-record-shapes!"))
|
|
||||||
(define set-protocol-methods! (var-deref "jolt.passes.types" "set-protocol-methods!"))
|
|
||||||
(define wp-infer! (var-deref "jolt.passes.types" "wp-infer!"))
|
|
||||||
(define run-passes (var-deref "jolt.passes" "run-passes"))
|
|
||||||
(define emit (var-deref "jolt.backend-scheme" "emit"))
|
|
||||||
(define (anode src) (analyze (make-analyze-ctx "user") (jolt-ce-read src)))
|
|
||||||
(define (evals src) (jolt-compile-eval (string-append "(do " src ")") "user"))
|
|
||||||
(define (sub? s t)(let((n(string-length s))(m(string-length t)))(let loop((i 0))(cond((>(+ i m)n)#f)((string=?(substring s i(+ i m))t)#t)(else(loop(+ i 1)))))))
|
|
||||||
|
|
||||||
(define fails 0) (define total 0)
|
|
||||||
(define (check label actual expected)
|
|
||||||
(set! total (+ total 1))
|
|
||||||
(unless (equal? actual expected)
|
|
||||||
(set! fails (+ fails 1))
|
|
||||||
(printf " FAIL ~a: got ~s expected ~s\n" label actual expected)))
|
|
||||||
|
|
||||||
(evals "(defrecord R [^double k])")
|
|
||||||
(evals "(defprotocol P (m [x]))")
|
|
||||||
(evals "(defrecord A [v] P (m [x] (->R 1.0)))")
|
|
||||||
(evals "(defrecord B [v] P (m [x] (->R 2.0)))")
|
|
||||||
(evals "(defprotocol Q (q [x]))")
|
|
||||||
(evals "(defrecord C [v] Q (q [x] (->R 3.0)))")
|
|
||||||
(evals "(defrecord D [v] Q (q [x] 7)))") ; one impl returns a number, not R
|
|
||||||
(set-record-shapes! (chez-record-shapes-map))
|
|
||||||
(set-protocol-methods! (chez-protocol-methods-map))
|
|
||||||
(set-optimize! #t)
|
|
||||||
|
|
||||||
;; analyze the impl-registering forms + a consumer; the fixpoint collects the
|
|
||||||
;; impl return types. (the analyzed defrecord nodes carry register-inline-method.)
|
|
||||||
(define na (anode "(defrecord A [v] P (m [x] (->R 1.0)))"))
|
|
||||||
(define nb (anode "(defrecord B [v] P (m [x] (->R 2.0)))"))
|
|
||||||
(define nc (anode "(defrecord C [v] Q (q [x] (->R 3.0)))"))
|
|
||||||
(define nd (anode "(defrecord D [v] Q (q [x] 7))"))
|
|
||||||
(define f (anode "(def f (fn [a] (* (:k (m a)) 2.0)))"))
|
|
||||||
(define g (anode "(def g (fn [a] (:k (q a))))"))
|
|
||||||
(wp-infer! (jolt-vector na nb nc nd f g))
|
|
||||||
|
|
||||||
;; m's impls all return R -> (:k (m a)) reads off an R -> bare-index + unbox.
|
|
||||||
(define fe (emit (run-passes f (make-analyze-ctx "user"))))
|
|
||||||
(check "monomorphic protocol return bare-indexes the field read" (sub? fe "jrec-field-at") #t)
|
|
||||||
(check "monomorphic protocol return unboxes the ^double field" (sub? fe "fl") #t)
|
|
||||||
|
|
||||||
;; q's impls return R and a number -> joined to non-record -> stays generic (sound).
|
|
||||||
(define ge (emit (run-passes g (make-analyze-ctx "user"))))
|
|
||||||
(check "mixed-return protocol keeps generic jolt-get" (sub? ge "jolt-get") #t)
|
|
||||||
(check "mixed-return protocol does not bare-index" (sub? ge "jrec-field-at") #f)
|
|
||||||
|
|
||||||
(if (= fails 0)
|
|
||||||
(begin (printf "protoret gate: ~a/~a passed\n" total total) (exit 0))
|
|
||||||
(begin (printf "protoret gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))
|
|
||||||
|
|
@ -1,11 +1,11 @@
|
||||||
;; run-sci.ss — SCI conformance: load borkdude/sci's own source (vendor/sci) through
|
;; run-sci.ss — SCI conformance: load borkdude/sci's own source (vendor/sci) through
|
||||||
;; joltc and require its forms to compile+eval. A real-world Clojure-compatibility
|
;; joltc and require its forms to compile+eval. A real-world Clojure-compatibility
|
||||||
;; stress test. Floor-gated like the corpus: a regression below
|
;; stress test. Floor-gated like the corpus: a regression below
|
||||||
;; the floor (or the count today, 210/218) fails. Raise the floor as host gaps close
|
;; the floor (or the count today, 205/218) fails. Raise the floor as host gaps close
|
||||||
;; (the tail is genuine gaps — set! on vars, some macro/def shapes).
|
;; (the tail is genuine gaps — set! on vars, some macro/def shapes).
|
||||||
;;
|
;;
|
||||||
;; chez --script host/chez/run-sci.ss
|
;; chez --script host/chez/run-sci.ss
|
||||||
;; JOLT_SCI_FLOOR=N override the floor (default 210)
|
;; JOLT_SCI_FLOOR=N override the floor (default 205)
|
||||||
;; SCI_VERBOSE=1 print each failing form's error
|
;; SCI_VERBOSE=1 print each failing form's error
|
||||||
(import (chezscheme))
|
(import (chezscheme))
|
||||||
|
|
||||||
|
|
@ -74,7 +74,7 @@
|
||||||
load-order)
|
load-order)
|
||||||
|
|
||||||
(printf "\nSCI load: ~a/~a forms ok (~a fail)\n" total-ok (+ total-ok total-fail) total-fail)
|
(printf "\nSCI load: ~a/~a forms ok (~a fail)\n" total-ok (+ total-ok total-fail) total-fail)
|
||||||
(define floor (let ((s (getenv "JOLT_SCI_FLOOR"))) (if s (string->number s) 210)))
|
(define floor (let ((s (getenv "JOLT_SCI_FLOOR"))) (if s (string->number s) 205)))
|
||||||
(when (< total-ok floor)
|
(when (< total-ok floor)
|
||||||
(printf "REGRESSION: ~a forms loaded < floor ~a\n" total-ok floor))
|
(printf "REGRESSION: ~a forms loaded < floor ~a\n" total-ok floor))
|
||||||
(flush-output-port)
|
(flush-output-port)
|
||||||
|
|
|
||||||
|
|
@ -1,108 +0,0 @@
|
||||||
;; run-wp.ss — whole-program param-type fixpoint gate (jolt.passes.types/wp-infer!).
|
|
||||||
;;
|
|
||||||
;; run-infer.ss drives the per-form inference; this drives the inter-procedural
|
|
||||||
;; driver: analyze a multi-def unit, run wp-infer!, and assert that a record type
|
|
||||||
;; flows across fn boundaries — a callee's param picks up its caller's ctor return
|
|
||||||
;; type, so a field read off it is marked for the bare-index back-end path.
|
|
||||||
;;
|
|
||||||
;; chez --script host/chez/run-wp.ss
|
|
||||||
(import (chezscheme))
|
|
||||||
(load "host/chez/rt.ss")
|
|
||||||
(set-chez-ns! "clojure.core")
|
|
||||||
(load "host/chez/seed/prelude.ss")
|
|
||||||
(load "host/chez/post-prelude.ss")
|
|
||||||
(set-chez-ns! "user")
|
|
||||||
(load "host/chez/host-contract.ss")
|
|
||||||
(load "host/chez/seed/image.ss")
|
|
||||||
(load "host/chez/compile-eval.ss")
|
|
||||||
|
|
||||||
(define analyze (var-deref "jolt.analyzer" "analyze"))
|
|
||||||
(define run-inference (var-deref "jolt.passes.types" "run-inference"))
|
|
||||||
(define set-record-shapes! (var-deref "jolt.passes.types" "set-record-shapes!"))
|
|
||||||
(define set-protocol-methods! (var-deref "jolt.passes.types" "set-protocol-methods!"))
|
|
||||||
(define wp-infer! (var-deref "jolt.passes.types" "wp-infer!"))
|
|
||||||
(define param-seeds-for (var-deref "jolt.passes.types" "param-seeds-for"))
|
|
||||||
(define reinfer-def (var-deref "jolt.passes.types" "reinfer-def"))
|
|
||||||
(define pr-str (var-deref "clojure.core" "pr-str"))
|
|
||||||
|
|
||||||
(define (anode src) (analyze (make-analyze-ctx "user") (jolt-ce-read src)))
|
|
||||||
(define (contains-sub? s sub)
|
|
||||||
(let ((n (string-length s)) (m (string-length sub)))
|
|
||||||
(let loop ((i 0))
|
|
||||||
(cond ((> (+ i m) n) #f)
|
|
||||||
((string=? (substring s i (+ i m)) sub) #t)
|
|
||||||
(else (loop (+ i 1)))))))
|
|
||||||
|
|
||||||
(define fails 0) (define total 0)
|
|
||||||
(define (check label actual expected)
|
|
||||||
(set! total (+ total 1))
|
|
||||||
(unless (equal? actual expected)
|
|
||||||
(set! fails (+ fails 1))
|
|
||||||
(printf " FAIL ~a: got ~s expected ~s\n" label actual expected)))
|
|
||||||
|
|
||||||
;; Node record shape (left/right untagged), like binary-trees.
|
|
||||||
(set-record-shapes!
|
|
||||||
(jolt-hash-map "user/->Node"
|
|
||||||
(jolt-hash-map (keyword #f "fields") (jolt-vector (keyword #f "left") (keyword #f "right"))
|
|
||||||
(keyword #f "tags") (jolt-vector jolt-nil jolt-nil)
|
|
||||||
(keyword #f "type") "user.Node")))
|
|
||||||
(set-protocol-methods! (jolt-hash-map))
|
|
||||||
|
|
||||||
;; a 3-def unit: make-tree returns ->Node, run calls check-tree with a make-tree
|
|
||||||
;; result, so check-tree's `node` param must be inferred as a Node.
|
|
||||||
(define mt (anode "(def make-tree (fn [depth] (if (zero? depth) (->Node nil nil) (->Node (make-tree (dec depth)) (make-tree (dec depth))))))"))
|
|
||||||
(define ct (anode "(def check-tree (fn [node] (:left node)))"))
|
|
||||||
(define rn (anode "(def run (fn [d] (check-tree (make-tree d))))"))
|
|
||||||
|
|
||||||
(wp-infer! (jolt-vector mt ct rn))
|
|
||||||
|
|
||||||
;; check-tree's param `node` should be seeded with a struct carrying the Node type
|
|
||||||
(define seed (param-seeds-for "user/check-tree"))
|
|
||||||
(check "check-tree has a param seed" (jolt-truthy? seed) #t)
|
|
||||||
(when (jolt-truthy? seed)
|
|
||||||
(check "node seeded as user.Node struct"
|
|
||||||
(contains-sub? (pr-str seed) "user.Node") #t))
|
|
||||||
|
|
||||||
;; reinfer-def then must mark the (:left node) read site for the bare-index path
|
|
||||||
(define marked (reinfer-def ct seed))
|
|
||||||
(check "read site marked :hint :struct" (contains-sub? (pr-str marked) ":hint :struct") #t)
|
|
||||||
|
|
||||||
;; a fn used only via value position (escape) must NOT be specialized — unknown
|
|
||||||
;; callers make a concrete seed unsound.
|
|
||||||
(define ev (anode "(def use-it (fn [f] (f 1)))"))
|
|
||||||
(define ec (anode "(def caller (fn [] (use-it check-tree)))")) ; check-tree escapes
|
|
||||||
(wp-infer! (jolt-vector mt ct rn ev ec))
|
|
||||||
(check "escaped fn keeps no param seed" (jolt-truthy? (param-seeds-for "user/check-tree")) #f)
|
|
||||||
|
|
||||||
;; a self-recursive fn that recurses on a NILABLE field (an untagged record field
|
|
||||||
;; is :any, so the child can be nil) must NOT be specialized — the recursion can
|
|
||||||
;; pass nil, so typing the param as a non-nil record would be unsound.
|
|
||||||
(define ctr (anode "(def walk (fn [node] (let [l (:left node)] (if (nil? l) 1 (walk l)))))"))
|
|
||||||
(define rnr (anode "(def run2 (fn [d] (walk (make-tree d))))"))
|
|
||||||
(wp-infer! (jolt-vector mt ctr rnr))
|
|
||||||
(check "self-recursive nilable param not specialized"
|
|
||||||
(jolt-truthy? (param-seeds-for "user/walk")) #f)
|
|
||||||
|
|
||||||
;; a self-recursive fn that recurses passing the SAME record type (make-tree always
|
|
||||||
;; returns a Node) is still safe to specialize — the recursion preserves the type.
|
|
||||||
(define mtt (anode "(def grow (fn [n acc] (if (zero? n) acc (grow (dec n) (->Node acc acc)))))"))
|
|
||||||
(define gcl (anode "(def gcaller (fn [] (grow 5 (->Node nil nil))))"))
|
|
||||||
(wp-infer! (jolt-vector mtt gcl))
|
|
||||||
(check "self-recursive same-type param keeps its seed"
|
|
||||||
(jolt-truthy? (param-seeds-for "user/grow")) #t)
|
|
||||||
|
|
||||||
;; a recursive fn that threads a param STRAIGHT THROUGH its recursion (same arg at
|
|
||||||
;; the same position) must keep that param's type — a pass-through self-call adds no
|
|
||||||
;; information and must not poison the param to :any. This is the ray tracer's
|
|
||||||
;; hittables, passed unchanged through ray-cast's recursion while its reduce element
|
|
||||||
;; reads the records' fields.
|
|
||||||
(define cwalk (anode "(def cwalk (fn [hs] (reduce (fn [acc h] (:left h)) nil hs)))"))
|
|
||||||
(define crec (anode "(def crec (fn [hs d] (if (< d 0) nil (do (cwalk hs) (crec hs (- d 1))))))"))
|
|
||||||
(define cdrv (anode "(def cdrive (fn [] (crec [(->Node nil nil) (->Node nil nil)] 5)))"))
|
|
||||||
(wp-infer! (jolt-vector cwalk crec cdrv))
|
|
||||||
(check "recursion pass-through param keeps its vec element type"
|
|
||||||
(contains-sub? (pr-str (param-seeds-for "user/crec")) "user.Node") #t)
|
|
||||||
|
|
||||||
(if (= fails 0)
|
|
||||||
(begin (printf "wp gate: ~a/~a passed\n" total total) (exit 0))
|
|
||||||
(begin (printf "wp gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))
|
|
||||||
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
638
host/chez/seq.ss
638
host/chez/seq.ss
|
|
@ -31,29 +31,11 @@
|
||||||
;; cvec is #f for every other seq; stored as two fields (not a cons) so a vector
|
;; cvec is #f for every other seq; stored as two fields (not a cons) so a vector
|
||||||
;; seq cell costs no extra allocation. The rest of the seq layer ignores them, so
|
;; seq cell costs no extra allocation. The rest of the seq layer ignores them, so
|
||||||
;; first/rest/count/printing are unchanged.
|
;; first/rest/count/printing are unchanged.
|
||||||
;; crest: the ChunkedCons case — cvec holds a STANDALONE chunk pvec (<=32 already-
|
(define-record-type cseq (fields head (mutable tail) (mutable forced?) list? cvec ci) (nongenerative chez-cseq-v3))
|
||||||
;; realized elements), ci the offset within it, and crest the seq AFTER the whole
|
(define (cseq-realized head tail) (make-cseq head tail #t #f #f 0)) ; tail already a seq
|
||||||
;; chunk (the clojure.lang.ChunkedCons _more). This is what map/filter/range emit
|
(define (cseq-lazy head tail-thunk) (make-cseq head tail-thunk #f #f #f 0))
|
||||||
;; so their result is itself a chunked-seq (chained chunked transforms each batch
|
(define (cseq-list head tail) (make-cseq head tail #t #t #f 0)) ; a PersistentList node
|
||||||
;; by 32, like the JVM). crest is #f for a plain vector-backed seq (whose "rest"
|
(define (cseq-vec head tail-thunk v i) (make-cseq head tail-thunk #f #f v i)) ; vector-backed
|
||||||
;; is the next 32-block of the SAME cvec) and for every non-chunked cell.
|
|
||||||
(define-record-type cseq (fields head (mutable tail) (mutable forced?) list? cvec ci crest) (nongenerative chez-cseq-v4))
|
|
||||||
(define (cseq-realized head tail) (make-cseq head tail #t #f #f 0 #f)) ; tail already a seq
|
|
||||||
(define (cseq-lazy head tail-thunk) (make-cseq head tail-thunk #f #f #f 0 #f))
|
|
||||||
(define (cseq-list head tail) (make-cseq head tail #t #t #f 0 #f)) ; a PersistentList node
|
|
||||||
(define (cseq-vec head tail-thunk v i) (make-cseq head tail-thunk #f #f v i #f)) ; vector-backed
|
|
||||||
;; A ChunkedCons cell over a standalone chunk pvec: head is chunk[i], walking
|
|
||||||
;; (seq-more) advances within the chunk and then continues into `rest`. `rest` is
|
|
||||||
;; the already-coerced after-chunk seq (cseq | jolt-nil | a jolt-lazyseq), held in
|
|
||||||
;; crest for chunk-rest/chunk-next and forced lazily by the tail thunk at the chunk
|
|
||||||
;; boundary so a chunked map over an infinite chunked source stays productive.
|
|
||||||
(define (cseq-chunked chunk i rest)
|
|
||||||
(make-cseq (pvec-nth-d chunk i jolt-nil)
|
|
||||||
(lambda () (let ((i1 (fx+ i 1)))
|
|
||||||
(if (fx<? i1 (pvec-count chunk))
|
|
||||||
(cseq-chunked chunk i1 rest)
|
|
||||||
(jolt-seq rest))))
|
|
||||||
#f #f chunk i rest))
|
|
||||||
(define (seq-first s) (cseq-head s))
|
(define (seq-first s) (cseq-head s))
|
||||||
(define (seq-more s) ; force the tail; returns a seq (cseq | jolt-nil)
|
(define (seq-more s) ; force the tail; returns a seq (cseq | jolt-nil)
|
||||||
(if (cseq-forced? s) (cseq-tail s)
|
(if (cseq-forced? s) (cseq-tail s)
|
||||||
|
|
@ -103,25 +85,10 @@
|
||||||
;; the seq leaf ops the emitter lowers core fns to
|
;; the seq leaf ops the emitter lowers core fns to
|
||||||
;; ============================================================================
|
;; ============================================================================
|
||||||
(define (jolt-first x) (let ((s (jolt-seq x))) (if (jolt-nil? s) jolt-nil (seq-first s))))
|
(define (jolt-first x) (let ((s (jolt-seq x))) (if (jolt-nil? s) jolt-nil (seq-first s))))
|
||||||
;; rest = Clojure's more(): the tail as a (possibly empty) seq, NOT nil, and
|
(define (jolt-rest x) ; () when the seq has 0/1 elements (NOT nil)
|
||||||
;; WITHOUT realizing it. A forced cseq (list / realized chain) hands back its tail
|
|
||||||
;; directly. An UNFORCED tail (vector / string / lazy-seq cell) is returned as a
|
|
||||||
;; deferred seq so (rest s) does not realize the next node — matching Clojure,
|
|
||||||
;; where (rest (iterate f x)) does not call f and a side-effecting lazy seq is
|
|
||||||
;; realized one element at a time. next = (seq (rest s)) still realizes one.
|
|
||||||
;; jolt-make-lazy-seq (lazy-bridge.ss) resolves at call time.
|
|
||||||
(define (jolt-rest x)
|
|
||||||
(let ((s (jolt-seq x)))
|
(let ((s (jolt-seq x)))
|
||||||
(cond
|
(if (jolt-nil? s) jolt-empty-list
|
||||||
((jolt-nil? s) jolt-empty-list)
|
(let ((m (seq-more s))) (if (jolt-nil? m) jolt-empty-list m)))))
|
||||||
((cseq-forced? s) (let ((m (cseq-tail s))) (if (jolt-nil? m) jolt-empty-list m)))
|
|
||||||
;; the lazyseq forces to a seq (cseq | nil); an empty realized lazyseq is
|
|
||||||
;; still a sequence value, printing "()" (see lazy-bridge.ss), so (rest s)
|
|
||||||
;; is never nil even when the tail is empty. jolt-seq coerces seq-more's
|
|
||||||
;; result (which may be jolt-empty-list, e.g. map's tail) back to cseq | nil,
|
|
||||||
;; the contract force-lazyseq relies on — else (seq (rest s)) of an empty
|
|
||||||
;; tail yields a truthy empty-list and walkers (distinct, dedupe) overrun.
|
|
||||||
(else (jolt-make-lazy-seq (lambda () (jolt-seq (seq-more s))))))))
|
|
||||||
(define (jolt-next x) ; nil when the rest is empty
|
(define (jolt-next x) ; nil when the rest is empty
|
||||||
;; next = (seq (rest x)): the rest must be RE-SEQ'd so an empty tail collapses to
|
;; next = (seq (rest x)): the rest must be RE-SEQ'd so an empty tail collapses to
|
||||||
;; nil. seq-more on a lazy seq (e.g. map's) forces to jolt-empty-list, which is
|
;; nil. seq-more on a lazy seq (e.g. map's) forces to jolt-empty-list, which is
|
||||||
|
|
@ -152,319 +119,31 @@
|
||||||
(if (jolt-nil? s) last (loop (jolt-seq (seq-more s)) (seq-first s)))))
|
(if (jolt-nil? s) last (loop (jolt-seq (seq-more s)) (seq-first s)))))
|
||||||
;; nth over a seq (walks; forces lazily). default? selects the 3-arg behavior.
|
;; nth over a seq (walks; forces lazily). default? selects the 3-arg behavior.
|
||||||
(define (seq-nth coll i default? d)
|
(define (seq-nth coll i default? d)
|
||||||
(if (fx<? i 0) (if default? d (jolt-throw (jolt-host-throwable "java.lang.IndexOutOfBoundsException" "index out of bounds")))
|
(if (fx<? i 0) (if default? d (error 'nth "index out of bounds"))
|
||||||
(let loop ((s (jolt-seq coll)) (i i))
|
(let loop ((s (jolt-seq coll)) (i i))
|
||||||
(cond ((jolt-nil? s) (if default? d (jolt-throw (jolt-host-throwable "java.lang.IndexOutOfBoundsException" "index out of bounds"))))
|
(cond ((jolt-nil? s) (if default? d (error 'nth "index out of bounds")))
|
||||||
((fx=? i 0) (seq-first s))
|
((fx=? i 0) (seq-first s))
|
||||||
(else (loop (jolt-seq (seq-more s)) (fx- i 1)))))))
|
(else (loop (jolt-seq (seq-more s)) (fx- i 1)))))))
|
||||||
|
|
||||||
;; --- checked arithmetic: JVM Numbers.ops-style category dispatch -------------
|
|
||||||
;; Every arithmetic/comparison site (the inlined jolt-n* macros in call position,
|
|
||||||
;; the variadic shims in value position) funnels a binary op through ONE dispatch:
|
|
||||||
;; both operands inside Chez's tower take the native op with JVM contagion rules
|
|
||||||
;; patched in (a double operand wins — Chez's exact-zero shortcut must not leak:
|
|
||||||
;; (* 1.5 0) is 0.0, not 0; an exact zero divisor throws ArithmeticException, a
|
|
||||||
;; double zero divisor yields ##Inf/##NaN); an operand OUTSIDE the tower (e.g.
|
|
||||||
;; BigDecimal) falls to a slow hook the numeric shim extends (java/bigdec.ss).
|
|
||||||
;; A non-numeric operand is a ClassCastException, like the JVM.
|
|
||||||
(define (jolt-num-cast-throw x)
|
|
||||||
(if (jolt-nil? x)
|
|
||||||
(jolt-throw (jolt-host-throwable "java.lang.NullPointerException" ""))
|
|
||||||
(jolt-throw (jolt-host-throwable
|
|
||||||
"java.lang.ClassCastException"
|
|
||||||
(string-append "class " (jolt-class-name x)
|
|
||||||
" cannot be cast to class java.lang.Number")))))
|
|
||||||
(define (jolt-div0-throw)
|
|
||||||
(jolt-throw (jolt-host-throwable "java.lang.ArithmeticException" "Divide by zero")))
|
|
||||||
|
|
||||||
;; slow hooks: one per op, taking over when an operand is outside Chez's tower.
|
|
||||||
;; A numeric shim (java/bigdec.ss) set!-extends them; the base case is the JVM's:
|
|
||||||
;; not a number -> ClassCastException. The hooks are BINARY and never re-enter
|
|
||||||
;; the variadic shims, so extension order can't recurse.
|
|
||||||
(define (jolt-add-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
|
|
||||||
(define (jolt-sub-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
|
|
||||||
(define (jolt-mul-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
|
|
||||||
(define (jolt-div-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
|
|
||||||
;; comparison of operands outside the Chez tower: numeric shims extend this to a
|
|
||||||
;; 3-way compare; anything left over is not a number.
|
|
||||||
(define (jolt-num-cmp-slow a b)
|
|
||||||
(jolt-num-cast-throw (if (number? a) b a)))
|
|
||||||
|
|
||||||
(define (jolt-add2 a b)
|
|
||||||
(if (and (number? a) (number? b)) (+ a b) (jolt-add-slow a b)))
|
|
||||||
(define (jolt-sub2 a b)
|
|
||||||
(if (and (number? a) (number? b)) (- a b) (jolt-sub-slow a b)))
|
|
||||||
(define (jolt-mul2 a b)
|
|
||||||
(if (and (number? a) (number? b))
|
|
||||||
(if (or (flonum? a) (flonum? b))
|
|
||||||
(fl* (real->flonum a) (real->flonum b))
|
|
||||||
(* a b))
|
|
||||||
(jolt-mul-slow a b)))
|
|
||||||
(define (jolt-div2 a b)
|
|
||||||
(if (and (number? a) (number? b))
|
|
||||||
(if (or (flonum? a) (flonum? b))
|
|
||||||
(fl/ (real->flonum a) (real->flonum b))
|
|
||||||
(if (eqv? b 0) (jolt-div0-throw) (/ a b)))
|
|
||||||
(jolt-div-slow a b)))
|
|
||||||
(define (jolt-lt2 a b)
|
|
||||||
(if (and (number? a) (number? b)) (< a b) (< (jolt-num-cmp-slow a b) 0)))
|
|
||||||
(define (jolt-gt2 a b)
|
|
||||||
(if (and (number? a) (number? b)) (> a b) (> (jolt-num-cmp-slow a b) 0)))
|
|
||||||
(define (jolt-le2 a b)
|
|
||||||
(if (and (number? a) (number? b)) (<= a b) (<= (jolt-num-cmp-slow a b) 0)))
|
|
||||||
(define (jolt-ge2 a b)
|
|
||||||
(if (and (number? a) (number? b)) (>= a b) (>= (jolt-num-cmp-slow a b) 0)))
|
|
||||||
;; min/max return the ORIGINAL operand (type and exactness kept, like
|
|
||||||
;; Numbers.min): (min 1 2.0) is 1, not 1.0. A NaN operand wins.
|
|
||||||
(define (jolt-min2 a b)
|
|
||||||
(cond ((and (flonum? a) (nan? a)) a)
|
|
||||||
((and (flonum? b) (nan? b)) b)
|
|
||||||
(else (if (jolt-lt2 a b) a b))))
|
|
||||||
(define (jolt-max2 a b)
|
|
||||||
(cond ((and (flonum? a) (nan? a)) a)
|
|
||||||
((and (flonum? b) (nan? b)) b)
|
|
||||||
(else (if (jolt-gt2 a b) a b))))
|
|
||||||
|
|
||||||
;; quot/rem/mod over the full tower: truncating division; a double operand makes
|
|
||||||
;; the result a double; mod has floor semantics (result takes the divisor's
|
|
||||||
;; sign). A zero divisor throws ArithmeticException in both worlds (JVM double
|
|
||||||
;; quot/rem check the divisor before dividing). Non-tower operands hit the
|
|
||||||
;; set!-extensible slow hooks.
|
|
||||||
(define (jolt-quot-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
|
|
||||||
(define (jolt-rem-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
|
|
||||||
(define (jolt-mod-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
|
|
||||||
(define (jolt-quot a b)
|
|
||||||
(cond ((not (and (number? a) (number? b))) (jolt-quot-slow a b))
|
|
||||||
((or (flonum? a) (flonum? b))
|
|
||||||
(let ((n (real->flonum a)) (d (real->flonum b)))
|
|
||||||
(if (fl= d 0.0) (jolt-div0-throw)
|
|
||||||
(let ((q (fl/ n d)))
|
|
||||||
(when (or (nan? q) (infinite? q))
|
|
||||||
(jolt-throw (jolt-host-throwable "java.lang.NumberFormatException"
|
|
||||||
"Infinite or NaN")))
|
|
||||||
(fltruncate q)))))
|
|
||||||
((eqv? b 0) (jolt-div0-throw))
|
|
||||||
((and (integer? a) (integer? b)) (quotient a b))
|
|
||||||
(else (truncate (/ a b)))))
|
|
||||||
(define (jolt-rem a b)
|
|
||||||
(cond ((not (and (number? a) (number? b))) (jolt-rem-slow a b))
|
|
||||||
((or (flonum? a) (flonum? b))
|
|
||||||
(let ((n (real->flonum a)) (d (real->flonum b)))
|
|
||||||
(if (fl= d 0.0) (jolt-div0-throw)
|
|
||||||
(let ((q (fl/ n d)))
|
|
||||||
(when (or (nan? q) (infinite? q))
|
|
||||||
(jolt-throw (jolt-host-throwable "java.lang.NumberFormatException"
|
|
||||||
"Infinite or NaN")))
|
|
||||||
(fl- n (fl* d (fltruncate q)))))))
|
|
||||||
((eqv? b 0) (jolt-div0-throw))
|
|
||||||
((and (integer? a) (integer? b)) (remainder a b))
|
|
||||||
(else (- a (* b (truncate (/ a b)))))))
|
|
||||||
(define (jolt-mod a b)
|
|
||||||
(cond ((not (and (number? a) (number? b))) (jolt-mod-slow a b))
|
|
||||||
((and (integer? a) (integer? b) (not (flonum? a)) (not (flonum? b)))
|
|
||||||
(if (eqv? b 0) (jolt-div0-throw) (modulo a b)))
|
|
||||||
(else
|
|
||||||
(let ((m (jolt-rem a b)))
|
|
||||||
(if (or (zero? m) (eq? (negative? m) (negative? b))) m (jolt-add2 m b))))))
|
|
||||||
|
|
||||||
;; value-position arithmetic (the higher-order forms: (reduce + []), (apply * xs)).
|
;; value-position arithmetic (the higher-order forms: (reduce + []), (apply * xs)).
|
||||||
;; Folded through the binary dispatch so contagion/edge rules hold; identities
|
;; Scheme's +/-/*// already implement the JVM-parity numeric tower: exact+exact ->
|
||||||
;; (+)=0 / (*)=1 are exact, matching exact integer arithmetic. The hot path uses
|
;; exact, exact/exact -> Ratio, any flonum -> flonum. Identities (+)=0 / (*)=1 are
|
||||||
;; the inlined native ops, not these.
|
;; exact, matching exact integer arithmetic. The hot path uses the inlined native
|
||||||
;; recognizer for slow-path numeric types; numeric shims extend it.
|
;; ops, not these.
|
||||||
(define (jolt-num-slow? x) #f)
|
(define (jolt-add . xs) (apply + xs))
|
||||||
(define (jolt-num-check1 x) ; (+ x)/(* x) return x but still type-check it
|
(define (jolt-sub . xs) (apply - xs))
|
||||||
(if (or (number? x) (jolt-num-slow? x)) x (jolt-num-cast-throw x)))
|
(define (jolt-mul . xs) (apply * xs))
|
||||||
(define (jolt-add . xs)
|
(define (jolt-div . xs) (apply / xs))
|
||||||
(cond ((null? xs) 0)
|
|
||||||
((null? (cdr xs)) (jolt-num-check1 (car xs)))
|
|
||||||
(else (fold-left jolt-add2 (car xs) (cdr xs)))))
|
|
||||||
(define (jolt-arity0-throw name)
|
|
||||||
(jolt-throw (jolt-host-throwable
|
|
||||||
"clojure.lang.ArityException"
|
|
||||||
(string-append "Wrong number of args (0) passed to: clojure.core/" name))))
|
|
||||||
(define (jolt-sub . xs)
|
|
||||||
(cond ((null? xs) (jolt-arity0-throw "-"))
|
|
||||||
((null? (cdr xs)) (jolt-sub2 0 (car xs)))
|
|
||||||
(else (fold-left jolt-sub2 (car xs) (cdr xs)))))
|
|
||||||
(define (jolt-mul . xs)
|
|
||||||
(cond ((null? xs) 1)
|
|
||||||
((null? (cdr xs)) (jolt-num-check1 (car xs)))
|
|
||||||
(else (fold-left jolt-mul2 (car xs) (cdr xs)))))
|
|
||||||
(define (jolt-div . xs)
|
|
||||||
(cond ((null? xs) (jolt-arity0-throw "/"))
|
|
||||||
((null? (cdr xs)) (jolt-div2 1 (car xs)))
|
|
||||||
(else (fold-left jolt-div2 (car xs) (cdr xs)))))
|
|
||||||
(define (jolt-min x . xs) (fold-left jolt-min2 x xs))
|
|
||||||
(define (jolt-max x . xs) (fold-left jolt-max2 x xs))
|
|
||||||
;; variadic comparison chains for value position ((apply < xs)).
|
|
||||||
(define (jolt-cmp-chain op2)
|
|
||||||
(lambda (x . xs)
|
|
||||||
(let loop ((a x) (rest xs))
|
|
||||||
(cond ((null? rest) #t)
|
|
||||||
((op2 a (car rest)) (loop (car rest) (cdr rest)))
|
|
||||||
(else #f)))))
|
|
||||||
(define jolt-lt (jolt-cmp-chain jolt-lt2))
|
|
||||||
(define jolt-gt (jolt-cmp-chain jolt-gt2))
|
|
||||||
(define jolt-le (jolt-cmp-chain jolt-le2))
|
|
||||||
(define jolt-ge (jolt-cmp-chain jolt-ge2))
|
|
||||||
|
|
||||||
;; call-position arithmetic: inlined macros with the both-Chez-numbers fast path
|
|
||||||
;; open-coded; anything else falls to the binary dispatch above. Comparisons
|
|
||||||
;; return a genuine Scheme boolean (the backend's truthy elision relies on it).
|
|
||||||
(define-syntax jolt-n+
|
|
||||||
(syntax-rules ()
|
|
||||||
((_) 0)
|
|
||||||
((_ a) (jolt-add a))
|
|
||||||
((_ ea eb) (let ((a ea) (b eb))
|
|
||||||
(if (and (number? a) (number? b)) (+ a b) (jolt-add a b))))
|
|
||||||
((_ a b c ...) (jolt-n+ (jolt-n+ a b) c ...))))
|
|
||||||
(define-syntax jolt-n-
|
|
||||||
(syntax-rules ()
|
|
||||||
((_) (jolt-sub))
|
|
||||||
((_ a) (jolt-sub a))
|
|
||||||
((_ ea eb) (let ((a ea) (b eb))
|
|
||||||
(if (and (number? a) (number? b)) (- a b) (jolt-sub a b))))
|
|
||||||
((_ a b c ...) (jolt-n- (jolt-n- a b) c ...))))
|
|
||||||
(define-syntax jolt-n*
|
|
||||||
(syntax-rules ()
|
|
||||||
((_) 1)
|
|
||||||
((_ a) (jolt-mul a))
|
|
||||||
((_ ea eb) (let ((a ea) (b eb))
|
|
||||||
(if (and (number? a) (number? b))
|
|
||||||
(if (or (flonum? a) (flonum? b))
|
|
||||||
(fl* (real->flonum a) (real->flonum b))
|
|
||||||
(* a b))
|
|
||||||
(jolt-mul a b))))
|
|
||||||
((_ a b c ...) (jolt-n* (jolt-n* a b) c ...))))
|
|
||||||
(define-syntax jolt-n-div
|
|
||||||
(syntax-rules ()
|
|
||||||
((_) (jolt-div))
|
|
||||||
((_ a) (jolt-div a))
|
|
||||||
((_ a b) (jolt-div2 a b))
|
|
||||||
((_ a b c ...) (jolt-n-div (jolt-div2 a b) c ...))))
|
|
||||||
(define-syntax define-n-cmp
|
|
||||||
(syntax-rules ()
|
|
||||||
((_ name op op2)
|
|
||||||
(define-syntax name
|
|
||||||
(syntax-rules ()
|
|
||||||
((_) (op2))
|
|
||||||
((_ a) (begin a #t))
|
|
||||||
((_ ea eb) (let ((a ea) (b eb))
|
|
||||||
(if (and (number? a) (number? b)) (op a b) (op2 a b))))
|
|
||||||
((_ ea eb c (... ...)) (let ((a ea) (b eb))
|
|
||||||
(and (name a b) (name b c (... ...))))))))))
|
|
||||||
(define-n-cmp jolt-n< < jolt-lt2)
|
|
||||||
(define-n-cmp jolt-n> > jolt-gt2)
|
|
||||||
(define-n-cmp jolt-n<= <= jolt-le2)
|
|
||||||
(define-n-cmp jolt-n>= >= jolt-ge2)
|
|
||||||
(define-syntax jolt-n-min
|
|
||||||
(syntax-rules ()
|
|
||||||
((_) (jolt-min))
|
|
||||||
((_ a) (jolt-min a))
|
|
||||||
((_ a b) (jolt-min2 a b))
|
|
||||||
((_ a b c ...) (jolt-n-min (jolt-min2 a b) c ...))))
|
|
||||||
(define-syntax jolt-n-max
|
|
||||||
(syntax-rules ()
|
|
||||||
((_) (jolt-max))
|
|
||||||
((_ a) (jolt-max a))
|
|
||||||
((_ a b) (jolt-max2 a b))
|
|
||||||
((_ a b c ...) (jolt-n-max (jolt-max2 a b) c ...))))
|
|
||||||
|
|
||||||
;; --- unchecked (Java long) arithmetic: wrap to signed 64 bits ----------------
|
|
||||||
;; Clojure's unchecked-* (and +/-/* under *unchecked-math*) are long ops that
|
|
||||||
;; WRAP on overflow; jolt's checked arithmetic is arbitrary-precision. These
|
|
||||||
;; truncate to the low 64 bits as a two's-complement signed long. Chez fixnums are
|
|
||||||
;; 61-bit, so wrapping uses bignum bit ops + a mask (no fx fast path). The backend
|
|
||||||
;; emits the binary jolt-unc* for :long-typed unchecked ops; the variadic
|
|
||||||
;; clojure.core/unchecked-* fns reduce through them.
|
|
||||||
(define unc-mask64 #xFFFFFFFFFFFFFFFF)
|
|
||||||
(define unc-2^63 #x8000000000000000)
|
|
||||||
(define unc-2^64 #x10000000000000000)
|
|
||||||
(define unc-neg-2^63 (- unc-2^63))
|
|
||||||
;; Wrap to a signed 64-bit value. Fast path: an exact integer already in
|
|
||||||
;; [-2^63, 2^63) is its own wrap — skip the bignum mask, which on Chez (61-bit
|
|
||||||
;; fixnums) allocates for any value past 2^60. Only an out-of-range result (a
|
|
||||||
;; multiply overflowing into 128 bits) needs the mask + sign fixup.
|
|
||||||
(define (jolt-wrap64 x)
|
|
||||||
(if (and (exact? x) (integer? x) (>= x unc-neg-2^63) (< x unc-2^63))
|
|
||||||
x
|
|
||||||
(let ((m (bitwise-and (if (and (number? x) (exact? x) (integer? x)) x (exact (floor x))) unc-mask64)))
|
|
||||||
(if (>= m unc-2^63) (- m unc-2^64) m))))
|
|
||||||
;; unchecked-* only WRAP integer (long) math; on a flonum OR ratio operand they
|
|
||||||
;; are an ordinary numeric op, since *unchecked-math* never wraps a non-long —
|
|
||||||
;; Clojure's unchecked-add falls back to regular arithmetic for non-primitives:
|
|
||||||
;; (unchecked-multiply 1.5 2.0) => 3.0, (unchecked-add 2/3 2/3) => 4/3, not a
|
|
||||||
;; truncated long. (test.check's rand-double is (* double-unit shifted), and
|
|
||||||
;; gen/ratio sums ratios, both under *unchecked-math*.) Wrap iff both are exact
|
|
||||||
;; integers.
|
|
||||||
(define (unc-int? x) (and (exact? x) (integer? x)))
|
|
||||||
(define (jolt-uncadd2 a b) (if (and (unc-int? a) (unc-int? b)) (jolt-wrap64 (+ a b)) (+ a b)))
|
|
||||||
(define (jolt-uncsub2 a b) (if (and (unc-int? a) (unc-int? b)) (jolt-wrap64 (- a b)) (- a b)))
|
|
||||||
(define (jolt-uncmul2 a b) (if (and (unc-int? a) (unc-int? b)) (jolt-wrap64 (* a b)) (* a b)))
|
|
||||||
(define (jolt-uncinc x) (if (unc-int? x) (jolt-wrap64 (+ x 1)) (+ x 1)))
|
|
||||||
(define (jolt-uncdec x) (if (unc-int? x) (jolt-wrap64 (- x 1)) (- x 1)))
|
|
||||||
(define (jolt-uncneg x) (if (unc-int? x) (jolt-wrap64 (- x)) (- x)))
|
|
||||||
(define (jolt-unchecked-add . xs) (if (null? xs) 0 (fold-left jolt-uncadd2 (car xs) (cdr xs))))
|
|
||||||
(define (jolt-unchecked-mul . xs) (if (null? xs) 1 (fold-left jolt-uncmul2 (car xs) (cdr xs))))
|
|
||||||
(define (jolt-unchecked-sub . xs)
|
|
||||||
(cond ((null? xs) 0) ((null? (cdr xs)) (jolt-uncneg (car xs))) (else (fold-left jolt-uncsub2 (car xs) (cdr xs)))))
|
|
||||||
(define (jolt-unchecked-div a b) (quotient (jolt-wrap64 a) (jolt-wrap64 b)))
|
|
||||||
(define (jolt-unchecked-rem a b) (remainder (jolt-wrap64 a) (jolt-wrap64 b)))
|
|
||||||
;; the clojure.core/unchecked-* vars are def-var!'d in natives-seq.ss (def-var! is
|
|
||||||
;; defined after this file loads).
|
|
||||||
|
|
||||||
;; --- ^long ops that tolerate a full 64-bit value -----------------------------
|
|
||||||
;; A ^long is 64-bit but a Chez fixnum is only 61-bit, so the backend's fast fx
|
|
||||||
;; ops would raise on a value past 2^60 (e.g. a long from the PRNG / wrapping
|
|
||||||
;; arithmetic). These take the fx fast path when the operands ARE fixnums and fall
|
|
||||||
;; back to the generic op otherwise — so ^long comparisons / quot / min etc. on a
|
|
||||||
;; full-width long stay correct. Macros (define-syntax) so the fast path inlines.
|
|
||||||
(define-syntax define-l-binop
|
|
||||||
(syntax-rules ()
|
|
||||||
((_ name fxop genop)
|
|
||||||
(define-syntax name
|
|
||||||
(syntax-rules ()
|
|
||||||
((_ a b) (let ((x a) (y b))
|
|
||||||
(if (and (fixnum? x) (fixnum? y)) (fxop x y) (genop x y)))))))))
|
|
||||||
(define-l-binop jolt-l< fx<? <)
|
|
||||||
(define-l-binop jolt-l<= fx<=? <=)
|
|
||||||
(define-l-binop jolt-l> fx>? >)
|
|
||||||
(define-l-binop jolt-l>= fx>=? >=)
|
|
||||||
(define-l-binop jolt-l= fx=? =)
|
|
||||||
(define-l-binop jolt-l-min fxmin min)
|
|
||||||
(define-l-binop jolt-l-max fxmax max)
|
|
||||||
(define-l-binop jolt-l-quot fxquotient quotient)
|
|
||||||
(define-l-binop jolt-l-rem fxremainder remainder)
|
|
||||||
(define-l-binop jolt-l-mod fxmodulo modulo)
|
|
||||||
(define-syntax jolt-l-inc (syntax-rules () ((_ a) (let ((x a)) (if (fixnum? x) (fx1+ x) (+ x 1))))))
|
|
||||||
(define-syntax jolt-l-dec (syntax-rules () ((_ a) (let ((x a)) (if (fixnum? x) (fx1- x) (- x 1))))))
|
|
||||||
|
|
||||||
;; ============================================================================
|
;; ============================================================================
|
||||||
;; IFn dispatch — the dynamic "value as fn" fallback. A callee that the emitter
|
;; IFn dispatch — the dynamic "value as fn" fallback. A callee that the emitter
|
||||||
;; can't statically resolve to a procedure (a keyword/coll/proc held in a local)
|
;; can't statically resolve to a procedure (a keyword/coll/proc held in a local)
|
||||||
;; routes here. Off the arithmetic/self-recursion hot path by construction.
|
;; routes here. Off the arithmetic/self-recursion hot path by construction.
|
||||||
;; ============================================================================
|
;; ============================================================================
|
||||||
;; (pred . handler) arms making a host type invocable; handler gets (f args).
|
|
||||||
(define jolt-invoke-arms '())
|
|
||||||
(define (register-invoke-arm! pred handler)
|
|
||||||
(set! jolt-invoke-arms (cons (cons pred handler) jolt-invoke-arms)))
|
|
||||||
(define (jolt-invoke-arm-for f)
|
|
||||||
(let loop ((as jolt-invoke-arms))
|
|
||||||
(cond ((null? as) #f)
|
|
||||||
(((caar as) f) (cdar as))
|
|
||||||
(else (loop (cdr as))))))
|
|
||||||
|
|
||||||
(define (jolt-invoke f . args)
|
(define (jolt-invoke f . args)
|
||||||
(cond
|
(cond
|
||||||
((procedure? f) (apply f args))
|
((procedure? f) (apply f args))
|
||||||
((keyword? f) (apply jolt-get (car args) f (cdr args))) ; (:k m [d]) -> (get m :k [d])
|
((keyword? f) (apply jolt-get (car args) f (cdr args))) ; (:k m [d]) -> (get m :k [d])
|
||||||
((jolt-symbol? f) (apply jolt-get (car args) f (cdr args))) ; ('s m [d]) -> (get m 's [d])
|
|
||||||
;; a VECTOR invokes as nth (a bad index throws, like IPersistentVector.invoke);
|
|
||||||
;; maps and sets invoke as get.
|
|
||||||
((pvec? f) (if (and (pair? args) (null? (cdr args)))
|
|
||||||
(jolt-nth f (car args))
|
|
||||||
(apply jolt-get f args)))
|
|
||||||
((jolt-coll? f) (apply jolt-get f args)) ; (coll k [d]) -> (get coll k [d])
|
((jolt-coll? f) (apply jolt-get f args)) ; (coll k [d]) -> (get coll k [d])
|
||||||
((jolt-transient? f) (apply jolt-get f args)) ; a transient vec/map/set is callable on the JVM
|
((jolt-transient? f) (apply jolt-get f args)) ; a transient vec/map/set is callable on the JVM
|
||||||
;; a record/reify implementing clojure.lang.IFn is callable: dispatch to its
|
;; a record/reify implementing clojure.lang.IFn is callable: dispatch to its
|
||||||
|
|
@ -473,73 +152,7 @@
|
||||||
=> (lambda (m) (apply jolt-invoke m f args)))
|
=> (lambda (m) (apply jolt-invoke m f args)))
|
||||||
((and (reified-methods f) (hashtable-ref (reified-methods f) "invoke" #f))
|
((and (reified-methods f) (hashtable-ref (reified-methods f) "invoke" #f))
|
||||||
=> (lambda (m) (apply jolt-invoke m f args)))
|
=> (lambda (m) (apply jolt-invoke m f args)))
|
||||||
;; host types registered as callable (promise delivers, …): consulted only
|
(else (error 'invoke "not a fn" f))))
|
||||||
;; after every built-in case missed, so the hot dispatch pays nothing.
|
|
||||||
((jolt-invoke-arm-for f) => (lambda (h) (h f args)))
|
|
||||||
;; calling a non-fn: a ClassCastException naming the operator's CLASS (like
|
|
||||||
;; the JVM's "class clojure.lang.LazySeq cannot be cast to ... IFn" — never
|
|
||||||
;; the value, whose printed form may be unbounded: ((range)) must throw, not
|
|
||||||
;; hang rendering an infinite seq). Thrown via jolt-throw so it is catchable
|
|
||||||
;; and carries the throw-site continuation for a stack trace.
|
|
||||||
(else (jolt-throw (jolt-host-throwable "java.lang.ClassCastException"
|
|
||||||
(string-append
|
|
||||||
"class "
|
|
||||||
(guard (e (#t "value"))
|
|
||||||
(let ((c (jolt-class-name f)))
|
|
||||||
(if (string? c) c (jolt-pr-str f))))
|
|
||||||
" cannot be cast to class clojure.lang.IFn"))))))
|
|
||||||
|
|
||||||
;; ============================================================================
|
|
||||||
;; chunked-seq accessors — the host side of the Clojure IChunkedSeq contract
|
|
||||||
;; (chunk-first ++ chunk-rest == the seq). Two chunked shapes share the cseq
|
|
||||||
;; record: a vector-backed seq (cvec = whole pvec, ci = absolute index, crest #f,
|
|
||||||
;; rest = next 32-block of cvec) and a ChunkedCons (cvec = standalone chunk pvec,
|
|
||||||
;; crest = the after-chunk seq). natives-array.ss binds these into clojure.core and
|
|
||||||
;; the chunk-buffer/chunk/chunk-cons builder API on top of them.
|
|
||||||
;; ============================================================================
|
|
||||||
(define seq-chunk-size 32)
|
|
||||||
;; (chunk-pvec . end-index) for a chunked cell, else #f. A ChunkedCons block is the
|
|
||||||
;; whole remaining chunk (crest carries what comes after); a vector seq block is the
|
|
||||||
;; next <=32 elements within cvec.
|
|
||||||
(define (na-vblock s)
|
|
||||||
(and (cseq? s) (cseq-cvec s)
|
|
||||||
(let ((v (cseq-cvec s)) (i (cseq-ci s)))
|
|
||||||
(cons v (if (cseq-crest s) (pvec-count v) (fxmin (fx+ i seq-chunk-size) (pvec-count v)))))))
|
|
||||||
(define (na-chunked-seq? x) (and (na-vblock x) #t))
|
|
||||||
;; Copy the block [i, end) straight out of the pvec trie's 32-element leaf node
|
|
||||||
;; (pv-chunk-for is O(log n)). seq-chunk-size == pv-width and vector-seq blocks are
|
|
||||||
;; 32-aligned, so a block is exactly one leaf; the rare non-aligned window crossing
|
|
||||||
;; a leaf boundary falls back to per-index reads. Flattening the whole backing
|
|
||||||
;; vector per block (pvec-v) made chunk-first O(n), so walking chunk-by-chunk was
|
|
||||||
;; O(n^2). A ChunkedCons chunk is a small tail-only pvec, so the leaf IS the chunk.
|
|
||||||
(define (na-chunk-first s)
|
|
||||||
(let ((vb (na-vblock s)))
|
|
||||||
(if vb
|
|
||||||
(let* ((pv (car vb)) (i (cseq-ci s)) (end (cdr vb)) (len (fx- end i))
|
|
||||||
(node (pv-chunk-for pv i)) (off (fxand i pv-mask)))
|
|
||||||
(if (fx<=? (fx+ off len) (vector-length node))
|
|
||||||
(make-pvec (vec-copy-range node off (fx+ off len)))
|
|
||||||
(let ((out (make-vector len)))
|
|
||||||
(let loop ((j 0))
|
|
||||||
(if (fx<? j len)
|
|
||||||
(begin (vector-set! out j (pvec-nth-d pv (fx+ i j) jolt-nil)) (loop (fx+ j 1)))
|
|
||||||
(make-pvec out))))))
|
|
||||||
(jolt-first s)))) ; eager-buffer fallback
|
|
||||||
;; chunk-rest / chunk-next: drop the whole current chunk. For a ChunkedCons that is
|
|
||||||
;; crest (the after-chunk seq); for a vector seq it is the seq at the next block.
|
|
||||||
(define (na-chunk-rest s)
|
|
||||||
(cond
|
|
||||||
((and (cseq? s) (cseq-crest s))
|
|
||||||
(let ((r (jolt-seq (cseq-crest s)))) (if (jolt-nil? r) jolt-empty-list r)))
|
|
||||||
((na-vblock s) => (lambda (vb)
|
|
||||||
(if (fx>=? (cdr vb) (pvec-count (car vb))) jolt-empty-list (vec->seq (car vb) (cdr vb)))))
|
|
||||||
(else (jolt-rest s))))
|
|
||||||
(define (na-chunk-next s)
|
|
||||||
(cond
|
|
||||||
((and (cseq? s) (cseq-crest s)) (jolt-seq (cseq-crest s)))
|
|
||||||
((na-vblock s) => (lambda (vb)
|
|
||||||
(if (fx>=? (cdr vb) (pvec-count (car vb))) jolt-nil (vec->seq (car vb) (cdr vb)))))
|
|
||||||
(else (jolt-next s))))
|
|
||||||
|
|
||||||
;; ============================================================================
|
;; ============================================================================
|
||||||
;; map / filter / reduce / into / remove + range / take / concat / apply
|
;; map / filter / reduce / into / remove + range / take / concat / apply
|
||||||
|
|
@ -549,96 +162,44 @@
|
||||||
;; an empty seq, so (= () (map f [])) is true and (nil? (map f [])) is false.
|
;; an empty seq, so (= () (map f [])) is true and (nil? (map f [])) is false.
|
||||||
;; jolt-empty-list seqs back to nil, so it stays a valid lazy-tail terminator for
|
;; jolt-empty-list seqs back to nil, so it stays a valid lazy-tail terminator for
|
||||||
;; the non-empty case (printing / seq= / reduce all walk via jolt-seq).
|
;; the non-empty case (printing / seq= / reduce all walk via jolt-seq).
|
||||||
;; Single-coll map (core.clj's [f coll] arity). Chunk-preserving: when the source
|
|
||||||
;; seq is chunked, realize the WHOLE first chunk — apply f to every element eagerly
|
|
||||||
;; into a fresh chunk — and chunk-cons it onto a lazy map of chunk-rest, so the
|
|
||||||
;; result is itself a chunked-seq. A non-chunked source maps one element at a time.
|
|
||||||
(define (map-seq f s)
|
(define (map-seq f s)
|
||||||
(cond
|
(if (jolt-nil? s) jolt-empty-list
|
||||||
((jolt-nil? s) jolt-empty-list)
|
(cseq-lazy (jolt-invoke f (seq-first s)) (lambda () (map-seq f (jolt-seq (seq-more s)))))))
|
||||||
((na-chunked-seq? s)
|
|
||||||
(let* ((c (na-chunk-first s)) (n (pvec-count c)) (out (make-vector n)))
|
|
||||||
(let loop ((i 0))
|
|
||||||
(if (fx<? i n)
|
|
||||||
(begin (vector-set! out i (jolt-invoke f (pvec-nth-d c i jolt-nil))) (loop (fx+ i 1)))
|
|
||||||
(cseq-chunked (make-pvec out) 0
|
|
||||||
(jolt-make-lazy-seq (lambda () (jolt-seq (map-seq f (jolt-seq (na-chunk-rest s)))))))))))
|
|
||||||
(else
|
|
||||||
(cseq-lazy (jolt-invoke f (seq-first s)) (lambda () (map-seq f (jolt-seq (seq-more s))))))))
|
|
||||||
(define (map-seq* f seqs) ; multi-collection map; stops at the shortest
|
(define (map-seq* f seqs) ; multi-collection map; stops at the shortest
|
||||||
(if (any-nil? seqs) jolt-empty-list
|
(if (any-nil? seqs) jolt-empty-list
|
||||||
(cseq-lazy (apply jolt-invoke f (map seq-first seqs))
|
(cseq-lazy (apply jolt-invoke f (map seq-first seqs))
|
||||||
(lambda () (map-seq* f (map (lambda (s) (jolt-seq (seq-more s))) seqs))))))
|
(lambda () (map-seq* f (map (lambda (s) (jolt-seq (seq-more s))) seqs))))))
|
||||||
;; map is fully lazy: Clojure's (map f coll) is a LazySeq whose body — including
|
|
||||||
;; (f (first coll)) — runs only when forced, so a side-effecting f does not fire
|
|
||||||
;; at construction. Wrap the (eager-headed) map-seq in a lazy-seq node; forcing it
|
|
||||||
;; once yields the cseq chain, which then iterates with no per-element overhead.
|
|
||||||
;; jolt-seq coerces map-seq's result (cseq | jolt-empty-list) to cseq | nil, the
|
|
||||||
;; contract force-lazyseq relies on (see jolt-rest).
|
|
||||||
(define (jolt-map f . colls)
|
(define (jolt-map f . colls)
|
||||||
(if (null? (cdr colls))
|
(if (null? (cdr colls))
|
||||||
(jolt-make-lazy-seq (lambda () (jolt-seq (map-seq f (jolt-seq (car colls))))))
|
(map-seq f (jolt-seq (car colls)))
|
||||||
(jolt-make-lazy-seq (lambda () (jolt-seq (map-seq* f (map jolt-seq colls)))))))
|
(map-seq* f (map jolt-seq colls))))
|
||||||
|
|
||||||
;; Chunk-preserving, like core.clj filter: a chunked source has pred applied to the
|
|
||||||
;; whole chunk, the kept elements packed into a fresh (possibly smaller) chunk, and
|
|
||||||
;; that chunk-cons'd onto a lazy filter of chunk-rest. An all-rejected chunk emits
|
|
||||||
;; no empty cell — it recurses straight into chunk-rest (chunk-cons of an empty
|
|
||||||
;; chunk == its rest). A non-chunked source filters one element at a time.
|
|
||||||
(define (filter-seq pred s keep)
|
(define (filter-seq pred s keep)
|
||||||
(cond
|
(let loop ((s s))
|
||||||
((jolt-nil? s) jolt-empty-list) ; empty result is () (see map-seq)
|
(cond ((jolt-nil? s) jolt-empty-list) ; empty result is () (see map-seq)
|
||||||
((na-chunked-seq? s)
|
((eq? keep (jolt-truthy? (jolt-invoke pred (seq-first s))))
|
||||||
(let* ((c (na-chunk-first s)) (n (pvec-count c)))
|
(cseq-lazy (seq-first s) (lambda () (filter-seq pred (jolt-seq (seq-more s)) keep))))
|
||||||
(let loop ((i 0) (acc '()))
|
(else (loop (jolt-seq (seq-more s)))))))
|
||||||
(if (fx<? i n)
|
(define (jolt-filter pred coll) (filter-seq pred (jolt-seq coll) #t))
|
||||||
(let ((x (pvec-nth-d c i jolt-nil)))
|
(define (jolt-remove pred coll) (filter-seq pred (jolt-seq coll) #f))
|
||||||
(loop (fx+ i 1) (if (eq? keep (jolt-truthy? (jolt-invoke pred x))) (cons x acc) acc)))
|
|
||||||
(let ((kept (reverse acc)))
|
|
||||||
(if (null? kept)
|
|
||||||
(filter-seq pred (jolt-seq (na-chunk-rest s)) keep)
|
|
||||||
(cseq-chunked (make-pvec (list->vector kept)) 0
|
|
||||||
(jolt-make-lazy-seq
|
|
||||||
(lambda () (jolt-seq (filter-seq pred (jolt-seq (na-chunk-rest s)) keep)))))))))))
|
|
||||||
(else
|
|
||||||
(let walk ((s s))
|
|
||||||
(cond ((jolt-nil? s) jolt-empty-list)
|
|
||||||
((eq? keep (jolt-truthy? (jolt-invoke pred (seq-first s))))
|
|
||||||
(cseq-lazy (seq-first s) (lambda () (filter-seq pred (jolt-seq (seq-more s)) keep))))
|
|
||||||
(else (walk (jolt-seq (seq-more s)))))))))
|
|
||||||
;; filter/remove are fully lazy (LazySeq): defer the predicate and the source seq
|
|
||||||
;; until forced, like Clojure. (lazy-seq* = a 0-arg lazy node coercing to cseq|nil.)
|
|
||||||
(define (jolt-filter pred coll)
|
|
||||||
(jolt-make-lazy-seq (lambda () (jolt-seq (filter-seq pred (jolt-seq coll) #t)))))
|
|
||||||
(define (jolt-remove pred coll)
|
|
||||||
(jolt-make-lazy-seq (lambda () (jolt-seq (filter-seq pred (jolt-seq coll) #f)))))
|
|
||||||
|
|
||||||
;; honors `reduced`: a reducing fn that returns (reduced x) stops the fold and
|
;; honors `reduced`: a reducing fn that returns (reduced x) stops the fold and
|
||||||
;; unwraps to x (so does a reduced INIT). Checked at entry, so the value returned
|
;; unwraps to x (so does a reduced INIT). Checked at entry, so the value returned
|
||||||
;; by the last step is unwrapped on the next turn before the seq is consulted.
|
;; by the last step is unwrapped on the next turn before the seq is consulted.
|
||||||
;; reduce a vector's backing store directly by index from element i — no per-
|
;; reduce a vector's backing store directly by index from element i — no per-
|
||||||
;; element seq cells. Honors `reduced`. The chunked-seq fast path.
|
;; element seq cells. Honors `reduced`. The chunked-seq fast path.
|
||||||
;; Reduce a chunk pvec from index i. Returns the accumulator RAW — a `reduced` box
|
|
||||||
;; is returned unwrapped-by reduce-seq, not here — so a ChunkedCons continuation can
|
|
||||||
;; see early termination instead of folding it back into the running value.
|
|
||||||
(define (vec-reduce f acc v i)
|
(define (vec-reduce f acc v i)
|
||||||
(let ((n (pvec-count v)) (raw (pvec-v v)))
|
(let ((n (pvec-count v)) (raw (pvec-v v)))
|
||||||
(let loop ((i i) (acc acc))
|
(let loop ((i i) (acc acc))
|
||||||
(cond ((jolt-reduced? acc) acc)
|
(cond ((jolt-reduced? acc) (jolt-reduced-val acc))
|
||||||
((fx>=? i n) acc)
|
((fx>=? i n) acc)
|
||||||
(else (loop (fx+ i 1) (jolt-invoke f acc (vector-ref raw i))))))))
|
(else (loop (fx+ i 1) (jolt-invoke f acc (vector-ref raw i))))))))
|
||||||
(define (reduce-seq f acc s)
|
(define (reduce-seq f acc s)
|
||||||
(cond
|
(cond
|
||||||
((jolt-reduced? acc) (jolt-reduced-val acc))
|
((jolt-reduced? acc) (jolt-reduced-val acc))
|
||||||
((jolt-nil? s) acc)
|
((jolt-nil? s) acc)
|
||||||
;; a chunked seq reduces its chunk pvec directly, in a tight loop. A vector seq
|
;; a vector-backed (chunked) seq reduces its vector directly, in a tight loop.
|
||||||
;; (crest #f) reduces the whole backing vector and is then done; a ChunkedCons
|
((and (cseq? s) (cseq-cvec s)) (vec-reduce f acc (cseq-cvec s) (cseq-ci s)))
|
||||||
;; reduces this chunk and continues into its after-chunk rest.
|
|
||||||
((and (cseq? s) (cseq-cvec s))
|
|
||||||
(let ((acc2 (vec-reduce f acc (cseq-cvec s) (cseq-ci s))))
|
|
||||||
(cond ((jolt-reduced? acc2) (jolt-reduced-val acc2))
|
|
||||||
((cseq-crest s) (reduce-seq f acc2 (jolt-seq (cseq-crest s))))
|
|
||||||
(else acc2))))
|
|
||||||
(else (reduce-seq f (jolt-invoke f acc (seq-first s)) (jolt-seq (seq-more s))))))
|
(else (reduce-seq f (jolt-invoke f acc (seq-first s)) (jolt-seq (seq-more s))))))
|
||||||
(define jolt-reduce
|
(define jolt-reduce
|
||||||
(case-lambda
|
(case-lambda
|
||||||
|
|
@ -646,11 +207,11 @@
|
||||||
(if (jolt-nil? s) (jolt-invoke f) ; (reduce f []) -> (f)
|
(if (jolt-nil? s) (jolt-invoke f) ; (reduce f []) -> (f)
|
||||||
(reduce-seq f (seq-first s) (jolt-seq (seq-more s))))))
|
(reduce-seq f (seq-first s) (jolt-seq (seq-more s))))))
|
||||||
((f init coll)
|
((f init coll)
|
||||||
;; IReduceInit: a deftype/record OR reify with its own `reduce` method drives
|
;; IReduceInit: a reify/record with its own `reduce` method drives the
|
||||||
;; the reduction, e.g. (reduce f init (reify clojure.lang.IReduceInit
|
;; reduction (reduce f init (reify clojure.lang.IReduceInit (reduce [_ f i] ...))).
|
||||||
;; (reduce [_ f i] ...))) or the same on a deftype.
|
|
||||||
(cond
|
(cond
|
||||||
((iface-method coll "reduce" 3)
|
((and (jreify? coll) (reified-methods coll)
|
||||||
|
(hashtable-ref (reified-methods coll) "reduce" #f))
|
||||||
=> (lambda (m) (let ((r (jolt-invoke m coll f init)))
|
=> (lambda (m) (let ((r (jolt-invoke m coll f init)))
|
||||||
(if (jolt-reduced? r) (jolt-reduced-val r) r))))
|
(if (jolt-reduced? r) (jolt-reduced-val r) r))))
|
||||||
(else (reduce-seq f init (jolt-seq coll)))))))
|
(else (reduce-seq f init (jolt-seq coll)))))))
|
||||||
|
|
@ -661,73 +222,32 @@
|
||||||
;; falls back to a copy-on-write wrapper for other targets (lists, sorted colls,
|
;; falls back to a copy-on-write wrapper for other targets (lists, sorted colls,
|
||||||
;; nil), so those keep the old per-step jolt-conj behaviour.
|
;; nil), so those keep the old per-step jolt-conj behaviour.
|
||||||
(define (jolt-into to from)
|
(define (jolt-into to from)
|
||||||
;; only an editable collection rides the transient path; anything else
|
(meta-carry to
|
||||||
;; (PersistentQueue, sorted colls, seqs) folds through conj, like RT's
|
(jolt-persistent! (reduce-seq (lambda (t x) (jolt-conj! t x)) (jolt-transient-new to) (jolt-seq from)))))
|
||||||
;; instanceof IEditableCollection split.
|
|
||||||
(if (or (pvec? to) (pmap? to) (pset? to))
|
|
||||||
(meta-carry to
|
|
||||||
(jolt-persistent! (reduce-seq (lambda (t x) (jolt-conj! t x)) (jolt-transient-new to) (jolt-seq from))))
|
|
||||||
(meta-carry to
|
|
||||||
(reduce-seq (lambda (acc x) (jolt-conj1 acc x)) to (jolt-seq from)))))
|
|
||||||
|
|
||||||
(define (range-from n) (cseq-lazy n (lambda () (range-from (+ n 1)))))
|
(define (range-from n) (cseq-lazy n (lambda () (range-from (+ n 1)))))
|
||||||
;; A bounded range is a real chunked-seq, like clojure.lang.LongRange: eager, with
|
(define (range-bounded n end step)
|
||||||
;; chunk-first handing out a block of up to 32 consecutive values. Each block is
|
|
||||||
;; materialized into a pvec and chunk-cons'd onto a lazy continuation, so a chunked
|
|
||||||
;; map/filter over a range batches by 32 (the JVM's observable realization), while a
|
|
||||||
;; huge range still produces its tail one block at a time.
|
|
||||||
;; An empty range is () (jolt-empty-list), NOT nil — (range 0) and (range 5 5) are
|
|
||||||
;; empty seqs in Clojure, so (= () (range 0)) holds, and () seqs back to nil so it
|
|
||||||
;; also terminates the chunked tail (see jolt-take).
|
|
||||||
(define (range-chunked n end step)
|
|
||||||
(if (if (> step 0.0) (< n end) (> n end))
|
(if (if (> step 0.0) (< n end) (> n end))
|
||||||
(let loop ((i 0) (v n) (acc '()))
|
(cseq-lazy n (lambda () (range-bounded (+ n step) end step)))
|
||||||
(if (and (fx<? i seq-chunk-size) (if (> step 0.0) (< v end) (> v end)))
|
jolt-nil))
|
||||||
(loop (fx+ i 1) (+ v step) (cons v acc))
|
|
||||||
(cseq-chunked (make-pvec (list->vector (reverse acc))) 0
|
|
||||||
(jolt-make-lazy-seq (lambda () (jolt-seq (range-chunked v end step)))))))
|
|
||||||
jolt-empty-list))
|
|
||||||
;; numeric tower: exact 0/1 defaults so (range 3) yields exact ints
|
;; numeric tower: exact 0/1 defaults so (range 3) yields exact ints
|
||||||
;; (= JVM longs); flonum args still produce flonums (Scheme arithmetic preserves).
|
;; (= JVM longs); flonum args still produce flonums (Scheme arithmetic preserves).
|
||||||
;; (range) with no bound is the lazy, NON-chunked (iterate inc' 0) form.
|
|
||||||
(define jolt-range
|
(define jolt-range
|
||||||
(case-lambda
|
(case-lambda
|
||||||
(() (range-from 0))
|
(() (range-from 0))
|
||||||
((end) (range-chunked 0 end 1))
|
((end) (range-bounded 0 end 1))
|
||||||
((start end) (range-chunked start end 1))
|
((start end) (range-bounded start end 1))
|
||||||
((start end step) (range-chunked start end step))))
|
((start end step) (range-bounded start end step))))
|
||||||
|
|
||||||
;; An empty take result is () (jolt-empty-list), NOT nil — (take 0 coll) and
|
|
||||||
;; (take n []) are empty seqs in Clojure, so (= () (take 0 [:a])) and printing
|
|
||||||
;; "()" hold. jolt-empty-list seqs back to nil, so it also terminates the lazy
|
|
||||||
;; tail when n hits 0 mid-stream (see map-seq).
|
|
||||||
;; The LAST element (n=1) terminates without touching the rest, so (take n s)
|
|
||||||
;; realizes exactly n elements of a side-effecting seq — matching Clojure, where
|
|
||||||
;; (take 0 (rest s)) never seqs coll. Realizing one more, as forcing seq-more at
|
|
||||||
;; the boundary would, over-runs the source by one (medley's sequence-padded).
|
|
||||||
(define (jolt-take n coll)
|
(define (jolt-take n coll)
|
||||||
;; lazy (LazySeq): realize exactly n elements, none at construction. (take
|
(let ((n (->idx n)))
|
||||||
;; Double/POSITIVE_INFINITY coll) takes the whole coll on the JVM (the count
|
(let loop ((n n) (s (jolt-seq coll)))
|
||||||
;; never reaches 0); test.check's rose-tree unchunk relies on it. Coercing +inf.0
|
(if (or (fx<=? n 0) (jolt-nil? s)) jolt-nil
|
||||||
;; to a fixnum index would throw, so take all up front in that case.
|
(cseq-lazy (seq-first s) (lambda () (loop (fx- n 1) (jolt-seq (seq-more s)))))))))
|
||||||
(jolt-make-lazy-seq
|
|
||||||
(lambda ()
|
|
||||||
(jolt-seq
|
|
||||||
(if (and (flonum? n) (infinite? n))
|
|
||||||
(if (> n 0.0) (jolt-seq coll) jolt-empty-list)
|
|
||||||
(let ((n (->idx n)))
|
|
||||||
(let loop ((n n) (s (jolt-seq coll)))
|
|
||||||
(cond
|
|
||||||
((or (fx<=? n 0) (jolt-nil? s)) jolt-empty-list)
|
|
||||||
((fx=? n 1) (cseq-lazy (seq-first s) (lambda () jolt-empty-list)))
|
|
||||||
(else (cseq-lazy (seq-first s) (lambda () (loop (fx- n 1) (jolt-seq (seq-more s))))))))))))))
|
|
||||||
(define (jolt-drop n coll)
|
(define (jolt-drop n coll)
|
||||||
(jolt-make-lazy-seq
|
(let loop ((n (->idx n)) (s (jolt-seq coll)))
|
||||||
(lambda ()
|
(if (or (fx<=? n 0) (jolt-nil? s)) (if (jolt-nil? s) jolt-empty-list s)
|
||||||
(jolt-seq
|
(loop (fx- n 1) (jolt-seq (seq-more s))))))
|
||||||
(let loop ((n (->idx n)) (s (jolt-seq coll)))
|
|
||||||
(if (or (fx<=? n 0) (jolt-nil? s)) (if (jolt-nil? s) jolt-empty-list s)
|
|
||||||
(loop (fx- n 1) (jolt-seq (seq-more s)))))))))
|
|
||||||
|
|
||||||
;; lazily append seq a then the seqable produced by the thunk `brest` — the rest
|
;; lazily append seq a then the seqable produced by the thunk `brest` — the rest
|
||||||
;; is NOT forced until a is exhausted, so concat is fully lazy (Clojure semantics).
|
;; is NOT forced until a is exhausted, so concat is fully lazy (Clojure semantics).
|
||||||
|
|
@ -738,32 +258,14 @@
|
||||||
(if (jolt-nil? a) (jolt-seq (brest))
|
(if (jolt-nil? a) (jolt-seq (brest))
|
||||||
(cseq-lazy (seq-first a) (lambda () (concat2 (jolt-seq (seq-more a)) brest)))))
|
(cseq-lazy (seq-first a) (lambda () (concat2 (jolt-seq (seq-more a)) brest)))))
|
||||||
(define (jolt-concat . colls)
|
(define (jolt-concat . colls)
|
||||||
(jolt-make-lazy-seq
|
(cond ((null? colls) jolt-empty-list)
|
||||||
(lambda ()
|
((null? (cdr colls)) (jolt-seq (car colls)))
|
||||||
(jolt-seq
|
(else (concat2 (jolt-seq (car colls)) (lambda () (apply jolt-concat (cdr colls)))))))
|
||||||
(cond ((null? colls) jolt-empty-list)
|
|
||||||
((null? (cdr colls)) (jolt-seq (car colls)))
|
|
||||||
(else (concat2 (jolt-seq (car colls)) (lambda () (apply jolt-concat (cdr colls))))))))))
|
|
||||||
|
|
||||||
;; Lazily concatenate a (possibly infinite) SEQ of colls — what (apply concat ss)
|
;; (apply f a b ... coll): spread the trailing seqable into the call.
|
||||||
;; means, but without realizing ss. Pulls one coll at a time, concatenating it with
|
|
||||||
;; a lazy tail, so mapcat / (apply concat …) over an infinite source stays lazy.
|
|
||||||
(define (lazy-concat-seq ss)
|
|
||||||
(let ((s (jolt-seq ss)))
|
|
||||||
(if (jolt-nil? s)
|
|
||||||
jolt-empty-list
|
|
||||||
(jolt-concat (seq-first s)
|
|
||||||
(jolt-make-lazy-seq (lambda () (lazy-concat-seq (seq-more s))))))))
|
|
||||||
|
|
||||||
;; (apply f a b ... coll): spread the trailing seqable into the call. concat is
|
|
||||||
;; special-cased: it produces a LAZY result, so spreading an infinite tail through
|
|
||||||
;; a Scheme variadic (which must realize it) would hang — route to lazy-concat-seq,
|
|
||||||
;; prepending any fixed leading colls.
|
|
||||||
(define (jolt-apply f . args)
|
(define (jolt-apply f . args)
|
||||||
(let* ((r (reverse args)) (tail (car r)) (fixed (reverse (cdr r))))
|
(let* ((r (reverse args)) (spread (seq->list (jolt-seq (car r)))) (fixed (reverse (cdr r))))
|
||||||
(if (eq? f jolt-concat)
|
(apply jolt-invoke f (append fixed spread))))
|
||||||
(lazy-concat-seq (fold-right jolt-cons (jolt-seq tail) fixed))
|
|
||||||
(apply jolt-invoke f (append fixed (seq->list (jolt-seq tail)))))))
|
|
||||||
|
|
||||||
;; ============================================================================
|
;; ============================================================================
|
||||||
;; numeric predicates / identity — usable in fn AND value position (map/filter).
|
;; numeric predicates / identity — usable in fn AND value position (map/filter).
|
||||||
|
|
@ -773,14 +275,8 @@
|
||||||
;; Parity over the full integer range (JVM even?/odd? accept any integer,
|
;; Parity over the full integer range (JVM even?/odd? accept any integer,
|
||||||
;; bignums included); a fixnum-only fxand crashes on a large value (e.g. a hash).
|
;; bignums included); a fixnum-only fxand crashes on a large value (e.g. a hash).
|
||||||
(define (parity-int n) (if (flonum? n) (exact (floor n)) n))
|
(define (parity-int n) (if (flonum? n) (exact (floor n)) n))
|
||||||
(define (jolt-parity-check n)
|
(define (jolt-even? n) (even? (parity-int n)))
|
||||||
(unless (and (number? n) (exact? n) (integer? n))
|
(define (jolt-odd? n) (odd? (parity-int n)))
|
||||||
(jolt-throw (jolt-host-throwable
|
|
||||||
"java.lang.IllegalArgumentException"
|
|
||||||
(string-append "Argument must be an integer: "
|
|
||||||
(guard (e (#t "?")) (jolt-str n)))))))
|
|
||||||
(define (jolt-even? n) (jolt-parity-check n) (even? (parity-int n)))
|
|
||||||
(define (jolt-odd? n) (jolt-parity-check n) (odd? (parity-int n)))
|
|
||||||
(define (jolt-pos? n) (> n 0))
|
(define (jolt-pos? n) (> n 0))
|
||||||
(define (jolt-neg? n) (< n 0))
|
(define (jolt-neg? n) (< n 0))
|
||||||
(define (jolt-zero? n) (= n 0))
|
(define (jolt-zero? n) (= n 0))
|
||||||
|
|
@ -789,18 +285,8 @@
|
||||||
;; ============================================================================
|
;; ============================================================================
|
||||||
;; keys / vals — return seqs (nil on the empty map), HAMT-iteration order
|
;; keys / vals — return seqs (nil on the empty map), HAMT-iteration order
|
||||||
;; ============================================================================
|
;; ============================================================================
|
||||||
;; keys/vals of anything empty is nil (RT.keys over a nil seq); a non-empty
|
(define (jolt-keys m) (if (jolt-nil? m) jolt-nil (list->cseq (pmap-fold m (lambda (k v a) (cons k a)) '()))))
|
||||||
;; non-map still fails (its elements are not MapEntries).
|
(define (jolt-vals m) (if (jolt-nil? m) jolt-nil (list->cseq (pmap-fold m (lambda (k v a) (cons v a)) '()))))
|
||||||
(define (jolt-keys m)
|
|
||||||
(cond ((jolt-nil? m) jolt-nil)
|
|
||||||
((pmap? m) (list->cseq (pmap-fold m (lambda (k v a) (cons k a)) '())))
|
|
||||||
((jolt-nil? (jolt-seq m)) jolt-nil)
|
|
||||||
(else (list->cseq (pmap-fold m (lambda (k v a) (cons k a)) '())))))
|
|
||||||
(define (jolt-vals m)
|
|
||||||
(cond ((jolt-nil? m) jolt-nil)
|
|
||||||
((pmap? m) (list->cseq (pmap-fold m (lambda (k v a) (cons v a)) '())))
|
|
||||||
((jolt-nil? (jolt-seq m)) jolt-nil)
|
|
||||||
(else (list->cseq (pmap-fold m (lambda (k v a) (cons v a)) '())))))
|
|
||||||
|
|
||||||
;; ============================================================================
|
;; ============================================================================
|
||||||
;; sequential equality + hash (hooks called from values.ss / collections.ss);
|
;; sequential equality + hash (hooks called from values.ss / collections.ss);
|
||||||
|
|
|
||||||
|
|
@ -18,51 +18,6 @@ check() {
|
||||||
}
|
}
|
||||||
pass=0
|
pass=0
|
||||||
|
|
||||||
# An uncaught error reports the source location of the top-level form (stderr).
|
|
||||||
check_loc() {
|
|
||||||
err="$(bin/joltc -e "$1" 2>&1 >/dev/null)"
|
|
||||||
if printf '%s' "$err" | grep -q "$2"; then
|
|
||||||
pass=$((pass + 1))
|
|
||||||
else
|
|
||||||
echo " FAIL (loc): $1"
|
|
||||||
echo " want stderr to contain \`$2\`, got \`$err\`"
|
|
||||||
fails=$((fails + 1))
|
|
||||||
fi
|
|
||||||
}
|
|
||||||
|
|
||||||
# An uncaught error's stack trace must name the runtime-eval'd fn frames that
|
|
||||||
# survive TCO (the non-tail spine), even though the eval path registers no source
|
|
||||||
# map — "print what is available". Asserts a substring appears under " trace:".
|
|
||||||
check_trace() {
|
|
||||||
err="$(bin/joltc -e "$1" 2>&1 >/dev/null)"
|
|
||||||
if printf '%s' "$err" | grep -q ' trace:' && printf '%s' "$err" | grep -q "$2"; then
|
|
||||||
pass=$((pass + 1))
|
|
||||||
else
|
|
||||||
echo " FAIL (trace): $1"
|
|
||||||
echo " want stderr trace to contain \`$2\`, got \`$err\`"
|
|
||||||
fails=$((fails + 1))
|
|
||||||
fi
|
|
||||||
}
|
|
||||||
|
|
||||||
# JOLT_TRACE opts into the tail-frame history (the ring of rings): every $2 (an
|
|
||||||
# ERE) must match the " trace:" block. Used to assert TCO-elided frames are
|
|
||||||
# recovered and non-tail caller context survives a tail loop.
|
|
||||||
check_trace_on() {
|
|
||||||
err="$(JOLT_TRACE=1 bin/joltc -e "$1" 2>&1 >/dev/null)"
|
|
||||||
ok=1
|
|
||||||
printf '%s' "$err" | grep -q ' trace:' || ok=0
|
|
||||||
shift
|
|
||||||
for want in "$@"; do
|
|
||||||
printf '%s' "$err" | grep -Eq "$want" || ok=0
|
|
||||||
done
|
|
||||||
if [ "$ok" = 1 ]; then
|
|
||||||
pass=$((pass + 1))
|
|
||||||
else
|
|
||||||
echo " FAIL (trace-on): want [$*] in trace, got \`$err\`"
|
|
||||||
fails=$((fails + 1))
|
|
||||||
fi
|
|
||||||
}
|
|
||||||
|
|
||||||
check '(+ 1 2)' '3'
|
check '(+ 1 2)' '3'
|
||||||
check '(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (fib 15)' '610'
|
check '(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (fib 15)' '610'
|
||||||
check '(->> (range 10) (filter even?) (map (fn [x] (* x x))) (reduce +))' '120'
|
check '(->> (range 10) (filter even?) (map (fn [x] (* x x))) (reduce +))' '120'
|
||||||
|
|
@ -76,188 +31,6 @@ check '(deref (future (+ 1 2)))' '3'
|
||||||
check '(/ 1 2)' '1/2'
|
check '(/ 1 2)' '1/2'
|
||||||
check '(= 3 3.0)' 'false'
|
check '(= 3 3.0)' 'false'
|
||||||
check '(== 3 3.0)' 'true'
|
check '(== 3 3.0)' 'true'
|
||||||
# a deftype whose simple name collides with a built-in host class must not shadow
|
|
||||||
# the java class: (java.io.PushbackReader. …) still builds the java reader (has
|
|
||||||
# .read), while the bare name in the deftype's own ns is the deftype. (Fresh -e
|
|
||||||
# process per check, so the deftype doesn't leak.)
|
|
||||||
check '(do (deftype PushbackReader [x]) (.read (java.io.PushbackReader. (java.io.StringReader. "A") 1)))' '65'
|
|
||||||
check '(do (deftype PushbackReader [x]) (.-x (PushbackReader. 42)))' '42'
|
|
||||||
check_loc '(throw (ex-info "boom" {}))' ' at 1:'
|
|
||||||
|
|
||||||
# A throw that crosses the eval boundary (eval / load-string) must surface its
|
|
||||||
# ex-info :message, not Chez's "attempt to apply non-procedure" noise from
|
|
||||||
# re-wrapping a raw value raised through `eval`.
|
|
||||||
check '(try (eval (read-string "(throw (ex-info \"boom\" {}))")) (catch :default e (ex-message e)))' 'boom'
|
|
||||||
check '(try (load-string "(+") (catch :default e (ex-message e)))' 'EOF while reading'
|
|
||||||
# An uncaught throw prints the ex-info message alongside its source location.
|
|
||||||
check_loc '(throw (ex-info "boom" {}))' 'boom'
|
|
||||||
check_loc '(do (+ 1 1) (/ 1 0))' ' at 1:'
|
|
||||||
|
|
||||||
# Runtime-eval'd fns aren't source-mapped, but their native frame names survive on
|
|
||||||
# the non-tail spine; the trace must show them. deepest/+ are tail calls (erased);
|
|
||||||
# middle and outer wait on a non-tail (inc …) so their frames are live at the throw.
|
|
||||||
trace_prog='(defn deepest [x] (+ x 1)) (defn middle [x] (inc (deepest x))) (defn outer [x] (inc (middle x))) (outer :nan)'
|
|
||||||
check_trace "$trace_prog" 'middle'
|
|
||||||
check_trace "$trace_prog" 'outer'
|
|
||||||
|
|
||||||
# JOLT_TRACE (tail-frame history / ring of rings). An all-tail chain is entirely
|
|
||||||
# TCO-erased from the continuation, but the history recovers every frame — incl.
|
|
||||||
# `deepest`, the actual error site.
|
|
||||||
check_trace_on '(defn deepest [x] (+ x 1)) (defn middle [x] (deepest x)) (defn outer [x] (middle x)) (outer :nan)' \
|
|
||||||
'deepest' 'middle' 'outer'
|
|
||||||
# A tail loop (a<->b) under a NON-tail caller: the loop is confined to one rib's
|
|
||||||
# bounded inner ring, so the caller context (`driver`, `top`) is NOT flushed out —
|
|
||||||
# the point of the ring of rings.
|
|
||||||
check_trace_on '(declare b) (defn a [n] (if (zero? n) (+ :x 1) (b (dec n)))) (defn b [n] (a n)) (defn driver [] (inc (a 6))) (defn top [] (inc (driver))) (top)' \
|
|
||||||
'driver' 'top'
|
|
||||||
# A ^long/^double return hint wraps the body in a coercion, so the hinted fn's call
|
|
||||||
# is NOT a tail call — its own frame is still live and must appear (not be elided).
|
|
||||||
check_trace_on '(defn g [n] (+ :x n)) (defn ^long f [n] (g n)) (f 3)' 'f' 'g'
|
|
||||||
# History is per top-level form: a later form's error trace shows its own frames
|
|
||||||
# (h2/u2), not frames from an earlier, already-returned form (h1/u1).
|
|
||||||
check_trace_on '(defn h1 [x] (inc x)) (defn u1 [] (inc (h1 5))) (u1) (defn h2 [x] (+ :x x)) (defn u2 [] (inc (h2 5))) (u2)' \
|
|
||||||
'h2' 'u2'
|
|
||||||
err_stale="$(JOLT_TRACE=1 bin/joltc -e '(defn h1 [x] (inc x)) (defn u1 [] (inc (h1 5))) (u1) (defn h2 [x] (+ :x x)) (defn u2 [] (inc (h2 5))) (u2)' 2>&1 >/dev/null)"
|
|
||||||
if printf '%s' "$err_stale" | grep -q 'h1'; then
|
|
||||||
echo " FAIL (trace-on): stale frame h1 from an earlier form leaked into the trace"
|
|
||||||
fails=$((fails + 1))
|
|
||||||
else
|
|
||||||
pass=$((pass + 1))
|
|
||||||
fi
|
|
||||||
# A file-backed project run maps each runtime-compiled frame to ns/name (file:line)
|
|
||||||
# — the eval path registers source in trace mode, so the trace isn't bare names.
|
|
||||||
tr_proj="$(mktemp -d)"
|
|
||||||
mkdir -p "$tr_proj/src/tp"
|
|
||||||
printf '{:paths ["src"] :aliases {:run {:main-opts ["-m" "tp.core"]}}}\n' > "$tr_proj/deps.edn"
|
|
||||||
printf '(ns tp.core)\n(defn deep [x] (+ x 1))\n(defn mid [x] (inc (deep x)))\n(defn -main [& _] (mid :nan))\n' > "$tr_proj/src/tp/core.clj"
|
|
||||||
tr_out="$(JOLT_TRACE=1 JOLT_PWD="$tr_proj" bin/joltc -M:run 2>&1)"
|
|
||||||
if printf '%s' "$tr_out" | grep -Eq 'tp\.core/deep \(.*/tp/core\.clj:2\)'; then
|
|
||||||
pass=$((pass + 1))
|
|
||||||
else
|
|
||||||
echo " FAIL: JOLT_TRACE trace should map a frame to ns/name (file:line)"
|
|
||||||
printf '%s\n' "$tr_out" | sed 's/^/ | /'
|
|
||||||
fails=$((fails + 1))
|
|
||||||
fi
|
|
||||||
rm -rf "$tr_proj"
|
|
||||||
|
|
||||||
# --help prints usage, and lists the nREPL server under its real flag name.
|
|
||||||
help_out="$(bin/joltc --help 2>/dev/null)"
|
|
||||||
if printf '%s' "$help_out" | grep -q -- '--nrepl-server'; then
|
|
||||||
pass=$((pass + 1))
|
|
||||||
else
|
|
||||||
echo " FAIL: --help should list --nrepl-server"
|
|
||||||
fails=$((fails + 1))
|
|
||||||
fi
|
|
||||||
|
|
||||||
# clojure.test extension points (assert-expr / do-report / report) need separate
|
|
||||||
# top-level forms — assert-expr must register before `is` expands — so this is a
|
|
||||||
# multi-form `joltc run`, not an -e one-liner. The file self-checks its tallies.
|
|
||||||
ct_out="$(bin/joltc run test/chez/clojure-test.clj 2>/dev/null)"
|
|
||||||
if printf '%s' "$ct_out" | grep -q 'CLOJURE-TEST OK'; then
|
|
||||||
pass=$((pass + 1))
|
|
||||||
else
|
|
||||||
echo " FAIL: clojure.test extension points"
|
|
||||||
echo " $(printf '%s' "$ct_out" | grep CLOJURE-TEST | tail -1)"
|
|
||||||
fails=$((fails + 1))
|
|
||||||
fi
|
|
||||||
|
|
||||||
# A data reader that returns a CODE form (deps.edn data_readers.clj -> reader fn)
|
|
||||||
# must have its result spliced in and COMPILED, like Clojure — #code [:x] becomes
|
|
||||||
# (+ 40 2) and evaluates to 42, not the literal list. A project run so the source
|
|
||||||
# root's data_readers.clj is picked up.
|
|
||||||
dr_out="$(JOLT_PWD="$root/test/chez/datareader-app" bin/joltc run -m drtest.main 2>/dev/null | tail -1)"
|
|
||||||
if [ "$dr_out" = "42" ]; then
|
|
||||||
pass=$((pass + 1))
|
|
||||||
else
|
|
||||||
echo " FAIL: code-returning data reader (#code) not compiled — got \`$dr_out\`, want 42"
|
|
||||||
fails=$((fails + 1))
|
|
||||||
fi
|
|
||||||
|
|
||||||
# A required namespace's own :as aliases must not leak into the requirer: fix.main
|
|
||||||
# aliases clojure.string as ss and requires fix.lib (which aliases clojure.set as
|
|
||||||
# ss); (ss/upper-case "hi") in main must stay clojure.string -> "HI #{1 2}".
|
|
||||||
al_out="$(JOLT_PWD="$root/test/chez/alias-leak-app" bin/joltc run -m fix.main 2>/dev/null | tail -1)"
|
|
||||||
if [ "$al_out" = "HI #{1 2}" ]; then
|
|
||||||
pass=$((pass + 1))
|
|
||||||
else
|
|
||||||
echo " FAIL: a loaded ns's alias leaked into its requirer — got \`$al_out\`, want \`HI #{1 2}\`"
|
|
||||||
fails=$((fails + 1))
|
|
||||||
fi
|
|
||||||
|
|
||||||
# Unit-checks the REPL read-until-complete predicate over balanced/unbalanced,
|
|
||||||
# string, comment and regex-literal inputs. A multi-form `joltc run` so jolt.main
|
|
||||||
# is loaded and its private var resolves; the file self-checks and prints a sentinel.
|
|
||||||
rr_out="$(bin/joltc run test/chez/repl-reader-test.clj 2>/dev/null)"
|
|
||||||
if printf '%s' "$rr_out" | grep -q 'REPL-READER OK'; then
|
|
||||||
pass=$((pass + 1))
|
|
||||||
else
|
|
||||||
echo " FAIL: repl-form-complete? predicate"
|
|
||||||
echo " $(printf '%s' "$rr_out" | grep REPL-READER | tail -1)"
|
|
||||||
fails=$((fails + 1))
|
|
||||||
fi
|
|
||||||
|
|
||||||
# REPL must exit on :repl/quit / :exit — a reliable exit that works in any
|
|
||||||
# terminal, unlike ^D (which some terminals/editors don't deliver as EOF).
|
|
||||||
# Pipe: an evaluable form, the quit keyword, then a sentinel that must NOT run.
|
|
||||||
repl_out="$(printf '(+ 1000 23)\n:repl/quit\n(* 999 9)\n' | bin/joltc repl 2>/dev/null)"
|
|
||||||
if printf '%s' "$repl_out" | grep -q '1023' && ! printf '%s' "$repl_out" | grep -q '8991'; then
|
|
||||||
pass=$((pass + 1))
|
|
||||||
else
|
|
||||||
echo " FAIL: repl should exit on :repl/quit before later forms"
|
|
||||||
printf '%s\n' "$repl_out" | sed 's/^/ | /'
|
|
||||||
fails=$((fails + 1))
|
|
||||||
fi
|
|
||||||
|
|
||||||
repl_out="$(printf '(- 2024 1)\n:exit\n(* 999 9)\n' | bin/joltc repl 2>/dev/null)"
|
|
||||||
if printf '%s' "$repl_out" | grep -q '2023' && ! printf '%s' "$repl_out" | grep -q '8991'; then
|
|
||||||
pass=$((pass + 1))
|
|
||||||
else
|
|
||||||
echo " FAIL: repl should exit on :exit before later forms"
|
|
||||||
printf '%s\n' "$repl_out" | sed 's/^/ | /'
|
|
||||||
fails=$((fails + 1))
|
|
||||||
fi
|
|
||||||
|
|
||||||
# A form split across lines is accumulated and evaluated once complete, with a
|
|
||||||
# secondary continuation prompt before each continued line.
|
|
||||||
repl_out="$(printf '(+ 1\n2)\n:exit\n' | bin/joltc repl 2>/dev/null)"
|
|
||||||
if printf '%s' "$repl_out" | grep -q '3' && ! printf '%s' "$repl_out" | grep -q 'error'; then
|
|
||||||
pass=$((pass + 1))
|
|
||||||
else
|
|
||||||
echo " FAIL: repl should accumulate multi-line forms to 3"
|
|
||||||
printf '%s\n' "$repl_out" | sed 's/^/ | /'
|
|
||||||
fails=$((fails + 1))
|
|
||||||
fi
|
|
||||||
|
|
||||||
# A single-line regex literal is complete on its own — the #" opens a regex whose
|
|
||||||
# body (delimiters, quotes and all) must not be miscounted as unbalanced parens.
|
|
||||||
repl_out="$(printf '(re-find #"(a)(b)" "ab")\n:exit\n' | bin/joltc repl 2>/dev/null)"
|
|
||||||
if printf '%s' "$repl_out" | grep -q 'ab' && ! printf '%s' "$repl_out" | grep -q 'error'; then
|
|
||||||
pass=$((pass + 1))
|
|
||||||
else
|
|
||||||
echo " FAIL: repl should evaluate a one-line regex literal, not wait for more input"
|
|
||||||
printf '%s\n' "$repl_out" | sed 's/^/ | /'
|
|
||||||
fails=$((fails + 1))
|
|
||||||
fi
|
|
||||||
|
|
||||||
# REPL-driven development traces by default: an error in an evaluated form shows a
|
|
||||||
# tail-frame backtrace with no JOLT_TRACE set. rb tail-calls ra tail-calls +, all
|
|
||||||
# TCO-elided from the continuation — only the history recovers them.
|
|
||||||
repl_err="$(printf '(defn ra [x] (+ x 1))\n(defn rb [x] (ra x))\n(rb :nan)\n:exit\n' | bin/joltc repl 2>&1)"
|
|
||||||
if printf '%s' "$repl_err" | grep -q ' trace:' && printf '%s' "$repl_err" | grep -q 'rb'; then
|
|
||||||
pass=$((pass + 1))
|
|
||||||
else
|
|
||||||
echo " FAIL: a REPL error should show a tail-frame trace by default"
|
|
||||||
printf '%s\n' "$repl_err" | sed 's/^/ | /'
|
|
||||||
fails=$((fails + 1))
|
|
||||||
fi
|
|
||||||
# JOLT_TRACE=0 opts out — no trace in the REPL.
|
|
||||||
repl_off="$(printf '(defn ra [x] (+ x 1))\n(defn rb [x] (ra x))\n(rb :nan)\n:exit\n' | JOLT_TRACE=0 bin/joltc repl 2>&1)"
|
|
||||||
if printf '%s' "$repl_off" | grep -q ' trace:'; then
|
|
||||||
echo " FAIL: JOLT_TRACE=0 should suppress the REPL trace"
|
|
||||||
fails=$((fails + 1))
|
|
||||||
else
|
|
||||||
pass=$((pass + 1))
|
|
||||||
fi
|
|
||||||
|
|
||||||
echo "cli smoke: $pass passed, $fails failed"
|
echo "cli smoke: $pass passed, $fails failed"
|
||||||
[ "$fails" -eq 0 ]
|
[ "$fails" -eq 0 ]
|
||||||
|
|
|
||||||
|
|
@ -1,206 +0,0 @@
|
||||||
;; source-registry.ss — map emitted procedures back to Clojure source for native
|
|
||||||
;; stack traces, and render an uncaught throwable.
|
|
||||||
;;
|
|
||||||
;; A direct-linked def compiles to (define jv$ns$name <fn>); the back end also
|
|
||||||
;; emits (jolt-register-source! "jv$ns$name" ns name file line) once per such def
|
|
||||||
;; — at definition time, so there is zero per-call cost. On an uncaught error we
|
|
||||||
;; walk Chez's native continuation frames, read each frame's procedure name, and
|
|
||||||
;; look it up here to print a Clojure backtrace.
|
|
||||||
;;
|
|
||||||
;; CAVEATS. Names map only for stable Chez procedure names — direct-link / AOT
|
|
||||||
;; closed-world builds. The open-world -e/repl/run path stores fns in var cells
|
|
||||||
;; as anonymous lambdas, so its frames don't map (the trace falls back to the
|
|
||||||
;; top-level location compile-eval.ss tracks). Pervasive tail-call optimization
|
|
||||||
;; also erases tail-called frames, so even a mapped trace shows only the non-tail
|
|
||||||
;; spine — the immediate error site is often a tail call and won't appear.
|
|
||||||
|
|
||||||
;; Keyed by the procedure name Chez actually reports for a frame — the SHORT
|
|
||||||
;; munged fn name (the letrec self-binding emit-fn uses), e.g. "deepest", not the
|
|
||||||
;; jv$ns$name global. Two vars in different namespaces can share a short name; an
|
|
||||||
;; 'ambiguous marker then keeps the frame name in the trace but drops the
|
|
||||||
;; (now-uncertain) ns/file:line, so a trace is never misattributed.
|
|
||||||
(define source-registry (make-hashtable string-hash string=?))
|
|
||||||
|
|
||||||
(define (jolt-register-source! procname ns nm file line)
|
|
||||||
(let ((existing (hashtable-ref source-registry procname #f)))
|
|
||||||
(cond
|
|
||||||
((not existing) (hashtable-set! source-registry procname (vector ns nm file line)))
|
|
||||||
((and (vector? existing)
|
|
||||||
(or (not (equal? (vector-ref existing 0) ns))
|
|
||||||
(not (equal? (vector-ref existing 1) nm))))
|
|
||||||
(hashtable-set! source-registry procname 'ambiguous))))
|
|
||||||
jolt-nil)
|
|
||||||
(def-var! "jolt.host" "register-source!" jolt-register-source!)
|
|
||||||
|
|
||||||
;; The continuation to walk for an uncaught value: the one jolt-throw captured for
|
|
||||||
;; THIS value (identity-tagged via jolt-throw-cont, so a stale entry from an
|
|
||||||
;; earlier caught throw is never reused), else a host condition's own
|
|
||||||
;; &continuation, else #f. raw may arrive as the &jolt-throw condition wrapping
|
|
||||||
;; the value (the built-binary launcher hands jolt-report-throwable the guard's
|
|
||||||
;; raw value) or already unwrapped (the cli unwraps first); unwrap here so the
|
|
||||||
;; identity match holds either way.
|
|
||||||
(define (jolt-error-continuation raw)
|
|
||||||
(let* ((v (jolt-unwrap-throw raw))
|
|
||||||
(tc (jolt-throw-cont)))
|
|
||||||
(cond
|
|
||||||
((and (pair? tc) (eq? (car tc) v)) (cdr tc))
|
|
||||||
((and (condition? v) (continuation-condition? v)) (condition-continuation v))
|
|
||||||
(else #f))))
|
|
||||||
|
|
||||||
;; A frame inspector's procedure name as a string, or #f for a non-frame / unnamed.
|
|
||||||
(define (srcreg-frame-name io)
|
|
||||||
(and (guard (e (#t #f)) (eq? (io 'type) 'continuation))
|
|
||||||
(let ((code (guard (e (#t #f)) (io 'code))))
|
|
||||||
(and code
|
|
||||||
(let ((nm (guard (e (#t #f)) (code 'name))))
|
|
||||||
(cond ((string? nm) nm)
|
|
||||||
((symbol? nm) (symbol->string nm))
|
|
||||||
(else #f)))))))
|
|
||||||
|
|
||||||
;; Frame names that are pure Chez / jolt-runtime plumbing — the eval boundary,
|
|
||||||
;; the var-cell trampoline, continuation/winder internals. They carry no Clojure
|
|
||||||
;; meaning, so an unmapped frame with one of these names is dropped from the trace
|
|
||||||
;; (a MAPPED frame is always kept — a jolt fn that happens to share the name still
|
|
||||||
;; resolves to its source). Any name Chez prefixes with `$` (system) or that jolt
|
|
||||||
;; prefixes with `jolt-` (host runtime) is plumbing too.
|
|
||||||
(define srcreg-plumbing-names
|
|
||||||
(let ((h (make-hashtable string-hash string=?)))
|
|
||||||
(for-each (lambda (s) (hashtable-set! h s #t))
|
|
||||||
'("dynamic-wind" "winder-dummy" "ksrc" "invoke" "apply"
|
|
||||||
"call-with-values" "call/cc" "call-with-current-continuation"
|
|
||||||
"raise" "raise-continuable" "with-exception-handler" "guard"
|
|
||||||
"eval" "compile" "interpret" "expand" "read" "load"
|
|
||||||
;; host dispatch/coercion helpers (not `jolt-` prefixed) that carry
|
|
||||||
;; no Clojure meaning in a trace
|
|
||||||
"record-method-dispatch" "protocol-resolve" "devirt-resolve"
|
|
||||||
"list->cseq" "host-static-call" "host-call"))
|
|
||||||
h))
|
|
||||||
(define (srcreg-plumbing-name? nm)
|
|
||||||
(or (hashtable-ref srcreg-plumbing-names nm #f)
|
|
||||||
(and (fx>? (string-length nm) 0) (char=? (string-ref nm 0) #\$))
|
|
||||||
(and (fx>=? (string-length nm) 5) (string=? (substring nm 0 5) "jolt-"))))
|
|
||||||
|
|
||||||
;; Walk a continuation, returning its frames (innermost first) as (frame-name .
|
|
||||||
;; record) pairs. record is a source vector #(ns name file line) for a frame that
|
|
||||||
;; maps to registered Clojure source, the symbol 'ambiguous for a short name shared
|
|
||||||
;; across namespaces, or #f for an unmapped-but-named frame (the common case on the
|
|
||||||
;; open-world eval path, where nothing is registered — the bare frame name is still
|
|
||||||
;; a useful trace line). Plumbing frames (host spine, eval boundary) and unnamed
|
|
||||||
;; frames are skipped; raw depth is capped.
|
|
||||||
(define (jolt-frame-records k)
|
|
||||||
;; read the env at call time, not load time: a built binary runs top-level forms
|
|
||||||
;; at heap-build time, where this would always be unset.
|
|
||||||
(let ((debug? (getenv "JOLT_DEBUG_FRAMES")))
|
|
||||||
(guard (e (#t '()))
|
|
||||||
(let loop ((io (inspect/object k)) (n 0) (acc '()))
|
|
||||||
(if (or (not io) (fx>=? n 400))
|
|
||||||
(reverse acc)
|
|
||||||
(let* ((nm (srcreg-frame-name io))
|
|
||||||
(src (and nm (hashtable-ref source-registry nm #f)))
|
|
||||||
;; keep a frame that maps, or any named frame that isn't plumbing
|
|
||||||
(keep? (and nm (or src (not (srcreg-plumbing-name? nm))))))
|
|
||||||
(when (and debug? nm)
|
|
||||||
(display (string-append " [frame] " nm (if src " *MAPPED*"
|
|
||||||
(if keep? "" " (skipped)")) "\n")
|
|
||||||
(current-error-port)))
|
|
||||||
(loop (guard (e (#t #f)) (io 'link)) (fx+ n 1)
|
|
||||||
(if keep? (cons (cons nm src) acc) acc))))))))
|
|
||||||
|
|
||||||
;; Render a list of (frame-name . record) pairs (innermost/deepest first) to a
|
|
||||||
;; backtrace string. record is a source vector #(ns name file line) -> "ns/name
|
|
||||||
;; (file:line)", or 'ambiguous / #f -> the bare frame name. A run of the same
|
|
||||||
;; frame-name collapses to one "name (xN)" line (deep recursion, or a hot fn a
|
|
||||||
;; loop re-enters), and the number of distinct lines is capped.
|
|
||||||
(define (jolt-render-recs recs)
|
|
||||||
(let ((port (open-output-string)))
|
|
||||||
(let loop ((rs recs) (shown 0))
|
|
||||||
(if (or (null? rs) (fx>=? shown 30))
|
|
||||||
(get-output-string port)
|
|
||||||
(let* ((p (car rs)) (frame-name (car p)) (r (cdr p)))
|
|
||||||
;; count a maximal run of the same frame-name
|
|
||||||
(let run ((tail (cdr rs)) (cnt 1))
|
|
||||||
(if (and (pair? tail) (string=? (car (car tail)) frame-name))
|
|
||||||
(run (cdr tail) (fx+ cnt 1))
|
|
||||||
(begin
|
|
||||||
(put-string port " ")
|
|
||||||
(if (vector? r)
|
|
||||||
(let ((ns (vector-ref r 0)) (nm (vector-ref r 1))
|
|
||||||
(file (vector-ref r 2)) (line (vector-ref r 3)))
|
|
||||||
(put-string port ns) (put-string port "/") (put-string port nm)
|
|
||||||
(when (string? file)
|
|
||||||
(put-string port " (") (put-string port file)
|
|
||||||
(put-string port ":") (put-string port (number->string line))
|
|
||||||
(put-string port ")")))
|
|
||||||
(put-string port frame-name)) ; 'ambiguous / unmapped: bare name
|
|
||||||
(when (fx>? cnt 1)
|
|
||||||
(put-string port " (x") (put-string port (number->string cnt)) (put-string port ")"))
|
|
||||||
(put-char port #\newline)
|
|
||||||
(loop tail (fx+ shown 1))))))))))
|
|
||||||
|
|
||||||
;; Multi-line backtrace for an uncaught value. Two sources, in preference order:
|
|
||||||
;; 1. The tail-frame history ring (rt.ss), when JOLT_TRACE enabled it — an
|
|
||||||
;; execution history of the runtime-compiled fns entered before the throw,
|
|
||||||
;; INCLUDING ones TCO erased from the live continuation. Most-recent first.
|
|
||||||
;; 2. Otherwise the live continuation (jolt-frame-records) — the accurate but
|
|
||||||
;; TCO-truncated non-tail spine.
|
|
||||||
;; Each frame maps to "ns/name (file:line)" when registered, else its bare name.
|
|
||||||
;; #f when neither source yields a frame (the caller then prints just the location).
|
|
||||||
;; The tail-frame history ring rendered as a backtrace, or #f when tracing is off /
|
|
||||||
;; empty. A mapped frame is kept; else drop plumbing (same rule as the continuation
|
|
||||||
;; path) so the two sources read consistently.
|
|
||||||
(define (jolt-history-backtrace)
|
|
||||||
(let* ((hist (jolt-trace-snapshot))
|
|
||||||
(recs (let loop ((ns hist) (acc '()))
|
|
||||||
(if (null? ns)
|
|
||||||
(reverse acc)
|
|
||||||
(let* ((nm (car ns)) (src (hashtable-ref source-registry nm #f)))
|
|
||||||
(loop (cdr ns)
|
|
||||||
(if (or src (not (srcreg-plumbing-name? nm)))
|
|
||||||
(cons (cons nm src) acc) acc)))))))
|
|
||||||
(and (pair? recs) (jolt-render-recs recs))))
|
|
||||||
|
|
||||||
(define (jolt-backtrace-string v)
|
|
||||||
(or (jolt-history-backtrace)
|
|
||||||
(let ((k (jolt-error-continuation v)))
|
|
||||||
(and k
|
|
||||||
(let ((recs (jolt-frame-records k)))
|
|
||||||
(and (pair? recs) (jolt-render-recs recs)))))))
|
|
||||||
|
|
||||||
;; Exposed for the REPL / nREPL error paths, which catch errors themselves instead
|
|
||||||
;; of going through the uncaught reporter. Returns the " trace:\n<frames>" block
|
|
||||||
;; from the tail-frame HISTORY only — the live continuation in a REPL is just the
|
|
||||||
;; REPL's own machinery — or nil when tracing is off (so a caller can when-let).
|
|
||||||
(def-var! "jolt.host" "backtrace-string"
|
|
||||||
(lambda ()
|
|
||||||
(let ((bt (jolt-history-backtrace)))
|
|
||||||
(if bt (string-append " trace:\n" bt) jolt-nil))))
|
|
||||||
|
|
||||||
;; Render an uncaught jolt throw (any value, not just a Chez condition) to a port:
|
|
||||||
;; an ex-info shows its message + ex-data (+ a host cause); anything else is
|
|
||||||
;; pr-str'd. Shared by the cli (cli.ss) and a built binary's launcher (build.ss).
|
|
||||||
(define (jolt-render-throwable raw port)
|
|
||||||
(let ((v (jolt-unwrap-throw raw)))
|
|
||||||
(if (jolt=2 (jolt-get v jolt-kw-ex-type jolt-nil) jolt-kw-ex-info)
|
|
||||||
(begin
|
|
||||||
(display "Unhandled exception: " port)
|
|
||||||
(display (jolt-str-render-one (jolt-get v jolt-kw-message jolt-nil)) port)
|
|
||||||
(newline port)
|
|
||||||
(let ((data (jolt-get v jolt-kw-data jolt-nil)))
|
|
||||||
(unless (jolt-nil? data)
|
|
||||||
(display " ex-data: " port) (display (jolt-pr-str data) port) (newline port)))
|
|
||||||
(let ((cause (jolt-get v jolt-kw-cause jolt-nil)))
|
|
||||||
(when (condition? cause)
|
|
||||||
(display " cause: " port)
|
|
||||||
(display (with-output-to-string (lambda () (display-condition cause))) port)
|
|
||||||
(newline port))))
|
|
||||||
(begin
|
|
||||||
(display "Unhandled exception: " port)
|
|
||||||
(display (if (condition? v) (with-output-to-string (lambda () (display-condition v))) (jolt-pr-str v)) port)
|
|
||||||
(newline port)))))
|
|
||||||
|
|
||||||
;; Render the throwable, then its Clojure backtrace when one maps. The caller adds
|
|
||||||
;; any top-level source location (the runtime cli does; a built binary has none).
|
|
||||||
(define (jolt-report-throwable v port)
|
|
||||||
(jolt-render-throwable v port)
|
|
||||||
(let ((bt (jolt-backtrace-string v)))
|
|
||||||
(when bt (display " trace:\n" port) (display bt port))))
|
|
||||||
|
|
@ -1,115 +0,0 @@
|
||||||
#!/bin/sh
|
|
||||||
# static-native smoke: a project's :jolt/native lib with a :static archive is
|
|
||||||
# LINKED INTO the built binary (the default), so the binary calls the C function
|
|
||||||
# with no shared object on disk at runtime. --dynamic keeps the old behavior —
|
|
||||||
# load a shared object at runtime.
|
|
||||||
root="$(CDPATH= cd -- "$(dirname -- "$0")/../.." && pwd)"
|
|
||||||
cd "$root"
|
|
||||||
|
|
||||||
# Preflight: needs cc (to build the test libs AND to cc-link the app) + Chez's
|
|
||||||
# kernel dev files, same as build-smoke. Skip otherwise (CI on a distro package).
|
|
||||||
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 "static-native smoke: skipped (Chez kernel dev files or C compiler not available)"
|
|
||||||
exit 0
|
|
||||||
fi
|
|
||||||
export JOLT_CHEZ_CSV="$csv"
|
|
||||||
|
|
||||||
case "$(uname -s)" in
|
|
||||||
Darwin) plat=":darwin"; soext="dylib"; shared="-dynamiclib" ;;
|
|
||||||
*) plat=":linux"; soext="so"; shared="-shared" ;;
|
|
||||||
esac
|
|
||||||
|
|
||||||
work="$(mktemp -d)"
|
|
||||||
trap 'rm -rf "$work"' EXIT
|
|
||||||
app="$work/app"
|
|
||||||
mkdir -p "$app/src/app"
|
|
||||||
|
|
||||||
# 1. a trivial C library, built BOTH as a static archive and a shared object.
|
|
||||||
cat > "$work/greet.c" <<'EOF'
|
|
||||||
int jolt_static_answer(void) { return 42; }
|
|
||||||
EOF
|
|
||||||
cc -c "$work/greet.c" -o "$work/greet.o"
|
|
||||||
ar rcs "$work/libgreet.a" "$work/greet.o"
|
|
||||||
cc $shared "$work/greet.c" -o "$work/libgreet.$soext"
|
|
||||||
|
|
||||||
# 2. an app that binds that symbol via FFI.
|
|
||||||
cat > "$app/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
|
|
||||||
|
|
||||||
out="$work/app-bin"
|
|
||||||
|
|
||||||
# --- default: static link ---------------------------------------------------
|
|
||||||
# A static-only spec (no runtime candidate): the build resolves the symbol by
|
|
||||||
# preloading the archive, and the binary links it in — nothing to load at runtime.
|
|
||||||
cat > "$app/deps.edn" <<EOF
|
|
||||||
{:paths ["src"]
|
|
||||||
:jolt/native [{:name "greet" :static {:archive "$work/libgreet.a"}}]}
|
|
||||||
EOF
|
|
||||||
echo "static-native smoke: building (default: static link)"
|
|
||||||
if ! JOLT_PWD="$app" bin/joltc build -m app.core -o "$out" >"$work/build.log" 2>&1; then
|
|
||||||
echo " FAIL: jolt build (static) exited non-zero"; cat "$work/build.log"; exit 1
|
|
||||||
fi
|
|
||||||
[ -x "$out" ] || { echo " FAIL: no executable produced"; exit 1; }
|
|
||||||
# A static lib emits a process-symbol load (its archive is in-process), not a
|
|
||||||
# dlopen of the shared object.
|
|
||||||
if ! grep -q "jolt-build-load-native '() #f #t" "$out.build/flat.ss"; then
|
|
||||||
echo " FAIL: static native did not emit a process-symbol load"; exit 1
|
|
||||||
fi
|
|
||||||
if grep -q "libgreet.$soext" "$out.build/flat.ss"; then
|
|
||||||
echo " FAIL: static native baked a runtime shared-object load"; exit 1
|
|
||||||
fi
|
|
||||||
# Remove BOTH libs: a static-linked symbol lives in the binary, nothing to load.
|
|
||||||
rm -f "$work/libgreet.a" "$work/libgreet.$soext" "$work/greet.o"
|
|
||||||
got="$(cd / && "$out" 2>&1)"
|
|
||||||
if [ "$got" != "answer: 42" ]; then
|
|
||||||
echo " FAIL: static-linked binary output mismatch"
|
|
||||||
echo "--- want ---"; echo "answer: 42"; echo "--- got ----"; echo "$got"; exit 1
|
|
||||||
fi
|
|
||||||
|
|
||||||
# --- --dynamic: runtime load ------------------------------------------------
|
|
||||||
# Rebuild the shared object (static phase deleted it) and give the spec a runtime
|
|
||||||
# candidate; --dynamic loads it at startup instead of linking the archive.
|
|
||||||
cc $shared "$work/greet.c" -o "$work/libgreet.$soext"
|
|
||||||
cat > "$app/deps.edn" <<EOF
|
|
||||||
{:paths ["src"]
|
|
||||||
:jolt/native [{:name "greet"
|
|
||||||
:static {:archive "$work/libgreet.a"}
|
|
||||||
$plat ["$work/libgreet.$soext"]}]}
|
|
||||||
EOF
|
|
||||||
echo "static-native smoke: building (--dynamic: runtime load)"
|
|
||||||
if ! JOLT_PWD="$app" bin/joltc build -m app.core -o "$out" --dynamic >"$work/build.log" 2>&1; then
|
|
||||||
echo " FAIL: jolt build --dynamic exited non-zero"; cat "$work/build.log"; exit 1
|
|
||||||
fi
|
|
||||||
# --dynamic loads the shared object at runtime.
|
|
||||||
if ! grep -q "libgreet.$soext" "$out.build/flat.ss"; then
|
|
||||||
echo " FAIL: --dynamic did not emit a runtime shared-object load"; exit 1
|
|
||||||
fi
|
|
||||||
got="$(cd / && "$out" 2>&1)"
|
|
||||||
if [ "$got" != "answer: 42" ]; then
|
|
||||||
echo " FAIL: --dynamic binary output mismatch (shared object present)"
|
|
||||||
echo "--- got ----"; echo "$got"; exit 1
|
|
||||||
fi
|
|
||||||
# With the shared object gone, a --dynamic binary must FAIL — proving the symbol
|
|
||||||
# was loaded at runtime, not baked in.
|
|
||||||
rm -f "$work/libgreet.$soext"
|
|
||||||
rc=0; { (cd / && exec "$out"); } >/dev/null 2>&1 || rc=$?
|
|
||||||
if [ "$rc" -eq 0 ]; then
|
|
||||||
echo " FAIL: --dynamic binary still ran with its shared object removed"; exit 1
|
|
||||||
fi
|
|
||||||
|
|
||||||
echo "static-native smoke: passed (static default + --dynamic runtime load)"
|
|
||||||
|
|
@ -1,109 +0,0 @@
|
||||||
/* launcher.c — the native stub for self-contained jolt binaries (jolt-eaj).
|
|
||||||
*
|
|
||||||
* A toolchain-free `jolt build` (and joltc itself) produces an executable by
|
|
||||||
* appending a Chez boot image to a copy of this prebuilt stub, framed as:
|
|
||||||
*
|
|
||||||
* [stub bytes][boot bytes][boot-length : little-endian u64]["JOLTBOOT"]
|
|
||||||
*
|
|
||||||
* (see host/chez/java/io.ss jolt-append-payload!). At startup the stub locates
|
|
||||||
* its own executable, reads the trailing 16-byte frame to find the boot, and
|
|
||||||
* hands the boot to the Chez kernel — no external boot file, no Chez install.
|
|
||||||
*
|
|
||||||
* Built once at joltc-build time against the Chez kernel (libkernel.a + scheme.h)
|
|
||||||
* by host/chez/build-joltc.ss; the resulting binary is embedded into joltc and
|
|
||||||
* copied per app build. Inherently per-platform (the boot targets the host
|
|
||||||
* machine-type), like a native compiler.
|
|
||||||
*/
|
|
||||||
#include "scheme.h"
|
|
||||||
#include <stdint.h>
|
|
||||||
#include <stdio.h>
|
|
||||||
#include <stdlib.h>
|
|
||||||
#include <string.h>
|
|
||||||
|
|
||||||
#if defined(__APPLE__)
|
|
||||||
#include <mach-o/dyld.h>
|
|
||||||
static int self_path(char *buf, uint32_t size) {
|
|
||||||
/* _NSGetExecutablePath fills buf and reports the needed size on overflow. */
|
|
||||||
return _NSGetExecutablePath(buf, &size);
|
|
||||||
}
|
|
||||||
#elif defined(_WIN32)
|
|
||||||
#include <windows.h>
|
|
||||||
static int self_path(char *buf, uint32_t size) {
|
|
||||||
DWORD n = GetModuleFileNameA(NULL, buf, size);
|
|
||||||
return (n == 0 || n >= size) ? -1 : 0;
|
|
||||||
}
|
|
||||||
#else
|
|
||||||
#include <unistd.h>
|
|
||||||
static int self_path(char *buf, uint32_t size) {
|
|
||||||
ssize_t n = readlink("/proc/self/exe", buf, (size_t)size - 1);
|
|
||||||
if (n < 0) return -1;
|
|
||||||
buf[n] = '\0';
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#define JOLT_MAGIC "JOLTBOOT"
|
|
||||||
#define JOLT_MAGIC_LEN 8
|
|
||||||
#define JOLT_TRAILER_LEN 16 /* u64 length + 8-byte magic */
|
|
||||||
|
|
||||||
int main(int argc, char *argv[]) {
|
|
||||||
char path[4096];
|
|
||||||
if (self_path(path, (uint32_t)sizeof(path)) != 0) {
|
|
||||||
fprintf(stderr, "jolt: cannot resolve own executable path\n");
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
FILE *f = fopen(path, "rb");
|
|
||||||
if (!f) { fprintf(stderr, "jolt: cannot open self for reading\n"); return 1; }
|
|
||||||
|
|
||||||
if (fseek(f, 0, SEEK_END) != 0) { fclose(f); return 1; }
|
|
||||||
long fsize = ftell(f);
|
|
||||||
if (fsize < JOLT_TRAILER_LEN) {
|
|
||||||
fprintf(stderr, "jolt: no boot payload (run was not produced by jolt build)\n");
|
|
||||||
fclose(f);
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
unsigned char trailer[JOLT_TRAILER_LEN];
|
|
||||||
if (fseek(f, fsize - JOLT_TRAILER_LEN, SEEK_SET) != 0 ||
|
|
||||||
fread(trailer, 1, JOLT_TRAILER_LEN, f) != JOLT_TRAILER_LEN) {
|
|
||||||
fclose(f);
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
if (memcmp(trailer + 8, JOLT_MAGIC, JOLT_MAGIC_LEN) != 0) {
|
|
||||||
fprintf(stderr, "jolt: boot payload not found\n");
|
|
||||||
fclose(f);
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
uint64_t boot_len = 0;
|
|
||||||
for (int i = 0; i < 8; i++)
|
|
||||||
boot_len |= ((uint64_t)trailer[i]) << (8 * i);
|
|
||||||
|
|
||||||
long boot_off = fsize - JOLT_TRAILER_LEN - (long)boot_len;
|
|
||||||
if (boot_off < 0) {
|
|
||||||
fprintf(stderr, "jolt: corrupt boot payload\n");
|
|
||||||
fclose(f);
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* The kernel keeps the boot bytes for the life of the process (demand-loaded),
|
|
||||||
* so this buffer is freed only after Sscheme_deinit. */
|
|
||||||
void *boot = malloc((size_t)boot_len);
|
|
||||||
if (!boot) { fclose(f); return 1; }
|
|
||||||
if (fseek(f, boot_off, SEEK_SET) != 0 ||
|
|
||||||
fread(boot, 1, (size_t)boot_len, f) != (size_t)boot_len) {
|
|
||||||
free(boot);
|
|
||||||
fclose(f);
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
fclose(f);
|
|
||||||
|
|
||||||
Sscheme_init(0);
|
|
||||||
Sregister_boot_file_bytes("jolt", boot, (iptr)boot_len);
|
|
||||||
Sbuild_heap(0, 0);
|
|
||||||
int status = Sscheme_start(argc, (const char **)argv);
|
|
||||||
Sscheme_deinit();
|
|
||||||
free(boot);
|
|
||||||
return status;
|
|
||||||
}
|
|
||||||
|
|
@ -41,9 +41,7 @@
|
||||||
;; expansion still re-analyzes as a set literal.
|
;; expansion still re-analyzes as a set literal.
|
||||||
(define (jolt-sqset . parts) (apply jolt-hash-set (sq-flatten parts)))
|
(define (jolt-sqset . parts) (apply jolt-hash-set (sq-flatten parts)))
|
||||||
;; map FORM: a plain pmap (the analyzer's form-map? = pmap with no :jolt/type).
|
;; map FORM: a plain pmap (the analyzer's form-map? = pmap with no :jolt/type).
|
||||||
;; Clojure's syntaxQuote builds the map via `apply hash-map`, so a `{...} template
|
(define (jolt-sqmap . parts) (apply jolt-hash-map parts))
|
||||||
;; is HASH-ordered (unlike a {...} literal, which keeps insertion order).
|
|
||||||
(define (jolt-sqmap . parts) (jolt-hash-map-build parts))
|
|
||||||
|
|
||||||
(def-var! "clojure.core" "__sq1" jolt-sq1)
|
(def-var! "clojure.core" "__sq1" jolt-sq1)
|
||||||
(def-var! "clojure.core" "__sqcat" jolt-sqcat)
|
(def-var! "clojure.core" "__sqcat" jolt-sqcat)
|
||||||
|
|
|
||||||
|
|
@ -16,17 +16,11 @@
|
||||||
;; this record, not a pvec), which group-by relies on. Loaded after collections.ss
|
;; this record, not a pvec), which group-by relies on. Loaded after collections.ss
|
||||||
;; (persistent ops + key-hash) and converters.ss.
|
;; (persistent ops + key-hash) and converters.ss.
|
||||||
|
|
||||||
;; For a transient MAP, `n` holds the array-mode capacity (entries it can hold
|
|
||||||
;; before promoting to hash order) and `ord` the reverse insertion-order key list;
|
|
||||||
;; for a vector `n` is the element count. A transient array map promotes to hash
|
|
||||||
;; at max(8, source-count) entries (TransientArrayMap, array sized max(16, len)),
|
|
||||||
;; with no keyword exception — unlike the persistent assoc growth rule.
|
|
||||||
(define-record-type jolt-transient
|
(define-record-type jolt-transient
|
||||||
(fields kind (mutable buf) (mutable n) (mutable active) (mutable ord))
|
(fields kind (mutable buf) (mutable n) (mutable active))
|
||||||
(nongenerative jolt-transient-v3))
|
(nongenerative jolt-transient-v2))
|
||||||
|
|
||||||
(define tvec-min-cap 8)
|
(define tvec-min-cap 8)
|
||||||
(define tmap-min-cap 8)
|
|
||||||
|
|
||||||
(define (jolt-transient-new coll)
|
(define (jolt-transient-new coll)
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -34,36 +28,16 @@
|
||||||
(let* ((v (pvec-v coll)) (cnt (vector-length v)) (cap (fxmax tvec-min-cap cnt))
|
(let* ((v (pvec-v coll)) (cnt (vector-length v)) (cap (fxmax tvec-min-cap cnt))
|
||||||
(buf (make-vector cap jolt-nil)))
|
(buf (make-vector cap jolt-nil)))
|
||||||
(let loop ((i 0)) (when (fx<? i cnt) (vector-set! buf i (vector-ref v i)) (loop (fx+ i 1))))
|
(let loop ((i 0)) (when (fx<? i cnt) (vector-set! buf i (vector-ref v i)) (loop (fx+ i 1))))
|
||||||
(make-jolt-transient 'vec buf cnt #t #f)))
|
(make-jolt-transient 'vec buf cnt #t)))
|
||||||
((pmap? coll)
|
((pmap? coll)
|
||||||
(let ((ht (make-hashtable key-hash jolt=2)) (ord '()) (cnt 0))
|
(let ((ht (make-hashtable key-hash jolt=2)))
|
||||||
;; visit in iteration order so `ord` ends up reverse-insertion (persistent! reverses it back)
|
(pmap-fold coll (lambda (k v acc) (hashtable-set! ht k v) acc) 0)
|
||||||
(pmap-fold-fwd coll (lambda (k v acc) (hashtable-set! ht k v) (set! ord (cons k ord)) (set! cnt (fx+ cnt 1)) acc) 0)
|
(make-jolt-transient 'map ht 0 #t)))
|
||||||
(make-jolt-transient 'map ht (fxmax tmap-min-cap cnt) #t ord)))
|
|
||||||
((pset? coll)
|
((pset? coll)
|
||||||
(let ((ht (make-hashtable key-hash jolt=2)))
|
(let ((ht (make-hashtable key-hash jolt=2)))
|
||||||
(pset-fold coll (lambda (e acc) (hashtable-set! ht e #t) acc) 0)
|
(pset-fold coll (lambda (e acc) (hashtable-set! ht e #t) acc) 0)
|
||||||
(make-jolt-transient 'set ht 0 #t #f)))
|
(make-jolt-transient 'set ht 0 #t)))
|
||||||
;; RFC 0003: any COLLECTION transients (the sorted/list/seq superset rides
|
(else (make-jolt-transient 'cow coll 0 #t))))
|
||||||
;; the copy-on-write fallback); a non-collection is the JVM's cast failure.
|
|
||||||
((or (cseq? coll) (empty-list-t? coll) (jolt-lazyseq? coll)
|
|
||||||
(htable? coll) (jrec? coll))
|
|
||||||
(make-jolt-transient 'cow coll 0 #t #f))
|
|
||||||
(else
|
|
||||||
(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.IEditableCollection"))))))
|
|
||||||
|
|
||||||
;; map put/delete that maintain the reverse insertion-order list in `ord`.
|
|
||||||
(define (tmap-put! t k v)
|
|
||||||
(let ((ht (jolt-transient-buf t)))
|
|
||||||
(unless (hashtable-contains? ht k) (jolt-transient-ord-set! t (cons k (jolt-transient-ord t))))
|
|
||||||
(hashtable-set! ht k v)))
|
|
||||||
(define (tmap-del! t k)
|
|
||||||
(let ((ht (jolt-transient-buf t)))
|
|
||||||
(when (hashtable-contains? ht k) (jolt-transient-ord-set! t (remove-key (jolt-transient-ord t) k)))
|
|
||||||
(hashtable-delete! ht k)))
|
|
||||||
|
|
||||||
(define (jolt-trans-check t who)
|
(define (jolt-trans-check t who)
|
||||||
(unless (jolt-transient? t) (error #f (string-append who ": not a transient") t))
|
(unless (jolt-transient? t) (error #f (string-append who ": not a transient") t))
|
||||||
|
|
@ -86,21 +60,9 @@
|
||||||
(if (fx<? i cnt) (begin (vector-set! out i (vector-ref buf i)) (loop (fx+ i 1)))
|
(if (fx<? i cnt) (begin (vector-set! out i (vector-ref buf i)) (loop (fx+ i 1)))
|
||||||
(make-pvec out)))))))
|
(make-pvec out)))))))
|
||||||
((map)
|
((map)
|
||||||
(let* ((ht (jolt-transient-buf t)) (cnt (hashtable-size ht)) (cap (jolt-transient-n t))
|
(let ((ht (jolt-transient-buf t)) (m empty-pmap))
|
||||||
;; Clojure 1.13: a keyword-only map stays an array map up to 64 entries,
|
(vector-for-each (lambda (k) (set! m (pmap-assoc m k (hashtable-ref ht k jolt-nil)))) (hashtable-keys ht))
|
||||||
;; so a keyword map built through a transient (into {} …) keeps insertion
|
m))
|
||||||
;; order to 64, matching the literal/assoc paths.
|
|
||||||
(cap (if (all-keywords? (jolt-transient-ord t)) (fxmax array-map-limit-kw cap) cap)))
|
|
||||||
(if (fx>? cnt cap)
|
|
||||||
;; promoted past the array capacity: hash order
|
|
||||||
(let ((m empty-pmap-hash))
|
|
||||||
(vector-for-each (lambda (k) (set! m (pmap-put-hash m k (hashtable-ref ht k jolt-nil)))) (hashtable-keys ht))
|
|
||||||
m)
|
|
||||||
;; array map: rebuild in insertion order
|
|
||||||
(let ((m empty-pmap))
|
|
||||||
(for-each (lambda (k) (set! m (pmap-put-ordered m k (hashtable-ref ht k jolt-nil))))
|
|
||||||
(reverse (jolt-transient-ord t)))
|
|
||||||
m))))
|
|
||||||
((set)
|
((set)
|
||||||
(let ((ht (jolt-transient-buf t)) (s empty-pset))
|
(let ((ht (jolt-transient-buf t)) (s empty-pset))
|
||||||
(vector-for-each (lambda (e) (set! s (pset-conj s e))) (hashtable-keys ht))
|
(vector-for-each (lambda (e) (set! s (pset-conj s e))) (hashtable-keys ht))
|
||||||
|
|
@ -129,8 +91,8 @@
|
||||||
(define (tmap-conj-entry! t x)
|
(define (tmap-conj-entry! t x)
|
||||||
(cond
|
(cond
|
||||||
((jolt-nil? x) #t)
|
((jolt-nil? x) #t)
|
||||||
((pvec? x) (tmap-put! t (pvec-nth-d x 0 jolt-nil) (pvec-nth-d x 1 jolt-nil)))
|
((pvec? x) (hashtable-set! (jolt-transient-buf t) (pvec-nth-d x 0 jolt-nil) (pvec-nth-d x 1 jolt-nil)))
|
||||||
((pmap? x) (pmap-fold-fwd x (lambda (k v acc) (tmap-put! t k v) acc) 0))
|
((pmap? x) (pmap-fold x (lambda (k v acc) (hashtable-set! (jolt-transient-buf t) k v) acc) 0))
|
||||||
(else (error #f "conj!: a transient map takes a map entry or a map" x))))
|
(else (error #f "conj!: a transient map takes a map entry or a map" x))))
|
||||||
|
|
||||||
;; (conj!) -> fresh transient vector; (conj! coll) -> the 1-arity transducer-
|
;; (conj!) -> fresh transient vector; (conj! coll) -> the 1-arity transducer-
|
||||||
|
|
@ -157,14 +119,14 @@
|
||||||
(let ((kvs (assoc-pad kvs0)))
|
(let ((kvs (assoc-pad kvs0)))
|
||||||
(when (odd? (length kvs)) (error #f "assoc!: no value supplied for key"))
|
(when (odd? (length kvs)) (error #f "assoc!: no value supplied for key"))
|
||||||
(case (jolt-transient-kind t)
|
(case (jolt-transient-kind t)
|
||||||
((map) (let lp ((xs kvs)) (unless (null? xs) (tmap-put! t (car xs) (cadr xs)) (lp (cddr xs)))))
|
((map) (let lp ((xs kvs)) (unless (null? xs) (hashtable-set! (jolt-transient-buf t) (car xs) (cadr xs)) (lp (cddr xs)))))
|
||||||
((vec) (let lp ((xs kvs)) (unless (null? xs) (tvec-assoc1! t (car xs) (cadr xs)) (lp (cddr xs)))))
|
((vec) (let lp ((xs kvs)) (unless (null? xs) (tvec-assoc1! t (car xs) (cadr xs)) (lp (cddr xs)))))
|
||||||
(else (jolt-transient-buf-set! t (apply jolt-assoc (jolt-transient-buf t) kvs)))))
|
(else (jolt-transient-buf-set! t (apply jolt-assoc (jolt-transient-buf t) kvs)))))
|
||||||
t)
|
t)
|
||||||
(define (jolt-dissoc! t . ks)
|
(define (jolt-dissoc! t . ks)
|
||||||
(jolt-trans-check t "dissoc!")
|
(jolt-trans-check t "dissoc!")
|
||||||
(case (jolt-transient-kind t)
|
(case (jolt-transient-kind t)
|
||||||
((map) (for-each (lambda (k) (tmap-del! t k)) ks))
|
((map) (for-each (lambda (k) (hashtable-delete! (jolt-transient-buf t) k)) ks))
|
||||||
(else (jolt-transient-buf-set! t (apply jolt-dissoc (jolt-transient-buf t) ks))))
|
(else (jolt-transient-buf-set! t (apply jolt-dissoc (jolt-transient-buf t) ks))))
|
||||||
t)
|
t)
|
||||||
(define (jolt-disj! t . xs)
|
(define (jolt-disj! t . xs)
|
||||||
|
|
@ -184,11 +146,8 @@
|
||||||
|
|
||||||
;; persistent disj over sets (pset-disj already exists in collections.ss).
|
;; persistent disj over sets (pset-disj already exists in collections.ss).
|
||||||
(define (jolt-disj s . xs)
|
(define (jolt-disj s . xs)
|
||||||
;; (disj nil ...) is nil on the JVM (disj is otherwise set-only).
|
(meta-carry s
|
||||||
(if (jolt-nil? s)
|
(let loop ((s s) (xs xs)) (if (null? xs) s (loop (pset-disj s (car xs)) (cdr xs))))))
|
||||||
jolt-nil
|
|
||||||
(meta-carry s
|
|
||||||
(let loop ((s s) (xs xs)) (if (null? xs) s (loop (pset-disj s (car xs)) (cdr xs)))))))
|
|
||||||
|
|
||||||
;; --- see-through accessors ---------------------------------------------------
|
;; --- see-through accessors ---------------------------------------------------
|
||||||
(define (tvec-in-bounds? t i) (and (fixnum? i) (fx>=? i 0) (fx<? i (jolt-transient-n t))))
|
(define (tvec-in-bounds? t i) (and (fixnum? i) (fx>=? i 0) (fx<? i (jolt-transient-n t))))
|
||||||
|
|
|
||||||
|
|
@ -16,7 +16,6 @@
|
||||||
(define-record-type jolt-nil-t (fields) (nongenerative jolt-nil-v1))
|
(define-record-type jolt-nil-t (fields) (nongenerative jolt-nil-v1))
|
||||||
(define jolt-nil (make-jolt-nil-t))
|
(define jolt-nil (make-jolt-nil-t))
|
||||||
(define (jolt-nil? x) (jolt-nil-t? x))
|
(define (jolt-nil? x) (jolt-nil-t? x))
|
||||||
(define (jolt-some? x) (not (jolt-nil-t? x)))
|
|
||||||
|
|
||||||
;; --- truthiness: only nil and false are falsey -------------------------------
|
;; --- truthiness: only nil and false are falsey -------------------------------
|
||||||
(define (jolt-truthy? x) (not (or (jolt-nil? x) (eq? x #f))))
|
(define (jolt-truthy? x) (not (or (jolt-nil? x) (eq? x #f))))
|
||||||
|
|
@ -24,44 +23,21 @@
|
||||||
;; --- keywords: interned so identity works; optional namespace ----------------
|
;; --- keywords: interned so identity works; optional namespace ----------------
|
||||||
(define-record-type keyword-t (fields ns name khash) (nongenerative keyword-v1))
|
(define-record-type keyword-t (fields ns name khash) (nongenerative keyword-v1))
|
||||||
(define keyword-table (make-hashtable string-hash string=?))
|
(define keyword-table (make-hashtable string-hash string=?))
|
||||||
;; The common no-ns keyword is interned in a table keyed by NAME directly, so a
|
|
||||||
;; lookup of an already-interned :kw (the hot case — every (:kw x), map literal,
|
|
||||||
;; keyword arg) is one hashtable-ref with NO allocation. The ns table keeps the
|
|
||||||
;; combined key. Both share the keyword-t khash (equal-hash of the combined key),
|
|
||||||
;; so hash values are unchanged.
|
|
||||||
(define keyword-table-bare (make-hashtable string-hash string=?))
|
|
||||||
;; NUL separator can't occur in a keyword ns/name, so the intern key is
|
;; NUL separator can't occur in a keyword ns/name, so the intern key is
|
||||||
;; unambiguous (a "/" separator would collide ns="a" name="b/c" with ns="a/b").
|
;; unambiguous (a "/" separator would collide ns="a" name="b/c" with ns="a/b").
|
||||||
(define (keyword-intern-key ns name) (string-append (or ns "") "\x0;" name))
|
(define (keyword-intern-key ns name) (string-append (or ns "") "\x0;" name))
|
||||||
(define (keyword ns name)
|
(define (keyword ns name)
|
||||||
(if ns
|
(let ((k (keyword-intern-key ns name)))
|
||||||
(let ((k (keyword-intern-key ns name)))
|
(or (hashtable-ref keyword-table k #f)
|
||||||
(or (hashtable-ref keyword-table k #f)
|
(let ((kw (make-keyword-t ns name (equal-hash k))))
|
||||||
(let ((kw (make-keyword-t ns name (equal-hash k))))
|
(hashtable-set! keyword-table k kw)
|
||||||
(hashtable-set! keyword-table k kw)
|
kw))))
|
||||||
kw)))
|
|
||||||
(or (hashtable-ref keyword-table-bare name #f)
|
|
||||||
(let ((kw (make-keyword-t #f name (equal-hash (keyword-intern-key #f name)))))
|
|
||||||
(hashtable-set! keyword-table-bare name kw)
|
|
||||||
kw))))
|
|
||||||
(define (keyword? x) (keyword-t? x))
|
(define (keyword? x) (keyword-t? x))
|
||||||
|
|
||||||
;; --- symbols: ns + name + meta; NOT interned (meta varies), = by ns/name ------
|
;; --- symbols: ns + name + meta; NOT interned (meta varies), = by ns/name ------
|
||||||
;; The ns/name STRINGS are pooled (like JVM Symbol.intern, which .intern()s them):
|
|
||||||
;; two separately-read `?a` symbols share one name-string object, so code that
|
|
||||||
;; compares symbol names by identity (core.logic's non-unique lvar equality, via
|
|
||||||
;; (str sym)) behaves like the JVM.
|
|
||||||
(define symbol-string-pool (make-hashtable string-hash string=?))
|
|
||||||
(define (intern-symbol-string s)
|
|
||||||
(if (string? s)
|
|
||||||
(or (hashtable-ref symbol-string-pool s #f)
|
|
||||||
(begin (hashtable-set! symbol-string-pool s s) s))
|
|
||||||
s))
|
|
||||||
(define-record-type symbol-t (fields ns name meta) (nongenerative symbol-v1))
|
(define-record-type symbol-t (fields ns name meta) (nongenerative symbol-v1))
|
||||||
(define (jolt-symbol ns name)
|
(define (jolt-symbol ns name) (make-symbol-t ns name jolt-nil))
|
||||||
(make-symbol-t (intern-symbol-string ns) (intern-symbol-string name) jolt-nil))
|
(define (jolt-symbol/meta ns name meta) (make-symbol-t ns name meta))
|
||||||
(define (jolt-symbol/meta ns name meta)
|
|
||||||
(make-symbol-t (intern-symbol-string ns) (intern-symbol-string name) meta))
|
|
||||||
(define (jolt-symbol? x) (symbol-t? x))
|
(define (jolt-symbol? x) (symbol-t? x))
|
||||||
|
|
||||||
;; chars/strings: Chez natives (strings treated immutable).
|
;; chars/strings: Chez natives (strings treated immutable).
|
||||||
|
|
@ -96,16 +72,10 @@
|
||||||
((and (jolt-coll? a) (jolt-coll? b)) (jolt-coll=? a b))
|
((and (jolt-coll? a) (jolt-coll? b)) (jolt-coll=? a b))
|
||||||
(else (eq? a b))))
|
(else (eq? a b))))
|
||||||
(define (jolt=2 a b)
|
(define (jolt=2 a b)
|
||||||
;; identity fast path, like Util.equiv's k1 == k2: the same object equals
|
(let loop ((as jolt-eq-arms))
|
||||||
;; itself without a structural walk — (= s s) on an infinite lazy seq must not
|
(cond ((null? as) (jolt=2-base a b))
|
||||||
;; realize it. Numbers keep the exactness-aware arm (Chez may intern flonum
|
(((caar as) a b) ((cdar as) a b))
|
||||||
;; literals, and (= ##NaN ##NaN) is false like the JVM's).
|
(else (loop (cdr as))))))
|
||||||
(if (and (eq? a b) (not (number? a)))
|
|
||||||
#t
|
|
||||||
(let loop ((as jolt-eq-arms))
|
|
||||||
(cond ((null? as) (jolt=2-base a b))
|
|
||||||
(((caar as) a b) ((cdar as) a b))
|
|
||||||
(else (loop (cdr as)))))))
|
|
||||||
(define (jolt= a . rest)
|
(define (jolt= a . rest)
|
||||||
(let loop ((a a) (rest rest))
|
(let loop ((a a) (rest rest))
|
||||||
(cond ((null? rest) #t)
|
(cond ((null? rest) #t)
|
||||||
|
|
|
||||||
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