Compare commits

..

1 commit

Author SHA1 Message Date
Yogthos
e2598280fe DO NOT MERGE — reduce-acc SROA regresses (defeats vec-reduce)
Reduce-accumulator scalar replacement: lower (reduce (fn [acc x] body) (->Rec
inits) coll) with a non-escaping record accumulator to a loop carrying the acc
fields as scalar vars. Correct (run-reduce-sroa.ss 7/7, make test + shakesmoke
green) but a PERF REGRESSION: ray tracer hit-all 38.4s -> ~53s.

Root cause: jolt's reduce already iterates a vector with vec-reduce (seq.ss) — a
tight index loop over the backing store, zero per-element allocation. Lowering to
a (seq)/(first)/(next) loop allocates a seq node per element, trading hit-all's
CONDITIONAL ->HitAcc allocation for a per-element seq allocation. The targeted
accumulator allocation is also conditional (only on hit improvement), not the
dominant per-sphere cost. Kept on this branch for reference; not merged.
2026-06-26 11:28:34 -04:00
127 changed files with 5954 additions and 14474 deletions

View file

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

View file

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

1
.gitignore vendored
View file

@ -2,7 +2,6 @@ AGENTS.md
.DS_Store
CLAUDE.md
build/
target/
.clj-kondo/
.dirge/
.claude/

3
.gitmodules vendored
View file

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

367
LICENSE
View file

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

View file

@ -4,23 +4,18 @@
# build step. `make test` is the full gate. `make remint` rebuilds the seed after a
# source change.
.PHONY: test ci values corpus unit smoke buildsmoke staticnativesmoke selfhost sci cts certify ffi transient infer wp devirt fieldread numwp fieldnum protoret narrow directlink numeric inline shakesmoke remint joltc joltc-release joltc-debug joltcsmoke submodules
# Every target needs the vendored submodules; fail with the fix, not a load error.
submodules:
@test -f vendor/irregex/irregex.scm || { \
echo "vendor submodules missing; run: git submodule update --init --recursive"; exit 1; }
.PHONY: test ci values corpus unit smoke buildsmoke selfhost sci certify ffi transient infer wp devirt fieldread numwp fieldnum reducesroa directlink numeric inline shakesmoke remint
# Full gate (dev machine). Includes the self-host byte-fixpoint, which only holds
# on the same Chez that minted the seed.
test: submodules selfhost ci
test: selfhost ci
@echo "OK: all gates passed"
# CI gate: behavior only. The checked-in seed is a minted artifact (like a
# lockfile) — it RUNS correctly on any Chez, but `selfhost` rebuilds it and a
# different Chez version may emit byte-different (gensym/order) output, so the
# byte-fixpoint is a dev-machine check, not a CI one (jolt-8479).
ci: submodules values corpus unit smoke buildsmoke staticnativesmoke sci cts ffi transient infer wp devirt fieldread numwp fieldnum protoret narrow directlink numeric inline certify
ci: values corpus unit smoke buildsmoke sci ffi transient infer wp devirt fieldread numwp fieldnum reducesroa directlink numeric inline certify
@echo "OK: CI gates passed"
# Self-host fixpoint: bootstrap.ss rebuild == checked-in seed.
@ -47,38 +42,10 @@ smoke:
buildsmoke:
@sh host/chez/build-smoke.sh
# `jolt build` cc-links a :jolt/native :static archive into the binary (the
# default), and --dynamic keeps the runtime load-shared-object path.
staticnativesmoke:
@sh host/chez/static-native-smoke.sh
# Build joltc as a self-contained native binary into target/<profile>/joltc. The
# binary bundles the runtime, compiler, jolt-core + stdlib source, the Chez boots,
# and a launcher stub, so it runs AND compiles jolt apps with no Chez or cc on the
# machine. Built on a dev/CI host that HAS Chez + cc. release = optimize-level 3,
# no inspector info, compressed; debug = optimize-level 0 + inspector + debug info.
joltc-release:
@chez --script host/chez/build-joltc.ss release target/release/joltc
joltc-debug:
@chez --script host/chez/build-joltc.ss debug target/debug/joltc
# Re-mint the seed first so the embedded compiler image is current, then both builds.
joltc: selfhost joltc-release joltc-debug
@echo "OK: target/release/joltc and target/debug/joltc built"
# Self-build smoke: the distributed joltc compiles an app with Chez + cc removed.
joltcsmoke:
@sh host/chez/joltc-selfbuild-smoke.sh
# SCI conformance: load borkdude/sci's source through joltc (floor-gated).
sci:
@chez --script host/chez/run-sci.ss
# clojure-test-suite conformance: run the vendored jank-lang/clojure-test-suite
# per-namespace under joltc, gated on the per-namespace baseline
# (test/chez/cts-known-failures.txt).
cts:
@bash host/chez/cts.sh
# FFI: bind native functions (typed foreign-procedure), memory, and that a
# :blocking call is collect-safe (a parked thread doesn't pin the collector).
ffi:
@ -125,17 +92,11 @@ numwp:
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
# Reduce-accumulator scalar replacement: a reduce over a non-escaping record
# accumulator lowers to a seq loop carrying the acc fields as scalar vars, so the
# per-step record allocation goes away; the result matches the ordinary reduce.
reducesroa:
@chez --script host/chez/run-reduce-sroa.ss
# Direct-linking emission: a closed-world build binds top-level app defs to jv$
# Scheme bindings and routes app->app calls/refs to them, skipping var-deref +

View file

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

View file

@ -40,65 +40,29 @@ source — the jolt/JVM scorecard. jolt's optimizing passes fire only in a build
`joltc run -m` is unoptimized, so the harness always builds.
Indicative ratios (M-series, single isolated run — numbers are machine-specific,
regenerate locally), ascending:
regenerate locally). They cluster into two regimes:
| benchmark | ratio | axis |
|---|---|---|
| `fib` | ~0.6× | call + integer arith |
| `collections` | ~3.5× | persistent map/vector churn |
| `mandelbrot` | ~7.5× | pure float compute |
| `binary-trees` | ~10× | escaping short-lived records (allocation/GC) |
| `dispatch` | ~12× | megamorphic protocol dispatch |
| `mono-dispatch` | ~15× | monomorphic protocol dispatch |
| `mandelbrot` | ~8× | pure float compute |
| `fib` | ~9× | call + integer arith |
| `collections` | ~9× | persistent map/vector churn |
| `dispatch` | ~130× | megamorphic protocol dispatch |
| `binary-trees` | ~140× | escaping short-lived records (allocation/GC) |
| `mono-dispatch` | ~330× | monomorphic protocol dispatch |
- **Compute (~0.67.5×)** is the substrate floor: Chez is a native-compiling AOT
Scheme, not a profiling JIT. With native arith + direct-linking + inlining jolt
is at parity here — `fib` runs *faster* than JVM Clojure (no JIT warmup over a
short run), `collections` is within ~3.5×, and `mandelbrot` (~7.5×) is the
pure-tight-loop float ceiling that only native codegen moves further.
- **Dispatch & allocation (~1015×)** are the remaining architectural gaps, though
the type-proving / native-record / bare-field-read work has collapsed them by an
order of magnitude (`binary-trees` ~140×→~10×, `mono-dispatch` ~330×→~15×). On a
*statically proven* monomorphic receiver — which whole-program inference now gives
for a record iterated out of a vector — devirt resolves the impl and a per-site
inline cache holds it (resolved once, not per call), so `mono-dispatch` is no
longer worse than megamorphic. The remaining lever is `dispatch`: a *megamorphic*
site has no static type, so it pays a full protocol-registry lookup every call
where the JVM uses a polymorphic inline cache — a runtime (receiver-type-keyed)
cache is the missing piece. `binary-trees`
nodes escape into the tree, so scalar-replace can't remove them — residual GC
pressure.
## 64-bit integer arithmetic & generators (test.check)
The AOT suite above is float-compute / dispatch / allocation bound; none of it
exercises **64-bit integer arithmetic**, which Chez can't hold in a fixnum
(61-bit), so genuine 64-bit values are heap bignums. The SplitMix PRNG behind
`clojure.test.check` is the worst case — every `rand-long` is ~8 bignum ops. These
were measured in **run mode** (`joltc run`, where per-site var-cell caching is on;
the AOT build keeps it off) against JVM Clojure on the same portable source. The
first two rows are isolating microbenchmarks; the rest are real test.check
generators.
| workload | jolt | JVM | ratio | bound by |
|---|---|---|---|---|
| SplitMix `mix-64` (×100k) | 45ms | 14ms | ~3.2× | 64-bit integer arithmetic |
| deftype alloc + protocol dispatch (×100k) | 41ms | 5ms | ~8× | open-world dispatch |
| raw `split` + `rand-long` (×20k) | 74ms | 6ms | ~12× | bignum 64-bit + dispatch |
| `gen/large-integer` (×2k) | 108ms | 23ms | ~4.7× | arithmetic + rose-tree machinery |
| `(gen/vector gen/large-integer)` (×500) | 1289ms | 88ms | ~14.6× | element gen + gen machinery |
Two no-C codegen levers collapsed the **arithmetic** half: emitting `bit-and`/
`bit-or`/`bit-xor`/`bit-not` as inlined Chez `bitwise-*` primitives (they had gone
through a var-deref'd variadic overlay), and caching the resolved var cell per
reference site (a name lookup was ~45ns/access). Together they took `mix-64` from
~18× → ~3.2× JVM and the raw PRNG from ~30× → ~12×, and the generators ~1.6× each.
The residual gap is **machinery, not arithmetic**: the open-world generator
deftype/protocol dispatch + rose-tree allocation (~810×) can't be devirtualized
without static types, and the raw 64-bit ops bottom out at the Chez bignum floor
(~20× a native long, substrate-inherent). A native SplitMix C/FFI shim would give
the PRNG ~27× but is the only path that needs C.
- **Compute (~89×)** is the substrate floor: Chez is a native-compiling AOT
Scheme, not a profiling JIT, so it can't match HotSpot on hot loops. Native arith
already gets jolt closest here.
- **Dispatch & allocation (~130330×)** are the architectural gaps. jolt does a
full protocol-registry lookup on every call; the JVM inline-caches a
runtime-monomorphic site to near-free — which is why `mono-dispatch` is *worse*
than megamorphic. devirt only fires on *statically proven* receivers (which
`reduce`/`mapv` over a heterogeneous vector never gives), so the passes don't
engage; a call-site inline cache is the missing lever. `binary-trees` nodes
escape into the tree, so scalar-replace can't remove them — this is GC pressure.
- The optimization passes move these benchmarks <10% vs the unoptimized run, so the
gaps are not a missing-flag problem; they're the dispatch/GC/JIT-floor work.
## Running

View file

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

View file

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

View file

@ -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"`,
`"java.lang.String"`, and so on).
## Source layering: JVM-specific code lives in the java layer
Keep anything JVM-specific in `host/chez/java/`. The rest of the runtime stays
JVM-free, and the compiler in `jolt-core/` is JVM-free by construction.
- `host/chez/java/` holds the JVM model: the `java.*` mirrors, the class tokens
and class hierarchy, `(class x)`/`(type x)`/`instance?`, exception classes, the
interop dispatch for `.method`/`Class/static`/`(Class.)`. If a value or name
only means something because the JVM has it, it belongs here.
- The rest of `host/chez/` is the host-neutral runtime — the value model
(`values.ss`, `collections.ss`, `seq.ss`), reader, vars, multimethods, meta. It
speaks jolt's own taxonomy (`:string`, `:vector`, `:jolt/inst`), never JVM class
names.
- `jolt-core/` (the Clojure compiler + `clojure.core` overlay) emits and reasons
in that taxonomy only. The JVM mapping happens *after*, in the java layer.
The worked example is `type`. The core layer (`natives-meta.ss`) computes the
keyword taxonomy and binds it as `__type-tag` — that's what `print-method` and the
reader dispatch on, with no JVM in scope. The java layer (`java/host-class.ss`)
then rebinds the public `clojure.core/type` to Clojure's `(or (:type meta) (class
x))`, mapping `:jolt/inst` → `java.util.Date` and so on, right next to `(class
…)`. So the compiler keeps emitting `:jolt/inst`; the java layer remaps it.
When you add interop behaviour, prefer registering it through the generic hooks a
java-layer file already uses — `register-class-arm!` for `(class x)`,
`register-instance-check-arm!` for `instance?`, `register-eq-arm!` for value
equality — rather than threading a JVM concept back into a host-neutral file. A
new `java.*` shim is a new file under `host/chez/java/` loaded from `rt.ss`, not a
branch added to `collections.ss` or `seq.ss`.
## What's shimmed
This is the surface today, not the whole JVM. Methods not listed generally
@ -240,32 +210,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
`clj-http-lite` runs unchanged.
`__register-instance-check!` answers one `(instance? Foo x)` question. When a
class belongs to a *hierarchy* — a custom exception that should be caught as an
`IOException`, or a value that should match `(instance? SomeInterface x)` across
its whole supertype chain and dispatch a protocol extended to any of those
supertypes — declare its direct supers once with `jolt.host/register-class-supers!`
instead. `instance?`, `isa?`, `supers`/`ancestors`, and `extend-protocol`
dispatch all derive from the one declaration (supers are given by canonical name;
transitivity is computed):
```clojure
;; a library's exception type that catch/instance? should treat as an IOException
(jolt.host/register-class-supers! "com.acme.RetryExhaustedException"
["java.io.IOException"])
(throw (jolt.host/throwable "com.acme.RetryExhaustedException" "gave up"))
;; (catch java.io.IOException e …) now matches it; (instance? java.lang.Exception e) is true
```
deftype/defrecord classes join the same graph automatically at definition: a
record's ancestry carries the record interfaces (`clojure.lang.IRecord`,
`IPersistentMap`, `Associative`, …), a bare deftype carries
`clojure.lang.IType`, and every protocol the type implements inline appears as
an implemented interface — so `(ancestors MyRecord)`, `(isa? MyRecord
clojure.lang.IPersistentMap)`, and hierarchy relationships `derive`d on a
class's supers all answer like the JVM.
Extending a *built-in* class instead (adding a method to core's `String` shim,
say) means editing the relevant `host/chez/*.ss` file and running `make remint`
— see [building-and-deps.md](building-and-deps.md).

View file

@ -25,13 +25,15 @@ e.g. the [ring-app example](https://github.com/jolt-lang/examples/tree/main/ring
[dependency](https://github.com/weavejester/dependency) and
[meta-merge](https://github.com/weavejester/meta-merge) deps
* [honeysql](https://github.com/seancorfield/honeysql) — SQL formatter and helpers
* [clojure.jdbc](https://github.com/yogthos/clojure.jdbc) — via
* [clojure.jdbc](https://github.com/yogthos/clojure.jdbc) — as
[jolt-lang/db](https://github.com/jolt-lang/db)'s `jdbc.core`, over the built-in
SQLite access (libsqlite3 via Chez's FFI)
* [next.jdbc](https://github.com/seancorfield/next-jdbc) — a compatibility layer in
[jolt-lang/db](https://github.com/jolt-lang/db) over `jdbc.core`
* [tools.logging](https://github.com/clojure/tools.logging) — runs verbatim over a
native `clojure.tools.logging.impl` stderr backend
* [migratus](https://github.com/yogthos/migratus) — database migrations over
[jolt-lang/db](https://github.com/jolt-lang/db)
* [migratus](https://github.com/yogthos/migratus) — database migrations over the
next.jdbc layer
* [malli](https://github.com/metosin/malli) — data schema validation, on the
malli-app example.
* [markdown-clj](https://github.com/yogthos/markdown-clj) — Markdown → HTML, on the
@ -46,35 +48,6 @@ e.g. the [ring-app example](https://github.com/jolt-lang/examples/tree/main/ring
[data.priority-map](https://github.com/clojure/data.priority-map).
* [core.memoize](https://github.com/clojure/core.memoize) — function memoization
over [core.cache](https://github.com/clojure/core.cache).
* [core.async](https://github.com/clojure/core.async) — CSP channels and `go` blocks
(`<!`/`>!`/`alts!`, `pipeline`, `mult`/`mix`/`pub`/`sub`) on real OS threads.
* [core.logic](https://github.com/clojure/core.logic) — relational logic programming
(unification, `run`/`fresh`/`conde`, finite domains).
* [math.combinatorics](https://github.com/clojure/math.combinatorics) — permutations,
combinations, subsets, selections, cartesian products, partitions.
* [core.contracts](https://github.com/clojure/core.contracts) — programming by
contract (`contract`/`with-constraints`/`provide`), over
[core.unify](https://github.com/clojure/core.unify).
* [data.zip](https://github.com/clojure/data.zip) — zipper navigation, including
`clojure.data.zip.xml`; XML parsing via [jolt-lang/xml](https://github.com/jolt-lang/xml)
(which now ships `clojure.xml/parse`).
* [data.csv](https://github.com/clojure/data.csv) — reading and writing CSV.
* [data.codec](https://github.com/clojure/data.codec) — base64 encode/decode over
byte arrays.
* [data.priority-map](https://github.com/clojure/data.priority-map) — priority
maps (incl. keyfn / custom comparator), with `subseq`/`rsubseq`.
* [tools.macro](https://github.com/clojure/tools.macro) — local macros
(`macrolet`/`symbol-macrolet`), `mexpand`/`mexpand-all`.
* [algo.monads](https://github.com/clojure/algo.monads) — monad macros and
monads (maybe/seq/state/writer/reader/…), over
[tools.macro](https://github.com/clojure/tools.macro).
* [test.check](https://github.com/clojure/test.check) — property-based testing
(generators, `quick-check`, shrinking).
* [tools.reader](https://github.com/clojure/tools.reader) — a Clojure reader in
Clojure (edn + full reader, indexing/pushback reader types).
* [rewrite-clj](https://github.com/clj-commons/rewrite-clj) — parse/rewrite Clojure
source while preserving whitespace and comments (nodes + zipper), over
[tools.reader](https://github.com/clojure/tools.reader).
* [tick](https://github.com/juxt/tick) — date/time over Jolt's `java.time`;
`#time/…` literals via `time-literals`.
* [transit-jolt](https://github.com/jolt-lang/transit-jolt) — Transit (JSON) read/write

View file

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

View file

@ -196,164 +196,6 @@ cases; clojure-test-suite `core_test/parse_uuid.cljc`,
---
### clojure.template/apply-template, clojure.test/are — since 1.1
```
(apply-template argv expr values)
(are argv expr & args)
```
**Semantics**
- S1. `apply-template` MUST replace every occurrence of each `argv` symbol
in `expr` with its corresponding value by structural walk (postwalk symbol
substitution), not by lexical binding. Occurrences inside `quote` and at
any nesting depth substitute: `(apply-template '[x] '(f 'x) '[if])`
`(f 'if)`.
- S2. `do-template` MUST partition `args` by `(count argv)` and expand to a
`do` of one substituted `expr` per group.
- S3. `clojure.test/are` MUST expand through `do-template` with `expr`
wrapped in `is`. Consequently `(are [x] (special-symbol? 'x) if def)`
asserts `(special-symbol? 'if)` and `(special-symbol? 'def)` — a
let-binding implementation is non-conforming (the quoted symbol would not
substitute).
**Errors**
- X1. `are` MUST throw at macroexpansion when `(count args)` is not a
positive multiple of a non-empty `(count argv)` (empty/empty is allowed).
- X2. `apply-template` MUST throw when `argv` is not a vector of symbols.
**Conformance**
S1S3 → `test/chez/clojure-test.clj` (are with quoted template var);
clojure-test-suite `core_test/special_symbol_qmark.cljc` and every
`are`-based suite namespace.
---
### make-hierarchy, derive, underive, isa?, parents, ancestors, descendants — since 1.0
```
(make-hierarchy)
(derive tag parent) (derive h tag parent)
(underive tag parent) (underive h tag parent)
(isa? child parent) (isa? h child parent)
(parents tag) (ancestors tag) (descendants tag) ; + (f h tag) forms
```
**Semantics**
- S1. A hierarchy is a pure value `{:parents {tag #{...}} :ancestors {...}
:descendants {...}}`; the 3-arity forms are pure, the shorter arities read and
mutate the global hierarchy.
- S2. `isa?` is true when `(= child parent)`, when the host type system says
parent is assignable from child (both classes), when the relationship was
`derive`d — including a relationship derived on one of a class child's
supers — or component-wise for equal-length vectors.
- S3. Class tags answer through the host type hierarchy: `(parents c)` includes
the class's direct supers (`bases` — a concrete class's chain roots at
`java.lang.Object`, an interface's does not); `(ancestors c)` is the
transitive set plus anything `derive`d on the class or its supers. A
deftype/defrecord class's ancestry includes its implemented protocol
interfaces and, for records, the record interfaces
(`clojure.lang.IRecord`/`IPersistentMap`/`Associative`/…; `clojure.lang.IType`
for a bare deftype).
- S4. `derive` returns the updated hierarchy (3-arity) or nil (2-arity);
deriving a relationship that already holds transitively, or one that would
create a cycle, throws.
**Errors**
- X1. `derive` asserts its argument shapes: parent must be a namespaced Named
value; tag must be a class or a Named value (namespaced in the 2-arity
global form); `(derive h tag tag)` fails the `not=` assert. AssertionError.
- X2. `underive`/`derive` with a non-hierarchy `h` throw at the parents
lookup (the map is called as a function, like the reference).
- X3. `(descendants h SomeClass)` throws UnsupportedOperationException
("Can't get descendants of classes") — Java type inheritance is not
enumerable downward.
**Conformance**
S1S4, X1X3 → corpus `hierarchy / *` rows; clojure-test-suite
`core_test/{derive,underive,isa_…,parents,ancestors,descendants}.cljc`
(all fully passing).
---
### atom, add-watch, remove-watch, set-validator!, get-validator — since 1.0
```
(atom x & {:keys [meta validator]})
(add-watch iref key f) (remove-watch iref key)
(set-validator! iref f) (get-validator iref)
```
**Semantics**
- S1. Watches, validators, and reference metadata are one contract (the JVM's
ARef/IRef) shared by atoms, vars, and agents. `add-watch`/`remove-watch`
return the reference; re-adding a key replaces that watch in place.
- S2. A watch is called `(f key ref old new)` after a state change: atom
swap!/reset!/compare-and-set!, var ROOT changes (`def` on a watched var,
`var-set` outside a thread binding, `alter-var-root` — a thread-binding set
does not notify), and each agent action's state change.
- S3. A validator gates every state change and, via the `:validator` ctor
option, the initial value — an invalid initial value never constructs the
reference.
- S4. The `:meta` ctor option attaches reference metadata (`meta` reads it,
`alter-meta!`/`reset-meta!` update it); nil is allowed.
**Errors**
- X1. A rejected value (validator returns logical false or the ctor option
fails on the initial value) throws IllegalStateException "Invalid reference
state".
- X2. A non-map `:meta` ctor option throws ClassCastException.
**Conformance**
S1S4, X1X2 → corpus `iref / *` rows; clojure-test-suite
`core_test/{atom,add-watch,remove-watch}.cljc` (the remaining baselined error
in the watch namespaces is their STM `ref` section — refs are out of scope,
`stm-refs` in `coverage.md`).
---
### clojure.string coercion, some-fn, ifn? — since 1.2/1.3
```
(clojure.string/upper-case s) … (some-fn p & ps) (ifn? x)
```
**Semantics**
- S1. The clojure.string case fns and searches (`upper-case`, `lower-case`,
`capitalize`, `starts-with?`, `ends-with?`, `includes?`, `index-of`,
`replace`) take any Object `s` through its `toString`, like the reference's
`^CharSequence`+`.toString` signatures: `(upper-case :kw)` is `":KW"`,
`(capitalize 1)` is `"1"`. nil throws (method call on null); a nil `substr`
throws.
- S2. `some-fn` follows the reference arities: at least one predicate
(`(some-fn)` is an arity error) and the returned fn chains with `or`, so a
no-match result is the last predicate's own falsy value (`false` stays
`false`).
- S3. `ifn?` covers fns, keywords, symbols, maps, sets, vectors, vars,
multimethods, promises (invoking a promise delivers it), and a
deftype/defrecord implementing `clojure.lang.IFn`'s `invoke`.
- S4. A `defmulti`/`defmethod` deferred inside a fn body interns/resolves in
the namespace it was WRITTEN in (the macros bake their expansion ns), not
whatever namespace is current when it runs.
**Conformance**
S1S4 → corpus `string / toString coercion`, `core / some-fn`, `core / ifn?`,
`multimethods / deferred definition`; clojure-test-suite string/some-fn/
ifn-qmark/boolean-qmark/reduce namespaces (all fully passing).
---
## Authoring notes
- Source examples from the ClojureDocs export (`clojuredocs-export.edn`,

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -11,26 +11,6 @@
(define cli-args (cdr (command-line))) ; drop the script name
;; Fail early and actionably when the vendored submodules aren't checked out —
;; a plain `git clone` or GitHub's auto-generated "Source code" release archive
;; lacks them, and the raw failure ("load failed for vendor/irregex/irregex.scm")
;; doesn't say how to fix it. (The self-contained joltc binary embeds these and
;; never runs this file.)
(unless (file-exists? "vendor/irregex/irregex.scm")
(display "jolt: vendor submodules are missing (vendor/irregex).
" (current-error-port))
(display "GitHub's 'Source code' release archives don't include submodules.
" (current-error-port))
(display "Clone the repo instead:
" (current-error-port))
(display " git clone --recurse-submodules https://github.com/jolt-lang/jolt.git
" (current-error-port))
(display "or, in an existing checkout:
" (current-error-port))
(display " git submodule update --init --recursive
" (current-error-port))
(exit 1))
(load "host/chez/rt.ss")
(set-chez-ns! "clojure.core")
(load "host/chez/seed/prelude.ss")
@ -55,9 +35,8 @@
;; and exit non-zero, instead of Chez's opaque "non-condition value" dump. The
;; message/ex-data/cause + a mapped Clojure backtrace come from the shared
;; renderer (source-registry.ss); the cli adds the top-level source location.
(define (jolt-report-uncaught raw)
(let ((v (jolt-unwrap-throw raw))
(port (current-error-port)))
(define (jolt-report-uncaught v)
(let ((port (current-error-port)))
(jolt-render-throwable v port)
;; The top-level form that was evaluating when this propagated (file:line:col).
(let ((loc (jolt-current-source-string)))
@ -66,9 +45,6 @@
(when bt (display " trace:\n" port) (display bt port)))
(exit 1)))
;; JOLT_TRACE opt-in, at runtime (before any app ns compiles) so the app is traced.
(jolt-trace-init-from-env!)
(guard (v (#t (jolt-report-uncaught v)))
(cond
;; -e EXPR — evaluate one expression and print it (blank for nil). Wrapped in

View file

@ -130,7 +130,7 @@
(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"))))))
(else (error 'assoc "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.
@ -287,109 +287,26 @@
;; ============================================================================
;; persistent map / set over the HAMT
;; ============================================================================
;; A small map keeps its keys in INSERTION order (Clojure's PersistentArrayMap),
;; converting to hash order past a threshold (PersistentHashMap). The HAMT root
;; always backs the values; `order` is the auxiliary insertion-order key list when
;; the map is in array mode, or #f once it has grown into hash mode. Equality and
;; hashing fold over the entries order-independently, so this only affects
;; iteration order (seq/keys/vals/print), matching the JVM.
(define-record-type pmap (fields root cnt order) (nongenerative chez-pmap-v2))
(define empty-pmap (make-pmap empty-hnode 0 '())) ; {} = empty array map
(define empty-pmap-hash (make-pmap empty-hnode 0 #f)) ; hash-order backing (sets)
(define-record-type pmap (fields root cnt) (nongenerative chez-pmap-v1))
(define empty-pmap (make-pmap empty-hnode 0))
(define pmap-absent (list 'absent)) ; unique missing-key sentinel
;; PersistentArrayMap threshold: assoc of a new key promotes to hash mode once the
;; map already holds 8 entries (array.length >= 16 in the reference). Clojure 1.13
;; raised the limit to 64 for maps whose keys are ALL keywords (the common
;; keyword-map case); mixed-key maps still cap at 8.
(define array-map-limit 8)
(define array-map-limit-kw 64)
(define (all-keywords? ks)
(or (null? ks) (and (keyword? (car ks)) (all-keywords? (cdr ks)))))
;; Should a map of `cnt` entries with insertion order `ord` stay in array mode
;; when key `k` is added? Under 8 always; a keyword-only map (existing keys + the
;; new key all keywords) grows to 64; otherwise it caps at 8.
(define (pmap-array-keep? cnt ord k)
(cond ((fx<? cnt array-map-limit) #t)
((fx>=? cnt array-map-limit-kw) #f)
((and (keyword? k) (all-keywords? ord)) #t)
(else #f)))
(define (append-key ord k) (append ord (list k)))
(define (remove-key ord k) (let loop ((o ord)) (cond ((null? o) '()) ((jolt= (car o) k) (cdr o)) (else (cons (car o) (loop (cdr o)))))))
;; growth rule (PersistentArrayMap.assoc): a new key appends to the order while in
;; array mode under the limit; otherwise the result is hash-ordered. Replacing an
;; existing key (or assoc onto an already-hash map) keeps the current order.
(define (pmap-assoc m k v)
(let* ((added (box #f)) (r (node-assoc (pmap-root m) 0 (key-hash k) k v added))
(cnt (pmap-cnt m)) (ord (pmap-order m)))
(if (unbox added)
(if (and ord (pmap-array-keep? cnt ord k))
(make-pmap r (fx+ cnt 1) (append-key ord k))
(make-pmap r (fx+ cnt 1) #f))
(make-pmap r cnt ord))))
;; force-ordered / force-hash inserts for rebuilding a map whose final mode is
;; already decided (array-map ctor, transient persistent!).
(define (pmap-put-ordered m k v)
(let* ((added (box #f)) (r (node-assoc (pmap-root m) 0 (key-hash k) k v added)))
(if (unbox added)
(make-pmap r (fx+ (pmap-cnt m) 1) (append-key (or (pmap-order m) '()) k))
(make-pmap r (pmap-cnt m) (pmap-order m)))))
(define (pmap-put-hash m k v)
(let* ((added (box #f)) (r (node-assoc (pmap-root m) 0 (key-hash k) k v added)))
(make-pmap r (if (unbox added) (fx+ (pmap-cnt m) 1) (pmap-cnt m)) #f)))
(define (pmap->hash m) (if (pmap-order m) (make-pmap (pmap-root m) (pmap-cnt m) #f) m))
(make-pmap r (if (unbox added) (fx+ (pmap-cnt m) 1) (pmap-cnt m)))))
(define (pmap-dissoc m k)
(let* ((removed (box #f)) (r (node-dissoc (pmap-root m) 0 (key-hash k) k removed))
(ord (pmap-order m)))
(if (unbox removed)
(make-pmap r (fx- (pmap-cnt m) 1) (if ord (remove-key ord k) #f))
m)))
(let* ((removed (box #f)) (r (node-dissoc (pmap-root m) 0 (key-hash k) k removed)))
(make-pmap r (if (unbox removed) (fx- (pmap-cnt m) 1) (pmap-cnt m)))))
(define (pmap-get m k default) (node-get (pmap-root m) 0 (key-hash k) k default))
(define (pmap-contains? m k) (not (eq? pmap-absent (node-get (pmap-root m) 0 (key-hash k) k pmap-absent))))
;; The universal fold idiom across the runtime is `(pmap-fold m (lambda (k v a)
;; (cons ... a)) '())`, which accumulates in REVERSE visitation order. So that this
;; reconstructs the map's INSERTION order, pmap-fold visits an array-mode map's keys
;; in reverse insertion order; a hash-mode map visits HAMT order (its iteration
;; order is unspecified, so reverse-of-HAMT is equivalent and matches prior
;; behaviour). Use pmap-fold-fwd when building a value directly in iteration order.
(define (pmap-fold m proc acc)
(let ((ord (pmap-order m)))
(if ord
(fold-right (lambda (k a) (proc k (pmap-get m k jolt-nil) a)) acc ord) ; visits last->first
(node-fold (pmap-root m) proc acc))))
;; visit entries in iteration (insertion) order — for code that builds a new map /
;; ordered value directly rather than via cons-accumulation.
(define (pmap-fold-fwd m proc acc)
(let ((ord (pmap-order m)))
(if ord
(let loop ((ks ord) (a acc))
(if (null? ks) a (loop (cdr ks) (proc (car ks) (pmap-get m (car ks) jolt-nil) a))))
(node-fold (pmap-root m) proc acc))))
;; map LITERAL ({...}): array map up to 8 entries (64 if keyword-only, per 1.13),
;; hash map beyond (RT.map).
(define (pmap-fold m proc acc) (node-fold (pmap-root m) proc acc))
(define (jolt-hash-map . kvs)
(let loop ((m empty-pmap) (kvs kvs))
(cond ((null? kvs)
(let ((cnt (pmap-cnt m)) (ord (pmap-order m)))
(if (fx>? cnt (if (all-keywords? ord) array-map-limit-kw array-map-limit))
(pmap->hash m) m)))
(cond ((null? kvs) m)
((null? (cdr kvs)) (error 'hash-map "odd number of map literal entries"))
(else (loop (pmap-put-ordered m (car kvs) (cadr kvs)) (cddr kvs))))))
;; array-map ctor: insertion-ordered regardless of size (createAsIfByAssoc).
(define (jolt-array-map-build kvs)
(let loop ((m empty-pmap) (kvs kvs))
(cond ((null? kvs) m)
((null? (cdr kvs)) (error 'array-map "odd number of map entries"))
(else (loop (pmap-put-ordered m (car kvs) (cadr kvs)) (cddr kvs))))))
;; hash-map ctor: hash order (PersistentHashMap).
(define (jolt-hash-map-build kvs)
(let loop ((m empty-pmap-hash) (kvs kvs))
(cond ((null? kvs) m)
((null? (cdr kvs)) (error 'hash-map "odd number of map entries"))
(else (loop (pmap-put-hash m (car kvs) (cadr kvs)) (cddr kvs))))))
(else (loop (pmap-assoc m (car kvs) (cadr kvs)) (cddr kvs))))))
(define-record-type pset (fields m) (nongenerative chez-pset-v1))
(define empty-pset (make-pset empty-pmap-hash)) ; sets are hash-ordered
(define 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-disj s e) (make-pset (pmap-dissoc (pset-m s) e)))
(define (pset-contains? s e) (pmap-contains? (pset-m s) e))
@ -410,7 +327,7 @@
((empty-list-t? coll) (cseq-list x jolt-nil))
((pmap? coll)
(cond ((jolt-nil? x) coll) ; (conj m nil) = m
((pmap? x) (pmap-fold-fwd x (lambda (k v m) (pmap-assoc m k v)) coll)) ; merge in x's order
((pmap? x) (pmap-fold x (lambda (k v m) (pmap-assoc m k v)) coll)) ; merge
((and (pvec? x) (fx=? 2 (pvec-count x)))
(pmap-assoc coll (pvec-nth-d x 0 jolt-nil) (pvec-nth-d x 1 jolt-nil)))
(else (error 'conj "conj on a map expects a [k v] pair or a map"))))
@ -421,11 +338,9 @@
(if (null? args)
(jolt-vector)
(let ((coll (car args)) (xs (cdr args)))
(cond
;; 1-arity returns the coll untouched — (conj nil) is nil
((null? xs) coll)
((jolt-nil? coll) (fold-left jolt-conj1 jolt-empty-list xs))
(else (meta-carry coll (fold-left jolt-conj1 coll xs)))))))
(if (jolt-nil? coll)
(fold-left jolt-conj1 jolt-empty-list xs)
(meta-carry coll (fold-left jolt-conj1 coll xs))))))
;; A host shim registers a type's get via register-get-arm! (handler: (coll k d) ->
;; value) instead of set!-wrapping jolt-get — disjoint coll types, checked before the
@ -462,28 +377,21 @@
(define (rec-coll-method coll name)
(and (jrec? coll) (find-method-any-protocol (jrec-tag coll) name)))
(define (jolt-nth-nil-idx! i)
(when (jolt-nil? i)
(jolt-throw (jolt-host-throwable "java.lang.NullPointerException" "nth index"))))
(define jolt-nth
(case-lambda
((coll i)
(jolt-nth-nil-idx! i)
(let ((i (->idx i)))
(cond ((jolt-nil? coll) jolt-nil) ; RT.nth(nil, i) is nil at any index
((pvec? coll) (let ((v (pvec-v coll)))
(cond ((pvec? coll) (let ((v (pvec-v coll)))
(if (and (fx>=? i 0) (fx<? i (vector-length v))) (vector-ref v i)
(jolt-throw (jolt-host-throwable "java.lang.IndexOutOfBoundsException" "index out of bounds")))))
(error 'nth "index out of bounds"))))
((string? coll) (if (and (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i)
(jolt-throw (jolt-host-throwable "java.lang.IndexOutOfBoundsException" "index out of bounds"))))
(error 'nth "index out of bounds")))
((or (cseq? coll) (empty-list-t? coll)) (seq-nth coll i #f jolt-nil))
((rec-coll-method coll "nth") => (lambda (m) (jolt-invoke m coll i)))
(else (error 'nth "unsupported collection")))))
((coll i d)
(jolt-nth-nil-idx! i)
(let ((i (->idx i)))
(cond ((jolt-nil? coll) d) ; RT.nth(nil, i, notFound) is notFound
((pvec? coll) (pvec-nth-d coll i d))
(cond ((pvec? coll) (pvec-nth-d coll i d))
((string? coll) (if (and (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i) d))
((or (cseq? coll) (empty-list-t? coll)) (seq-nth coll i #t d))
((rec-coll-method coll "nth") => (lambda (m) (jolt-invoke m coll i d)))
@ -528,21 +436,6 @@
((pset? coll) (pset-contains? coll k))
((pvec? coll) (let ((k (->idx k))) (and (fixnum? k) (fx>=? k 0) (fx<? k (pvec-count coll)))))
((jolt-nil? coll) #f)
;; a string supports contains? by INDEX only (RT.contains: CharSequence +
;; Number key); any other key — or any unsupported type — is the JVM's
;; IllegalArgumentException.
((string? coll)
(if (and (number? k) (exact? k) (integer? k))
(and (>= k 0) (< k (string-length coll)))
(jolt-throw (jolt-host-throwable
"java.lang.IllegalArgumentException"
"contains? not supported on type: java.lang.String"))))
((or (cseq? coll) (empty-list-t? coll) (number? coll) (boolean? coll)
(keyword? coll) (jolt-symbol? coll) (char? coll))
(jolt-throw (jolt-host-throwable
"java.lang.IllegalArgumentException"
(string-append "contains? not supported on type: "
(guard (e (#t "?")) (jolt-class-name coll))))))
(else #f)))
(define (jolt-empty? coll)
@ -555,25 +448,15 @@
((cseq? coll) #f) ; a cseq is non-empty by construction
(else (error 'empty? "unsupported collection"))))
(define (jolt-stack-throw coll)
(jolt-throw (jolt-host-throwable
"java.lang.ClassCastException"
(string-append "class " (guard (e (#t "?")) (jolt-class-name coll))
" cannot be cast to class clojure.lang.IPersistentStack"))))
(define (jolt-peek coll)
(cond ((pvec? coll) (pvec-peek coll))
;; list peek = first; a non-list seq (range, a rest chain) is not an
;; IPersistentStack on the JVM
((and (cseq? coll) (cseq-list? coll)) (jolt-first coll))
((empty-list-t? coll) (jolt-first coll))
((jolt-nil? coll) jolt-nil)
(else (jolt-stack-throw coll))))
((or (cseq? coll) (empty-list-t? coll)) (jolt-first coll)) ; list peek = first
((jolt-nil? coll) jolt-nil) (else (error 'peek "unsupported collection"))))
(define (jolt-pop coll)
(cond ((jolt-nil? coll) jolt-nil) ; RT.pop(nil) is nil
((pvec? coll) (meta-carry coll (pvec-pop coll)))
((and (cseq? coll) (cseq-list? coll)) (meta-carry coll (jolt-rest coll)))
(cond ((pvec? coll) (meta-carry coll (pvec-pop coll)))
((cseq? coll) (meta-carry coll (jolt-rest coll))) ; list pop = rest
((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)

View file

@ -27,64 +27,9 @@
;; {: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))))))
(when (pmap? p) (jolt-current-source p))))
;; "file:line:col" / "line:col" for the current form, or #f when none is set.
(define (jolt-current-source-string)
@ -104,54 +49,6 @@
;; is only for the bare -e subset with no prelude. Turn prelude mode on once, here,
;; so every analyze->emit on this spine sees the full core.
((var-deref "jolt.backend-scheme" "set-prelude-mode!") #t)
;; Cache resolved var cells per reference site in runtime-compiled code (the big
;; win for libraries / REPL code). emit-image.ss turns this back off so the seed
;; mint and AOT build stay byte-deterministic. Guarded: the flag is absent in an
;; older seed during the first re-mint pass.
(let ((scv (var-deref "jolt.backend-scheme" "set-var-cache!")))
(when (procedure? scv) (scv #t)))
;; JOLT_TRACE is a falsey value (case-insensitive) — the single predicate both the
;; dev-mode enable and the whole-run enable consult, so "off" never accidentally
;; means "on". An empty / unset value is NOT falsey here — it carries no signal, so
;; dev mode still traces and a whole run still doesn't.
(define (jolt-trace-env-off? e)
(and (string? e)
(let ((s (string-downcase e)))
(or (string=? s "0") (string=? s "false") (string=? s "no")
(string=? s "off") (string=? s "n")))))
;; Tail-frame history. Turning it on makes the emitter add a per-fn history push to
;; every fn compiled AFTERWARD, and allocates this thread's ring. Suppressed when
;; JOLT_TRACE is a falsey value, so JOLT_TRACE=0 / off / no disables it in dev mode.
(define (jolt-enable-trace!)
(unless (jolt-trace-env-off? (getenv "JOLT_TRACE"))
(let ((stf (var-deref "jolt.backend-scheme" "set-trace-frames!")))
(when (procedure? stf) (stf #t)))
(jolt-trace-enable!)))
;; Exposed so the REPL / nREPL entrypoints (jolt.main, jolt.nrepl) can turn tracing
;; on for REPL-driven development without the user setting JOLT_TRACE. Because the
;; push is baked in at compile time, only code compiled after this call is traced —
;; which is exactly the code you eval / reload in a live session.
(def-var! "jolt.host" "enable-trace!" jolt-enable-trace!)
;; Explicit opt-in for a whole run (JOLT_TRACE=1): turn tracing on BEFORE any app
;; namespace is compiled, so a plain `-M:run` traces the app's own code too. Called
;; from the runtime entrypoints (cli.ss, and the built joltc launcher) — NOT at load
;; time: a built joltc runs top-level forms at heap-build time, where JOLT_TRACE is
;; always unset, so a load-time check would never see the user's runtime env. Only an
;; affirmative value (set, non-empty, not falsey) forces it on.
(define (jolt-trace-init-from-env!)
(let ((e (getenv "JOLT_TRACE")))
(when (and e (fx>? (string-length e) 0) (not (jolt-trace-env-off? e)))
(jolt-enable-trace!))))
;; (with-meta sym m) -> sym, else x — an (ns ^:no-doc name …) yields the name with
;; reader metadata as a with-meta form; strip it to read the bare ns symbol.
(define (ce-unwrap-meta x)
(if (and (cseq? x) (cseq-list? x))
(let ((items (seq->list x)))
(if (and (pair? items) (symbol-t? (car items))
(string=? (symbol-t-name (car items)) "with-meta") (pair? (cdr items)))
(cadr items) x))
x))
;; (quote X) -> X, else x — unwraps a quoted require spec.
(define (ce-unquote x)
@ -177,22 +74,14 @@
;; (require spec...) / (use spec...) — specs are quoted
((and hn (or (string=? hn "require") (string=? hn "use")))
(for-each (lambda (a) (chez-register-spec! ns (ce-unquote a))) (cdr items)))
;; (ns name (:require [a :as x]) ...) — clause specs are literal. Register
;; the aliases under NAME (the ns being defined), not the passed `ns`:
;; when a file is loaded its ns form compiles while (chez-current-ns) is
;; still the requiring ns, so using `ns` would leak the loaded ns's
;; aliases into its requirer and clobber a same-named alias there
;; (rewrite-clj.zip.base's [node.protocols :as node] over the caller's node).
;; (ns name (:require [a :as x]) ...) — clause specs are literal
((and hn (string=? hn "ns"))
(let ((ns-name (if (and (pair? (cdr items)) (symbol-t? (ce-unwrap-meta (cadr items))))
(symbol-t-name (ce-unwrap-meta (cadr items)))
ns)))
(for-each (lambda (clause)
(when (and (cseq? clause) (cseq-list? clause))
(let ((cl (seq->list clause)))
(when (ce-clause-require? cl)
(for-each (lambda (spec) (chez-register-spec! ns-name spec)) (cdr cl))))))
(if (pair? (cdr items)) (cddr items) '()))))
(for-each (lambda (clause)
(when (and (cseq? clause) (cseq-list? clause))
(let ((cl (seq->list clause)))
(when (ce-clause-require? cl)
(for-each (lambda (spec) (chez-register-spec! ns spec)) (cdr cl))))))
(if (pair? (cdr items)) (cddr items) '())))
(else (for-each (lambda (x) (ce-scan-requires! x ns)) items))))))))
;; Already-read FORM -> Scheme source string (analyze -> emit on Chez).
@ -243,13 +132,7 @@
;; A top-level (do ...) is UNROLLED — each subform compiled+eval'd in turn, like
;; Clojure's top-level do — so a runtime defmacro/def in an earlier subform is
;; visible (macro flag set, var interned) before a later subform is analyzed.
;; a non-form VALUE (a function object, a BigDecimal, a reference type)
;; self-evaluates, like eval on the JVM.
(define (jolt-compile-eval-form form ns)
(if (or (procedure? form) (jbigdec? form) (jolt-atom? form) (jolt-multifn? form))
form
(jolt-compile-eval-form* form ns)))
(define (jolt-compile-eval-form* form ns)
(cond
;; thread the current ns: an earlier subform may switch it (ns/in-ns call
;; set-chez-ns!), and the next subform must be ANALYZED in that ns so its defs
@ -267,9 +150,6 @@
;; record this form's source location first, so a compile- or run-time error
;; in it reports the right place.
(jolt-enter-form! form)
;; drop tail-frame history from earlier top-level forms, so an error's trace
;; shows only this form's own call history (a no-op unless JOLT_TRACE is on).
(jolt-trace-reset!)
(eval (read (open-input-string (jolt-analyze-emit-form form ns)))
(interaction-environment)))))

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -46,9 +46,7 @@
;; ANY non-empty seq is a list form for analysis (a macro/eval form built via
;; concat/map/cons is a lazy cseq with list?=#f, but evaluating it still means
;; calling its head) — not just reader-built lists.
;; a lazy seq is a list form too: a macro that builds its expansion with map/for
;; (now a LazySeq, not an eager cseq) and splices it must still analyze.
(define (hc-list? x) (or (empty-list-t? x) (cseq? x) (jolt-lazyseq? x)))
(define (hc-list? x) (or (empty-list-t? x) (cseq? x)))
(define (hc-vec? x) (pvec? x))
(define (hc-map? x) (and (pmap? x) (jolt-nil? (jolt-get x hc-kw-jolt-type))))
;; A set form is the reader's tagged map {:jolt/type :jolt/set :value <pvec>} OR a
@ -76,17 +74,6 @@
;; reconstruct it by name at the call site.
(define (hc-ns-value? x) (jns? x))
(define (hc-ns-value-name x) (jns-name x))
;; a live Var value spliced into a form (a macro that does `(~v …)` with v a
;; resolved var) — the analyzer turns it into a :the-var reference by ns+name.
(define (hc-var-value? x) (var-cell? x))
(define (hc-var-value-ns x) (var-cell-ns x))
(define (hc-var-value-name x) (var-cell-name x))
;; *unchecked-math* read at compile time: when truthy (a file's (set!
;; *unchecked-math* …)), the analyzer rewrites +/-/*/inc/dec to their wrapping
;; unchecked-* forms for the rest of that file, like the JVM.
(define (hc-unchecked-math?)
(jolt-truthy? (guard (e (#t #f)) (var-deref "clojure.core" "*unchecked-math*"))))
;; --- form accessors ---------------------------------------------------------
(define (hc-char-code x) (char->integer x)) ; native Chez char -> codepoint
@ -108,7 +95,7 @@
;; list items -> jolt vector (pvec); the analyzer mapv's over the result.
(define (hc-elements x)
(cond ((empty-list-t? x) empty-pvec)
((or (cseq? x) (jolt-lazyseq? x)) (make-pvec (list->vector (seq->list x))))
((cseq? x) (make-pvec (list->vector (seq->list x))))
(else empty-pvec)))
(define (hc-vec-items x) x) ; already a pvec
(define (hc-set-items x)
@ -184,12 +171,7 @@
;; a qualified ns may be a require :as alias (s/split -> clojure.string/split)
(let ((target (or (chez-resolve-alias (chez-actx-cns ctx) qualified) qualified)))
(var-cell-lookup target nm))
(or (let ((c (var-cell-lookup (chez-actx-cns ctx) nm)))
;; an undefined forward-intern must not shadow a real referred
;; or clojure.core var — e.g. the compiler ns referencing `set`,
;; which late-binds (interns `jolt.backend-scheme/set` undefined)
;; and would otherwise hide clojure.core/set on the mint fixpoint.
(and c (var-cell-defined? c) c))
(or (var-cell-lookup (chez-actx-cns ctx) nm)
;; a :refer'd name resolves to its source ns
(let ((ref (chez-resolve-refer (chez-actx-cns ctx) nm)))
(and ref (var-cell-lookup ref nm)))
@ -216,40 +198,17 @@
(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)
(pmap-fold 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)
(define (hc-expand-1 ctx form)
(let* ((items (seq->list form))
(head (car items))
(args (map hc-macro-arg (cdr items)))
(expander (var-cell-root (hc-resolve-cell ctx head)))
(amp-env (if (pair? maybe-env) (car maybe-env) (jolt-hash-map))))
(dynamic-wind
(lambda () (jolt-push-thread-bindings
(jolt-hash-map hc-amp-form-cell form hc-amp-env-cell amp-env)))
(lambda () (hc-propagate-pos form (apply jolt-invoke expander args)))
(lambda () (jolt-pop-thread-bindings)))))
(args (cdr items))
(expander (var-cell-root (hc-resolve-cell ctx head))))
(hc-propagate-pos form (apply jolt-invoke expander args))))
;; Classify a global (non-local) symbol reference against the var registry:
;; {:kind :var :ns NS :name NAME} — a defined var (compile ns / clojure.core)
@ -327,15 +286,10 @@
;; Any seq counts, not just a proper list: a macro that builds the template with
;; map/for (e.g. deftype's rewrite-set) yields a LAZY seq, and its ~unquotes must
;; still be recognized.
;; head symbol matches name nm, bare or clojure.core-qualified — the reader
;; produces clojure.core/unquote(-splicing) for ~/~@ (JVM parity), and this is
;; only used to spot those heads in syntax-quote templates.
(define (hc-head-is? x nm)
(and (cseq? x)
(let ((h (seq-first x)))
(and (symbol-t? h) (string=? (symbol-t-name h) nm)
(let ((ns (hc-sym-ns h)))
(or (jolt-nil? ns) (and (string? ns) (string=? ns "clojure.core"))))))))
(and (symbol-t? h) (jolt-nil? (hc-sym-ns h)) (string=? (symbol-t-name h) nm)))))
(define (hc-second x) (seq-first (jolt-seq (seq-more x))))
(define (hc-sq-symbol ctx form gsmap)
@ -354,16 +308,6 @@
;; a class token, not a var to namespace-qualify — leave it bare, as
;; Clojure's syntax-quote resolves it to the class.
((hc-fq-class-name? nm) form)
;; the compile ns's OWN def shadows clojure.core — a name the ns
;; excluded and redefined (e.g. core.logic's `==` after
;; (:refer-clojure :exclude [==])), or any ns-local redefinition.
;; Referred names live in a separate table, so this only hits a real
;; local intern, matching how the analyzer resolves the bare symbol.
((var-cell-lookup (chez-actx-cns ctx) nm) (jolt-symbol (chez-actx-cns ctx) nm))
;; a name the compile ns excluded from clojure.core (:refer-clojure
;; :exclude) is not clojure.core/nm even before the ns defines its own —
;; qualify to the compile ns, like Clojure (core.logic.fd's `==`).
((chez-core-excluded? (chez-actx-cns ctx) nm) (jolt-symbol (chez-actx-cns ctx) nm))
((var-cell-lookup "clojure.core" nm) (jolt-symbol "clojure.core" nm))
;; a name referred into the compile ns (:require :refer / :use :only)
;; qualifies to its SOURCE ns, not the compile ns — so a macro that
@ -417,32 +361,8 @@
(define (hc-syntax-quote-lower ctx inner)
(hc-sq-lower ctx inner (make-hashtable string-hash string=?)))
;; a ^Type param hint: name is the tag (a symbol, sometimes a string). Resolve it
;; against the record registry (records.ss) so the inference seeds the param as
;; that record — the open-world / cross-ns path where no caller type is inferred.
(define (hc-record-tag-name name)
(cond ((symbol-t? name) (symbol-t-name name))
((string? name) name)
(else #f)))
(define (hc-record-type? ctx name)
(let ((nm (hc-record-tag-name name)))
(if (and nm (chez-find-ctor-key nm (chez-current-ns))) #t #f)))
(define (hc-record-ctor-key ctx name)
(let ((nm (hc-record-tag-name name)))
(or (and nm (chez-find-ctor-key nm (chez-current-ns))) jolt-nil)))
;; The fully-qualified deftype tag ("ns.Name") IFF `class` names a deftype DEFINED
;; in the ctx's compile ns — the analyzer qualifies a bare (Name. …) to it, so a
;; deftype doesn't shadow a same-named built-in host class in an unrelated ns
;; (rewrite-clj imports java.io.PushbackReader; tools.reader defines its own). Strict:
;; only this ns's own def (the preferred shape key) counts, not the global
;; simple-name fallback, so a ns that merely uses the built-in resolves nil.
(define (hc-deftype-ctor-class ctx class)
(let* ((nm (jolt-str-render-one class))
(cns (hc-current-ns ctx))
(key (string-append cns "/->" nm)))
(if (hashtable-ref chez-record-shapes-tbl key #f)
(string-append cns "." nm)
jolt-nil)))
(define (hc-record-type? ctx name) #f)
(define (hc-record-ctor-key ctx name) 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))
@ -494,10 +414,6 @@
(def-var! "jolt.host" "form-uuid?" hc-uuid?)
(def-var! "jolt.host" "form-ns-value?" hc-ns-value?)
(def-var! "jolt.host" "form-ns-value-name" hc-ns-value-name)
(def-var! "jolt.host" "form-var-value?" hc-var-value?)
(def-var! "jolt.host" "form-var-value-ns" hc-var-value-ns)
(def-var! "jolt.host" "form-var-value-name" hc-var-value-name)
(def-var! "jolt.host" "unchecked-math?" hc-unchecked-math?)
(def-var! "jolt.host" "form-bigdec?" hc-bigdec?)
(def-var! "jolt.host" "form-bigdec-source" hc-bigdec-source)
(def-var! "jolt.host" "form-elements" hc-elements)
@ -518,7 +434,6 @@
(def-var! "jolt.host" "form-syntax-quote-lower" hc-syntax-quote-lower)
(def-var! "jolt.host" "record-type?" hc-record-type?)
(def-var! "jolt.host" "record-ctor-key" hc-record-ctor-key)
(def-var! "jolt.host" "deftype-ctor-class" hc-deftype-ctor-class)
(def-var! "jolt.host" "record-shapes" hc-record-shapes)
(def-var! "jolt.host" "protocol-methods" hc-protocol-methods)
(def-var! "jolt.host" "inline-enabled?" hc-inline-enabled?)

View file

@ -113,7 +113,7 @@
(define %h-set? jolt-set?)
(set! jolt-set? (lambda (x) (or (htable-sorted-set? x) (%h-set? x))))
(def-var! "clojure.core" "set?" jolt-set?)
(def-var! "clojure.core" "coll?" (lambda (x) (or (htable-sorted? x) (jrec-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 ---------------------------------------------------------
;; A sorted coll canonicalizes like its unordered counterpart:

View file

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

View file

@ -7,19 +7,21 @@
;;
;; 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.
;; scale or throws ArithmeticException on a non-terminating expansion. Clojure
;; contagion: a bigdec mixed with an integer 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 native hot path untouched:
;; - value position ((reduce + bigs)/(apply * bigs)): the jolt-add/-sub/-mul/-div
;; and compare shims dispatch here when a bigdec operand is present.
;; - 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 to the jbd op. Non-bigdec code is unaffected.
;; Gaps (a runtime bigdec the analyzer can't see statically): a bigdec mixed with a
;; flonum in call position ((+ 1.5M 2.0)) and arithmetic over a bigdec the analyzer
;; types as :any ((+ (bigdec x) 1)) fall through to the raw op and throw; use value
;; position or a literal-typed let.
(define-record-type jbigdec (fields unscaled scale) (nongenerative chez-jbigdec-v1))
@ -77,13 +79,11 @@
(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.
;; coerce an exact integer to a scale-0 bigdec; pass a bigdec through. Used on the
;; non-flonum mixed path (bigdec + long -> bigdec).
(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 --------------------------
@ -117,39 +117,12 @@
"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))))
;; a/b = (ua * 10^sb) / (ub * 10^sa) as an exact rational.
(jbd-rational->bigdec (/ (* (jbigdec-unscaled a) (expt 10 (jbigdec-scale b)))
(* (jbigdec-unscaled b) (expt 10 (jbigdec-scale a))))))
;; integer-division semantics (quot/rem): truncate toward zero, scale 0.
(define (jbd-int-quot a b)
@ -166,65 +139,13 @@
(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*).
;; the native fallback for the double-contagion path; bd-op is the exact bigdec op.
(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)))))
(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)
@ -282,96 +203,23 @@
;; --- 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)))))
;; Value-position arithmetic: (reduce + bigs) / (apply * bigs) pass +/*/- // AS A
;; VALUE, which lowers to these shims (NOT the inlined hot-path native op). Extend
;; them to dispatch to the bigdec engine when a bigdec operand is present; ordinary
;; numeric folds hit the captured native path unchanged.
(define jbd-prev-add jolt-add)
(define jbd-prev-sub jolt-sub)
(define jbd-prev-mul jolt-mul)
(define jbd-prev-div jolt-div)
(define jbd-prev-min jolt-min)
(define jbd-prev-max jolt-max)
(define (jbd-any? xs) (and (pair? xs) (or (jbigdec? (car xs)) (jbd-any? (cdr xs)))))
(set! jolt-add (lambda xs (if (jbd-any? xs) (apply jbd-add xs) (apply jbd-prev-add xs))))
(set! jolt-sub (lambda xs (if (jbd-any? xs) (apply jbd-sub xs) (apply jbd-prev-sub xs))))
(set! jolt-mul (lambda xs (if (jbd-any? xs) (apply jbd-mul xs) (apply jbd-prev-mul xs))))
(set! jolt-div (lambda xs (if (jbd-any? xs) (apply jbd-div xs) (apply jbd-prev-div xs))))
(set! jolt-min (lambda xs (if (jbd-any? xs) (apply jbd-min xs) (apply jbd-prev-min xs))))
(set! jolt-max (lambda xs (if (jbd-any? xs) (apply jbd-max xs) (apply jbd-prev-max xs))))
;; 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.

View file

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

View file

@ -151,31 +151,16 @@
(mutable queue) (mutable running?) mu cv)
(nongenerative jolt-agent-v1))
;; (agent state :meta m :validator f :error-mode e): the ARef ctor contract like
;; atom's — the validator runs against the initial state, :meta must be a map.
;; :error-mode is accepted/ignored (jolt agents are always :fail).
;; (agent state) / (agent state :validator f :error-mode m :meta x): only :validator
;; has runtime behaviour here; other opts are accepted/ignored.
(define (jolt-agent-new state . opts)
(let loop ((o opts) (validator jolt-nil) (m #f))
(let loop ((o opts) (validator jolt-nil))
(cond
((or (null? o) (null? (cdr o)))
(let ((a (make-jolt-agent state jolt-nil validator (vector '() '()) #f (make-mutex) (make-condition))))
(when (and (not (jolt-nil? validator)) (jolt-not (jolt-invoke validator state)))
(jolt-iref-state-throw))
(when (and m (not (jolt-nil? m)))
(unless (jolt-map? m)
(jolt-throw (jolt-host-throwable
"java.lang.ClassCastException"
(string-append "class " (jolt-class-name m)
" cannot be cast to class clojure.lang.IPersistentMap"))))
(hashtable-set! meta-table a m))
a))
(make-jolt-agent state jolt-nil validator (vector '() '()) #f (make-mutex) (make-condition)))
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "validator"))
(loop (cddr o) (cadr o) m))
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "meta"))
(loop (cddr o) validator (cadr o)))
(else (loop (cddr o) validator m)))))
;; agents are watchable IRefs; the worker notifies on each state change.
(register-iref-arm! jolt-agent?)
(loop (cddr o) (cadr o)))
(else (loop (cddr o) validator)))))
;; The action queue is an amortized-O(1) FIFO held as a mutable #(out in): `out` is
;; the front, `in` holds sends reversed onto it (an append-to-a-list send was O(n)).
@ -204,13 +189,11 @@
(guard (e (#t (with-mutex (jolt-agent-mu a)
(jolt-agent-err-set! a e)
(condition-broadcast (jolt-agent-cv a)))))
(let* ((old (jolt-agent-state a))
(nv (apply jolt-invoke (car act) old (cdr act))))
(let ((nv (apply jolt-invoke (car act) (jolt-agent-state a) (cdr act))))
(let ((vf (jolt-agent-validator a)))
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf nv)))
(jolt-iref-state-throw)))
(jolt-agent-state-set! a nv)
(iref-notify a old nv)))
(error #f "Invalid reference state")))
(jolt-agent-state-set! a nv)))
(loop)))))
;; send / send-off: enqueue the action, start the worker if idle. (jolt treats them
@ -301,16 +284,6 @@
(def-var! "clojure.core" "future-cancelled?" jolt-native-future-cancelled?)
(def-var! "clojure.core" "promise" jolt-promise-new)
(def-var! "clojure.core" "deliver" jolt-deliver)
;; a promise is an IFn on the JVM: (p val) delivers. Registered as a cold
;; invoke arm; callable-host? feeds the ifn? overlay (multimethods included).
(register-invoke-arm! jolt-promise?
(lambda (p args)
(if (and (pair? args) (null? (cdr args)))
(jolt-deliver p (car args))
(jolt-throw (jolt-host-throwable "clojure.lang.ArityException"
"Wrong number of args passed to a promise")))))
(def-var! "jolt.host" "callable-host?"
(lambda (x) (if (or (jolt-multifn? x) (jolt-promise? x)) #t jolt-nil)))
(def-var! "clojure.core" "agent" jolt-agent-new)
(def-var! "clojure.core" "agent?" jolt-agent?)
(def-var! "clojure.core" "send" jolt-agent-send)
@ -424,188 +397,4 @@
(with-mutex (vector-ref st 1)
(let loop () (when (> (vector-ref st 0) 0) (condition-wait (vector-ref st 2) (vector-ref st 1)) (loop)))))
jolt-nil))
(cons "getCount" (lambda (self) (vector-ref (jhost-state self) 0)))))
;; --- main-thread executor ---------------------------------------------------
;; Lets a worker thread (e.g. an nREPL eval future) run a thunk on the thread
;; that owns the GUI main loop. On macOS GTK quartz, g_application_run must run
;; on the process main thread or AppKit aborts (setMainMenu off-main → SIGABRT).
;; Under `joltc nrepl` the accept loop is backgrounded in a future and the
;; primordial thread enters jolt-run-main-pump; glimmer's run marshals its
;; startup through jolt-call-on-main-thread.
;;
;; - With no pump running (`joltc -M:run` calls run directly on the main thread),
;; call-on-main-thread runs the thunk INLINE — unchanged behaviour.
;; - A call from a thunk already executing on the pump runs inline too, so the
;; pump can't deadlock on itself.
;; - Otherwise the thunk is enqueued; the caller blocks until the pump runs it,
;; then receives the value, or the thrown condition is re-raised.
;;
;; stop-main-pump is the graceful-shutdown / external API: it tells the pump to
;; drain whatever is queued and return. The pump-active flag is flipped to #f
;; under jolt-main-queue-mu in the same critical section that decides to exit, and
;; call-on-main-thread reads that flag and enqueues under the SAME mutex, so a job
;; can never slip in after the pump has decided to leave — a call that loses the
;; race simply runs inline instead of blocking forever on a pump that is gone.
(define jolt-main-queue-mu (make-mutex))
(define jolt-main-queue-cv (make-condition))
(define jolt-main-queue '()) ; FIFO of jolt-main-job, guarded by mu
(define jolt-main-pump-active (box #f)) ; #t while run-main-pump owns this thread
(define jolt-main-pump-stop (box #f)) ; set by stop-main-pump to drain + exit
;; thread-local: this thread is the pump, mid-thunk → nested calls run inline.
(define jolt-in-main-pump? (make-thread-parameter #f))
(define-record-type jolt-main-job
(fields thunk (mutable done?) (mutable ok?) (mutable val) mu cv)
(nongenerative jolt-main-job-v1))
(define (jolt-call-on-main-thread thunk)
(if (jolt-in-main-pump?) ; reentrant — already on the pump
(jolt-invoke thunk)
;; Decide-and-enqueue atomically: read pump-active and (if active) push the
;; job under jolt-main-queue-mu, the same lock the pump holds when it flips
;; active to #f on exit. So we either get queued before the pump leaves, or
;; we see #f and fall through to inline — never enqueue onto a dead pump.
(let ((job (with-mutex jolt-main-queue-mu
(and (unbox jolt-main-pump-active)
(let ((j (make-jolt-main-job thunk #f #f jolt-nil
(make-mutex) (make-condition))))
(set! jolt-main-queue (append jolt-main-queue (list j)))
(condition-signal jolt-main-queue-cv)
j)))))
(if (not job)
(jolt-invoke thunk) ; no pump (or stopped) — inline, like -M:run
(begin
(with-mutex (jolt-main-job-mu job)
(let wait ()
(unless (jolt-main-job-done? job)
(condition-wait (jolt-main-job-cv job) (jolt-main-job-mu job))
(wait))))
(if (jolt-main-job-ok? job)
(jolt-main-job-val job)
(raise (jolt-main-job-val job))))))))
(define jolt-pump-kih
(lambda ()
(for-each (lambda (th) (guard (e (#t #f)) (th)))
(reverse (unbox jolt-shutdown-hooks)))
(exit 0)))
;; Park the calling thread until a keyboard interrupt (^C), then run the shutdown
;; hooks and exit. Unlike run-main-pump (whose tight recursive condition-wait
;; loop elides Chez's interrupt poll points, so the handler never fires), this
;; uses a single condition-wait — the form Chez reliably interrupts. The nREPL
;; server parks here; SIGINT is unblocked in this thread first (it was masked by
;; jolt-block-sigint so the accept loop inherited a blocked mask and couldn't
;; absorb ^C in its foreign accept() call).
(define jolt-park-mu (make-mutex))
(define jolt-park-cv (make-condition))
(define (jolt-park-until-interrupt)
(keyboard-interrupt-handler jolt-pump-kih)
(jolt-set-sigint-blocked #f)
(with-mutex jolt-park-mu (condition-wait jolt-park-cv jolt-park-mu))
jolt-nil)
(define (jolt-run-main-pump)
(with-mutex jolt-main-queue-mu
(set-box! jolt-main-pump-stop #f)
(set-box! jolt-main-pump-active #t))
;; dynamic-wind guarantees active is cleared even if the pump escapes abnormally,
;; so a later run-main-pump starts clean and call-on-main-thread never sees a
;; stale #t. The clean-exit path below also clears it under the mutex (the flip
;; that races call-on-main-thread); this is the belt-and-suspenders for escapes.
(dynamic-wind
(lambda () #f)
(lambda ()
(let loop ()
(let ((job (with-mutex jolt-main-queue-mu
(let wait ()
(cond
((not (null? jolt-main-queue))
(let ((j (car jolt-main-queue)))
(set! jolt-main-queue (cdr jolt-main-queue))
j))
((unbox jolt-main-pump-stop)
;; drain done, told to exit — clear active in the same
;; critical section so no job can be enqueued after.
(set-box! jolt-main-pump-active #f)
#f)
(else (condition-wait jolt-main-queue-cv jolt-main-queue-mu)
(wait)))))))
(when job
(let ((r (dynamic-wind
(lambda () (jolt-in-main-pump? #t))
(lambda ()
(guard (e (#t (cons #f e)))
(cons #t (jolt-invoke (jolt-main-job-thunk job)))))
(lambda () (jolt-in-main-pump? #f)))))
(with-mutex (jolt-main-job-mu job)
(jolt-main-job-ok?-set! job (car r))
(jolt-main-job-val-set! job (cdr r))
(jolt-main-job-done?-set! job #t)
(condition-broadcast (jolt-main-job-cv job))))
(loop)))))
(lambda ()
(with-mutex jolt-main-queue-mu (set-box! jolt-main-pump-active #f))))
jolt-nil)
(define (jolt-stop-main-pump)
(with-mutex jolt-main-queue-mu
(set-box! jolt-main-pump-stop #t)
(condition-broadcast jolt-main-queue-cv))
jolt-nil)
;; Shutdown hooks run by jolt-pump-kih (the keyboard-interrupt-handler installed by
;; park-until-interrupt) before (exit 0), so a foreground server (nREPL) can close
;; its socket and drop .nrepl-port on ^C instead of Chez's default mutex-corrupting
;; abort. Newest-first; each hook is isolated so one failing hook can't block the exit.
(define jolt-shutdown-hooks (box '()))
(define (jolt-add-shutdown-hook thunk)
(set-box! jolt-shutdown-hooks (cons thunk (unbox jolt-shutdown-hooks)))
jolt-nil)
;; Per-thread SIGINT mask. A worker thread parked in a foreign call (the nREPL
;; accept loop in c-accept, or a conn handler) can't run Chez's keyboard-interrupt
;; handler on ^C, so if SIGINT is delivered there the process hangs. Block SIGINT
;; in the primordial thread BEFORE forking such workers (they inherit the mask),
;; then park-until-interrupt unblocks it in the primordial once its handler is
;; installed, so ^C is always delivered to the parked thread. pthread_sigmask/
;; sigaddset are libc/libpthread symbols, resolvable once the process object is
;; loaded (as the socket fns already are). 128 bytes covers Linux's 1024-bit
;; sigset_t and is larger than macOS's 4-byte one.
;; foreign-procedure resolves its symbol eagerly, and these POSIX signal fns don't
;; exist on Windows — resolving them unguarded aborted startup ("no entry for
;; pthread_sigmask"). Guard so a non-POSIX host yields #f; jolt-set-sigint-blocked
;; then no-ops (Windows delivers ^C through the console, not a per-thread mask).
(define c-pthread-sigmask
(jolt-foreign-proc-safe "pthread_sigmask" '(int u8* u8*) 'int))
(define c-sigemptyset (jolt-foreign-proc-safe "sigemptyset" '(u8*) 'int))
(define c-sigaddset (jolt-foreign-proc-safe "sigaddset" '(u8* int) 'int))
;; POSIX SIG_BLOCK/SIG_UNBLOCK numerics differ by platform: Linux/glibc 0/1,
;; Darwin/macOS 1/2 (SIG_UNBLOCK is SIG_BLOCK+1 on both). Resolve SIG_BLOCK for
;; this host from the machine-type symbol — macOS builds contain "osx".
(define jolt-sig-block-how
(let* ((s (symbol->string (machine-type)))
(n (string-length s)))
(let loop ((i 0))
(cond
((> (+ i 3) n) 0) ; default: Linux/glibc
((string=? (substring s i (+ i 3)) "osx") 1) ; Darwin/macOS
(else (loop (+ i 1)))))))
(define (jolt-set-sigint-blocked block?)
(when (and c-pthread-sigmask c-sigemptyset c-sigaddset)
(let ((set (make-bytevector 128 0))
(old (make-bytevector 128 0)))
(c-sigemptyset set)
(c-sigaddset set 2) ; SIGINT = 2
(c-pthread-sigmask (if block? jolt-sig-block-how (+ jolt-sig-block-how 1)) set old)))
jolt-nil)
(def-var! "jolt.host" "call-on-main-thread" jolt-call-on-main-thread)
(def-var! "jolt.host" "run-main-pump" jolt-run-main-pump)
(def-var! "jolt.host" "stop-main-pump" jolt-stop-main-pump)
(def-var! "jolt.host" "add-shutdown-hook" jolt-add-shutdown-hook)
(def-var! "jolt.host" "block-sigint" (lambda () (jolt-set-sigint-blocked #t)))
(def-var! "jolt.host" "park-until-interrupt" jolt-park-until-interrupt)
(def-var! "jolt.host" "delete-file" delete-file)
(cons "getCount" (lambda (self) (vector-ref (jhost-state self) 0)))))

View file

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

View file

@ -35,56 +35,15 @@
((jolt-atom? x) "clojure.lang.Atom")
((char? x) "java.lang.Character")
((regex-t? x) "java.util.regex.Pattern")
;; an anonymous / unregistered fn — like the JVM, where (class #(..)) is a
;; concrete ns$fn__N subclass. The $fn marker lets clojure.spec.alpha's fn-sym
;; recognize it as anonymous and return ::s/unknown. A named fn is registered
;; (proc-name-tbl) and handled by a class-arm with its real ns$name.
((procedure? x) "clojure.lang.AFunction$fn")
((procedure? x) "clojure.lang.IFn")
;; an exception value (ex-info / host-constructed throwable) reports its JVM
;; class, so (= clojure.lang.ExceptionInfo (class e)) and clojure.test's
;; (thrown? Class …) match (records.ss ex-info-map?/ex-info-class).
((ex-info-map? x) (ex-info-class x))
;; persistent collections + namespace report their JVM class names (not jolt's
;; internal :vector/:set/… type keyword), so class-based dispatch — e.g. a
;; defmulti on [(class a) (class b)] — sees a real clojure.lang.* class.
((jns? x) "clojure.lang.Namespace")
((pvec? x) "clojure.lang.PersistentVector")
((pset? x) "clojure.lang.PersistentHashSet")
((pmap? x) "clojure.lang.PersistentArrayMap")
((jolt-lazyseq? x) "clojure.lang.LazySeq")
((empty-list-t? x) "clojure.lang.PersistentList$EmptyList")
((cseq? x) "clojure.lang.PersistentList")
(else (jolt-str-render-one (jolt-type x)))))
;; the class NAME of x (string), or nil for nil. (class x) wraps it in a Class
;; value (make-class-obj, host-static-classes.ss) so it renders like a JVM Class
;; while staying = its name string.
;; a raw Chez condition Clojure raises a specific class for (records-interop.ss
;; chez-condition-exc-class) reports that JVM class, so (class e) and a
;; (thrown? ArityException …) test match — not the opaque :object fallback.
(register-class-arm!
(lambda (x) (and (chez-condition-exc-class x) #t))
(lambda (x) (let ((p (assoc (chez-condition-exc-class x) class-token-alist)))
(if p (cdr p) "java.lang.IllegalArgumentException"))))
;; A fn def'd into a var reports a JVM-style class name "ns$munged-name" (the
;; forward CHAR_MAP), so clojure.spec.alpha's fn-sym (which splits on $ and
;; demunges) recovers the predicate's symbol. Anonymous / unregistered fns stay
;; clojure.lang.IFn (fn-sym yields :unknown, as on the JVM).
(define class-munge-map
'((#\? . "_QMARK_") (#\! . "_BANG_") (#\* . "_STAR_") (#\+ . "_PLUS_")
(#\> . "_GT_") (#\< . "_LT_") (#\= . "_EQ_") (#\/ . "_SLASH_") (#\- . "_")
(#\& . "_AMPERSAND_") (#\% . "_PERCENT_") (#\~ . "_TILDE_") (#\^ . "_CARET_")
(#\| . "_BAR_") (#\: . "_COLON_")))
(define (class-munge-name s)
(let ((out (open-output-string)))
(string-for-each
(lambda (c) (let ((t (assv c class-munge-map))) (if t (display (cdr t) out) (write-char c out))))
s)
(get-output-string out)))
(register-class-arm!
(lambda (x) (and (procedure? x) (hashtable-ref proc-name-tbl x #f)))
(lambda (x) (let ((p (hashtable-ref proc-name-tbl x #f)))
(string-append (car p) "$" (class-munge-name (cdr p))))))
(define (jolt-class-name x)
(let loop ((as jolt-class-arms))
(cond ((null? as) (jolt-class-base x))
@ -96,25 +55,11 @@
(def-var! "clojure.core" "class" jolt-class)
;; The PUBLIC clojure.core/type — Clojure's (or (:type meta) (class x)). This is the
;; java host layer's job: the core taxonomy (natives-meta.ss jolt-type, kept under
;; __type-tag for print-method) is JVM-free, and the JVM class mapping lives HERE,
;; next to (class …). The inst/array/byte-buffer host files extend `class` (a
;; class-arm or jolt-type fallthrough) and re-point `type` at this same fn, so the
;; remap of every value — :jolt/inst -> java.util.Date etc. — happens in one place.
(define ty-meta-key (keyword #f "type"))
(define (jolt-type-pub x)
(let* ((m (jolt-meta x))
(override (if (jolt-nil? m) jolt-nil (jolt-get m ty-meta-key jolt-nil))))
(if (not (jolt-nil? override)) override (jolt-class x))))
(def-var! "clojure.core" "type" jolt-type-pub)
;; bare class-name tokens -> canonical JVM class-name strings.
(define class-token-alist
'(("String" . "java.lang.String") ("Number" . "java.lang.Number")
("Boolean" . "java.lang.Boolean") ("Long" . "java.lang.Long")
("Integer" . "java.lang.Integer") ("Double" . "java.lang.Double")
("Float" . "java.lang.Float") ("Byte" . "java.lang.Byte") ("Short" . "java.lang.Short")
("Object" . "java.lang.Object") ("Character" . "java.lang.Character")
("InputStream" . "java.io.InputStream") ("OutputStream" . "java.io.OutputStream")
("File" . "java.io.File") ("Reader" . "java.io.Reader") ("Writer" . "java.io.Writer")
@ -126,7 +71,6 @@
("Charset" . "java.nio.charset.Charset") ("Base64" . "java.util.Base64")
("Exception" . "java.lang.Exception")
("IllegalArgumentException" . "java.lang.IllegalArgumentException")
("ArityException" . "clojure.lang.ArityException")
("IllegalStateException" . "java.lang.IllegalStateException")
("RuntimeException" . "java.lang.RuntimeException")
("UnsupportedOperationException" . "java.lang.UnsupportedOperationException")
@ -149,20 +93,7 @@
("IndexOutOfBoundsException" . "java.lang.IndexOutOfBoundsException")
("UnsupportedEncodingException" . "java.io.UnsupportedEncodingException")
("FileNotFoundException" . "java.io.FileNotFoundException")
("Throwable" . "java.lang.Throwable")
;; clojure.lang / java.util types that class-based multimethods dispatch on.
("Fn" . "clojure.lang.Fn") ("IFn" . "clojure.lang.IFn")
("Namespace" . "clojure.lang.Namespace") ("Named" . "clojure.lang.Named")
("Set" . "java.util.Set") ("List" . "java.util.List") ("Map" . "java.util.Map")
("Collection" . "java.util.Collection") ("Iterable" . "java.lang.Iterable")
("CharSequence" . "java.lang.CharSequence") ("Comparable" . "java.lang.Comparable")
("Runnable" . "java.lang.Runnable") ("Callable" . "java.util.concurrent.Callable")
("IPersistentSet" . "clojure.lang.IPersistentSet")
("IPersistentVector" . "clojure.lang.IPersistentVector")
("IPersistentMap" . "clojure.lang.IPersistentMap")
("IPersistentCollection" . "clojure.lang.IPersistentCollection")
("Sequential" . "clojure.lang.Sequential") ("Seqable" . "clojure.lang.Seqable")
("Associative" . "clojure.lang.Associative")))
("Throwable" . "java.lang.Throwable")))
(for-each
(lambda (pair) (def-var! "clojure.core" (car pair) (cdr pair)))
class-token-alist)
@ -184,7 +115,6 @@
(for-each
(lambda (nm) (def-var! "clojure.core" nm nm))
'("java.lang.Long" "java.lang.Integer" "java.lang.Double" "java.lang.Float"
"java.lang.Byte" "java.lang.Short"
"java.lang.Number" "java.lang.String" "java.lang.Boolean" "java.lang.Character"
"java.lang.Object"
;; exception classes compared against (class e): (= java.net.SocketTimeoutException (class e))
@ -199,7 +129,7 @@
"java.lang.IndexOutOfBoundsException" "java.io.FileNotFoundException"
"java.io.UnsupportedEncodingException"
;; clojure.lang.ExceptionInfo / IExceptionInfo compared against (class e)
"clojure.lang.ExceptionInfo" "clojure.lang.IExceptionInfo" "clojure.lang.ArityException"
"clojure.lang.ExceptionInfo" "clojure.lang.IExceptionInfo"
"java.util.regex.Pattern" "java.net.URI" "java.util.UUID"
"clojure.lang.PersistentQueue"
"clojure.lang.Keyword" "clojure.lang.Symbol" "clojure.lang.Ratio" "clojure.lang.Atom"))

View file

@ -50,7 +50,7 @@
(cond ((null? args) (make-arraylist '()))
((number? (car args)) (make-arraylist '()))
(else (make-arraylist (seq->list (jolt-seq (car args))))))))
(define arraylist-methods
(register-host-methods! "arraylist"
(list
(cons "add" (lambda (self . a)
;; (.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-insert-at! self (jnum->exact (car a)) (cadr a)) jolt-nil))))
(cons "add!" (lambda (self x) (al-push! self x) #t))
(cons "addAll" (lambda (self . a)
;; (.addAll coll) appends; (.addAll i coll) inserts at i.
(let* ((at-i (= 2 (length a)))
(i (if at-i (jnum->exact (car a)) (al-cnt self)))
(coll (if at-i (cadr a) (car a))))
(let loop ((xs (seq->list (jolt-seq coll))) (k i))
(if (null? xs) (pair? (seq->list (jolt-seq coll)))
(begin (al-insert-at! self k (car xs)) (loop (cdr xs) (fx+ k 1))))))))
(cons "get" (lambda (self i) (vector-ref (al-vec self) (jnum->exact i))))
(cons "set" (lambda (self i x)
(let* ((idx (jnum->exact i)) (old (vector-ref (al-vec self) idx)))
@ -80,43 +72,6 @@
(cons "toArray" (lambda (self . _) (apply jolt-vector (al->list self))))
(cons "iterator" (lambda (self) (make-jiterator (list->cseq (al->list self)))))
(cons "toString" (lambda (self) (jolt-pr-str (list->cseq (al->list self)))))))
(register-host-methods! "arraylist" arraylist-methods)
;; java.util.LinkedList: the ArrayList backing plus the Deque surface
;; (addFirst/addLast/removeFirst/removeLast/getFirst/getLast/peek/push/pop).
;; tools.reader holds pending splice forms in one and (seq)s / .remove(0)s it.
(define (al-first self) (vector-ref (al-vec self) 0))
(define (al-last self) (vector-ref (al-vec self) (fx- (al-cnt self) 1)))
(define linkedlist-methods
(append arraylist-methods
(list
(cons "addFirst" (lambda (self x) (al-insert-at! self 0 x) jolt-nil))
(cons "addLast" (lambda (self x) (al-push! self x) jolt-nil))
(cons "offer" (lambda (self x) (al-push! self x) #t))
(cons "removeFirst" (lambda (self) (let ((o (al-first self))) (al-remove-at! self 0) o)))
(cons "removeLast" (lambda (self) (let ((o (al-last self))) (al-remove-at! self (fx- (al-cnt self) 1)) o)))
(cons "getFirst" al-first) (cons "getLast" al-last)
(cons "peek" (lambda (self) (if (fx=? 0 (al-cnt self)) jolt-nil (al-first self))))
(cons "poll" (lambda (self) (if (fx=? 0 (al-cnt self)) jolt-nil (let ((o (al-first self))) (al-remove-at! self 0) o))))
(cons "push" (lambda (self x) (al-insert-at! self 0 x) jolt-nil))
(cons "pop" (lambda (self) (let ((o (al-first self))) (al-remove-at! self 0) o))))))
(define (make-linkedlist xs)
(let ((al (make-arraylist xs))) (make-jhost "linkedlist" (jhost-state al))))
(register-host-methods! "linkedlist" linkedlist-methods)
(let ((ctor (lambda args
(cond ((null? args) (make-linkedlist '()))
(else (make-linkedlist (seq->list (jolt-seq (car args)))))))))
(register-class-ctor! "LinkedList" ctor)
(register-class-ctor! "java.util.LinkedList" ctor))
;; ArrayList / LinkedList are Iterable: (seq al) walks the elements (nil if empty),
;; so (seq pending-forms) and reduce/into over one work like the JVM.
(define %al-seq jolt-seq)
(set! jolt-seq
(lambda (x)
(if (and (jhost? x) (or (string=? (jhost-tag x) "arraylist") (string=? (jhost-tag x) "linkedlist")))
(list->cseq (al->list x))
(%al-seq x))))
;; Appendable.append text: append(x) renders x; append(csq,start,end) appends the
;; subsequence csq[start,end) (data.json's writer appends string runs this way).
@ -154,9 +109,6 @@
(cons "flush" (lambda (self) jolt-nil))
(cons "close" (lambda (self) jolt-nil))
(cons "toString" (lambda (self) (sb-str self)))))
;; (str sw) / print a StringWriter -> its accumulated content, like the JVM
;; (str calls toString) — data.csv writes CSV to a StringWriter and reads it back.
(register-str-render! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "writer"))) sb-str)
;; a file-backed writer (clojure.java.io/writer of a File/path): accumulates like
;; StringWriter, then persists to the path on flush/close, so
@ -176,26 +128,14 @@
;; push to the port (so (.write *out* s) and (binding [*out* *err*] …) work);
;; it isn't a buffer, so toString is empty. Lets libraries that touch *out*/*err*
;; (tools.logging, selmer) compile and run.
;; *out*/*err* resolve their port LIVE — 'out -> (current-output-port), 'err ->
;; (current-error-port) — so a (.write *out* …) / (.flush *out*) follows a
;; with-out-str redirect (with-output-to-string rebinds current-output-port) the
;; same way print/__write do. Storing the startup port instead pinned *out* to the
;; real stdout, so rewrite-clj's (z/print) — which writes via *out* — escaped the
;; capture. A stored port object (should any other code make a port-writer) is used
;; as-is.
(define (port-writer-port self)
(let ((p (vector-ref (jhost-state self) 0)))
(cond ((eq? p 'out) (current-output-port))
((eq? p 'err) (current-error-port))
(else p))))
(register-host-methods! "port-writer"
(list (cons "write" (lambda (self x) (display (writer-piece x) (port-writer-port self)) jolt-nil))
(cons "append" (lambda (self x . rest) (display (append-text x rest) (port-writer-port self)) self))
(cons "flush" (lambda (self) (flush-output-port (port-writer-port self)) jolt-nil))
(list (cons "write" (lambda (self x) (display (writer-piece x) (vector-ref (jhost-state self) 0)) jolt-nil))
(cons "append" (lambda (self x . rest) (display (append-text x rest) (vector-ref (jhost-state self) 0)) self))
(cons "flush" (lambda (self) (flush-output-port (vector-ref (jhost-state self) 0)) jolt-nil))
(cons "close" (lambda (self) jolt-nil))
(cons "toString" (lambda (self) ""))))
(def-var! "clojure.core" "*out*" (make-jhost "port-writer" (vector 'out)))
(def-var! "clojure.core" "*err*" (make-jhost "port-writer" (vector 'err)))
(def-var! "clojure.core" "*out*" (make-jhost "port-writer" (vector (current-output-port))))
(def-var! "clojure.core" "*err*" (make-jhost "port-writer" (vector (current-error-port))))
;; 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
@ -387,11 +327,6 @@
;; state: a vector #(wrapped-reader pushed-list)
(register-class-ctor! "PushbackReader"
(lambda (rdr . _) (make-jhost "pushback-reader" (vector rdr '()))))
;; Fully-qualified aliases so (java.io.PushbackReader. …) / (java.io.StringReader. …)
;; resolve to these built-ins even when a library defines a deftype of the same
;; simple name (tools.reader), which would otherwise take the bare-name slot.
(register-class-ctor! "java.io.PushbackReader" (lookup-class class-ctors-tbl "PushbackReader"))
(register-class-ctor! "java.io.StringReader" (lookup-class class-ctors-tbl "StringReader"))
;; LineNumberingPushbackReader: a pushback-reader (jolt doesn't track line
;; numbers; getLineNumber is a stub for error-reporting paths that read it).
(register-class-ctor! "LineNumberingPushbackReader"
@ -455,15 +390,7 @@
(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"))))))
;; 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"))))))))
(error #f "NoSuchElementException")))))))
;; ---- String / BigInteger / MapEntry constructors ----------------------------
;; (String. bytes [charset]) decodes bytes (a bytevector OR a jolt byte-array)
@ -506,12 +433,8 @@
(list->string (vector->list v)))))
((string? x) x)
(else (jolt-str-render-one x)))))
;; (BigInteger. s) | (BigInteger. s radix) — parse a string in the given radix
;; (default 10). tools.reader's integer parser builds (BigInteger. digits radix).
(register-class-ctor! "BigInteger"
(lambda (v . r) (parse-int-or-throw v (if (null? r) 10 (jnum->exact (car r))) "BigInteger")))
(register-class-ctor! "java.math.BigInteger"
(lambda (v . r) (parse-int-or-throw v (if (null? r) 10 (jnum->exact (car r))) "BigInteger")))
(lambda (v) (parse-int-or-throw v 10 "BigInteger")))
(register-class-ctor! "MapEntry" (lambda (k v) (make-map-entry k v)))
;; JVM exception ctors -> a typed host throwable carrying the canonical :jolt/class
;; (so class / instance? / getMessage / ex-message reflect the real type) and the
@ -642,31 +565,20 @@
;; record-method-dispatch already routes string? -> jolt-string-method. Add a
;; regex-t arm (Pattern .split / .matcher-less surface used by corpus) by wrapping
;; once more — a regex-t isn't a jhost.
(register-method-arm! 42
(define %hs-rmd2 record-method-dispatch)
(set! record-method-dispatch
(lambda (obj method-name rest-args)
(let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
(cond
((regex-t? obj)
(cond ((string=? method-name "split")
;; .split returns a String[] — a seq (prints
;; (a b c), not a vector). re-split with no limit; drop trailing
;; empties (JVM default).
(let ((parts (re-split (regex-t-irx obj) (car rest) #f)))
(list->cseq (str-split-drop-trailing parts))))
((string=? method-name "pattern") (regex-t-source obj))
((or (string=? method-name "toString")) (regex-t-source obj))
;; (.matcher pattern s) -> a Matcher (matcher-t) for stepping matches.
((string=? method-name "matcher") (jolt-re-matcher obj (car rest)))
(else (error #f (string-append "No method " method-name " on Pattern")))))
;; java.util.regex.Matcher: .matches (anchored whole-region), .find
;; (next match), .group [n], .groupCount.
((jolt-matcher? obj)
(cond ((string=? method-name "matches") (jolt-matcher-matches obj))
((string=? method-name "find") (not (jolt-nil? (jolt-re-find obj))))
((string=? method-name "group") (apply jolt-matcher-group obj rest))
((string=? method-name "groupCount") (jolt-matcher-group-count obj))
(else (error #f (string-append "No method " method-name " on Matcher")))))
(else 'pass)))))
(if (regex-t? obj)
(let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
(cond ((string=? method-name "split")
;; .split returns a String[] — a seq (prints
;; (a b c), not a vector). re-split with no limit; drop trailing
;; empties (JVM default).
(let ((parts (re-split (regex-t-irx obj) (car rest) #f)))
(list->cseq (str-split-drop-trailing parts))))
((string=? method-name "pattern") (regex-t-source obj))
(else (error #f (string-append "No method " method-name " on Pattern")))))
(%hs-rmd2 obj method-name rest-args))))
;; ---- def-var! the registry entry points so emit can also reach them ---------
(def-var! "clojure.core" "host-static-ref" host-static-ref)
@ -708,34 +620,19 @@
;; htable arm: dispatch (.method obj a*) through the table's tag method registry;
;; 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)
(let ((tag (and (htable? obj) (hashtable-ref (htable-h obj) "jolt/type" #f))))
(let* ((mh (and tag (hashtable-ref tagged-methods-tbl (tag->method-key tag) #f)))
(f (and mh (hashtable-ref mh method-name #f))))
(if f
(apply f obj (if (jolt-nil? rest-args) '() (seq->list rest-args)))
'pass)))))
(%hs-rmd-htable obj method-name rest-args))))))
(def-var! "clojure.core" "__register-class-methods!"
(lambda (tag members) (register-tagged-methods! tag (jmap->static-alist members)) jolt-nil))
;; java.lang.ThreadLocal via a Chez thread-parameter: real per-thread storage with
;; a lazy initialValue (the proxy macro lowers (proxy [ThreadLocal] …) to this).
;; .get returns the thread's value, computing initialValue once; .set / .remove.
(define tl-unset (list 'tl-unset))
(define (jolt-make-thread-local init-thunk)
(make-jhost "threadlocal" (vector (make-thread-parameter tl-unset) init-thunk)))
(register-host-methods! "threadlocal"
(list (cons "get" (lambda (self)
(let* ((st (jhost-state self)) (tp (vector-ref st 0)) (v (tp)))
(if (eq? v tl-unset)
(let ((nv (jolt-invoke (vector-ref st 1)))) (tp nv) nv)
v))))
(cons "set" (lambda (self v) ((vector-ref (jhost-state self) 0) v) jolt-nil))
(cons "remove" (lambda (self) ((vector-ref (jhost-state self) 0) tl-unset) jolt-nil))))
(def-var! "jolt.host" "make-thread-local" jolt-make-thread-local)
;; Pluggable instance? — a library registers (fn [class-name-string val] -> true
;; | false | nil); nil means "not my class, fall through". First non-nil wins.
(define user-instance-checks '())
@ -765,12 +662,6 @@
(register-instance-check-arm!
(lambda (type-sym val)
(let ((iface (hsc-last-segment (symbol-t-name type-sym))))
;; the value's own class-graph tags (value-host-tags) are authoritative — the
;; SAME source protocol dispatch reads, so instance? and extend-protocol can't
;; disagree about the interfaces a builtin implements.
(if (let ((tags (value-host-tags val)))
(or (member (symbol-t-name type-sym) tags) (member iface tags)))
#t
(let ((hit (cond
((or (string=? iface "IObj") (string=? iface "IMeta")) (hsc-imeta? val))
((or (string=? iface "IMapEntry") (string=? iface "MapEntry")) (jolt-map-entry? val))
@ -780,7 +671,6 @@
((string=? iface "IPersistentSet") (or (pset? val) (htable-sorted-set? val)))
((string=? iface "ISeq")
(or (cseq? val) (empty-list-t? val) (jolt-lazyseq? val)))
((string=? iface "LazySeq") (jolt-lazyseq? val))
;; Seqable is anything (seq x) works on — every persistent
;; collection, not just seqs (a vector IS Seqable, not an ISeq).
((string=? iface "Seqable")
@ -831,7 +721,7 @@
((or (string=? iface "Reader") (string=? iface "BufferedReader"))
(reader-jhost? val))
(else 'none))))
(if (eq? hit 'none) 'pass (if hit #t #f)))))))
(if (eq? hit 'none) 'pass (if hit #t #f))))))
;; java.lang.Class value: (class x) / (.getClass x) return one. It renders like
;; the JVM — str/.toString -> "class <name>", pr -> "<name>", .getName -> "<name>"
@ -841,12 +731,7 @@
(define (make-class-obj name) (make-jhost "class" (vector name)))
(define (jclass? x) (and (jhost? x) (string=? (jhost-tag x) "class")))
(define (jclass-name x) (vector-ref (jhost-state x) 0))
(define (class-key x)
(cond ((jclass? x) (jclass-name x))
((string? x) x)
;; a deftype/defrecord NAME var holds its ctor; treat it as the class
((procedure? x) (hashtable-ref chez-deftype-ctor-tag x #f))
(else #f)))
(define (class-key x) (cond ((jclass? x) (jclass-name x)) ((string? x) x) (else #f)))
(register-eq-arm! (lambda (a b) (or (jclass? a) (jclass? b)))
(lambda (a b) (let ((ka (class-key a)) (kb (class-key b)))
(and ka kb (string=? ka kb) #t))))
@ -860,9 +745,6 @@
(cons "toString" (lambda (self) (string-append "class " (jclass-name self))))
(cons "isArray" (lambda (self) (let ((n (jclass-name self)))
(and (fx>? (string-length n) 0) (char=? (string-ref n 0) #\[)))))
;; Class.isInstance(o) == (instance? class o); core.logic's deftype .equals
;; uses (.. this getClass (isInstance o)).
(cons "isInstance" (lambda (self o) (if (instance-check self o) #t #f)))
(cons "getClass" (lambda (self) (make-class-obj "java.lang.Class")))))
;; (jolt.host/table? x) — is x a host tagged-table?
@ -913,33 +795,6 @@
(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}
@ -954,160 +809,27 @@
(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 '()))
(let loop ((pending (hashtable-ref class-supers-tbl name '())) (seen '()))
(cond ((null? pending) (reverse seen))
((member (car pending) seen) (loop (cdr pending) seen))
(else (loop (append (class-direct-supers (car pending)) (cdr pending))
(else (loop (append (hashtable-ref class-supers-tbl (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`).
;; super / ancestor class-name strings, or nil when jolt models no hierarchy for it.
(def-var! "jolt.host" "class-supers"
(lambda (x)
(let ((name (class-key x)))
(if name
(let ((as (class-ancestors-rooted name)))
(if (null? as) jolt-nil (list->cseq as)))
(if (and name (hashtable-contains? class-supers-tbl name))
(list->cseq (hashtable-ref class-supers-tbl name '()))
jolt-nil))))
(def-var! "jolt.host" "class-ancestors"
(lambda (x)
(let ((name (class-key x)))
(if name
(let ((as (class-ancestors-rooted name)))
(let ((as (class-ancestors-list name)))
(if (null? as) jolt-nil (list->cseq as)))
jolt-nil))))
(def-var! "jolt.host" "class-bases"
(lambda (x)
(let ((name (class-key x)))
(if name
(let* ((ds (class-direct-supers name))
;; a concrete class's bases include its superclass — Object when
;; nothing more specific is modeled (interfaces have none).
(ds (if (or (string=? name "java.lang.Object")
(jch-interface? name)
(member "java.lang.Object" ds))
ds
(append ds '("java.lang.Object")))))
(if (null? ds) jolt-nil (list->cseq ds)))
jolt-nil))))
;; is X a class value — a jclass, a deftype ctor, or a name string the host
;; graph models?
(def-var! "jolt.host" "class-value?"
(lambda (x)
(if (jclass? x)
#t
(let ((n (class-key x)))
(if (and n (hsc-class-known? n)) #t jolt-nil)))))

View file

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

View file

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

View file

@ -179,7 +179,7 @@
(else (loop (+ i 1)))))))
(define (parse-ms pattern input)
(let ((pn (string-length pattern)) (inn (string-length input))
(y 1970) (mo 1) (d 1) (hh 0) (mi 0) (ss 0) (frac-ms 0) (pm 'none))
(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
;; (catch DateTimeParseException …) over a bad date matches), like the JVM.
(define (pfail)
@ -208,7 +208,7 @@
(begin
(when (eq? pm 'pm) (when (< hh 12) (set! hh (+ hh 12))))
(when (eq? pm 'am) (when (= hh 12) (set! hh 0)))
(make-jinst (+ (* 1000 (+ (* (days-from-civil y mo d) 86400) (* hh 3600) (* mi 60) ss)) frac-ms)))
(make-jinst (* 1000 (+ (* (days-from-civil y mo d) 86400) (* hh 3600) (* mi 60) ss))))
(let ((c (string-ref pattern pi)))
(cond
((char-alphabetic? c)
@ -225,25 +225,7 @@
((char=? c #\d) (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! d (car r)) (loop (+ pi k) (cdr r))))
((or (char=? c #\H) (char=? c #\h)) (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! hh (car r)) (loop (+ pi k) (cdr r))))
((char=? c #\m) (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! mi (car r)) (loop (+ pi k) (cdr r))))
((char=? c #\s) (let ((r (read-digits-w ii (if (>= k 2) k #f))))
(set! ss (car r))
;; an ISO formatter (modeled here as an ss-pattern with no S
;; field) still accepts an optional fractional second; consume
;; .fff -> millis from the input. Skip when the pattern carries
;; the fraction itself (a following '.'/S handles it).
(let ((j (cdr r)) (pnext (if (< (+ pi k) pn) (string-ref pattern (+ pi k)) #\nul)))
(if (and (not (char=? pnext #\.)) (not (char=? pnext #\S))
(< j inn) (char=? (string-ref input j) #\.)
(< (+ j 1) inn) (digit? (string-ref input (+ j 1))))
(let frac ((p (+ j 1)) (kk 0) (acc 0))
(if (and (< p inn) (digit? (string-ref input p)))
(frac (+ p 1) (+ kk 1) (if (< kk 3) (+ (* acc 10) (- (char->integer (string-ref input p)) 48)) acc))
(begin (set! frac-ms (* acc (expt 10 (max 0 (- 3 kk))))) (loop (+ pi k) p))))
(loop (+ pi k) j)))))
((char=? c #\S) (let frac ((p ii) (kk 0) (acc 0))
(if (and (< p inn) (< kk k) (digit? (string-ref input p)))
(frac (+ p 1) (+ kk 1) (+ (* acc 10) (- (char->integer (string-ref input p)) 48)))
(begin (set! frac-ms (* acc (expt 10 (max 0 (- 3 kk))))) (loop (+ pi k) p)))))
((char=? c #\s) (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! ss (car r)) (loop (+ pi k) (cdr r))))
((char=? c #\E) (loop (+ pi k) (cdr (read-alpha ii))))
((char=? c #\a) (let ((r (read-alpha ii)))
(set! pm (if (string=? (ascii-string-down (car r)) "pm") 'pm 'am))
@ -280,10 +262,6 @@
(register-hash-arm! jinst? (lambda (x) (jolt-hash (jinst-ms x))))
;; #inst is a java.util.Date — (class x) / (type x) report that, not the internal
;; :jolt/inst tag (which print-method still dispatches on via __type-tag).
(register-class-arm! jinst? (lambda (x) "java.util.Date"))
;; java.time.Instant is nano-precise: two Instants are = when their epoch-nanos
;; match (so an Instant and one shifted by a single nanosecond differ).
(define (jt-instant-tag? x) (and (jhost? x) (string=? (jhost-tag x) "instant")))
@ -307,6 +285,7 @@
(define %it-type jolt-type)
(set! jolt-type (lambda (x) (if (jinst? x) inst-type-kw (%it-type x))))
(def-var! "clojure.core" "type" jolt-type)
;; instance? java.util.Date -> a jinst; java.time.Instant/LocalDateTime -> the
;; matching jhost tag. The instance? macro passes the class-name symbol.
@ -562,7 +541,8 @@
(cons "format" (lambda (self d) (format-ms (vector-ref (jhost-state self) 0) (ms-of d))))))
;; a jinst's java.util.Date method surface (record-method-dispatch arm).
(register-method-arm! 40
(define %it-rmd record-method-dispatch)
(set! record-method-dispatch
(lambda (obj method-name rest-args)
(cond
((jinst? obj)
@ -585,7 +565,7 @@
((string=? method-name "before") (< (jinst-ms obj) (ms-of (car (seq->list rest-args)))))
((string=? method-name "after") (> (jinst-ms obj) (ms-of (car (seq->list rest-args)))))
(else (error #f (string-append "No method " method-name " on Date")))))
(else 'pass))))
(else (%it-rmd obj method-name rest-args)))))
;; Clojure's built-in data readers, so a library that merges default-data-readers
;; or binds *data-readers* (e.g. aero's reader opts) resolves #inst / #uuid.

View file

@ -29,70 +29,6 @@
(hashtable-set! embedded-resources name content))
(define-record-type embedded-res (fields name content) (nongenerative jolt-embres-v1))
;; --- self-contained build artifacts (jolt-eaj) ------------------------------
;; A toolchain-free `jolt build` (the distributed joltc) carries the Chez
;; petite/scheme boots and a prebuilt launcher stub baked into its own boot image.
;; They live in the same table as embedded-resources, but keyed under bytevector
;; values (register-embedded-bytes!) rather than strings; resolve-on-roots /
;; io/resource only ever ask for the string-keyed source entries, so the two
;; coexist. The build driver reads them at heap-build time from files that exist
;; only on the dev machine.
(define (register-embedded-bytes! name bv) (hashtable-set! embedded-resources name bv))
(define (jolt-embedded-bytes name)
(let ((v (hashtable-ref embedded-resources name #f)))
(and (bytevector? v) v)))
;; Read a whole file as a bytevector ("" -> empty). Used to slurp boot/stub files.
(define (read-file-bytes path)
(let ((p (open-file-input-port path)))
(let ((bv (get-bytevector-all p)))
(close-port p)
(if (eof-object? bv) (bytevector) bv))))
;; Write an embedded bytevector resource out to a path. make-boot-file needs the
;; petite/scheme boots as files, so they are spilled to scratch before the call.
(define (jolt-spill-embedded! name path)
(let ((bv (jolt-embedded-bytes name)))
(unless bv (error 'jolt-spill-embedded! "no embedded bytes for" name))
(let ((p (open-file-output-port path (file-options no-fail) (buffer-mode block))))
(put-bytevector p bv)
(close-port p))))
;; Frame an app boot onto a file that already holds the stub bytes. Layout:
;; [stub][boot][boot-length:le64]["JOLTBOOT"]. The stub (host/chez/stub/launcher.c)
;; reads the trailing 16 bytes — the 8-byte magic, then the preceding 8-byte LE
;; length — to locate and register the boot, so a boot that itself contains the
;; magic bytes can't be mistaken for the frame.
(define jolt-payload-magic (string->utf8 "JOLTBOOT"))
(define (jolt-append-payload! path boot-bv)
(let ((head (read-file-bytes path))) ; the stub bytes already written
(let ((p (open-file-output-port path (file-options no-fail) (buffer-mode block)))
(lb (make-bytevector 8 0)))
(bytevector-u64-set! lb 0 (bytevector-length boot-bv) (endianness little))
(put-bytevector p head)
(put-bytevector p boot-bv)
(put-bytevector p lb)
(put-bytevector p jolt-payload-magic)
(close-port p))))
;; chmod 0755 via libc, so the produced binary is executable. load-shared-object
;; with #f pulls the running process's own symbols (chmod is in libc, linked into
;; every Chez binary) — no external toolchain. Falls back to /bin/sh chmod if the
;; symbol can't be resolved.
(define jolt-chmod-755
(let ((c (jolt-foreign-proc-safe "chmod" '(string int) 'int)))
(lambda (path)
(cond
(c (c path #o755))
;; Windows has no chmod and needs none (execute is by extension)
((let ((m (symbol->string (machine-type))))
(let loop ((i 0))
(cond ((> (+ i 2) (string-length m)) #f)
((string=? (substring m i (+ i 2)) "nt") #t)
(else (loop (+ i 1))))))
0)
(else (system (string-append "chmod 755 '" path "'")))))))
;; A user-facing relative path resolves against JOLT_PWD — the user's cwd before
;; the launcher cd'd to the jolt repo root — matching the JVM, where io/file is
;; cwd-relative. (io/resource builds jfiles from the source roots directly, so it
@ -245,13 +181,14 @@
(else (loop (- i 1))))))
(else #f))))
(register-method-arm! 41
(define %io-rmd record-method-dispatch)
(set! record-method-dispatch
(lambda (obj method-name rest-args)
(if (jfile? obj)
(let* ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args)))
(r (jfile-method obj method-name rest)))
(if r (car r) (error #f "no File method" method-name)))
'pass)))
(%io-rmd obj method-name rest-args))))
;; .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
@ -382,6 +319,7 @@
(define io-kw-file (keyword "jolt" "file"))
(define %io-type jolt-type)
(set! jolt-type (lambda (x) (if (jfile? x) io-kw-file (%io-type x))))
(def-var! "clojure.core" "type" jolt-type)
;; (instance? java.io.File f): the instance? macro passes the class-name symbol;
;; match "File" / "java.io.File" (and any *.File) against a jfile.
@ -416,11 +354,6 @@
;; method (a no-op for in-memory streams); absent method -> no-op.
((htable? x) (guard (e (#t jolt-nil)) (record-method-dispatch x "close" jolt-nil)) jolt-nil)
((jfile? x) jolt-nil)
;; a deftype/defrecord that implements a `close` method (java.io.Closeable /
;; AutoCloseable, e.g. tools.reader's reader types) closes through it — the
;; same method (.close x) would dispatch to.
((and (jrec? x) (jrec-cl x "close"))
(record-method-dispatch x "close" jolt-nil) jolt-nil)
(else
(let ((closef (jolt-get x (keyword #f "close") jolt-nil)))
(if (and (not (jolt-nil? closef)) (procedure? closef))
@ -528,25 +461,6 @@
;; is how libraries reach Clojure's base loader, e.g. aws-api's resources ns).
(register-class-statics! "RT" (list (cons "baseLoader" (lambda () the-classloader))))
(register-class-statics! "clojure.lang.RT" (list (cons "baseLoader" (lambda () the-classloader))))
;; clojure.lang.RT/nextID — process-unique increasing id (AtomicInteger(1)
;; getAndIncrement), used by id generators such as core.logic's lvar.
(define rt-next-id-counter 1)
(define (rt-next-id)
(let ((v rt-next-id-counter))
(set! rt-next-id-counter (+ rt-next-id-counter 1))
v))
(register-class-statics! "RT" (list (cons "nextID" rt-next-id)))
(register-class-statics! "clojure.lang.RT" (list (cons "nextID" rt-next-id)))
;; clojure.lang.Util — hash/equality helpers libraries call directly (core.logic's
;; LCons.hashCode uses Util/hash). hash = Java hashCode (0 for nil); hasheq = the
;; value hash jolt's = uses; equiv = value equality; identical = reference identity.
(let ((util-statics
(list (cons "hash" (lambda (x) (if (jolt-nil? x) 0 (record-method-dispatch x "hashCode" jolt-nil))))
(cons "hasheq" (lambda (x) (jolt-hash x)))
(cons "equiv" (lambda (a b) (if (jolt= a b) #t #f)))
(cons "identical" (lambda (a b) (if (eq? a b) #t #f))))))
(register-class-statics! "Util" util-statics)
(register-class-statics! "clojure.lang.Util" util-statics))
;; Thread/currentThread -> a fresh thread jhost wrapping THIS thread's interrupt
;; flag (the box from current-interrupt-box, host-static.ss), so .interrupt from
;; any thread sets the target thread's flag and .isInterrupted reads it without
@ -555,11 +469,6 @@
(register-host-methods! "thread"
(list (cons "getContextClassLoader" (lambda (self) the-classloader))
(cons "getName" (lambda (self) "main"))
;; no reified call stack (jolt does TCO, so caller frames are erased) — an
;; empty StackTraceElement[]. clojure.spec.test.alpha's instrument reads it
;; to name the caller var; it degrades to no ::caller, the conform error
;; (the ExceptionInfo) is still thrown.
(cons "getStackTrace" (lambda (self) (jolt-vector)))
(cons "interrupt" (lambda (self)
(when (box? (jhost-state self)) (set-box! (jhost-state self) #t))
jolt-nil))
@ -609,51 +518,7 @@
(register-class-statics! "java.util.UUID"
(list (cons "randomUUID" (lambda () (jolt-random-uuid)))
(cons "fromString" (lambda (s) (jolt-parse-uuid (jolt-str-render-one s))))))
;; (UUID. msb lsb): build from the most/least-significant 64-bit halves (the JVM's
;; 2-long ctor), the form test.check's uuid generator uses. (UUID. s) parses a
;; string. The 128 bits format as the canonical 8-4-4-4-12 lowercase hex string.
(define (uuid-long->hex16 n)
(let* ((u (bitwise-and (jnum->exact n) #xFFFFFFFFFFFFFFFF))
(s (string-downcase (number->string u 16)))) ; JVM UUIDs are lowercase
(string-append (make-string (- 16 (string-length s)) #\0) s)))
(define (uuid-from-halves msb lsb)
(let ((h (uuid-long->hex16 msb)) (l (uuid-long->hex16 lsb)))
(make-juuid (string-append (substring h 0 8) "-" (substring h 8 12) "-" (substring h 12 16)
"-" (substring l 0 4) "-" (substring l 4 16)))))
(define (uuid-ctor . args)
(if (= (length args) 2)
(uuid-from-halves (car args) (cadr args))
(jolt-parse-uuid (jolt-str-render-one (car args)))))
(register-class-ctor! "UUID" uuid-ctor)
(register-class-ctor! "java.util.UUID" uuid-ctor)
;; (Long. n) / (Long. "n"): a Long is just jolt's integer; return it (parse a string).
(register-class-ctor! "Long" (lambda (x) (if (string? x) (parse-int-or-throw x 10 "Long") (->num (jnum->exact x)))))
(register-class-ctor! "java.lang.Long" (lambda (x) (if (string? x) (parse-int-or-throw x 10 "Long") (->num (jnum->exact x)))))
;; (Integer. n) / (Integer. "n"): jolt's integer, range-checked like intCast.
(define (integer-ctor x)
(jolt-int-cast (if (string? x) (parse-int-or-throw x 10 "Integer") x)))
(register-class-ctor! "Integer" integer-ctor)
(register-class-ctor! "java.lang.Integer" integer-ctor)
;; (Double. x) / (Double. "x"): jolt's double.
(define (double-ctor x)
(if (string? x)
(let ((n (string->number x)))
(if n (exact->inexact n)
(jolt-throw (jolt-host-throwable "java.lang.NumberFormatException"
(string-append "For input string: \"" x "\"")))))
(jolt-double x)))
(register-class-ctor! "Double" double-ctor)
(register-class-ctor! "java.lang.Double" double-ctor)
;; (Boolean. "true") / (Boolean. b): true for the string "true" (case-insensitive,
;; anything else false) or the boolean itself — Boolean.valueOf semantics; the
;; box is jolt's plain boolean.
(define (boolean-ctor x)
(cond ((string? x) (string-ci=? x "true"))
((boolean? x) x)
(else #f)))
(register-class-ctor! "Boolean" boolean-ctor)
(register-class-ctor! "java.lang.Boolean" boolean-ctor)
(register-class-ctor! "UUID" (lambda (s) (jolt-parse-uuid (jolt-str-render-one s))))
;; --- java.net.URI -----------------------------------------------------------
;; A minimal RFC-3986 split into scheme/authority/host/port/path/query/fragment,
@ -741,14 +606,6 @@
(cons "hashCode" (lambda (u) (string-hash (uri-field u 'string))))
(cons "equals" (lambda (u o) (and (jhost? o) (string=? (jhost-tag o) "uri")
(string=? (uri-field u 'string) (uri-field o 'string)))))))
;; (= u1 u2) is value equality by string form (the .equals method above only
;; serves explicit (.equals …)); hash matches so a URI works as a map key / set
;; member (ring/hiccup compare (URI. "/") values).
(define (uri-jhost? x) (and (jhost? x) (string=? (jhost-tag x) "uri")))
(register-eq-arm! (lambda (a b) (or (uri-jhost? a) (uri-jhost? b)))
(lambda (a b) (and (uri-jhost? a) (uri-jhost? b)
(string=? (uri-field a 'string) (uri-field b 'string)))))
(register-hash-arm! uri-jhost? (lambda (x) (string-hash (uri-field x 'string))))
;; str / pr-str of a uri -> its string form.
(register-str-render! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "uri")))
(lambda (x) (uri-field x 'string)))

View file

@ -1116,37 +1116,20 @@
((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))
;; 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)))))))
((jt-time? 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 "NANO_OF_DAY") (lt-nano-of-day t))
((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 "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 "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))
(else (error #f (string-append "LocalTime has no field " f)))))
((jt-dt? t)
;; route a field to whichever part supports it (date fields incl. the
;; aligned-* group to the date, the rest to the time).
(if (temporal-supports-field? (ldt-date t) f)
(if (member f '("YEAR" "MONTH_OF_YEAR" "DAY_OF_MONTH" "DAY_OF_WEEK" "DAY_OF_YEAR" "EPOCH_DAY" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "ERA"))
(temporal-get-field (ldt-date t) f)
(temporal-get-field (ldt-time t) f)))
((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 "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)))))
((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")))))
;; field set: (with temporal ChronoField value) -> a new temporal.
@ -1196,17 +1168,10 @@
(else #f))))
(define (temporal-supports-field? t 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"
"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" "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))
(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))
((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-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))
((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))))
;; 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-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))
;; --- TemporalAdjuster: a date->date transform applied via (.with t adjuster) --

View file

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

View file

@ -108,30 +108,10 @@
((string=? cs "utf-32le") (string->utf32 s (endianness little)))
(else (string->utf8 s)))))
;; Object.hashCode parity: Java's specified String hash and Clojure's Symbol hash
;; (Util.hashCombine), so (.hashCode s) / (.hashCode sym) match the JVM. 32-bit int.
(define (jolt-u32 x) (bitwise-and x #xFFFFFFFF))
(define (jolt-s32 x) (let ((m (jolt-u32 x))) (if (>= m #x80000000) (- m #x100000000) m)))
(define (java-string-hash s)
(let ((n (string-length s)))
(let loop ((i 0) (h 0))
(if (fx<? i n)
(loop (fx+ i 1) (jolt-s32 (+ (* 31 h) (char->integer (string-ref s i)))))
(jolt-s32 h)))))
(define (java-hash-combine seed hash)
(let* ((su (jolt-u32 seed))
(sl (bitwise-arithmetic-shift-left su 6))
(sr (bitwise-arithmetic-shift-right (jolt-s32 su) 2))
(add (+ (jolt-u32 hash) #x9e3779b9 sl sr)))
(jolt-s32 (bitwise-xor su (jolt-u32 add)))))
(define (java-symbol-hash name ns)
(java-hash-combine (java-string-hash name) (if ns (java-string-hash ns) 0)))
(define (jolt-string-method method s rest)
(define (arg n) (list-ref rest n))
(cond
((string=? method "toString") s)
((string=? method "hashCode") (java-string-hash s))
((string=? method "toLowerCase") (ascii-string-down s))
((string=? method "toUpperCase") (ascii-string-up s))
((string=? method "trim") (str-trim s))

View file

@ -10,42 +10,46 @@
(define (ex-info-class v)
(let ((c (jolt-get v jolt-kw-class jolt-nil)))
(if (string? c) c "clojure.lang.ExceptionInfo")))
;; Is `wanted` (simple name) `cls` or a supertype of it? The exception hierarchy
;; lives in the one class graph (class-hierarchy.ss) — resolve the simple name to
;; its graph key and ask jch-isa?, so exceptions and every other class share a
;; single source of truth (ExceptionInfo -> IExceptionInfo is a graph edge).
;; immediate-parent chain of the JVM exception hierarchy (simple names). Drives
;; instance? across exception supertypes — (instance? Throwable (ex-info …)) etc.
(define exception-parent
'(("ExceptionInfo" . "RuntimeException")
("RuntimeException" . "Exception")
("IllegalArgumentException" . "RuntimeException")
("NumberFormatException" . "IllegalArgumentException")
("IllegalStateException" . "RuntimeException")
("UnsupportedOperationException" . "RuntimeException")
("ArithmeticException" . "RuntimeException")
("NullPointerException" . "RuntimeException")
("ClassCastException" . "RuntimeException")
("IndexOutOfBoundsException" . "RuntimeException")
("ConcurrentModificationException" . "RuntimeException")
("NoSuchElementException" . "RuntimeException")
("UncheckedIOException" . "RuntimeException")
("DateTimeException" . "RuntimeException")
("DateTimeParseException" . "DateTimeException")
("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)
(jch-isa? (jch-fqn-of-simple cls) wanted))
;; A raw Chez condition (an arity or non-seqable error Chez itself raised, not a
;; jolt ex-info) carries no jolt exception class. Map the ones Clojure raises a
;; specific class for, by message, so (class e) and (instance? C e) match the JVM.
;; Returns a simple class name or #f.
(define (ri-substring? needle hay)
(let ((nl (string-length needle)) (hl (string-length hay)))
(let loop ((i 0))
(cond ((> (+ i nl) hl) #f)
((string=? needle (substring hay i (+ i nl))) #t)
(else (loop (+ i 1)))))))
(define (chez-condition-exc-class v)
(and (condition? v) (message-condition? v)
(let ((m (condition-message v)))
(and (string? m)
(cond ((ri-substring? "incorrect number of arguments" m) "ArityException")
((ri-substring? "not seqable" m) "IllegalArgumentException")
;; Chez's numeric ops raise "~s is not a real number" on a bad
;; operand. The JVM throws NullPointerException for a nil operand
;; (null deref) and ClassCastException for a non-number (can't
;; cast to Number) — clojure.spec.alpha's conform-explain relies
;; on the distinction. The offending value rides in the irritants.
((or (ri-substring? "is not a real number" m)
(ri-substring? "is not a number" m))
(if (and (irritants-condition? v)
(let loop ((xs (condition-irritants v)))
(and (pair? xs) (or (jolt-nil? (car xs)) (loop (cdr xs))))))
"NullPointerException"
"ClassCastException"))
(else #f))))))
(let loop ((c cls))
(cond ((not c) #f)
((string=? c wanted) #t)
((and (string=? c "ExceptionInfo") (string=? wanted "IExceptionInfo")) #t)
(else (let ((p (assoc c exception-parent))) (loop (and p (cdr p))))))))
;; instance-check: (type-sym val) — type/protocol membership. Host shims loaded
;; later (io, inst-time, natives-array, natives-queue, host-static-classes)
@ -57,35 +61,14 @@
(define (register-instance-check-arm! f) ; f: (type-sym val) -> #t | #f | 'pass
(set! instance-check-registry (cons f instance-check-registry)))
;; (instance? C raw-condition): match when C is the condition's mapped class or a
;; supertype of it (ArityException is also an IllegalArgumentException, etc.).
(register-instance-check-arm!
(lambda (type-sym val)
(let ((k (chez-condition-exc-class val)))
(if k (if (exception-isa? k (last-dot (symbol-t-name type-sym))) #t #f) 'pass))))
;; Object / java.lang.Object is the root of the type hierarchy: every non-nil
;; value is an instance of Object; nil is not an instance of anything.
(register-instance-check-arm!
(lambda (type-sym val)
(let ((tn (symbol-t-name type-sym)))
(if (or (string=? tn "Object") (string=? tn "java.lang.Object"))
(not (jolt-nil? val))
'pass))))
(define (instance-check-base type-sym val)
(let ((tname (symbol-t-name type-sym)))
(cond
((jrec? val)
(let ((tag (jrec-tag val)))
(or (string=? tag tname)
;; a simple name matches a qualified tag only at a `.` boundary:
;; "a.b.IntervalFD" is an IntervalFD, but "a.b.MultiIntervalFD" is NOT
;; (a raw string-suffix would wrongly match the latter).
(let ((tl (string-length tag)) (nl (string-length tname)))
(and (fx>? tl nl)
(char=? (string-ref tag (fx- (fx- tl nl) 1)) #\.)
(string=? (substring tag (fx- tl nl) tl) tname)))
(and (> (string-length tag) (string-length tname))
(string=? (substring tag (- (string-length tag) (string-length tname)) (string-length tag)) tname))
;; a protocol/interface the type implements (defprotocol generates an
;; interface; (instance? SomeProtocol record) is true when the record
;; implements it — core.match dispatches on instance? IPatternCompile).

View file

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

View file

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

View file

@ -57,25 +57,9 @@
((and (pmap? x) (eq? (jolt-get x rdr-kw-jolt-type) rdr-kw-jolt-tagged))
(let ((rdr (data-reader-symbol (jolt-get x rdr-kw-tag)))
(inner (ldr-apply-readers (jolt-get x rdr-kw-form))))
(cond
(rdr
;; Clojure applies a data reader at read time and substitutes its result
;; as code. A reader that returns a FORM (a list — e.g. borkdude.html's
;; #html expands to (->Html (str …))) must be compiled, so splice it in.
;; A reader that returns a VALUE (time-literals #time/date -> a Date) is
;; left as a runtime call (reader-fn 'inner): the value rebuilds at
;; startup, which also keeps a non-serializable constant out of an AOT
;; build. Apply is guarded — a reader that can't run at load time (its
;; deps not ready) falls back to the runtime call too.
(let ((result (and (symbol-t? rdr) (not (jolt-nil? (symbol-t-ns rdr)))
(guard (e (#t #f))
(let ((fn (var-deref (symbol-t-ns rdr) (symbol-t-name rdr))))
(and (procedure? fn) (jolt-invoke fn inner)))))))
(if (cseq? result)
result
(jolt-list rdr (jolt-list (jolt-symbol #f "quote") inner)))))
((eq? inner (jolt-get x rdr-kw-form)) x)
(else (rdr-make-tagged (jolt-get x rdr-kw-tag) inner)))))
(cond (rdr (jolt-list rdr (jolt-list (jolt-symbol #f "quote") inner)))
((eq? inner (jolt-get x rdr-kw-form)) x)
(else (rdr-make-tagged (jolt-get x rdr-kw-tag) inner)))))
((rdr-set-form? x)
(let-values (((items changed) (ldr-conv-each (seq->list (jolt-get x rdr-kw-value)))))
(if changed (rdr-carry-meta x (rdr-make-set items)) x)))
@ -138,31 +122,14 @@
(else (loop (cdr cs) (cons (car cs) seg) segs)))))
;; First existing <root>/rel.clj or <root>/rel.cljc on the search roots, else #f.
;; A self-contained joltc binary embeds jolt-core + stdlib source keyed by their
;; root-relative path ("clojure/string.clj"); those are checked first, so a
;; `require` resolves with no source on disk. The dev bin/joltc has an empty
;; source store, so the two hashtable probes miss and it falls straight to disk.
(define (resolve-on-roots rel)
(let ((eclj (string-append rel ".clj")) (ecljc (string-append rel ".cljc")))
(cond
((string? (hashtable-ref embedded-resources eclj #f)) eclj)
((string? (hashtable-ref embedded-resources ecljc #f)) ecljc)
(else
(let loop ((roots source-roots))
(if (null? roots) #f
(let ((clj (string-append (car roots) "/" rel ".clj"))
(cljc (string-append (car roots) "/" rel ".cljc")))
(cond ((file-exists? clj) clj)
((file-exists? cljc) cljc)
(else (loop (cdr roots)))))))))))
;; Read a namespace source. An embedded key (resolve-on-roots above, or the
;; build driver's app-order entries) reads its baked string; everything else is
;; a real path read off disk. Bytevector entries (the bundled boots/stub) are not
;; source, so a string? guard skips them.
(define (ldr-read-source path)
(let ((emb (hashtable-ref embedded-resources path #f)))
(if (string? emb) emb (read-file-string path))))
(let loop ((roots source-roots))
(if (null? roots) #f
(let ((clj (string-append (car roots) "/" rel ".clj"))
(cljc (string-append (car roots) "/" rel ".cljc")))
(cond ((file-exists? clj) clj)
((file-exists? cljc) cljc)
(else (loop (cdr roots))))))))
(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))
(hashtable-values var-table))
;; clojure.core.async ships native channel primitives (async.ss) AND a Clojure
;; overlay (stdlib/clojure/core/async.clj) with the higher-level dataflow API
;; (alts!, pipe, mult, mix, pub/sub, map, merge, …). The primitives pre-seed the
;; namespace above, which would make a `require` no-op and skip the overlay. Drop
;; it from the loaded set so a require pulls the overlay from the source roots
;; (like clojure.test); the primitives stay defined either way.
(hashtable-delete! loaded-ns "clojure.core.async")
;; Does `name` already have vars in the var-table? A namespace baked into the
;; image after the snapshot above — an AOT'd app namespace in a `jolt build`
;; binary — exists in memory with no source file; a later `require` of it must
@ -209,7 +168,7 @@
;; more forms", which would silently drop the entire rest of the file; here we
;; skip the no-op form and continue to true end-of-string.
(define (load-jolt-file path)
(let* ((src (ldr-read-source path)) (end (string-length src)))
(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
;; restores path when control returns to the rest of this file.
(parameterize ((rdr-source-file path)) ; list forms read here carry :file = path
@ -260,93 +219,50 @@
(else '()))))
(and (pair? items) (symbol-t? (car items)) (symbol-t-name (car items)))))
;; A libspec under a prefix joins onto it: a bare symbol `string` -> `prefix.string`,
;; a vector `[string :as s]` -> `[prefix.string :as s]` (opts preserved).
(define (prefix-join prefix lib)
(cond
((symbol-t? lib) (jolt-symbol #f (string-append prefix "." (symbol-t-name lib))))
((pvec? lib)
(let ((items (seq->list lib)))
(if (and (pair? items) (symbol-t? (car items)))
(apply jolt-vector (jolt-symbol #f (string-append prefix "." (symbol-t-name (car items)))) (cdr items))
lib)))
(else lib)))
;; The prefix-list form of a require/use spec: a LIST `(prefix lib …)` expands to
;; one spec per lib (prefix.lib), so (:require (clojure [string :as str])) means
;; clojure.string :as str. A vector / symbol spec is already a single lib.
(define (expand-spec s)
(if (or (cseq? s) (empty-list-t? s))
(let ((items (seq->list s)))
(if (and (pair? items) (symbol-t? (car items)) (pair? (cdr items)))
(map (lambda (lib) (prefix-join (symbol-t-name (car items)) lib)) (cdr items))
(list s)))
(list s)))
;; --- require/use that LOAD ---------------------------------------------------
;; Override the alias-only versions from natives-str.ss. Load each spec's target
;; (no-op if baked/already loaded), THEN register its :as/:refer under the caller
;; ns (chez-register-spec! reads the current ns, restored by load-namespace).
(define (loader-require . specs)
(for-each
(lambda (s0)
(for-each
(lambda (s)
(let ((target (spec-target-name s)))
(when target (load-namespace target)))
(chez-register-spec! (chez-current-ns) s))
(expand-spec s0)))
(lambda (s)
(let ((target (spec-target-name s)))
(when target (load-namespace target)))
(chez-register-spec! (chez-current-ns) s))
specs)
jolt-nil)
(def-var! "clojure.core" "require" loader-require)
(define (loader-use . specs0)
(define (loader-use . specs)
(for-each
(lambda (spec0)
(for-each
(lambda (spec)
(let ((target (spec-target-name spec)))
(when target (load-namespace target)))
(chez-register-spec! (chez-current-ns) spec)
(let* ((items (cond ((pvec? spec) (seq->list spec))
((symbol-t? spec) (list spec))
(else '())))
(target (and (pair? items) (symbol-t? (car items)) (symbol-t-name (car items))))
(filtered (let scan ((xs (if (pair? items) (cdr items) '())))
(cond ((null? xs) #f)
((and (keyword? (car xs))
(member (keyword-t-name (car xs)) '("only" "refer"))) #t)
(else (scan (cdr xs)))))))
(when (and target (not filtered))
(chez-register-refer-all! (chez-current-ns) target))))
(expand-spec spec0)))
specs0)
(lambda (spec)
(let ((target (spec-target-name spec)))
(when target (load-namespace target)))
(chez-register-spec! (chez-current-ns) spec)
(let* ((items (cond ((pvec? spec) (seq->list spec))
((or (cseq? spec) (empty-list-t? spec)) (seq->list spec))
((symbol-t? spec) (list spec))
(else '())))
(target (and (pair? items) (symbol-t? (car items)) (symbol-t-name (car items))))
(filtered (let scan ((xs (if (pair? items) (cdr items) '())))
(cond ((null? xs) #f)
((and (keyword? (car xs))
(member (keyword-t-name (car xs)) '("only" "refer"))) #t)
(else (scan (cdr xs)))))))
(when (and target (not filtered))
(chez-register-refer-all! (chez-current-ns) target))))
specs)
jolt-nil)
(def-var! "clojure.core" "use" loader-use)
(def-var! "clojure.core" "load-file" jolt-load-file)
;; The directory of a namespace's resource path: "clojure.tools.reader-test" ->
;; "clojure/tools" (drop the last segment of ns-name->rel). "" for a top-level ns.
(define (ns-rel-dir name)
(let* ((r (ns-name->rel name)))
(let loop ((k (fx- (string-length r) 1)))
(cond ((fx<? k 0) "")
((char=? (string-ref r k) #\/) (substring r 0 k))
(else (loop (fx- k 1)))))))
;; load: an arg starting with "/" is a root-relative resource path ("/app/extra");
;; otherwise it is resolved against the CURRENT namespace's directory, matching
;; Clojure — (load "common_tests") from clojure.tools.reader-test loads
;; clojure/tools/common_tests.clj. Strip the leading slash / try .clj/.cljc.
;; load: each arg is a "/"-rooted resource path like "/app/extra"; load the file
;; for it relative to the search roots (strip the leading slash, try .clj/.cljc).
(define (jolt-load . paths)
(for-each
(lambda (p)
(let* ((rel (cond
((and (> (string-length p) 0) (char=? (string-ref p 0) #\/))
(substring p 1 (string-length p)))
(else (let ((dir (ns-rel-dir (chez-current-ns))))
(if (string=? dir "") p (string-append dir "/" p))))))
(let* ((rel (if (and (> (string-length p) 0) (char=? (string-ref p 0) #\/))
(substring p 1 (string-length p)) p))
(f (resolve-on-roots rel)))
(if f (load-jolt-file f)
(error #f "Could not locate resource on source roots" p))))
@ -384,14 +300,3 @@
(def-var! "jolt.host" "load-namespace" (lambda (n) (load-namespace n) jolt-nil))
(def-var! "jolt.host" "file-exists?" (lambda (p) (if (file-exists? p) #t #f)))
(def-var! "jolt.host" "getenv" (lambda (n) (let ((v (getenv n))) (if v v jolt-nil))))
;; jolt version string. A self-contained binary build bakes the real tag into the
;; saved heap by emitting (set! jolt-baked-version "…") in flat.ss; a dev run off
;; the seed leaves it #f and falls back to $JOLT_VERSION (bin/joltc sets it from
;; `git describe`), then "dev".
(define jolt-baked-version #f)
(def-var! "jolt.host" "jolt-version"
(lambda ()
(or jolt-baked-version
(let ((v (getenv "JOLT_VERSION"))) (and v (> (string-length v) 0) v))
"dev")))

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -25,11 +25,18 @@
(def-var! "clojure.core" "volatile!" jolt-volatile!)
(def-var! "clojure.core" "deref" jolt-deref)
;; --- sequence ----------------------------------------------------------------
;; transduce lives in the overlay (clojure/core/22-coll.clj): it's a pure
;; composition (xf (reduce xf init coll)) over reduce, so the Clojure version
;; lowers to the same code the native shim did. sequence stays native (below):
;; its transformer iterator drives the reduced box + lazy realization directly.
;; --- transduce / sequence ----------------------------------------------------
;; (transduce xform f coll) / (transduce xform f init coll): build the transformed
;; reducing fn (xform f), reduce it over coll (reduce-seq honors `reduced`), then
;; run the completion (1-arg) arity. The 3-arg init defaults to (f) — the rf's
;; 0-arity, e.g. (+) = 0, (conj) = [].
(define jolt-transduce
(case-lambda
((xform f coll) (jolt-transduce xform f (jolt-invoke f) coll))
((xform f init coll)
(let* ((xf (jolt-invoke xform f))
(res (reduce-seq xf init (jolt-seq coll))))
(jolt-invoke xf res)))))
;; (sequence coll) -> a seq; (sequence xform coll) -> a LAZY seq of coll transformed
;; by xform. A transformer iterator (mirrors clojure.core's TransformerIterator):
@ -80,6 +87,7 @@
((coll) (jolt-seq coll))
((xform coll) (sequence-xf xform coll))))
(def-var! "clojure.core" "transduce" jolt-transduce)
(def-var! "clojure.core" "sequence" jolt-sequence)
;; --- cat ---------------------------------------------------------------------

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -31,46 +31,6 @@
;; 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"))
;; unique present-vs-absent sentinel for extension-map lookups (so a present nil
;; in the extension map is distinguished from a genuine miss).
@ -140,21 +100,6 @@
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)))
@ -282,20 +227,9 @@
(lambda (a b)
(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)))
;; 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))
(else #f))))
;; a deftype's declared hashCode governs its map/set hashing (paired with the
;; 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)))))
(register-hash-arm! jrec? jrec-hash)
;; 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
;; implements clojure.lang.ILookup routes to its valAt (core.match's pattern types
@ -308,25 +242,7 @@
;; 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
;; 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 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 (jrec-cl coll name) (and (jrec? coll) (find-method-any-protocol (jrec-tag coll) name)))
(define %r-jolt-count jolt-count)
(set! jolt-count (lambda (coll)
(cond ((jrec-cl coll "count") => (lambda (m) (jolt-invoke m coll)))
@ -407,9 +323,7 @@
(define %r-jolt-seq jolt-seq)
(set! jolt-seq (lambda (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
;; to %r-jolt-seq, which errors like the JVM).
((jrec-record? x) (list->cseq (jrec-entry-list x)))
((jrec? x) (list->cseq (jrec-entry-list x)))
(else (%r-jolt-seq x)))))
(define %r-jolt-conj1 jolt-conj1)
(set! jolt-conj1 (lambda (coll x)
@ -421,8 +335,7 @@
;; 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.
(define %r-jolt-empty? jolt-empty?)
(set! jolt-empty? (lambda (coll)
(if (jrec-collection? coll) (jolt-nil? (jolt-seq coll)) (%r-jolt-empty? coll))))
(set! jolt-empty? (lambda (coll) (if (jrec? coll) (jolt-nil? (jolt-seq coll)) (%r-jolt-empty? coll))))
(define %r-jolt-peek jolt-peek)
(set! jolt-peek (lambda (coll)
(cond ((jrec-cl coll "peek") => (lambda (m) (jolt-invoke m coll)))
@ -437,13 +350,10 @@
;; 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
;; 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?)
(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" "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 ------------------------------------------------------
;; type-tag -> (proto-name -> (method-name -> fn))
@ -463,28 +373,9 @@
(and (pair? protos)
(let ((f (hashtable-ref (hashtable-ref ti (car protos) #f) method #f)))
(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)
(let ((ti (hashtable-ref type-registry type-tag #f)))
(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).
(define (value-host-tags obj)
@ -495,38 +386,18 @@
((number? obj) '("Long" "Integer" "BigInteger" "BigInt" "Number" "Object"))
((string? obj) '("String" "CharSequence" "Object"))
((boolean? obj) '("Boolean" "Object"))
((keyword? obj) (jch-tags "clojure.lang.Keyword"))
((jolt-symbol? obj) (jch-tags "clojure.lang.Symbol"))
((pvec? obj) (jch-tags "clojure.lang.PersistentVector"))
((pmap? obj) (jch-tags "clojure.lang.PersistentArrayMap"))
((pset? obj) (jch-tags "clojure.lang.PersistentHashSet"))
;; jolt models every seq as a list (no distinct LazySeq), so a seq also
;; reports PersistentList / IPersistentList / IPersistentStack — extend-protocol
;; clojure.lang.IPersistentList (algo.monads' writer monad) dispatches on one.
((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"))
((keyword? obj) '("Keyword" "Named" "Object"))
((jolt-symbol? obj) '("Symbol" "Named" "Object"))
((pvec? obj) '("PersistentVector" "APersistentVector" "IPersistentVector" "IPersistentCollection"
"List" "java.util.List" "Sequential" "Collection" "Iterable" "java.lang.Iterable" "Object"))
((pmap? obj) '("PersistentArrayMap" "APersistentMap" "IPersistentMap" "Associative"
"Map" "java.util.Map" "Iterable" "java.lang.Iterable" "Object"))
((pset? obj) '("PersistentHashSet" "APersistentSet" "IPersistentSet" "Set" "java.util.Set" "Collection" "Iterable" "java.lang.Iterable" "Object"))
((or (cseq? obj) (empty-list-t? obj)) '("ASeq" "ISeq" "IPersistentCollection" "Sequential" "Collection" "Iterable" "java.lang.Iterable" "Object"))
;; 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"))
;; 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"))
@ -561,23 +432,8 @@
;; 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"))
;; 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"))
;; 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"))))
(define (record-tag obj) (and (jrec? obj) (jrec-tag obj)))
@ -607,26 +463,11 @@
(number? a) (not (flonum? a)))
(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)
;; Register the ctor globally by simple class name (like StringBuilder) so
;; (Name. …) interop resolves ns-agnostically: a deftype used across files works
;; even when the runtime current ns is the caller's, not the defining ns
;; (host-new checks class-ctors-tbl before the current-ns var fallback).
(register-class-ctor! (symbol-t-name name-sym) ctor)
;; 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))
@ -660,12 +501,11 @@
'("Long" "Integer" "Number" "Double" "Ratio" "BigInt" "BigInteger"
"String" "CharSequence" "Boolean" "Character"
"Keyword" "Symbol" "Named" "Object" "nil"
"Fn" "IFn" "AFn" "URI" "Var" "IDeref"
"Fn" "IFn" "AFn" "URI"
"PersistentVector" "APersistentVector" "IPersistentVector"
"PersistentArrayMap" "APersistentMap" "IPersistentMap"
"PersistentHashSet" "APersistentSet" "IPersistentSet"
"ASeq" "ISeq" "IPersistentCollection" "Associative" "Sequential"
"PersistentList" "IPersistentList" "IPersistentStack"
"Map" "java.util.Map" "List" "java.util.List" "Set" "java.util.Set"
"Collection" "java.util.Collection" "Iterable" "java.lang.Iterable"
"UUID" "BigDecimal" "Date" "Timestamp" "Instant" "java.sql.Date"
@ -677,12 +517,7 @@
"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"))
"[B" "[C" "[I" "[J" "[D" "[Ljava.lang.Object;"))
h))
(define (strip-prefix s p)
(let ((pl (string-length p)))
@ -696,17 +531,7 @@
(strip-prefix type-name "java.time.")
(strip-prefix type-name "clojure.lang.")
type-name)))
;; a host class if the literal set lists it OR the class graph models it — both
;; 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)))
(and (hashtable-ref host-type-set base #f) base)))
;; 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
;; restores it). deftype/defrecord inline impls go through register-inline-method
@ -719,14 +544,7 @@
(when pi (hashtable-set! pi extend-mark #t))))))
(define (register-method type-name proto-name method-name fn)
(let* ((host (canonical-host-tag type-name))
(local (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))))
(tag (or host (string-append (chez-current-ns) "." type-name))))
(register-protocol-method tag proto-name method-name fn)
(mark-extend! tag proto-name)
jolt-nil))
@ -745,12 +563,6 @@
(let ((h (make-hashtable string-hash string=?))) (hashtable-set! type-registry tag h) h))))
(unless (hashtable-ref ti proto-name #f)
(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)
;; protocol-resolve: the impl procedure for obj — by record type tag, a reify's
@ -835,38 +647,21 @@
;; "#<compound condition>".
(def-var! "jolt.host" "condition-message"
(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))))
(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)))
;; (.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
;; (above) wins, this is the field-accessor fallback.
((and (jrec? obj) (null? rest) (jrec-has? obj (keyword #f method-name)))
(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)
=> (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))))))
@ -903,8 +698,6 @@
(string-append (if (symbol-t-ns obj) (string-append (symbol-t-ns obj) "/") "")
(symbol-t-name obj)))
((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")))))
;; clojure.lang.Namespace: name/getName yield the ns name as a Symbol (JVM:
;; Namespace.name is a Symbol). clojure.spec.alpha reads (.name *ns*).
@ -954,14 +747,6 @@
((jolt=2 (seq-first s) target)
(if last? (loop (jolt-seq (seq-more s)) (fx+ i 1) i) i))
(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.).
((string=? method-name "toString") (jolt-str-render-one obj))
((string=? method-name "hashCode") (jolt-hash obj))
@ -969,46 +754,10 @@
(else (error #f (string-append "No method " method-name " for value: "
(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 +
;; the protocol short-names it implements (for satisfies?/instance?).
(define-record-type jreify (fields methods protos) (nongenerative chez-jreify-v1))
(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)
(let ((ht (make-hashtable string-hash string=?))
(protos (if (and (pair? proto-names) (null? (cdr proto-names)) (jolt-coll-pred? (car proto-names)))
@ -1066,24 +815,6 @@
;; yields (jolt-symbol #f (jrec-tag x)), the ns.Name class-name symbol.
(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" "register-protocol-methods!" register-protocol-methods!)
(def-var! "clojure.core" "register-method" register-method)

View file

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

View file

@ -11,17 +11,6 @@
;; Emitted programs do `(load "host/chez/rt.ss")`; this loads values.ss in turn.
(load "host/chez/values.ss")
;; Resolve a libc entry point at RUN time. A literal (foreign-procedure "name" …)
;; in COMPILED code becomes a fasl relocation resolved when the boot loads — on a
;; platform lacking the symbol (chmod/sigaddset on Windows) that kills the boot
;; before any guard can run. eval defers the lookup to evaluation time, where the
;; guard works; returns #f when the entry doesn't exist.
(define (jolt-foreign-proc-safe name args res)
(guard (e (#t #f))
(load-shared-object #f)
(and (foreign-entry? name)
(eval `(foreign-procedure ,name ,args ,res)))))
(load "host/chez/collections.ss")
(load "host/chez/seq.ss")
@ -33,157 +22,26 @@
;; pass an exact integer through, error if it doesn't fit a fixnum or isn't a
;; number. The hint is a promise the value is a fixnum-range long; the body's fx*
;; ops rely on it. (^double params coerce with the built-in exact->inexact.)
;; A ^long is a 64-bit value; a Chez fixnum is only 61-bit, so a value that
;; overflows the fixnum range (a full-width long, e.g. from unchecked / wrapping
;; arithmetic) passes through as an exact integer rather than erroring. fx ops in
;; the body still require fixnums (they raise on a bignum), but generic /
;; unchecked-* ops handle it.
(define (jolt->fx x)
(cond ((fixnum? x) x)
((and (number? x) (exact? x) (integer? x)) x)
((flonum? x) (exact (truncate x)))
((rational? x) (exact (truncate x)))
(else (error 'jolt "^long hint: not a number" x))))
(let ((n (cond ((fixnum? x) x)
((flonum? x) (exact (truncate x)))
((rational? x) (exact (truncate x)))
(else (error 'jolt "^long hint: not a number" x)))))
(if (fixnum? n) n (error 'jolt "^long hint: value out of fixnum range" x))))
;; jolt `not`: only nil and false are falsey.
(define (jolt-not x) (if (jolt-truthy? x) #f #t))
;; --- exceptions --------------------------------------------------------------
;; throw raises a Chez condition WRAPPING the jolt value; catch (emitted as
;; `guard`) and jolt-report-uncaught unwrap it back via jolt-unwrap-throw.
;; Raising the value RAW broke when a throw crossed the host/`eval` boundary:
;; Chez re-wrapped the non-condition into a compound condition whose
;; message-extraction APPLIES the value (crashing on an empty-map :data ->
;; "attempt to apply non-procedure"), and the real message was lost. A real
;; condition propagates intact through any number of eval boundaries.
;; throw raises the jolt value RAW (no envelope);
;; catch (emitted as `guard`) binds it directly. Chez `raise` accepts any
;; object, so a thrown number/map/ex-info all work; uncaught -> non-zero exit.
;; 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))
(call/cc (lambda (k) (jolt-throw-cont (cons v k)) (raise v))))
;; ex-info builds the tagged map {:jolt/type :jolt/ex-info :message :data :cause}
;; — a real jolt-hash-map, so the ex-data/ex-message/ex-cause tier fns read it
;; via jolt-get for free. Arity 2 (msg data) or 3 (msg data cause).
@ -251,21 +109,7 @@
;; evaluates to #'ns/name (a first-class var), so (var? (def x 1)) is true and
;; (pr-str (def x 1)) is "#'ns/x". The prelude's def-var! forms discard the
;; return, so this is transparent there.
;; proc -> (ns . name) for the var it was def'd into, so (class a-fn) can report a
;; JVM-style class name and clojure.spec.alpha's fn-sym can recover the symbol of a
;; bare-fn predicate. Weak so GC'd fns drop out. Last def of a given proc wins.
(define proc-name-tbl (make-weak-eq-hashtable))
(define (def-var! ns name v)
;; first def of a given proc wins, so an alias like (def inc' inc) — which binds
;; the SAME proc to a second var — doesn't rename inc.
(when (and (procedure? v) (not (hashtable-contains? proc-name-tbl v)))
(hashtable-set! proc-name-tbl v (cons ns name)))
(let ((c (jolt-var ns name))) (var-cell-root-set! c v) (var-cell-defined?-set! c #t) c))
;; jolt.host/throwable — build a typed throwable a library can throw so (class …),
;; instance?, .getMessage and ex-message all reflect the named JVM class (e.g. an
;; http client throwing java.net.ConnectException). Strictly better than a
;; hand-rolled :jolt/ex-info table, which carries only the class.
(def-var! "jolt.host" "throwable" jolt-host-throwable)
(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))
;; var def-time metadata: the :def emit passes the def's reader meta
;; (^:private / ^Type tag / docstring -> {:doc}) here, stored in an eq side-table
;; keyed by the cell. jolt-meta (natives-meta.ss) merges it onto {:ns :name},
@ -341,59 +185,6 @@
;; bare nil renders as the empty string (a nil ELEMENT inside a collection still
;; prints "nil", which jolt-pr-str handles).
(define (jolt-final-str x) (if (jolt-nil? x) "" (jolt-pr-str x)))
;; --- *print-level* / *print-length* -----------------------------------------
;; Both vars default to nil (= unlimited). A non-nil number limits collection
;; nesting depth / element count in BOTH printers (jolt-pr-str here and
;; jolt-pr-readable in printing.ss). Cells captured lazily — the vars are def'd
;; after rt.ss. The nil default takes a fast path: jolt-print-hash? is #f and the
;; limited-string walkers never truncate.
(define plevel-cell #f)
(define plength-cell #f)
(define (jolt-print-level)
(unless plevel-cell (set! plevel-cell (jolt-var "clojure.core" "*print-level*")))
(let ((v (jolt-var-get plevel-cell))) (and (number? v) v)))
(define (jolt-print-length)
(unless plength-cell (set! plength-cell (jolt-var "clojure.core" "*print-length*")))
(let ((v (jolt-var-get plength-cell))) (and (number? v) v)))
(define jolt-print-depth (make-thread-parameter 0))
;; A collection at depth >= *print-level* renders as "#". The top-level collection
;; is depth 0, so *print-level* 0 collapses any collection, 1 keeps the outermost.
(define (jolt-print-hash?)
(let ((lvl (jolt-print-level))) (and lvl (fx>=? (jolt-print-depth) lvl))))
;; Rendered element strings of a vector (by index), honoring *print-length*: at
;; most N, then "...". render-one runs at the current (already bumped) depth.
(define (jolt-limited-vec-strs x render-one)
(let ((len (pvec-count x)) (lim (jolt-print-length)))
(let loop ((i 0) (acc '()))
(cond ((fx>=? i len) (reverse acc))
((and lim (fx>=? i lim)) (reverse (cons "..." acc)))
(else (loop (fx+ i 1) (cons (render-one (pvec-nth-d x i jolt-nil)) acc)))))))
;; Rendered element strings of a seq, walked lazily so an infinite seq is realized
;; only up to *print-length*.
(define (jolt-limited-seq-strs s render-one)
(let ((lim (jolt-print-length)))
(let loop ((s s) (i 0) (acc '()))
(cond ((jolt-nil? s) (reverse acc))
((and lim (fx>=? i lim)) (reverse (cons "..." acc)))
(else (loop (jolt-seq (seq-more s)) (fx+ i 1) (cons (render-one (seq-first s)) acc)))))))
;; Truncate an already-collected element-string list (set / map, finite) to
;; *print-length*, appending "..." when more remain.
(define (jolt-limited-list-strs strs)
(let ((lim (jolt-print-length)))
(if (not lim) strs
(let loop ((s strs) (i 0) (acc '()))
(cond ((null? s) (reverse acc))
((fx>=? i lim) (reverse (cons "..." acc)))
(else (loop (cdr s) (fx+ i 1) (cons (car s) acc))))))))
;; bump the print depth around a collection's element rendering — but only when
;; *print-level* is set, since depth is consulted only to enforce it. With the
;; common nil default this is a plain begin, so printing pays no parameterize.
(define-syntax with-deeper-print
(syntax-rules ()
((_ body ...) (if (jolt-print-level)
(parameterize ((jolt-print-depth (fx+ (jolt-print-depth) 1))) body ...)
(begin body ...)))))
;; A host shim registers a type's str-style rendering via register-pr-str-arm! (or
;; register-pr-arm! in printing.ss for both printers at once) instead of
;; set!-wrapping jolt-pr-str. Disjoint types, checked before the base cases.
@ -414,23 +205,18 @@
(if (or (jolt-nil? ns) (not ns) (eq? ns '())) (symbol-t-name x)
(string-append ns "/" (symbol-t-name x)))))
((regex-t? x) (string-append "#\"" (regex-t-source x) "\""))
((pvec? x) (if (jolt-print-hash?) "#"
(with-deeper-print
(string-append "[" (jolt-str-join (jolt-limited-vec-strs x jolt-pr-str)) "]"))))
((pset? x) (if (jolt-print-hash?) "#"
(with-deeper-print
(string-append "#{" (jolt-str-join (jolt-limited-list-strs
(pset-fold x (lambda (e a) (cons (jolt-pr-str e) a)) '()))) "}"))))
((pmap? x) (if (jolt-print-hash?) "#"
(with-deeper-print
(string-append "{" (jolt-str-join (jolt-limited-list-strs
(pmap-fold x (lambda (k v a) (cons (string-append (jolt-pr-str k) " " (jolt-pr-str v)) a)) '()))) "}"))))
;; lists / cons / lazy seqs all print as (...) — forces a finite seq (or up to
;; *print-length* of an infinite one).
((empty-list-t? x) (if (jolt-print-hash?) "#" "()"))
((cseq? x) (if (jolt-print-hash?) "#"
(with-deeper-print
(string-append "(" (jolt-str-join (jolt-limited-seq-strs x jolt-pr-str)) ")"))))
((pvec? x) (let ((acc '())) (let loop ((i (fx- (pvec-count x) 1)))
(when (fx>=? i 0) (set! acc (cons (jolt-pr-str (pvec-nth-d x i jolt-nil)) acc)) (loop (fx- i 1))))
(string-append "[" (jolt-str-join acc) "]")))
((pset? x) (string-append "#{" (jolt-str-join (pset-fold x (lambda (e a) (cons (jolt-pr-str e) a)) '())) "}"))
((pmap? x) (string-append "{" (jolt-str-join
(pmap-fold x (lambda (k v a) (cons (string-append (jolt-pr-str k) " " (jolt-pr-str v)) a)) '())) "}"))
;; lists / cons / lazy seqs all print as (...) — forces a finite seq.
((empty-list-t? x) "()")
((cseq? x) (string-append "(" (jolt-str-join
(let loop ((s x) (acc '()))
(if (jolt-nil? s) (reverse acc)
(loop (jolt-seq (seq-more s)) (cons (jolt-pr-str (seq-first s)) acc))))) ")"))
(else (format "~a" x))))
(define (jolt-pr-str x)
(let loop ((as jolt-pr-str-arms))
@ -473,11 +259,6 @@
;; jolt-pr-str (above), and the var-cell machinery — so loaded last.
(load "host/chez/multimethods.ss")
;; the single JVM class/interface graph — value-host-tags, instance?, isa?/supers,
;; and the exception hierarchy all derive from it. Before records.ss so
;; value-host-tags can build on jch-tags.
(load "host/chez/java/class-hierarchy.ss")
;; records + protocols: defrecord/deftype/defprotocol/
;; extend-type/reify. A jrec record type set!-extended into the collection
;; dispatchers + a protocol registry. After multimethods.ss (chez-current-ns) and

View file

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

View file

@ -77,28 +77,6 @@
(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)))

View file

@ -59,15 +59,6 @@
(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))))"))

View file

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

View file

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

View file

@ -0,0 +1,84 @@
;; run-reduce-sroa.ss — reduce-accumulator scalar replacement gate.
;;
;; A (reduce (fn [acc x] body) (->Rec inits) coll) whose accumulator is a
;; non-escaping record (read only via its fields, rebuilt each step as a same-shape
;; ctor or carried forward unchanged) lowers to a seq loop that carries the acc's
;; fields as scalar loop vars and reconstructs the record once at exit — killing the
;; per-step allocation. This is the ray tracer's hit-all pattern (a HitAcc per
;; sphere test). Pinned here: the reduce call is gone (lowered to a loop), the
;; lowered result matches the generic reduce, and non-lowerable shapes (non-record
;; init, escaping acc) keep the ordinary reduce.
;;
;; chez --script host/chez/run-reduce-sroa.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 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-src) (eval (read (open-input-string scm-src)) (interaction-environment)))
(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)))
(evals "(defrecord Acc [sum cnt])")
(set-record-shapes! (chez-record-shapes-map))
(set-protocol-methods! (jolt-hash-map))
(set-optimize! #t)
(define (emit-opt src) (emit (run-passes (anode src) (make-analyze-ctx "user"))))
;; canonical accumulator: a same-shape ctor in one branch, the acc carried forward
;; in the other. Only the fields of acc are read; acc never escapes.
(define run-src
"(def run (fn [xs] (:sum (reduce (fn [acc x] (if (> x 0) (->Acc (+ (:sum acc) x) (+ (:cnt acc) 1)) acc)) (->Acc 0 0) xs))))")
(define run-scm (emit-opt run-src))
(check "reduce accumulator lowered (no reduce call)" (contains-sub? run-scm "reduce") #f)
(built run-scm)
(check "lowered result matches generic"
(jolt-invoke (var-deref "user" "run") (jolt-vector 1 -2 3 4))
(evals "(:sum (reduce (fn [acc x] (if (> x 0) (->Acc (+ (:sum acc) x) (+ (:cnt acc) 1)) acc)) (->Acc 0 0) [1 -2 3 4]))"))
;; a reduce over a record acc that reads BOTH fields at the end still matches.
(define cnt-src
"(def cntr (fn [xs] (:cnt (reduce (fn [acc x] (->Acc (+ (:sum acc) x) (+ (:cnt acc) 1))) (->Acc 0 0) xs))))")
(define cnt-scm (emit-opt cnt-src))
(check "second accumulator lowered" (contains-sub? cnt-scm "reduce") #f)
(built cnt-scm)
(check "count accumulator correct" (jolt-invoke (var-deref "user" "cntr") (jolt-vector 5 5 5 5)) 4)
;; empty coll returns the init (reduce semantics): (:sum (->Acc 0 0)) = 0
(check "empty coll returns init" (jolt-invoke (var-deref "user" "run") (jolt-vector)) 0)
;; --- negatives: shapes that must NOT be lowered keep the ordinary reduce --------
;; non-record init
(check "non-record reduce untouched"
(contains-sub? (emit-opt "(def sm (fn [xs] (reduce (fn [acc x] (+ acc x)) 0 xs)))") "reduce") #t)
;; acc escapes (passed whole to a fn)
(check "escaping-acc reduce untouched"
(contains-sub? (emit-opt "(def esc (fn [xs] (reduce (fn [acc x] (do (identity acc) (->Acc (+ (:sum acc) x) (:cnt acc)))) (->Acc 0 0) xs)))") "reduce") #t)
(if (= fails 0)
(begin (printf "reduce-sroa gate: ~a/~a passed\n" total total) (exit 0))
(begin (printf "reduce-sroa gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))

View file

@ -91,18 +91,6 @@
(check "self-recursive same-type param keeps its seed"
(jolt-truthy? (param-seeds-for "user/grow")) #t)
;; a recursive fn that threads a param STRAIGHT THROUGH its recursion (same arg at
;; the same position) must keep that param's type — a pass-through self-call adds no
;; information and must not poison the param to :any. This is the ray tracer's
;; hittables, passed unchanged through ray-cast's recursion while its reduce element
;; reads the records' fields.
(define cwalk (anode "(def cwalk (fn [hs] (reduce (fn [acc h] (:left h)) nil hs)))"))
(define crec (anode "(def crec (fn [hs d] (if (< d 0) nil (do (cwalk hs) (crec hs (- d 1))))))"))
(define cdrv (anode "(def cdrive (fn [] (crec [(->Node nil nil) (->Node nil nil)] 5)))"))
(wp-infer! (jolt-vector cwalk crec cdrv))
(check "recursion pass-through param keeps its vec element type"
(contains-sub? (pr-str (param-seeds-for "user/crec")) "user.Node") #t)
(if (= fails 0)
(begin (printf "wp gate: ~a/~a passed\n" total total) (exit 0))
(begin (printf "wp gate: ~a/~a passed (~a failed)\n" (- total fails) total fails) (exit 1)))

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

View file

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

View file

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

View file

@ -35,13 +35,9 @@
;; 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)))
;; &continuation, else #f.
(define (jolt-error-continuation v)
(let ((tc (jolt-throw-cont)))
(cond
((and (pair? tc) (eq? (car tc) v)) (cdr tc))
((and (condition? v) (continuation-condition? v)) (condition-continuation v))
@ -57,36 +53,10 @@
((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.
;; Walk a continuation, returning the registered jolt frames (innermost first) as
;; (frame-name . record) pairs, where record is #(ns name file line) or the symbol
;; 'ambiguous. Unmapped frames (host spine, anonymous lambdas) 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.
@ -96,107 +66,61 @@
(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))))))
(src (and nm (hashtable-ref source-registry nm #f))))
(when (and debug? nm)
(display (string-append " [frame] " nm (if src " *MAPPED*"
(if keep? "" " (skipped)")) "\n")
(display (string-append " [frame] " nm (if src " *MAPPED*" "") "\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))))
(if src (cons (cons nm src) acc) acc))))))))
;; Multi-line backtrace for an uncaught value — " ns/name (file:line)" for a
;; mapped frame, the bare frame name for an ambiguous one — or #f when no jolt
;; frame maps (the caller then prints just the top-level location). Capped to the
;; innermost frames.
(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))))
(let ((k (jolt-error-continuation v)))
(and k
(let ((recs (jolt-frame-records k)))
(and (pair? recs)
(let ((port (open-output-string)))
(let loop ((rs recs) (shown 0))
(when (and (pair? rs) (fx<? shown 30))
(let* ((p (car rs)) (frame-name (car p)) (r (cdr p)))
(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: bare name
(put-char port #\newline))
(loop (cdr rs) (fx+ shown 1))))
(get-output-string port)))))))
;; 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)))))
(define (jolt-render-throwable v port)
(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).

View file

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

View file

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

View file

@ -41,9 +41,7 @@
;; expansion still re-analyzes as a set literal.
(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).
;; Clojure's syntaxQuote builds the map via `apply hash-map`, so a `{...} template
;; is HASH-ordered (unlike a {...} literal, which keeps insertion order).
(define (jolt-sqmap . parts) (jolt-hash-map-build parts))
(define (jolt-sqmap . parts) (apply jolt-hash-map parts))
(def-var! "clojure.core" "__sq1" jolt-sq1)
(def-var! "clojure.core" "__sqcat" jolt-sqcat)

View file

@ -16,17 +16,11 @@
;; this record, not a pvec), which group-by relies on. Loaded after collections.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
(fields kind (mutable buf) (mutable n) (mutable active) (mutable ord))
(nongenerative jolt-transient-v3))
(fields kind (mutable buf) (mutable n) (mutable active))
(nongenerative jolt-transient-v2))
(define tvec-min-cap 8)
(define tmap-min-cap 8)
(define (jolt-transient-new coll)
(cond
@ -34,36 +28,16 @@
(let* ((v (pvec-v coll)) (cnt (vector-length v)) (cap (fxmax tvec-min-cap cnt))
(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))))
(make-jolt-transient 'vec buf cnt #t #f)))
(make-jolt-transient 'vec buf cnt #t)))
((pmap? coll)
(let ((ht (make-hashtable key-hash jolt=2)) (ord '()) (cnt 0))
;; visit in iteration order so `ord` ends up reverse-insertion (persistent! reverses it back)
(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 (fxmax tmap-min-cap cnt) #t ord)))
(let ((ht (make-hashtable key-hash jolt=2)))
(pmap-fold coll (lambda (k v acc) (hashtable-set! ht k v) acc) 0)
(make-jolt-transient 'map ht 0 #t)))
((pset? coll)
(let ((ht (make-hashtable key-hash jolt=2)))
(pset-fold coll (lambda (e acc) (hashtable-set! ht e #t) acc) 0)
(make-jolt-transient 'set ht 0 #t #f)))
;; RFC 0003: any COLLECTION transients (the sorted/list/seq superset rides
;; 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)))
(make-jolt-transient 'set ht 0 #t)))
(else (make-jolt-transient 'cow coll 0 #t))))
(define (jolt-trans-check t who)
(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)))
(make-pvec out)))))))
((map)
(let* ((ht (jolt-transient-buf t)) (cnt (hashtable-size ht)) (cap (jolt-transient-n t))
;; Clojure 1.13: a keyword-only map stays an array map up to 64 entries,
;; so a keyword map built through a transient (into {} …) keeps insertion
;; 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))))
(let ((ht (jolt-transient-buf t)) (m empty-pmap))
(vector-for-each (lambda (k) (set! m (pmap-assoc m k (hashtable-ref ht k jolt-nil)))) (hashtable-keys ht))
m))
((set)
(let ((ht (jolt-transient-buf t)) (s empty-pset))
(vector-for-each (lambda (e) (set! s (pset-conj s e))) (hashtable-keys ht))
@ -129,8 +91,8 @@
(define (tmap-conj-entry! t x)
(cond
((jolt-nil? x) #t)
((pvec? x) (tmap-put! 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))
((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 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))))
;; (conj!) -> fresh transient vector; (conj! coll) -> the 1-arity transducer-
@ -157,14 +119,14 @@
(let ((kvs (assoc-pad kvs0)))
(when (odd? (length kvs)) (error #f "assoc!: no value supplied for key"))
(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)))))
(else (jolt-transient-buf-set! t (apply jolt-assoc (jolt-transient-buf t) kvs)))))
t)
(define (jolt-dissoc! t . ks)
(jolt-trans-check t "dissoc!")
(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))))
t)
(define (jolt-disj! t . xs)
@ -184,11 +146,8 @@
;; persistent disj over sets (pset-disj already exists in collections.ss).
(define (jolt-disj s . xs)
;; (disj nil ...) is nil on the JVM (disj is otherwise set-only).
(if (jolt-nil? s)
jolt-nil
(meta-carry s
(let loop ((s s) (xs xs)) (if (null? xs) s (loop (pset-disj s (car xs)) (cdr xs)))))))
(meta-carry s
(let loop ((s s) (xs xs)) (if (null? xs) s (loop (pset-disj s (car xs)) (cdr xs))))))
;; --- see-through accessors ---------------------------------------------------
(define (tvec-in-bounds? t i) (and (fixnum? i) (fx>=? i 0) (fx<? i (jolt-transient-n t))))

View file

@ -47,21 +47,9 @@
(define (keyword? x) (keyword-t? x))
;; --- 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 (jolt-symbol ns name)
(make-symbol-t (intern-symbol-string ns) (intern-symbol-string name) jolt-nil))
(define (jolt-symbol/meta ns name meta)
(make-symbol-t (intern-symbol-string ns) (intern-symbol-string name) meta))
(define (jolt-symbol ns name) (make-symbol-t ns name jolt-nil))
(define (jolt-symbol/meta ns name meta) (make-symbol-t ns name meta))
(define (jolt-symbol? x) (symbol-t? x))
;; chars/strings: Chez natives (strings treated immutable).
@ -96,16 +84,10 @@
((and (jolt-coll? a) (jolt-coll? b)) (jolt-coll=? a b))
(else (eq? a b))))
(define (jolt=2 a b)
;; identity fast path, like Util.equiv's k1 == k2: the same object equals
;; itself without a structural walk — (= s s) on an infinite lazy seq must not
;; realize it. Numbers keep the exactness-aware arm (Chez may intern flonum
;; literals, and (= ##NaN ##NaN) is false like the JVM's).
(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)))))))
(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)
(let loop ((a a) (rest rest))
(cond ((null? rest) #t)

161
install
View file

@ -1,161 +0,0 @@
#!/usr/bin/env bash
# Installs the latest (or a specific) version of joltc, the self-contained jolt
# binary. It bundles the runtime, compiler, jolt-core + stdlib, and the Chez
# boots, so there is nothing else to install — no Chez, no cc, no JVM.
set -euo pipefail
version=""
checksum=""
default_install_dir="/usr/local/bin"
install_dir="$default_install_dir"
download_dir=""
repo="jolt-lang/jolt"
print_help() {
echo "Installs the latest (or a specific) version of joltc."
echo "Installation directory defaults to ${default_install_dir}."
echo
echo "Usage:"
echo " install [--dir <dir>] [--download-dir <dir>] [--version <version>] [--checksum <sha256>]"
echo
echo "Defaults:"
echo " * Installation directory: ${default_install_dir}"
echo " * Download directory: a temporary directory"
echo " * Version: the latest release on GitHub"
echo " * Checksum: fetched from the release and verified automatically"
exit 1
}
has() {
command -v "$1" >/dev/null 2>&1
}
fetch() {
local url=$1
local outfile=${2:-}
if has curl; then
if [[ -n $outfile ]]; then curl -fsSL "$url" -o "$outfile"; else curl -fsSL "$url"; fi
elif has wget; then
if [[ -n $outfile ]]; then wget -qO "$outfile" "$url"; else wget -qO - "$url"; fi
else
>&2 echo "Either 'curl' or 'wget' needs to be on PATH."
exit 1
fi
}
while [[ $# -gt 0 ]]; do
case "$1" in
--dir) install_dir="$2"; shift 2 ;;
--download-dir) download_dir="$2"; shift 2 ;;
--version) version="$2"; shift 2 ;;
--checksum) checksum="$2"; shift 2 ;;
--help|-h) print_help ;;
*) print_help ;;
esac
done
if [[ -z "$download_dir" ]]; then
download_dir="$(mktemp -d)"
trap 'rm -rf "$download_dir"' EXIT
fi
# --- resolve platform / arch to a release target -----------------------------
case "$(uname -s)" in
Linux*) platform=linux ;;
Darwin*) platform=macos ;;
*) >&2 echo "Unsupported OS: $(uname -s). Prebuilt binaries exist for Linux and macOS."; exit 1 ;;
esac
case "$(uname -m)" in
x86_64|amd64) arch=x86_64 ;;
aarch64|arm64) arch=aarch64 ;;
*) >&2 echo "Unsupported architecture: $(uname -m)."; exit 1 ;;
esac
target="${arch}-${platform}"
case "$target" in
x86_64-linux|aarch64-macos) ;;
x86_64-macos)
>&2 echo "No prebuilt joltc for Intel macOS (GitHub retired the Intel runner)."
>&2 echo "Build from source: https://github.com/${repo} (needs Chez Scheme + cc)."
exit 1 ;;
*) >&2 echo "No prebuilt joltc for ${target}."
>&2 echo "Available: x86_64-linux, aarch64-macos."
>&2 echo "Build from source: https://github.com/${repo} (make joltc-release)."
exit 1 ;;
esac
# --- resolve version ---------------------------------------------------------
if [[ -z "$version" ]]; then
version="$(fetch "https://api.github.com/repos/${repo}/releases/latest" \
| grep -m1 '"tag_name"' | sed -E 's/.*"tag_name": *"([^"]+)".*/\1/')"
if [[ -z "$version" ]]; then
>&2 echo "Could not determine the latest release. Pass --version explicitly."
exit 1
fi
fi
tag="v${version#v}" # accept 0.1.0 or v0.1.0; the tag/asset carry the leading v
filename="joltc-${tag}-${target}.tar.gz"
download_url="https://github.com/${repo}/releases/download/${tag}/${filename}"
if has sha256sum; then
sha256sum_cmd="sha256sum"
elif has shasum; then
sha256sum_cmd="shasum -a 256"
else
sha256sum_cmd=""
fi
mkdir -p "$download_dir" && (
cd "$download_dir"
echo "Downloading ${download_url}"
fetch "$download_url" "$filename"
# verify: an explicit --checksum wins; otherwise fetch the release's .sha256.
if [[ -z "$checksum" ]]; then
checksum="$(fetch "${download_url}.sha256" 2>/dev/null | cut -d' ' -f1 || true)"
fi
if [[ -n "$checksum" && -n "$sha256sum_cmd" ]]; then
got="$($sha256sum_cmd "$filename" | cut -d' ' -f1)"
if [[ "$got" != "$checksum" ]]; then
>&2 echo "Checksum mismatch on ${filename}"
>&2 echo " got: ${got}"
>&2 echo " expected: ${checksum}"
exit 1
fi
elif [[ -z "$sha256sum_cmd" ]]; then
>&2 echo "Note: no sha256sum/shasum on PATH; skipping checksum verification."
fi
tar -zxf "$filename"
rm -f "$filename"
)
# the tarball unpacks to a directory holding the binary
extracted="${download_dir}/joltc-${tag}-${target}/joltc"
if [[ ! -f "$extracted" ]]; then
>&2 echo "Expected ${extracted} in the archive but it was not found."
exit 1
fi
mkdir -p "$install_dir"
if [[ -f "$install_dir/joltc" ]]; then
echo "Moving existing $install_dir/joltc to $install_dir/joltc.old"
mv -f "$install_dir/joltc" "$install_dir/joltc.old"
fi
mv -f "$extracted" "$install_dir/joltc"
chmod +x "$install_dir/joltc"
# clear the macOS quarantine flag so Gatekeeper doesn't block the fresh download
if [[ "$platform" == "macos" ]] && has xattr; then
xattr -d com.apple.quarantine "$install_dir/joltc" 2>/dev/null || true
fi
echo "Successfully installed joltc ${tag} to ${install_dir}/joltc"
if ! echo ":$PATH:" | grep -q ":${install_dir}:"; then
echo "Note: ${install_dir} is not on your PATH."
fi

View file

@ -43,10 +43,3 @@
(defn mapv [f & colls] (vec (apply map f colls)))
(defn update [m k f & args] (assoc m k (apply f (get m k) args)))
;; set: realize a seqable and dedup through the set constructor; nil -> #{}. The
;; compiler uses it off the emit path (backend bare-native-names, type inference),
;; so unlike boolean it can live here — compiling this tier never calls set, and by
;; the time those callers run the tier is bound. Pure composition of hash-set/seq/
;; apply, so it lowers to the same code the native shim did.
(defn set [coll] (if (nil? coll) #{} (apply hash-set (seq coll))))

View file

@ -117,9 +117,7 @@
(let [nm (if (and (seq? nm) (= 'with-meta (first nm))) (second nm) nm)
calls (reduce
(fn [acc clause]
;; a reference clause may be a list (:require …) or a vector
;; [:require …]; Clojure accepts both, dispatching on (first clause).
(if (or (seq? clause) (vector? clause))
(if (seq? clause)
(let [head (first clause) args (rest clause)]
(cond
(= head :require) (conj acc `(require ~@(map (fn [s] `(quote ~s)) args)))
@ -159,15 +157,6 @@
(defmacro declare [& syms]
`(do ~@(map (fn* [s] `(def ~s)) syms)))
;; letfn is a macro over the letfn* special form, matching Clojure: each
;; (name [params] body*) spec becomes a name + a (fn name [params] body*) binding.
;; So (macroexpand-1 '(letfn …)) yields the letfn* form macroexpansion tooling
;; (tools.macro / tools.analyzer) expects, instead of an opaque special form.
(defmacro letfn [fnspecs & body]
(cons 'letfn*
(cons (reduce (fn [acc s] (conj (conj acc (first s)) (cons 'fn s))) [] fnspecs)
body)))
;; destructure — Clojure's binding-vector expander.
;; Turns a binding vector that may contain destructuring
;; patterns into a plain binding vector (alternating symbol / init-form) built from
@ -188,23 +177,9 @@
[false nil]
(if or-map (keys or-map) [])))
amp? (fn* [x] (and (symbol? x) (= "&" (name x))))
;; split a :keys/:syms/:strs name list at & into [sym bind?] pairs. Names
;; before & bind normally (bind? true); names after & are declared-only
;; (bind? false) — accepted keys (:keys) or required keys (:keys!), per
;; CLJ-2961.
classify
(fn* [names]
(nth (reduce (fn* [st x]
(if (amp? x)
[(nth st 0) false]
[(conj (nth st 0) [x (nth st 1)]) (nth st 1)]))
[[] true] names)
0))
proc
(fn* proc [pat init acc]
(cond
;; CLJ-2954: & is reserved for destructuring rest, never a binding.
(amp? pat) (throw (new IllegalArgumentException "Can't use & as a local binding"))
(symbol? pat) (conj (conj acc pat) init)
(vector? pat)
(let* [g (symbol (str (gensym)))
@ -226,16 +201,16 @@
(let* [g (symbol (str (gensym)))
gm (symbol (str (gensym)))
;; kwargs: a map pattern may bind against the sequential rest
;; of a fn — (& {:keys [...]}) — a seq of alternating k/v args,
;; optionally with a trailing map (Clojure 1.11: (f :a 1 {:b 2})
;; merges the map over the pairs; (f {:a 1}) is just the map).
;; An odd count means the last arg is that trailing map. A real
;; map value is used as-is, so ordinary map destructuring is
;; unaffected. g holds init once; gm is the coerced map every
;; lookup (and :as) reads from.
;; of a fn — (& {:keys [...]}) — which is a seq of alternating
;; k/v args, or a single trailing map. Coerce like Clojure (and
;; like the interpreter's destructure-bind, so interpret/compile
;; agree): a sequential value with one map element is that map,
;; otherwise (apply hash-map). A real map value is used as-is, so
;; ordinary map destructuring is unaffected. g holds init once;
;; gm is the coerced map every lookup (and :as) reads from.
coerce `(if (sequential? ~g)
(if (odd? (count ~g))
(merge (apply hash-map (butlast ~g)) (last ~g))
(if (and (= 1 (count ~g)) (map? (first ~g)))
(first ~g)
(apply hash-map ~g))
~g)
or-map (get pat :or)
@ -245,45 +220,30 @@
;; group binds a :keys/:strs/:syms list. dnsp is the destructuring
;; namespace from a qualified key like :ns/keys — it both prefixes
;; the lookup key and overrides a bare symbol's namespace.
;; group binds a :keys/:strs/:syms list. checked? marks the
;; :keys!/:strs!/:syms! variants (CLJ-2961): lookups use req!
;; (throw on missing) instead of get. A pair is [sym bind?];
;; bind? false (names after &) is declared-only — for checked
;; groups it still runs req! (bound to a throwaway gensym) to
;; enforce the key, for unchecked groups it's a no-op.
group
(fn* group [a names kind dnsp checked?]
(fn* group [a names kind dnsp]
(if names
(reduce
;; s is a symbol (a b) or a keyword (:a :b); name/
;; namespace handle both, so :keys [:major] binds
;; `major` looking up :major (str would keep the colon).
(fn* [aa pair]
(let* [s (nth pair 0)
bind? (nth pair 1)
local (name s)
(fn* [aa s]
(let* [local (name s)
nsp (or (namespace s) dnsp)
keyform (cond
(= kind :kw) (keyword (if nsp (str nsp "/" local) local))
(= kind :str) local
:else `(quote ~(symbol nsp local)))
fo (find-or or-map local)
lookup (cond
checked? `(req! ~gm ~keyform)
(nth fo 0) `(get ~gm ~keyform ~(nth fo 1))
:else `(get ~gm ~keyform))]
(cond
bind? (conj (conj aa (symbol local)) lookup)
checked? (conj (conj aa (symbol (str (gensym)))) lookup)
:else aa)))
a (classify names))
fo (find-or or-map local)]
(conj (conj aa (symbol local))
(if (nth fo 0)
`(get ~gm ~keyform ~(nth fo 1))
`(get ~gm ~keyform)))))
a names)
a))
g1 (group base (get pat :keys) :kw nil false)
g2 (group g1 (get pat :strs) :str nil false)
g3 (group g2 (get pat :syms) :sym nil false)
g4 (group g3 (get pat :keys!) :kw nil true)
g5 (group g4 (get pat :strs!) :str nil true)
g6 (group g5 (get pat :syms!) :sym nil true)]
g1 (group base (get pat :keys) :kw nil)
g2 (group g1 (get pat :strs) :str nil)
g3 (group g2 (get pat :syms) :sym nil)]
;; remaining keys: a qualified :ns/keys|:ns/strs|:ns/syms groups under
;; its namespace; any other keyword is skipped; a non-keyword is a
;; nested binding pattern.
@ -291,12 +251,9 @@
(if (keyword? k)
(let* [kn (name k) kns (namespace k)]
(cond
(and kns (= kn "keys")) (group a (get pat k) :kw kns false)
(and kns (= kn "strs")) (group a (get pat k) :str kns false)
(and kns (= kn "syms")) (group a (get pat k) :sym kns false)
(and kns (= kn "keys!")) (group a (get pat k) :kw kns true)
(and kns (= kn "strs!")) (group a (get pat k) :str kns true)
(and kns (= kn "syms!")) (group a (get pat k) :sym kns true)
(and kns (= kn "keys")) (group a (get pat k) :kw kns)
(and kns (= kn "strs")) (group a (get pat k) :str kns)
(and kns (= kn "syms")) (group a (get pat k) :sym kns)
:else a))
;; a direct binding {x :x}: apply its :or default
;; (keyed by the local symbol) when the key is absent.
@ -305,7 +262,7 @@
`(get ~gm ~(get pat k) ~(nth fo 1))
`(get ~gm ~(get pat k)))
a))))
g6 (keys pat)))
g3 (keys pat)))
:else (throw (str "unsupported destructuring pattern: " (pr-str pat)))))
ploop
(fn* ploop [i acc]
@ -420,37 +377,25 @@
;; vector + body or a sequence of ([params] body) clauses, so no arity branching is
;; needed. (map? is true for symbol forms too, so guard the attr-map with symbol?.)
;; Defined before fresh-sym below, which is a defn-.
;; defn lives in the earliest tier, so its macro body may only use primitives
;; available before the seq/coll tiers — conj (which merges a map onto a map),
;; assoc, meta, with-meta — not merge/last/butlast.
(defmacro defn [fn-name & body]
(let [docstring (when (and (seq body) (string? (first body))) (first body))
body (if docstring (rest body) body)
;; the attr-map after an optional docstring (or after the name) — its keys
;; merge into the var metadata, like Clojure. A map in the first arity
;; position is the attr-map only when more body follows (else it is a lone
;; map body) and is never a symbol (a name carries its meta as a form).
attr-map (when (and (seq body) (next body) (map? (first body)) (not (symbol? (first body))))
(first body))
body (if attr-map (rest body) body)
;; the bare name + any ^{:map} metadata the reader attached to it.
fn-only-name (if (symbol? fn-name) fn-name (first (rest fn-name)))
name-meta (meta fn-only-name)
m1 (if attr-map (if name-meta (conj name-meta attr-map) attr-map) name-meta)
meta-map (if docstring (assoc (if m1 m1 {}) :doc docstring) m1)]
;; pass the name through to fn: the compiled fn's host name carries it, so
;; stack traces read app.deep/level3 instead of a gensym. All metadata
;; (docstring + attr-map + the name's own) is attached to the def name symbol,
;; which analyze-def reads and evaluates — so (meta #'f) reflects every source.
(if meta-map
`(def ~(with-meta fn-only-name meta-map) (fn ~(with-meta fn-only-name nil) ~@body))
`(def ~fn-only-name (fn ~fn-only-name ~@body)))))
body (if (and (seq body) (map? (first body)) (not (symbol? (first body))))
(rest body) body)
;; ^{:map} metadata on the name reads as a (with-meta sym …) form, not an
;; annotated symbol. def attaches the metadata, but fn needs a
;; bare symbol, so unwrap it for the fn name.
fn-only-name (if (symbol? fn-name) fn-name (first (rest fn-name)))]
;; pass the name through to fn: the compiled fn's host name carries it,
;; so stack traces read app.deep/level3 instead of a gensym. A leading
;; docstring rides the def's docstring slot so (:doc (meta #'f)) is set.
(if docstring
`(def ~fn-name ~docstring (fn ~fn-only-name ~@body))
`(def ~fn-name (fn ~fn-only-name ~@body)))))
;; defn- marks the var :private (like Clojure). Jolt doesn't restrict access, but
;; ns-publics filters private vars out — a lib that introspects ns-publics (e.g.
;; honeysql's "all helpers have docstrings") sees only the public ones.
(defmacro defn- [fn-name & body]
`(defn ~(with-meta fn-name (assoc (if (meta fn-name) (meta fn-name) {}) :private true)) ~@body))
;; Jolt doesn't enforce privacy, so defn- is just defn (matching how Clojure's own
;; defn- delegates to defn with :private metadata).
(defmacro defn- [fn-name & body] `(defn ~fn-name ~@body))
;; A fresh jolt symbol inside a macro body (a bare (gensym) returns a host symbol
;; the destructurer rejects). This defn compiles fine: by the time a tier triggers
@ -546,9 +491,7 @@
sub (wrap-mods (rest mods) inner)]
(if (= (first m) :when)
`(if ~(nth m 1) ~sub [])
;; `let` (not let*) so a :let binding may itself
;; destructure — (for [x xs :let [{:keys [y]} x]] …).
`(let ~(nth m 1) ~sub)))))
`(let* ~(nth m 1) ~sub)))))
build (fn build [idx groups]
(let [g (nth groups idx)
my-bind (nth g 0)
@ -577,8 +520,6 @@
;; name binds only in the taken branch (temp# tests the value); via `let` so the
;; binding form may itself destructure, matching Clojure.
(defmacro when-let [bindings & body]
(when (not= 2 (count bindings))
(throw (new IllegalArgumentException "when-let requires exactly 2 forms in binding vector")))
(let [form (bindings 0) tst (bindings 1)]
`(let [temp# ~tst]
(if temp# (let [~form temp#] ~@body) nil))))

View file

@ -59,13 +59,11 @@
;; nil, which prints as "nil" (str yields ""). Only the top-level arg needs the
;; guard; nil nested in a collection already renders as "nil" via the collection
;; printer.
;; print renders non-readably (__print1): a nested string is raw, unlike str/pr
;; which quote it. (print ["x"]) => [x], (str ["x"]) => ["x"].
(defn print [& xs]
(__write (loop [out "" s (seq xs) first? true]
(if s
(let [x (first s)
r (__print1 x)]
r (if (nil? x) "nil" (str x))]
(recur (str out (if first? "" " ") r) (next s) false))
out)))
nil)
@ -155,43 +153,8 @@
(when-let [s (seq coll)]
(or (pred (first s)) (recur pred (next s)))))
;; Reference arities: at least one predicate ((some-fn) is an arity error), and
;; the returned fn chains with or — a no-match result is the last predicate's
;; own falsy value (false stays false, not nil).
(defn some-fn
([p]
(fn sp1
([] nil)
([x] (p x))
([x y] (or (p x) (p y)))
([x y z] (or (p x) (p y) (p z)))
([x y z & args] (or (sp1 x y z)
(some p args)))))
([p1 p2]
(fn sp2
([] nil)
([x] (or (p1 x) (p2 x)))
([x y] (or (p1 x) (p1 y) (p2 x) (p2 y)))
([x y z] (or (p1 x) (p1 y) (p1 z) (p2 x) (p2 y) (p2 z)))
([x y z & args] (or (sp2 x y z)
(some (fn [q] (or (p1 q) (p2 q))) args)))))
([p1 p2 p3]
(fn sp3
([] nil)
([x] (or (p1 x) (p2 x) (p3 x)))
([x y] (or (p1 x) (p2 x) (p3 x) (p1 y) (p2 y) (p3 y)))
([x y z] (or (p1 x) (p2 x) (p3 x) (p1 y) (p2 y) (p3 y) (p1 z) (p2 z) (p3 z)))
([x y z & args] (or (sp3 x y z)
(some (fn [q] (or (p1 q) (p2 q) (p3 q))) args)))))
([p1 p2 p3 & ps]
(let [ps (cons p1 (cons p2 (cons p3 ps)))]
(fn spn
([] nil)
([x] (some (fn [p] (p x)) ps))
([x y] (or (spn x) (spn y)))
([x y z] (or (spn x) (spn y) (spn z)))
([x y z & args] (or (spn x y z)
(some (fn [p] (some p args)) ps)))))))
(defn some-fn [& preds]
(fn [& xs] (some (fn [p] (some p xs)) preds)))
(defn not-any? [pred coll] (not (some pred coll)))
@ -212,22 +175,13 @@
(defn simple-ident? [x] (or (simple-symbol? x) (simple-keyword? x)))
;; Numeric-tower predicates over the Chez tower (jolt has exact ints, ratios, and
;; flonums). ratio? = exact non-integer; rational? = exact (int or ratio). Built on
;; the jolt.host tower tests so they lower to the same code the native shims did.
;; decimal?/integer?/float?/int?/double? stay native (bigdec-extended or on the
;; compiler emit/inference path) — see predicates.ss.
(defn ratio? [x]
(and (number? x) (jolt.host/exact? x) (jolt.host/rational-type? x) (not (integer? x))))
(defn rational? [x]
(or (and (number? x) (jolt.host/exact? x)) (decimal? x)))
;; No first-class Class objects: class names are symbols the evaluator handles in
;; instance?/new positions, never values — so nothing is a class.
;; Jolt has no ratio or bigdecimal types, so these are constants / reduce to int?.
(defn ratio? [x] false)
(defn decimal? [x] false)
;; No first-class Class objects either: class names are symbols the evaluator
;; handles in instance?/new positions, never values — so nothing is a class.
(defn class? [x] false)
;; list?: a list-marked cseq node or the empty list (). A lazy/vector-backed seq,
;; (rest list), (seq coll), (map …) are seqs but not lists. Not extended like
;; map?/set?/seq?, so it migrates cleanly.
(defn list? [x] (or (and (jolt.host/cseq? x) (jolt.host/cseq-list? x)) (jolt.host/empty-list? x)))
(defn rational? [x] (int? x))
(defn nat-int? [x] (and (int? x) (>= x 0)))
(defn neg-int? [x] (and (int? x) (neg? x)))
(defn pos-int? [x] (and (int? x) (pos? x)))
@ -275,8 +229,7 @@
(loop [i 0 s (seq coll)]
(if (and s (< i n)) (recur (inc i) (next s)) i))))
;; the reducing fn returns proc's result, so a Reduced from proc short-circuits
(defn run! [proc coll] (reduce (fn [_ x] (proc x)) nil coll) nil)
(defn run! [proc coll] (reduce (fn [_ x] (proc x) nil) nil coll) nil)
(defn completing
([f] (completing f identity))
@ -335,40 +288,21 @@
(defn val [e] (if (map-entry? e) (nth e 1) (throw (ex-info "val requires a map entry" {}))))
;; --- Ad-hoc hierarchies (stage 3) — Clojure's canonical pure-map port. -----
;; A hierarchy is {:parents {tag #{parents}} :ancestors {tag #{all}}
;; A hierarchy is {:parents {tag #{parents}} :ancestors {tag #{all}}
;; :descendants {tag #{all}}}. The 3-arity forms are PURE; the 1/2-arity forms
;; operate on the private global hierarchy atom. Multimethod dispatch
;; (evaluator defmulti-setup) calls isa? through the interned var.
;;
;; Ported from clojure.core with the reference's argument assertions and throw
;; contracts intact — bad shapes throw exactly where they do there (a non-map h
;; fails on the (parent-map tag) call, invalid tags fail the asserts). The class
;; arms answer through the host class graph (jolt.host/class-* seams).
(defn make-hierarchy []
{:parents {} :descendants {} :ancestors {}})
(def ^:private global-hierarchy (atom (make-hierarchy)))
(defn- hier-assert [ok form]
(when-not ok (throw (new AssertionError (str "Assert failed: " form)))))
;; a hierarchy tag naming a class — a class value, or the name string of a class
;; the host graph models (jolt classes are their name strings).
(defn- class-tag? [tag] (if (jolt.host/class-value? tag) true false))
(defn isa?
([child parent] (isa? (deref global-hierarchy) child parent))
([h child parent]
(or (= child parent)
;; JVM class assignability (Object root + modeled clojure.lang/java.* ancestry),
;; so a class-keyed multimethod / (isa? (class x) C) dispatches like the JVM.
(jolt.host/class-isa? child parent)
(contains? (get (get h :ancestors) child #{}) parent)
;; a hierarchy relationship established on one of a class's supers
(and (class-tag? child)
(some (fn [s] (contains? (get (get h :ancestors) s #{}) parent))
(jolt.host/class-supers child)))
(and (vector? parent) (vector? child)
(= (count parent) (count child))
(loop [ret true i 0]
@ -378,44 +312,24 @@
(defn parents
([tag] (parents (deref global-hierarchy) tag))
([h tag] (not-empty
(let [tp (get (get h :parents) tag)]
(if (class-tag? tag)
(into (set (jolt.host/class-bases tag)) tp)
tp)))))
([h tag] (not-empty (get (get h :parents) tag))))
(defn ancestors
([tag] (ancestors (deref global-hierarchy) tag))
([h tag] (not-empty
(let [ta (get (get h :ancestors) tag)]
(if (class-tag? tag)
;; the class's own ancestry plus hierarchy relationships derived
;; on the class or any of its supers
(let [superclasses (set (jolt.host/class-supers tag))]
(reduce into superclasses
(cons ta (map (fn [s] (get (get h :ancestors) s))
superclasses))))
ta)))))
([h tag]
;; the user hierarchy plus any modeled JVM ancestry (jolt.host/class-ancestors)
;; so (ancestors (class x)) answers like the JVM for the common interfaces.
(let [hier (get (get h :ancestors) tag)
host (jolt.host/class-ancestors tag)]
(not-empty (if host (into (or hier #{}) host) hier)))))
(defn descendants
([tag] (descendants (deref global-hierarchy) tag))
([h tag] (if (class-tag? tag)
(throw (new UnsupportedOperationException "Can't get descendants of classes"))
(not-empty (get (get h :descendants) tag)))))
([h tag] (not-empty (get (get h :descendants) tag))))
(defn derive
([tag parent]
(hier-assert (namespace parent) "(namespace parent)")
(hier-assert (or (class-tag? tag)
(and (or (keyword? tag) (symbol? tag)) (namespace tag)))
"(or (class? tag) (and (instance? clojure.lang.Named tag) (namespace tag)))")
(swap! global-hierarchy derive tag parent) nil)
([tag parent] (swap! global-hierarchy derive tag parent) nil)
([h tag parent]
(hier-assert (not= tag parent) "(not= tag parent)")
(hier-assert (or (class-tag? tag) (keyword? tag) (symbol? tag))
"(or (class? tag) (instance? clojure.lang.Named tag))")
(hier-assert (or (keyword? parent) (symbol? parent))
"(instance? clojure.lang.Named parent)")
(let [tp (get h :parents)
td (get h :descendants)
ta (get h :ancestors)
@ -423,14 +337,14 @@
(reduce (fn [ret k]
(assoc ret k
(reduce conj (get targets k #{})
(cons target (targets target)))))
m (cons source (sources source))))]
(cons target (get targets target)))))
m (cons source (get sources source))))]
(or
(when-not (contains? (tp tag) parent)
(when (contains? (ta tag) parent)
(throw (new Exception (str tag " already has " parent " as ancestor"))))
(when (contains? (ta parent) tag)
(throw (new Exception (str "Cyclic derivation: " parent " has " tag " as ancestor"))))
(when-not (contains? (get tp tag #{}) parent)
(when (contains? (get ta tag #{}) parent)
(throw (str tag " already has " parent " as ancestor")))
(when (contains? (get ta parent #{}) tag)
(throw (str "Cyclic derivation: " parent " has " tag " as ancestor")))
{:parents (assoc tp tag (conj (get tp tag #{}) parent))
:ancestors (tf ta tag td parent ta)
:descendants (tf td parent ta tag td)})
@ -440,15 +354,15 @@
([tag parent] (swap! global-hierarchy underive tag parent) nil)
([h tag parent]
(let [parent-map (get h :parents)
childs-parents (if (parent-map tag)
(disj (parent-map tag) parent)
childs-parents (if (get parent-map tag)
(disj (get parent-map tag) parent)
#{})
new-parents (if (not-empty childs-parents)
(assoc parent-map tag childs-parents)
(dissoc parent-map tag))
deriv-seq (mapcat (fn [e] (cons (key e) (interpose (key e) (val e))))
(seq new-parents))]
(if (contains? (parent-map tag) parent)
(if (contains? (get parent-map tag #{}) parent)
(reduce (fn [p [t pr]] (derive p t pr))
(make-hierarchy) (partition 2 deriv-seq))
h))))
@ -459,8 +373,7 @@
(defn sequential? [x] (or (vector? x) (seq? x)))
(defn associative? [x] (or (map? x) (vector? x)))
(defn counted? [x]
;; a String is not Counted on the JVM (count works via CharSequence, not O(1))
(or (vector? x) (map? x) (set? x) (list? x)))
(or (vector? x) (map? x) (set? x) (list? x) (string? x)))
(defn indexed? [x] (vector? x))
;; sorted? is defined by the next tier (25-sorted) — declared here so this
;; tier compiles (forward references are analysis errors).
@ -468,7 +381,7 @@
(defn reversible? [x] (or (vector? x) (sorted? x)))
(defn seqable? [x]
(if (or (nil? x) (coll? x) (string? x) (jolt.host/array-value? x)) true false))
(or (nil? x) (coll? x) (string? x)))
(defn boolean? [x] (or (true? x) (false? x)))
(defn double? [x] (and (number? x) (not (integer? x))))
@ -500,9 +413,7 @@
(future? x) (boolean (get x :cached))
(= :jolt/lazy-seq (get x :jolt/type)) (boolean (get x :realized))
(atom? x) true
;; name the class, never the value — an error message must not render an
;; arbitrary (possibly infinite) argument.
:else (throw (str "realized? not supported on: " (class x)))))
:else (throw (str "realized? not supported on: " x))))
(defn force [x] (if (delay? x) (deref x) x))

View file

@ -12,8 +12,7 @@
;; Clojure. Collections only — a string is seqable but not shuffleable, as on
;; the JVM (Collections/shuffle wants a Collection).
(defn shuffle [coll]
;; Collections/shuffle wants a java.util.Collection — a map is not one
(when (or (not (coll? coll)) (map? coll))
(when-not (coll? coll)
(throw (ex-info (str "shuffle requires a collection, got: " coll) {})))
(loop [v (vec coll) i (dec (count v))]
(if (pos? i)
@ -29,10 +28,6 @@
(defn sort-by
([keyfn coll] (sort-by keyfn compare coll))
([keyfn comp coll]
;; a collection is never a Comparator (the JVM cast would fail); catching it
;; here beats silently "sorting" through coll-as-fn lookups
(when (coll? comp)
(throw (new ClassCastException (str (class comp) " cannot be cast to java.util.Comparator"))))
(sort (fn [x y] (comp (keyfn x) (keyfn y))) coll)))
;; parse-uuid: nil unless s is a canonical 8-4-4-4-12 hex UUID string; throws
@ -66,10 +61,9 @@
\backspace "backspace" \space "space"})
(defn char-name-string [c] (get char-name-strings c))
;; Random selection over the host rand primitives — the reference shape:
;; nth directly (nil returns nil via RT.nth; a set throws like the JVM).
;; Random selection over the host rand primitives.
(defn rand-nth [coll]
(nth coll (rand-int (count coll))))
(let [v (vec coll)] (nth v (rand-int (count v)))))
(defn random-sample
([prob] (filter (fn [_] (< (rand) prob))))
@ -139,8 +133,8 @@
(concat (map first ss)
(apply interleave (map rest ss))))))))
;; rationalize is host-native (java/bigdec.ss): a double routes through its
;; shortest decimal print like BigDecimal.valueOf, so (rationalize 1.1) is 11/10.
;; No ratio type on Jolt, so rationalize is identity.
(defn rationalize [x] x)
;; 0-arg: a stateful transducer (tracks [seen? prev] in a volatile, so no sentinel
;; value is needed). 1-arg: eager dedupe of consecutive equal elements.
@ -166,14 +160,11 @@
(coll->cells (step (rest s) prev))
(coll->cells (cons x (step (rest s) x)))))
nil)))))]
;; defer (seq coll) into the lazy-seq so a side-effecting source is not
;; realized at construction (dedupe is lazy, like Clojure's).
(make-lazy-seq
(fn* []
(let [s (seq coll)]
(if s
(coll->cells (cons (first s) (step (rest s) (first s))))
nil)))))))
(let [s (seq coll)]
(if s
(make-lazy-seq
(fn* [] (coll->cells (cons (first s) (step (rest s) (first s))))))
())))))
;; Internal helper for {:keys [...]} destructuring over a seq of k/v pairs —
;; canonical Clojure 1.11 shape (core.clj seq-to-map-for-destructuring):
@ -233,14 +224,13 @@
(defn inst-ms [x]
(if (inst? x) (get x :ms) (throw (str "inst-ms requires an inst, got: " x))))
;; Clojure 1.11 map transformers. An empty-map base keeps insertion order;
;; transformed keys canonicalize via assoc (collisions: last entry in seq order
;; wins, matching the reference).
;; Clojure 1.11 map transformers. PHM base so transformed keys canonicalize
;; (collisions: last entry in seq order wins, matching the reference).
(defn update-keys [m f]
(reduce-kv (fn [acc k v] (assoc acc (f k) v)) {} m))
(reduce-kv (fn [acc k v] (assoc acc (f k) v)) (hash-map) m))
(defn update-vals [m f]
(reduce-kv (fn [acc k v] (assoc acc k (f v))) {} m))
(reduce-kv (fn [acc k v] (assoc acc k (f v))) (hash-map) m))
;; Vector-returning partition variants (1.11): lazy seqs OF vectors.
(defn partitionv
@ -277,10 +267,7 @@
(when (< i (count vars))
(var-set (nth vars i) (nth saved i))
(recur (inc i))))))))
;; A vector's seq IS a real chunked-seq (chunk-first hands out a 32-element block).
;; This is only a placeholder so references compile during overlay load; the host
;; rebinds chunked-seq? to na-chunked-seq? in post-prelude.ss, which returns true
;; for a vector seq and false otherwise.
;; Jolt has no chunked seqs, so this is always false.
(defn chunked-seq? [x] false)
;; Atom peripheral operations. atom/swap!/reset!/deref stay native — the compiler
@ -354,8 +341,8 @@
(defn clojure-version [] "1.11.0-jolt")
;; bigdec is a host fn (host/chez/java/bigdec.ss) — a real BigDecimal value type.
;; numerator/denominator are host natives (converters.ss) over Chez's exact
;; rationals; a non-ratio is the Ratio cast failure.
(defn numerator [x] (throw (ex-info "numerator requires a ratio (Jolt has no ratios)" {})))
(defn denominator [x] (throw (ex-info "denominator requires a ratio (Jolt has no ratios)" {})))
;; jolt has no reflection, but a few common JVM interfaces carry a modeled
;; ancestry (jolt.host/class-supers) so reflective checks like

View file

@ -21,46 +21,23 @@
(defn true? [x] (= true x))
(defn false? [x] (= false x))
;; Presence-preserving and order-preserving: a key with a nil value is kept, and
;; the result follows keyseq order (an empty-map base keeps nil values and
;; canonicalizes collection keys).
;; Presence-preserving: a key with a nil value is kept ((hash-map) base keeps
;; nil values and canonicalizes collection keys).
(defn select-keys [map keyseq]
(reduce (fn [m k] (if (contains? map k) (assoc m k (get map k)) m))
{} keyseq))
(hash-map) keyseq))
(defn zipmap [keys vals]
(loop [m {} ks (seq keys) vs (seq vals)]
(loop [m (hash-map) ks (seq keys) vs (seq vals)]
(if (and ks vs)
(recur (assoc m (first ks) (first vs)) (next ks) (next vs))
m)))
;; Structmaps (legacy). A struct basis is the ordered vector of slot keys; a
;; struct map is a plain map carrying every basis key (nil when unset), in basis
;; order, so it looks up and compares like any other map.
(defn create-struct [& keys] (vec keys))
(defn struct-map [basis & inits]
(let [base (loop [m {} ks (seq basis)]
(if ks (recur (assoc m (first ks) nil) (next ks)) m))]
(loop [m base kvs (seq inits)]
(if kvs
(recur (assoc m (first kvs) (first (next kvs))) (next (next kvs)))
m))))
(defn struct [basis & vals]
(loop [m (struct-map basis) ks (seq basis) vs (seq vals)]
(if (and ks vs)
(recur (assoc m (first ks) (first vs)) (next ks) (next vs))
m)))
(defn accessor [basis key]
(fn [m] (get m key)))
;; conj semantics per entry arg (a map merges, a [k v] pair adds); nil args are
;; no-ops; all-nil (or no args) is nil.
(defn merge [& maps]
(when (some identity maps)
(reduce (fn [acc m] (if (nil? m) acc (conj (or acc {}) m)))
(reduce (fn [acc m] (if (nil? m) acc (conj (or acc (hash-map)) m)))
maps)))
(defn merge-with [f & maps]
@ -72,7 +49,7 @@
(assoc m k (f (get m k) v))
(assoc m k v))))
merge2 (fn [m1 m2]
(reduce merge-entry (or m1 {}) (seq m2)))]
(reduce merge-entry (or m1 (hash-map)) (seq m2)))]
(reduce merge2 maps))))
(defn get-in
@ -89,21 +66,6 @@
(recur nxt (next ks))))
m)))))
(defn req!
"Returns the value mapped to key k in map m, like `get`, but throws
IllegalArgumentException when k is not present. Unlike `get`, does not nil-pun:
a key present with a nil value returns nil, an absent key throws. The primitive
behind checked-keys destructuring (:keys! / :syms! / :strs!)."
{:added "1.13"}
[m k]
;; a fresh map is its own identity, so a present-but-nil value is distinguished
;; from an absent key (same trick as get-in's sentinel).
(let [sentinel (hash-map)
v (get m k sentinel)]
(if (identical? sentinel v)
(throw (new IllegalArgumentException (str "Expected key: " k)))
v)))
;; find-based, so nil RESULTS are cached too; args canonicalize as a collection key.
(defn memoize [f]
(let [mem (atom (hash-map))]
@ -148,12 +110,6 @@
(defn empty [coll]
(cond
(nil? coll) nil
;; a deftype/record with its own empty (IPersistentCollection) — e.g.
;; data.priority-map — uses it, before the generic map/set/vector arms.
(jolt.host/jrec-method? coll "empty") (.empty coll)
;; a defrecord without its own empty can't have one (RT: UnsupportedOperation)
(record? coll) (throw (new UnsupportedOperationException
(str "Can't create empty: " (.getName (class coll)))))
(sorted? coll) ((get (jolt.host/ref-get coll :ops) :empty) coll)
(map? coll) (with-meta {} (meta coll))
(set? coll) (with-meta #{} (meta coll))
@ -201,16 +157,10 @@
([x y z & args] (f (apply g x y z args)))))
([f g & fs] (reduce comp (comp f g) fs)))
;; Canonical IFn set: fns, keywords, symbols, maps (sorted incl.), sets,
;; vectors, vars — NOT lists ((ifn? '(1 2)) is false in Clojure) — plus the
;; host callables (multimethods, promises) and a deftype/record implementing
;; clojure.lang.IFn's invoke.
;; Canonical IFn set: fns, keywords, symbols, maps (sorted incl.),
;; sets, vectors, and vars — NOT lists ((ifn? '(1 2)) is false in Clojure).
(defn ifn? [x]
(if (or (fn? x) (keyword? x) (symbol? x) (map? x) (set? x) (vector? x) (var? x)
(jolt.host/callable-host? x)
(jolt.host/jrec-method? x "invoke"))
true
false))
(or (fn? x) (keyword? x) (symbol? x) (map? x) (set? x) (vector? x) (var? x)))
;; Auto-promoting (') and unchecked arithmetic. Jolt numbers don't overflow,
;; so all of these are the checked ops; fixed arities mirror Clojure's
@ -221,10 +171,22 @@
(def *' *)
(def inc' inc)
(def dec' dec)
;; unchecked-add / -subtract / -multiply / -negate / -inc / -dec (+ the -int
;; variants), -divide-int / -remainder-int, and the unchecked-long/-int casts are
;; host-defined (host/chez/seq.ss, converters.ss): they WRAP like the JVM
;; primitive conversions, which a plain overlay over checked casts can't do.
(defn unchecked-add [x y] (+ x y))
(defn unchecked-subtract [x y] (- x y))
(defn unchecked-multiply [x y] (* x y))
(defn unchecked-negate [x] (- x))
(defn unchecked-inc [x] (+ x 1))
(defn unchecked-dec [x] (- x 1))
(def unchecked-add-int unchecked-add)
(def unchecked-subtract-int unchecked-subtract)
(def unchecked-multiply-int unchecked-multiply)
(def unchecked-negate-int unchecked-negate)
(def unchecked-inc-int unchecked-inc)
(def unchecked-dec-int unchecked-dec)
(defn unchecked-divide-int [x y] (quot x y))
(defn unchecked-remainder-int [x y] (rem x y))
(defn unchecked-int [x] (int x))
(def unchecked-long unchecked-int)
;; int? is integer? on jolt: one number type, so fixed-precision and
;; arbitrary-precision integers coincide.
@ -286,14 +248,12 @@
(defn to-array-2d [coll] (to-array (map to-array coll)))
;; Wrapping (unchecked) coercions: truncate to the width and sign-fold like the
;; JVM primitive conversions ((unchecked-byte 200) is -56); unchecked-char wraps
;; into char range. unchecked-long/int are host natives (converters.ss).
(defn unchecked-byte [x]
(let [b (bit-and (unchecked-long x) 0xff)] (if (< b 128) b (- b 256))))
(defn unchecked-short [x]
(let [s (bit-and (unchecked-long x) 0xffff)] (if (< s 32768) s (- s 65536))))
(defn unchecked-char [x] (char (bit-and (unchecked-long x) 0xffff)))
;; Masking integer coercions (not aliases): byte/short wrap to their width.
;; unchecked-byte/short truncate to a number; unchecked-char returns a char (as on
;; the JVM). int handles chars, so (unchecked-byte \a) works.
(defn unchecked-byte [x] (bit-and (int x) 0xff))
(defn unchecked-short [x] (bit-and (int x) 0xffff))
(defn unchecked-char [x] (char (bit-and (int x) 0xffff)))
(defn unchecked-float [x] (double x))
(defn unchecked-double [x] (double x))
@ -325,14 +285,7 @@
;; --- JVM-shape stubs and trivial shells --------------------------------------
;; Pure compositions or documented jolt stubs; the host keeps nothing.
;; enumeration-seq drives a java.util.Enumeration (StringTokenizer, etc.) through
;; hasMoreElements/nextElement, like the JVM; an already-seqable arg (a jolt seq —
;; some host code passes a list) just seqs.
(defn enumeration-seq [e]
(if (or (nil? e) (seq? e) (sequential? e))
(seq e)
(lazy-seq (when (.hasMoreElements e)
(cons (.nextElement e) (enumeration-seq e))))))
(defn enumeration-seq [e] (seq e))
(defn iterator-seq [i] (seq i))
;; jolt is single-threaded: a promise is an atom, deref never blocks
@ -348,8 +301,7 @@
;; stays an unevaluated reader form on jolt and contains? can't see into it.
(def ^:private special-syms
#{'if 'do 'let* 'fn* 'quote 'var 'def 'loop* 'recur 'throw 'try 'catch
'finally 'new 'set! '. 'monitor-enter 'monitor-exit
'& 'case* 'deftype* 'letfn* 'reify*})
'finally 'new 'set! '. 'monitor-enter 'monitor-exit})
(defn special-symbol? [s] (contains? special-syms s))
@ -364,14 +316,3 @@
(defn proxy-super [& args] (throw "proxy-super: JVM proxies are not supported in Jolt"))
(defn construct-proxy [c & args] (throw "construct-proxy: not supported in Jolt"))
(defn get-proxy-class [& interfaces] (throw "get-proxy-class: not supported in Jolt"))
;; resolve, requiring the symbol's namespace first when it isn't loaded yet —
;; the dynamic-require pattern (tooling, plugin registries). The require and
;; resolve are the runtime fns, so this works identically under joltc run and
;; in an AOT binary (which compiles the namespace from the source roots).
(defn requiring-resolve [sym]
(if (qualified-symbol? sym)
(or (resolve sym)
(do (require (symbol (namespace sym)))
(resolve sym)))
(throw (new IllegalArgumentException (str "Not a qualified symbol: " sym)))))

View file

@ -28,18 +28,11 @@
(let [args (if (string? (first args)) (rest args) args)
args (if (and (map? (first args)) (not (symbol? (first args)))) (rest args) args)
dispatch (first args)
opts (rest args)
;; qualify with the EXPANSION ns: a defmulti deferred inside a fn (a
;; deftest body) must still define in the ns it was written in.
qname (symbol (str (clojure.core/ns-name clojure.core/*ns*))
(clojure.core/name name))]
`(defmulti-setup (quote ~qname) ~dispatch ~@opts)))
opts (rest args)]
`(defmulti-setup (quote ~name) ~dispatch ~@opts)))
(defmacro defmethod [mm dispatch-val & fn-tail]
;; the expansion ns rides along so a deferred defmethod resolves its multifn
;; against the ns it was written in (aliases and refers included).
`(defmethod-setup (quote ~mm) ~dispatch-val (fn ~@fn-tail)
~(str (clojure.core/ns-name clojure.core/*ns*))))
`(defmethod-setup (quote ~mm) ~dispatch-val (fn ~@fn-tail)))
;; Multimethod table ops: a multimethod's method table lives on its
;; VAR (the value is just the dispatch closure), so these pass the name quoted
@ -116,15 +109,11 @@
(with-open ~(vec (drop 2 bindings)) ~@body)
(finally (__close ~(first bindings)))))))
;; Binds *math-context*; BigDecimal arithmetic in the dynamic scope rounds its
;; results to the precision with the rounding mode (default HALF_UP, like
;; java.math.MathContext).
;; jolt numbers are doubles — there is no BigDecimal math context, so the
;; precision (and optional :rounding mode) is accepted and ignored.
(defmacro with-precision [precision & exprs]
(let [[rounding body] (if (= :rounding (first exprs))
[(second exprs) (drop 2 exprs)]
['HALF_UP exprs])]
`(binding [clojure.core/*math-context* {:precision ~precision :rounding '~rounding}]
~@body)))
(let [body (if (= :rounding (first exprs)) (drop 2 exprs) exprs)]
`(do ~@body)))
(defmacro with-bindings [binding-map & body]
`(with-bindings* ~binding-map (fn [] ~@body)))
@ -292,10 +281,6 @@
;; type's fields, bound from the instance (the method's first param), matching
;; Clojure's deftype scope. defrecord (below) expands to a bodyless (deftype …) and
;; handles its own methods, so this also serves the no-body case.
;; Legacy structmap definer: binds a var to the struct basis (see create-struct).
(defmacro defstruct [name & keys]
`(def ~name (create-struct ~@keys)))
(defmacro deftype [tname fields & body]
;; strip ^meta off the type name and fields (the reader yields a (with-meta sym m)
;; form for e.g. (deftype ^{:doc …} Foo …)), so (name …) sees a bare symbol.
@ -392,22 +377,13 @@
;; The clause is DATA, not a syntax-quote: a body that is itself a syntax-
;; quote would have its ~unquotes consumed a level early if re-spliced.
mk-clause (fn [spec]
;; fresh-name each _ param so two _ params don't collide on the
;; field binds / live-read instance (see defrecord's mk-clause).
(let [argv (mapv (fn [p] (if (= p (quote _)) (gensym "_p") p)) (nth spec 1))
(let [argv (nth spec 1)
inst (first argv)
;; A method param shadows a same-named field (Clojure
;; semantics): don't let-bind a field the param already
;; provides, and treat those params as shadowing so a
;; mutable field's live-read rewrite doesn't override them.
pnames (set (map name argv))
;; let-bind only immutable fields; mutable ones are read live
;; via rewrite-body so a set! within the method is observed.
binds (vec (mapcat (fn [f] [f `(get ~inst ~(keyword (name f)))])
(filter (fn [f] (and (not (mutable? f))
(not (contains? pnames (name f)))))
fields)))
mbody (map (fn [bf] (rewrite-body inst (set argv) bf)) (drop 2 spec))]
(filter (fn [f] (not (mutable? f))) fields)))
mbody (map (fn [bf] (rewrite-body inst #{} bf)) (drop 2 spec))]
(list argv (list* 'let binds mbody))))
groups (group-by-head body)
;; merge clauses by method NAME across ALL protocols into one multi-arity
@ -576,14 +552,8 @@
(parse-extend-impls type-impls))))
;; extend is a real FUNCTION — defined above extend-type.
;; JVM proxies are unsupported in general, EXCEPT (proxy [ThreadLocal] [] (initialValue
;; [] body)) — a per-thread store with a lazy initial value (test.check's no-seed
;; PRNG uses one). Other proxies stay nil.
(defmacro proxy [supers ctor-args & methods]
(when (and (vector? supers) (= 1 (count supers))
(let [s (name (first supers))] (or (= s "ThreadLocal") (= s "InheritableThreadLocal"))))
(let [init (some (fn [m] (when (= "initialValue" (name (first m))) m)) methods)]
`(jolt.host/make-thread-local (fn [] ~@(when init (nnext init)))))))
;; JVM proxies are unsupported.
(defmacro proxy [& args] nil)
;; definterface is JVM-only; bind the name to a marker and return the name (not a
;; var), matching the JVM where definterface yields the interface Class.
(defmacro definterface [name-sym & body]
@ -627,18 +597,10 @@
;; one clause from a spec; `this` is hinted with the record type so the
;; inference reads its fields bare-index. Clause as DATA (see deftype).
mk-clause (fn [spec]
;; rename each _ parameter to a fresh symbol so two _ params
;; (the common (m [_ _] …) on a 1-arg protocol method) don't
;; collide — the field binds read (get this :field) off the
;; FIRST param, which an ignored second _ would otherwise shadow.
(let [argv (mapv (fn [p] (if (= p (quote _)) (gensym "_p") p)) (nth spec 1))
(let [argv (nth spec 1)
inst (first argv)
hinted (assoc argv 0 (vary-meta inst assoc :tag (name name-sym)))
;; a method param shadows a same-named field (Clojure
;; semantics), so don't rebind a field the param provides.
pnames (set (map name argv))
binds (vec (mapcat (fn [f] [f `(get ~inst ~(keyword (name f)))])
(remove (fn [f] (contains? pnames (name f))) fields)))]
binds (vec (mapcat (fn [f] [f `(get ~inst ~(keyword (name f)))]) fields))]
(list hinted (list* 'let binds (drop 2 spec)))))
groups (group-by-head body)
;; merge clauses by name across protocols into one multi-arity fn (see
@ -651,8 +613,6 @@
;; deftype already defines ->name (= the ctor); no (name. …) interop needed,
;; so defrecord compiles too. map->name builds via that ctor.
(deftype ~name-sym ~fields)
;; mark the type a record (map?/record?/field-seq); a bare deftype is not.
(register-record-type! (quote ~name-sym))
;; build via the positional ctor for declared fields, then carry any
;; remaining keys as extension fields (JVM keeps them on the record).
(def ~mapf (fn* [~m]

View file

@ -96,12 +96,8 @@
([n x] (take n (repeat x))))
;; --- iterate ---
;; f is applied lazily, inside the tail thunk — (first (iterate f x)) is x with no
;; call to f, matching clojure.lang.Iterate. Wrapping the whole body in lazy-seq
;; instead would force (f x) the moment the head realizes (it is an eager argument
;; to cons), realizing one step ahead.
(defn iterate [f x]
(cons x (lazy-seq (iterate f (f x)))))
(lazy-seq (cons x (iterate f (f x)))))
;; --- partition-all --- (transducer + [n coll] + [n step coll])

View file

@ -150,7 +150,7 @@
;; documented jolt divergence).
(defmulti print-method (fn [x writer]
(let [t (get (meta x) :type)]
(if (keyword? t) t (__type-tag x)))))
(if (keyword? t) t (type x)))))
(defmethod print-method :default [o w]
(.write w (__pr-str1 o))
@ -160,7 +160,7 @@
;; (as Clojure's default does for most types).
(defmulti print-dup (fn [x writer]
(let [t (get (meta x) :type)]
(if (keyword? t) t (__type-tag x)))))
(if (keyword? t) t (type x)))))
(defmethod print-dup :default [o w] (print-method o w))

View file

@ -25,11 +25,9 @@
form-inst? form-inst-source form-uuid? form-uuid-source
form-bigdec? form-bigdec-source
form-ns-value? form-ns-value-name
form-var-value? form-var-value-ns form-var-value-name
unchecked-math?
form-macro? form-expand-1 resolve-global
form-sym-meta form-coll-meta host-intern! form-syntax-quote-lower
record-type? record-ctor-key deftype-ctor-class form-position late-bind?
record-type? record-ctor-key form-position late-bind?
resolve-class-hint]]))
(declare analyze)
@ -40,7 +38,7 @@
;; analyzed in analyze-list), so keep them in sync by intent, not by equality.
(def ^:private handled
#{"quote" "if" "do" "def" "fn*" "let*" "loop*" "recur" "throw" "try"
"syntax-quote" "var" "letfn*" "set!" "defmacro"})
"syntax-quote" "var" "letfn" "set!" "defmacro"})
(defn- uncompilable [why]
(throw (str "jolt/uncompilable: " why)))
@ -54,11 +52,6 @@
(defn- empty-env [] {:locals #{} :hints {}})
(defn- local? [env nm] (contains? (:locals env) nm))
(defn- add-locals [env names] (update env :locals #(reduce conj % names)))
;; &env value handed to a macro: a map of each in-scope local SYMBOL to nil
;; (Clojure's &env maps locals to compiler binding objects; consumers like
;; core.logic's matche only read its keys to tell locals from fresh pattern vars).
(defn- amp-env-map [env]
(reduce (fn [m n] (assoc m (symbol n) nil)) {} (:locals env)))
(defn- with-recur [env name] (assoc env :recur name))
;; Type hints. The reader keeps ^hint metadata on the binding symbol.
@ -258,7 +251,6 @@
(let [n {:op :try :body (analyze-seq ctx @body env)}
n (if (seq @catches)
(let [evar-name (gen-name "catch")
raw-name (gen-name "catch-raw")
evar (symbol evar-name)
dispatch
(reduce
@ -279,7 +271,6 @@
(list 'throw evar)
(reverse @catches))]
(assoc n :catch-sym evar-name
:catch-raw-sym raw-name
:catch-body (analyze-seq ctx (list dispatch)
(add-locals env [evar-name]))))
n)
@ -288,21 +279,26 @@
n)]
n)))
;; letfn*: (letfn* [name1 fn1 name2 fn2 …] body*) — the special form Clojure's
;; letfn macro expands to (flat name/fn-form pairs, the fn forms already named).
;; The named local fns are MUTUALLY recursive, so bind every name into the env
;; BEFORE analyzing any fn form — each then resolves its siblings (and itself) as
;; locals. Emitted as a :let flagged :letrec so the back end lowers it to
;; `letrec*`; the interpreter's shared mutable env gives the same semantics.
(defn- analyze-letfn* [ctx items env]
(let [bvec (vec (form-vec-items (nth items 1)))
n (quot (count bvec) 2)
names (mapv (fn [i] (form-sym-name (nth bvec (* 2 i)))) (range n))
env* (add-locals env names)
binds (mapv (fn [i]
[(nth names i)
(analyze ctx (nth bvec (inc (* 2 i))) env*)])
(range n))]
;; letfn: (letfn [(name [params] body*)...] body*). The named local fns are
;; MUTUALLY recursive, so bind every name into the env BEFORE analyzing any spec
;; — each spec then resolves its siblings (and itself) as locals. Emitted as a
;; :let flagged :letrec so the back end knows the bindings forward-reference each
;; other: Chez lowers it to `letrec*`. The interpreter's shared mutable env already
;; gives the letrec semantics that a
;; compiled sequential let* lacks — the reason letfn was uncompilable before.
(defn- analyze-letfn [ctx items env]
(let [specs (vec (form-vec-items (nth items 1)))
names (mapv #(form-sym-name (first (vec (form-elements %)))) specs)
env* (add-locals env names)
binds (mapv (fn [spec]
(let [cl (vec (form-elements spec))]
;; Build (fn name [params] body*) and analyze through the fn
;; MACRO so destructuring params desugar (the fn* primitive
;; would not — same trick defmacro uses). The named fn means
;; self- and sibling-calls resolve and it carries its own name.
[(form-sym-name (first cl))
(analyze ctx (cons (symbol "fn") cl) env*)]))
specs)]
{:op :let :letrec true :bindings binds
:body (analyze-seq ctx (drop 2 items) env*)}))
@ -394,18 +390,7 @@
(defn- analyze-special [ctx op items env]
(case op
;; A quoted collection keeps its USER metadata (rewrite-clj coerces
;; '^:x (4 5 6) and expects the meta back), but not the reader's location keys
;; (:line/:column/:file) — like Clojure, which strips those from a quoted
;; constant. The kept metadata is itself part of the literal, so quote it.
"quote" (let [qf (second items)
m (form-coll-meta qf)
m (when (map? m)
(let [u (dissoc m :line :column :end-line :end-column :file)]
(when (seq u) u)))]
(if (nil? m)
(quote-node qf)
(invoke (var-ref "clojure.core" "with-meta") [(quote-node qf) (quote-node m)])))
"quote" (quote-node (second items))
"if" (do
;; 2 or 3 argument forms only (spec 03-special-forms X1)
(when (or (< (count items) 3) (> (count items) 4))
@ -432,7 +417,7 @@
{:op :recur :recur-name rt
:args (mapv #(analyze ctx % env) (rest items))})
"try" (analyze-try ctx items env)
"letfn*" (analyze-letfn* ctx items env)
"letfn" (analyze-letfn ctx items env)
"fn*" (analyze-fn ctx items env)
;; Lower the backtick to construction code (zero runtime cost), then analyze
;; it — the macroexpand/compile-time step, per read -> macroexpand -> compile.
@ -493,12 +478,7 @@
;; token and the analyzed args. The Chez back end lowers it to a runtime
;; constructor dispatch.
(defn- analyze-ctor [ctx class args env]
;; Qualify a bare (Name. …) to its deftype's FQN when THIS ns defined the deftype,
;; so a deftype named like a built-in host class (tools.reader's PushbackReader)
;; resolves to the deftype here while an unrelated ns's bare (PushbackReader. …)
;; still reaches java.io.PushbackReader.
(host-new (or (deftype-ctor-class ctx class) class)
(mapv #(analyze ctx % env) args)))
(host-new class (mapv #(analyze ctx % env) args)))
;; jolt.ffi/__cfn: the low-level foreign-function form a jolt library
;; uses (via the jolt.ffi/foreign-fn macro) to bind native code. Shape:
@ -548,14 +528,7 @@
(defn- analyze-dot [ctx items env]
(when (< (count items) 3)
(throw (str "Malformed (. target member ...) form")))
(let [member0 (nth items 2)
;; (. target (member arg*)) is sugar for (. target member arg*) —
;; flatten the list-member form so the rest of the dispatch is uniform.
items (if (form-list? member0)
(let [ml (vec (form-elements member0))]
(into [(nth items 0) (nth items 1) (first ml)] (rest ml)))
items)
target (nth items 1)
(let [target (nth items 1)
member (nth items 2)
;; (. Class method args*) with a class target is a static call —
;; equivalent to (Class/method args*). resolve-global tags a class
@ -625,58 +598,25 @@
(var-ref (compile-ns ctx) nm)
(uncompilable (str "Unable to resolve symbol: " nm " in this context"))))))))
;; The wrapping unchecked-* name a core arithmetic op rewrites to under
;; *unchecked-math*, or nil. n is the full item count (head + args); unary - is a
;; negate.
(defn- unchecked-arith [hname n]
(cond
(= hname "+") "unchecked-add"
(= hname "*") "unchecked-multiply"
(= hname "-") (if (= n 2) "unchecked-negate" "unchecked-subtract")
(= hname "inc") "unchecked-inc"
(= hname "dec") "unchecked-dec"
:else nil))
(defn- analyze-list [ctx form env]
(let [items (vec (form-elements form))]
(if (zero? (count items))
(quote-node form)
(let [head (first items)
hname (when (and (form-sym? head) (nil? (form-sym-ns head))) (form-sym-name head))
;; a special-form head may arrive clojure.core-qualified: syntax-quote
;; namespace-qualifies a macro like `letfn` to `clojure.core/letfn`
;; (matching Clojure, where it is a macro), so a macro-emitted
;; (clojure.core/letfn …) must still dispatch to the special form.
sf-name (or hname
(when (and (form-sym? head)
(= "clojure.core" (form-sym-ns head))
(contains? handled (form-sym-name head)))
(form-sym-name head)))
shadowed (and hname (local? env hname))
;; under *unchecked-math*, a core +/-/*/inc/dec becomes its wrapping
;; unchecked-* (computed once; nil when off or not such an op). The op
;; may arrive bare (+) or clojure.core-qualified (clojure.core/*), the
;; latter from a macro's syntax-quote — both must wrap.
unm (when (unchecked-math?)
(let [opn (cond (and hname (not shadowed)) hname
(and (form-sym? head) (= "clojure.core" (form-sym-ns head)))
(form-sym-name head))]
(when opn (unchecked-arith opn (count items)))))]
shadowed (and hname (local? env hname))]
(cond
;; *unchecked-math* rewrite, before macro/special dispatch (these are
;; ordinary core fns). The unchecked-* form re-analyzes normally.
unm (analyze ctx (cons (symbol unm) (rest items)) env)
;; Canonical order (Clojure/CLJS analyze-seq): macroexpand FIRST, then
;; dispatch special forms / interop / invoke. A local shadows the macro.
;; A true special form is NOT shadowable by a same-named macro, matching
;; the reference macroexpand1's isSpecial check — so a ns that redefs a
;; macro `def`/`and`/`or` (clojure.spec.alpha) keeps the special form `def`.
(and (form-sym? head) (not shadowed)
(not (contains? handled sf-name)) (form-macro? ctx head))
(not (contains? handled hname)) (form-macro? ctx head))
;; defn/defn- expand to (def name (fn …)); carry the ORIGINAL form's
;; source offset onto the resulting def, since the macro builds a fresh
;; (def …) with no metadata. So the back end can register fn defs.
(let [node (analyze ctx (form-expand-1 ctx form (amp-env-map env)) env)
(let [node (analyze ctx (form-expand-1 ctx form) env)
p (form-position form)]
(if (and p (= :def (:op node))) (assoc node :pos p) node))
;; jolt.ffi/__cfn — the foreign-function special form (always emitted
@ -692,10 +632,10 @@
;; special-form heads are NOT shadowable (unlike macros): a local named
;; `if` does not change the meaning of (if …) in operator position, per
;; spec §3 and the reference. No (not shadowed) guard here.
(and sf-name (contains? handled sf-name))
(and hname (contains? handled hname))
;; stamp the form's source offset onto a top-level def so the back end
;; can register it (jv$ns$name -> source) for native stack traces.
(let [node (analyze-special ctx sf-name items env)
(let [node (analyze-special ctx hname items env)
p (form-position form)]
(if (and p (= :def (:op node))) (assoc node :pos p) node))
(and hname (not shadowed) (method-head? hname))
@ -763,8 +703,4 @@
;; a live namespace value spliced into a form (~*ns* in a macro) -> a
;; :the-ns leaf the back end reconstructs by name at the call site.
(form-ns-value? form) {:op :the-ns :name (form-ns-value-name form)}
;; a live Var value spliced into a form (a macro that resolves a var and
;; splices it, e.g. core.contracts' defcurry-from) -> a :the-var reference,
;; same as (var ns/name); the back end emits (jolt-var ns name).
(form-var-value? form) (the-var (form-var-value-ns form) (form-var-value-name form))
:else (uncompilable "unsupported form"))))

View file

@ -12,23 +12,18 @@
form-list? form-vec? form-map? form-set? form-char?
form-literal? form-elements form-vec-items
form-map-pairs form-set-items form-char-code
form-regex? form-regex-source
form-inst? form-inst-source form-uuid? form-uuid-source]]))
form-regex? form-regex-source]]))
;; Hot clojure.core primitives lowered to native Scheme.
;; `=` is the exactness-aware jolt= from values.ss; inc/dec/
;; not are rt shims. Arithmetic and comparisons lower to the jolt-n* checked
;; macros (host/chez/seq.ss): the both-Chez-numbers fast path is open-coded and
;; anything else (BigDecimal, a non-number) takes the Numbers.ops-style category
;; dispatch, with JVM contagion (a double operand wins; an exact zero divisor is
;; ArithmeticException; a double zero divisor is ##Inf/##NaN).
;; not are rt shims; mod/rem/quot map to Scheme's (Scheme has all three).
(def ^:private native-ops
{"+" "jolt-n+" "-" "jolt-n-" "*" "jolt-n*" "/" "jolt-n-div"
"<" "jolt-n<" ">" "jolt-n>" "<=" "jolt-n<=" ">=" "jolt-n>="
{"+" "+" "-" "-" "*" "*" "/" "/"
"<" "<" ">" ">" "<=" "<=" ">=" ">="
"=" "jolt=" "inc" "jolt-inc" "dec" "jolt-dec" "not" "jolt-not"
"min" "jolt-n-min" "max" "jolt-n-max"
"mod" "jolt-mod" "rem" "jolt-rem" "quot" "jolt-quot"
"vector" "jolt-vector" "hash-map" "jolt-hash-map-fn" "hash-set" "jolt-hash-set"
"min" "min" "max" "max"
"mod" "modulo" "rem" "remainder" "quot" "quotient"
"vector" "jolt-vector" "hash-map" "jolt-hash-map" "hash-set" "jolt-hash-set"
"conj" "jolt-conj" "get" "jolt-get" "nth" "jolt-nth" "count" "jolt-count"
"assoc" "jolt-assoc" "dissoc" "jolt-dissoc" "contains?" "jolt-contains?"
"empty?" "jolt-empty?" "peek" "jolt-peek" "pop" "jolt-pop"
@ -41,28 +36,18 @@
"even?" "jolt-even?" "odd?" "jolt-odd?" "pos?" "jolt-pos?" "neg?" "jolt-neg?"
"zero?" "jolt-zero?" "identity" "jolt-identity" "nil?" "jolt-nil?" "some?" "jolt-some?"
"ex-info" "jolt-ex-info"
;; bit ops: and/or/xor/not are Chez bitwise primitives (inlined to native code,
;; no helper call); operands must be integers (a non-integer errors, like the
;; JVM). The shifts keep their helpers (Java >>> masking / arithmetic shift) but
;; emit a direct call instead of var-deref + the variadic overlay.
;; and/or/xor/not map to variadic Chez bitwise prims (safe as a value at any
;; arity). bit-and-not is left to its overlay: its only Scheme impl is 2-arg, so
;; a value-position arity-3 use (via the variadic overlay) would mis-emit.
"bit-and" "bitwise-and" "bit-or" "bitwise-ior" "bit-xor" "bitwise-xor" "bit-not" "bitwise-not"
"bit-shift-left" "jolt-bit-shift-left" "bit-shift-right" "jolt-bit-shift-right"
"unsigned-bit-shift-right" "jolt-unsigned-bit-shift-right"
;; positional protocol-method dispatch (defprotocol-emitted shims) — bind
;; directly to the records.ss entry points so a protocol call doesn't var-deref.
"protocol-dispatch1" "protocol-dispatch1" "protocol-dispatch2" "protocol-dispatch2"
"protocol-dispatch3" "protocol-dispatch3"})
;; Value-position resolution for a clojure.core ref passed AS A VALUE (to map /
;; filter / reduce / apply). The jolt-n* call-position forms are macros, so value
;; position substitutes the variadic procedures over the same binary dispatch.
;; filter / reduce / apply). Arithmetic is the exception — Scheme's +/-/*// return
;; EXACT results for exact/zero-arg inputs, breaking the all-double model in
;; higher-order use, so value-position arithmetic routes to the flonum wrappers.
(def ^:private core-value-procs
(merge native-ops {"+" "jolt-add" "-" "jolt-sub" "*" "jolt-mul" "/" "jolt-div"
"min" "jolt-min" "max" "jolt-max"
"<" "jolt-lt" ">" "jolt-gt" "<=" "jolt-le" ">=" "jolt-ge"}))
"min" "jolt-min" "max" "jolt-max"}))
;; Per-op arity gate: only lower when the Scheme prim and the jolt fn agree at
;; this arity. Ops absent from the table are variadic (legal at any arity).
@ -80,14 +65,11 @@
"cons" #(= % 2) "filter" #(= % 2) "remove" #(= % 2) "into" #(= % 2)
"take" #(= % 2) "drop" #(= % 2) "map" #(>= % 2) "apply" #(>= % 2)
"reduce" #(or (= % 2) (= % 3)) "range" #(and (>= % 0) (<= % 3))
"ex-info" #(or (= % 2) (= % 3))
"bit-and" #(= % 2) "bit-or" #(= % 2) "bit-xor" #(= % 2) "bit-not" #(= % 1)
"bit-shift-left" #(= % 2) "bit-shift-right" #(= % 2)
"unsigned-bit-shift-right" #(= % 2)})
"ex-info" #(or (= % 2) (= % 3))})
;; jolt's comparison ops are vacuously true at arity 1 and DON'T inspect the arg,
;; but Scheme's < demands a number even there — special-case.
(def ^:private cmp1-ops #{"jolt-n<" "jolt-n>" "jolt-n<=" "jolt-n>="})
(def ^:private cmp1-ops #{"<" ">" "<=" ">="})
;; Host interop methods with a Chez RT shim (rt.ss jolt-host-call). A `.method`
;; call on any other method routes to record-method-dispatch (a reify/record
@ -97,7 +79,7 @@
;; Native-op Scheme procedures that return a genuine Scheme boolean (#t/#f), so an
;; :if test built from them needs no jolt-truthy? wrapper.
(def ^:private bool-returning-ops
#{"jolt-n<" "jolt-n<=" "jolt-n>" "jolt-n>=" "jolt=" "jolt-not"
#{"<" "<=" ">" ">=" "jolt=" "jolt-not"
"jolt-even?" "jolt-odd?" "jolt-pos?" "jolt-neg?"
"jolt-zero?" "jolt-empty?" "jolt-contains?" "jolt-nil?" "jolt-some?"})
@ -112,18 +94,11 @@
(def ^:private dbl-ops
{"+" "fl+" "-" "fl-" "*" "fl*" "/" "fl/" "min" "flmin" "max" "flmax"
"<" "fl<?" ">" "fl>?" "<=" "fl<=?" ">=" "fl>=?" "=" "fl=?" "==" "fl=?"})
;; A ^long is 64-bit; a Chez fixnum is only 61-bit. Arithmetic +/-/* keep the raw
;; fx ops (the fast-arith path; under *unchecked-math* they're already rewritten to
;; the wrapping unchecked-*). The comparisons / min/max / quot/rem/mod use the
;; jolt-l* fast-path-with-fallback macros (host/chez/seq.ss) so a full 64-bit
;; operand falls back to the generic op instead of raising.
(def ^:private lng-ops
{"+" "fx+" "-" "fx-" "*" "fx*" "min" "jolt-l-min" "max" "jolt-l-max"
;; unchecked-* WRAP to signed 64 bits (Java long), so they can't use the raising
;; fx ops — the backend emits the wrapping jolt-unc* helpers (host/chez/seq.ss).
"unchecked-add" "jolt-uncadd2" "unchecked-subtract" "jolt-uncsub2" "unchecked-multiply" "jolt-uncmul2"
"quot" "jolt-l-quot" "rem" "jolt-l-rem" "mod" "jolt-l-mod"
"<" "jolt-l<" ">" "jolt-l>" "<=" "jolt-l<=" ">=" "jolt-l>=" "=" "jolt-l=" "==" "jolt-l="})
{"+" "fx+" "-" "fx-" "*" "fx*" "min" "fxmin" "max" "fxmax"
"unchecked-add" "fx+" "unchecked-subtract" "fx-" "unchecked-multiply" "fx*"
"quot" "fxquotient" "rem" "fxremainder" "mod" "fxmodulo"
"<" "fx<?" ">" "fx>?" "<=" "fx<=?" ">=" "fx>=?" "=" "fx=?" "==" "fx=?"})
;; BigDecimal ops. jolt.passes.numeric tags an arithmetic/comparison invoke
;; :num-kind :bigdec when every operand is a bigdec (or an integer literal); these
@ -164,22 +139,6 @@
(def direct-link-fns (atom #{}))
(defn direct-link-reset! [] (reset! direct-link-defined #{}) (reset! direct-link-fns #{}))
;; Cache a resolved var cell in a per-site cell so a non-direct-linked var
;; reference skips the name lookup (string-append + hash) after the first use.
;; OFF during the seed mint (the seed must stay a byte-fixpoint, and caching the
;; compiler's own refs shifts the gensym-numbered cell names every pass); the
;; runtime eval path turns it on for user code, where it's the big win.
(def var-cache? (atom false))
(defn set-var-cache! [on] (reset! var-cache? on))
;; Opt-in tail-frame history (JOLT_TRACE): emit a (jolt-trace-push! "name") at the
;; head of every named fn body, so an entry records the frame into the runtime ring
;; buffer (rt.ss) and a TCO-elided frame still shows in an error's backtrace. OFF
;; during the seed mint and `jolt build` (byte-determinism + no runtime cost);
;; compile-eval.ss turns it on for runtime-eval'd user code when JOLT_TRACE is set.
(def trace-frames? (atom false))
(defn set-trace-frames! [on] (reset! trace-frames? on))
;; A direct-link Scheme binding name for a var. The fqn maps to a unique identifier
;; jv$<ns>$<name>; chars that break a Scheme identifier or the `$` separator are
;; escaped so distinct vars never collide.
@ -199,41 +158,10 @@
;; recursion auto-restores them (no manual save/restore, no throw-leak).
(def ^:dynamic *recur-target* nil)
(def ^:dynamic *known-procs* #{})
;; True while emitting a node in TAIL position. Only used, in trace mode, to mark a
;; tail call so the runtime routes its callee into the current history rib instead
;; of a new one (rt.ss). It never affects semantics — a wrong value only mislabels
;; a debug trace line — so partial propagation is safe. `emit` (the wrapper below)
;; clears it by default; the tail-transparent forms (fn body, if/do/let/loop) pass
;; it to their tail child. Default false so a top-level form is treated non-tail.
(def ^:dynamic *tail?* false)
(def ^:private gensym-counter (atom 0))
(defn- fresh-label [prefix] (str prefix (swap! gensym-counter inc)))
;; Per-site cache cells collected while emitting one top-level def. A site that
;; resolves a STABLE value — a devirtualized impl (constant tag/proto/method) or a
;; var cell (interned, so the cell never changes even when the var is redefined) —
;; resolves it once, not per call, the inline cache the JVM gets for free. When a
;; def init is being emitted this holds an atom; each site appends a fresh cell name
;; (bound to #f in a let wrapping the def, so it persists across calls and is shared
;; by every invocation) and resolves into it on first use. nil outside a def (a site
;; there falls back to a per-call resolve).
(def ^:private cache-cells (atom nil))
;; Emit a def's init (via the supplied thunk) under a fresh cache-cell collector,
;; then wrap the result in a let binding any cells its body registered so they
;; persist in the def's closure. Saves/restores the outer collector for nested
;; defs. Used by both the runtime def emit and the direct-link top-level emit.
(defn- emit-with-cells [emit-thunk]
(let [cells (atom [])
prev @cache-cells
_ (reset! cache-cells cells)
raw (emit-thunk)
_ (reset! cache-cells prev)]
(if (seq @cells)
(str "(let (" (str/join " " (map (fn [c] (str "(" c " #f)")) @cells)) ") " raw ")")
raw)))
;; Scheme syntactic keywords. A jolt local with one of these names would, when
;; emitted verbatim, shadow the Scheme form in operator position (a local named
;; `if` would turn the special form (if …) the back end emits into a call), so
@ -244,19 +172,10 @@
"unquote" "set!" "define" "define-syntax" "cond" "case" "when" "unless"
"and" "or" "do" "else" "guard" "parameterize" "delay" "values"})
;; clojure.core ops emitted as a BARE Scheme name (where native-ops maps the op
;; to itself: + - * / < > min max …). A local binding with one of these names
;; would otherwise shadow the emitted prim — e.g. (fn [max] (clojure.core/max …))
;; emits (max …) calling the param — so such locals are prefixed, like reserved
;; words. Derived from native-ops so the two never drift.
(def ^:private bare-native-names
(set (keep (fn [[k v]] (when (= k v) k)) native-ops)))
;; Most jolt names are already valid Scheme identifiers. The one that isn't is
;; `#`, which jolt auto-gensyms use as a suffix (p1__0000X4# from #(...)) — `#`
;; starts a datum in Scheme, so replace it with `_`. A name that collides with a
;; Scheme keyword OR a bare-emitted native op is prefixed with `_` so it can never
;; shadow the emitted form.
;; Scheme keyword is prefixed with `_` so it can never shadow the emitted form.
(defn- munge-name [s]
;; A Clojure symbol may contain chars that break a Scheme identifier: ' is the
;; quote reader macro (a bare f' would read as f then 'rest), # already maps to
@ -265,20 +184,9 @@
(let [s (-> s
(str/replace "#" "_")
(str/replace "'" "_PRIME_"))]
(if (or (contains? scheme-reserved s) (contains? bare-native-names s)) (str "_" s) s)))
(if (contains? scheme-reserved s) (str "_" s) s)))
(declare emit)
(declare emit*)
;; Ops that pass tail position through to a child (the child can itself be a tail
;; call): if/do carry it to their tail branch/last form, let/loop to their body,
;; and invoke reads it to decide whether the call is tail. Every other op's
;; children are non-tail, so `emit` clears *tail?* before dispatching them — that
;; way a stray true can't leak into, say, a call sitting in a vector literal.
(def ^:private tail-transparent-ops #{:if :do :let :loop :invoke})
(defn emit [node]
(if (and *tail?* (not (tail-transparent-ops (:op node))))
(binding [*tail?* false] (emit* node))
(emit* node)))
;; A Chez string literal. Every char outside printable ASCII becomes a
;; codepoint hex escape \x<cp>; ; the named escapes (\n \t \r \" \\) match what
@ -402,19 +310,6 @@
(form-map? form) (emit-quoted-map (form-map-pairs form))
;; a quoted #"…" regex value -> reconstruct it (same as the :regex IR leaf).
(form-regex? form) (str "(jolt-regex " (chez-str-lit (form-regex-source form)) ")")
;; quoted #inst / #uuid literals construct their value, like the JVM reader
;; (which builds the Date/UUID at read time, so a quoted/macro form carries the
;; value, not the raw tagged form). Same emit as the :inst / :uuid IR leaves.
(form-inst? form) (str "(jolt-inst-from-string " (chez-str-lit (form-inst-source form)) ")")
(form-uuid? form) (str "(jolt-uuid-from-string " (chez-str-lit (form-uuid-source form)) ")")
;; a quoted custom #tag with no registered reader -> a tagged-literal value
;; (Clojure's reader builds a TaggedLiteral), not the raw reader map. The tag is
;; stored as a :#name keyword; strip the leading # to the bare symbol.
(and (map? form) (= :jolt/tagged (get form :jolt/type)))
(let [nm (name (get form :tag))
tsym (if (= \# (first nm)) (subs nm 1) nm)]
(str "(jolt-tagged-literal (jolt-symbol #f " (chez-str-lit tsym) ") "
(emit-quoted (get form :form)) ")"))
;; plain jolt VALUES (metadata maps and anything nested in them)
(map? form) (emit-quoted-map-value form)
(vector? form) (str "(jolt-vector " (str/join " " (map emit-quoted form)) ")")
@ -439,10 +334,9 @@
;; letfn lowers to a :let flagged :letrec (mutually-recursive named local fns):
;; Scheme `letrec*` binds them so each sees its siblings. A plain let uses let*.
(defn- emit-let [node]
(let [kw (if (:letrec node) "letrec*" "let*")
;; bindings are non-tail; the body inherits the let's tail position
binds (binding [*tail?* false] (str/join " " (mapv emit-binding (:bindings node))))]
(str "(" kw " (" binds ") " (emit (:body node)) ")")))
(let [kw (if (:letrec node) "letrec*" "let*")]
(str "(" kw " (" (str/join " " (map emit-binding (:bindings node))) ") "
(emit (:body node)) ")")))
(defn- emit-loop [node]
(let [label (fresh-label "loop")
@ -450,10 +344,9 @@
names (map #(munge-name (nth % 0)) pairs)
;; inits evaluate in the OUTER scope (recur-target unchanged) and, like
;; Clojure loop/let, SEQUENTIALLY — wrap a let* around the named let.
inits (binding [*tail?* false] (mapv #(emit (nth % 1)) pairs))
inits (map #(emit (nth % 1)) pairs)
seq-bs (str/join " " (map (fn [n i] (str "(" n " " i ")")) names inits))
rebinds (str/join " " (map (fn [n] (str "(" n " " n ")")) names))
;; the loop body inherits the loop's tail position
body (binding [*recur-target* label] (emit (:body node)))]
(str "(let* (" seq-bs ") (let " label " (" rebinds ") " body "))")))
@ -514,11 +407,7 @@
params (map munge-name orig)
restp (when-let [r (:rest a)] (munge-name r))
label (fresh-label "fnrec")
ret (:ret-nhint a)
;; the body is the fn's tail position — UNLESS a ^double/^long return hint
;; wraps it in a coercion below, which puts the body back in non-tail.
body-tail? (not (or (= ret :double) (= ret :long)))
body (binding [*recur-target* label *tail?* body-tail?] (emit (:body a)))
body (binding [*recur-target* label] (emit (:body a)))
paramlist (cond
(and restp (empty? params)) restp
restp (str "(" (str/join " " params) " . " restp ")")
@ -543,16 +432,6 @@
self (when-let [nm (:name node)] (munge-name nm))
clauses (binding [*known-procs* (if self (conj *known-procs* self) *known-procs*)]
(mapv emit-arity-clause arities))
;; trace mode: record this frame on entry (before the body), so a frame
;; the body then tail-calls away is still in the ring at throw time. A
;; `recur` re-enters via the named-let, not the lambda, so a tight loop
;; records once, not per iteration.
clauses (if (and @trace-frames? self)
(mapv (fn [c] [(nth c 0)
(str "(begin (jolt-trace-push! " (chez-str-lit self) ") "
(nth c 1) ")")])
clauses)
clauses)
lambda (if (= 1 (count clauses))
(let [c (first clauses)] (str "(lambda " (nth c 0) " " (nth c 1) ")"))
(str "(case-lambda "
@ -597,12 +476,8 @@
(cond
(and (= kind :double) (= nm "inc")) (str "(fl+ " (first args) " 1.0)")
(and (= kind :double) (= nm "dec")) (str "(fl- " (first args) " 1.0)")
;; inc/dec tolerate a 64-bit operand (jolt-l-inc/dec fall back past fixnum range);
;; unchecked-inc/dec wrap (Java long). Neither can use the raising fx1+/fx1-.
(and (= kind :long) (= nm "inc")) (str "(jolt-l-inc " (first args) ")")
(and (= kind :long) (= nm "dec")) (str "(jolt-l-dec " (first args) ")")
(and (= kind :long) (= nm "unchecked-inc")) (str "(jolt-uncinc " (first args) ")")
(and (= kind :long) (= nm "unchecked-dec")) (str "(jolt-uncdec " (first args) ")")
(and (= kind :long) (or (= nm "inc") (= nm "unchecked-inc"))) (str "(fx1+ " (first args) ")")
(and (= kind :long) (or (= nm "dec") (= nm "unchecked-dec"))) (str "(fx1- " (first args) ")")
:else
(let [op (case kind :double (dbl-ops nm) :long (lng-ops nm) :bigdec (bd-ops nm))]
(order-args (fn [as] (str "(" op " " (str/join " " as) ")"))))))
@ -615,31 +490,8 @@
(= (nth shape i) kw) i
:else (recur (inc i))))))
;; A plain Scheme application: (callee op ...).
(defn- plain-call [callee operand-strs]
(str "(" callee (if (seq operand-strs) (str " " (str/join " " operand-strs)) "") ")"))
;; A tail call in trace mode. Force-bind the operands to temps FIRST (so any
;; operand whose own evaluation records a trace entry runs before our mark), THEN
;; set the tail mark, THEN apply — the callee's entry prologue consumes the mark
;; with nothing in between, so it can't be clobbered. Still a tail call: the let*'s
;; last form is the application, so TCO is preserved.
(defn- tail-marked-call [callee operand-strs]
(let [tmps (mapv (fn [_] (fresh-label "_tt$")) operand-strs)
binds (str/join " " (map (fn [t a] (str "(" t " " a ")")) tmps operand-strs))]
(str "(let* (" binds ") (jolt-trace-mark! #t) " (plain-call callee tmps) ")")))
;; Emit a call, tail-marked when we're in tail position and tracing is on; a plain
;; application otherwise. The mark is consumed by the callee's entry prologue —
;; direct calls (:local known-proc, direct-link) always have one; a jolt-invoke
;; call usually reaches one but not always (see the best-effort note in rt.ss).
(defn- emit-call [tail? callee operand-strs]
(if (and @trace-frames? tail?)
(tail-marked-call callee operand-strs)
(plain-call callee operand-strs)))
(defn- emit-invoke [node]
(let [tail? *tail?*] ; capture: children below emit non-tail
(binding [*tail?* false]
(let [fnode (:fn node)
(let [fnode (:fn node)
arg-nodes (:args node)
args (mapv emit arg-nodes)
nop (native-op fnode (count args))
@ -651,7 +503,8 @@
;; order [callee & args] together when ordering is observable.
invoke (fn []
(ordered-call (cons fnode arg-nodes) (cons (emit fnode) args)
(fn [operands] (emit-call tail? "jolt-invoke" operands))))]
(fn [[f & as]]
(str "(jolt-invoke " f (if (seq as) (str " " (str/join " " as)) "") ")"))))]
(cond
;; devirtualized protocol call: the inference proved the receiver (arg 0) is
;; one record type, so resolve the impl by that static tag instead of routing
@ -664,21 +517,11 @@
;; The receiver is bound once — it feeds both the resolve and the application.
(:devirt-type node)
(order-args (fn [as]
(let [r (fresh-label "_r$")
dv (str "(devirt-resolve " (chez-str-lit (:devirt-type node)) " "
(chez-str-lit (:devirt-proto node)) " " (chez-str-lit (:devirt-method node))
" " r ")")
cells @cache-cells
;; cache the resolved impl in a per-site cell when inside a
;; def (resolved once on first call, then reused); else
;; resolve per call.
resolver (if cells
(let [c (fresh-label "_dvc$")]
(swap! cells conj c)
(str "(or " c " (let ((_f " dv ")) (set! " c " _f) _f))"))
dv)]
(str "(let* ((" r " " (first as) ")) ("
resolver " " (str/join " " (cons r (rest as))) "))"))))
(let [r (fresh-label "_r$")]
(str "(let* ((" r " " (first as) ")) "
"((devirt-resolve " (chez-str-lit (:devirt-type node)) " "
(chez-str-lit (:devirt-proto node)) " " (chez-str-lit (:devirt-method node))
" " r ") " (str/join " " (cons r (rest as))) "))"))))
;; hint-directed fast arithmetic: jolt.passes.numeric proved every operand a
;; flonum (^double) or fixnum (^long), so emit the Chez fl*/fx* op.
(:num-kind node) (emit-numeric (:num-kind node) (:name fnode) args order-args)
@ -700,16 +543,11 @@
(if idx
(order-args (fn [as] (str "(jrec-field-at " (first as) " " idx " " (emit fnode) ")")))
(order-args (fn [as] (str "(jolt-get " (first as) " " (emit fnode) (defstr as) ")")))))
;; (coll k [default]) -> lookup — coll (fnode) is the callee, evaluated
;; before the key/default args. A VECTOR literal invokes as nth (a bad
;; index throws, IPersistentVector.invoke); maps/sets invoke as get.
;; (coll k [default]) -> (jolt-get coll k [default]) — coll (fnode) is the
;; callee, evaluated before the key/default args.
(= kind :coll)
(ordered-call (cons fnode arg-nodes) (cons (emit fnode) args)
(fn [[c & as]]
(str (if (and (= :vector (:op fnode)) (= 1 (count as)))
"(jolt-nth "
"(jolt-get ")
c " " (str/join " " as) ")")))
(fn [[c & as]] (str "(jolt-get " c " " (str/join " " as) ")")))
(and (stdlib-var? fnode) (not (deref prelude-mode?)))
(throw (ex-info (str "emit: unsupported stdlib fn `" (:ns fnode) "/" (:name fnode)
"` (no core on Chez yet)") {}))
@ -726,7 +564,8 @@
;; holds an arbitrary IFn -> dynamic dispatch.
(= :local (:op fnode))
(if (*known-procs* (munge-name (:name fnode)))
(order-args (fn [as] (emit-call tail? (munge-name (:name fnode)) as)))
(order-args (fn [as] (str "(" (munge-name (:name fnode))
(if (seq as) (str " " (str/join " " as)) "") ")")))
(invoke))
;; closed-world direct call: the callee var is an app fn def already emitted
;; with a Scheme binding — apply it directly, no var lookup, no jolt-invoke.
@ -735,7 +574,8 @@
;; below (which still uses the direct binding as the invoke target).
(and (= :var (:op fnode)) (direct-linkable? (:ns fnode) (:name fnode))
(direct-link-fn? (:ns fnode) (:name fnode)))
(order-args (fn [as] (emit-call tail? (dl-name (:ns fnode) (:name fnode)) as)))
(order-args (fn [as] (str "(" (dl-name (:ns fnode) (:name fnode))
(if (seq as) (str " " (str/join " " as)) "") ")")))
;; a late-bound :var call head can hold a procedure OR a non-applicable
;; value the RT dispatches (multimethod, keyword/coll IFn) — route via
;; jolt-invoke (transparent for a procedure).
@ -743,20 +583,16 @@
(invoke)
;; a computed callee can yield ANY IFn — route through jolt-invoke.
:else
(invoke))))))
(invoke))))
;; try/catch/finally. throw raises a Chez condition wrapping the jolt value
;; (jolt-throw = Scheme `raise` of a &jolt-throw condition); catch lowers to
;; `guard`, whose raw binding is unwrapped via jolt-unwrap-throw so the catch var
;; receives the jolt value (preserving ex-data/ex-message and the backtrace
;; identity tag). finally lowers to `dynamic-wind`'s after-thunk (runs on
;; success, catch and escape — Clojure finally semantics). Both keys optional.
;; try/catch/finally. throw raises the jolt value RAW (jolt-throw =
;; Scheme `raise`); catch lowers to `guard` with an `else` clause (the IR drops
;; the class), finally to `dynamic-wind`'s after-thunk (runs on success, catch and
;; escape — Clojure finally semantics). Both keys optional on the node.
(defn- emit-try [node]
(let [core (if-let [cs (:catch-sym node)]
(let [raw (munge-name (:catch-raw-sym node))]
(str "(guard (" raw " (else (let ((" (munge-name cs) " (jolt-unwrap-throw " raw "))) "
(emit (:catch-body node)) "))) "
(emit (:body node)) ")"))
(str "(guard (" (munge-name cs) " (else " (emit (:catch-body node)) ")) "
(emit (:body node)) ")")
(emit (:body node)))]
(if-let [fin (:finally node)]
(str "(dynamic-wind (lambda () #f) (lambda () " core ") (lambda () " (emit fin) "))")
@ -790,22 +626,7 @@
(returns-scheme-bool? (:body node) bools'))
:else false)))
;; In trace mode, a fn def also registers its source so the tail-frame history maps
;; the recorded frame-name to "ns/name (file:line)" instead of a bare name. Keyed by
;; the SAME munged name the entry push records (emit-fn's letrec self-binding = the
;; fn's own name). Returns "" when off / not a positioned fn def, so trace-off output
;; (seed mint, `jolt build`) is byte-identical. Direct-link builds already register
;; via emit-def-cached; this covers the open-world eval path.
(defn- trace-source-reg [node]
(let [init (:init node) pos (:pos node)]
(if (and @trace-frames? (= :fn (:op init)) (:name init) pos)
(str " (jolt-register-source! " (chez-str-lit (munge-name (:name init))) " "
(chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " "
(if (:file pos) (chez-str-lit (:file pos)) "jolt-nil") " "
(or (:line pos) 0) ")")
"")))
(defn emit* [node]
(defn emit [node]
(case (:op node)
:const (emit-const (:val node))
:local (munge-name (:name node))
@ -820,22 +641,7 @@
(and (stdlib-var? node) (not (deref prelude-mode?)))
(throw (ex-info (str "emit: unsupported stdlib ref `" (:ns node) "/" (:name node)
"` (no core on Chez yet)") {}))
;; inside a def, cache the interned var cell in a per-site cell so the
;; name lookup (string-append + hash) runs once, not per access; the
;; cell is stable and def-var! mutates its root in place, so this stays
;; correct under redefinition. Read through var-cell-deref — the
;; cell-based var-deref: binding-aware (a thread-bound dynamic var
;; resolves to its binding) AND lenient on an unbound root (the strict
;; jolt-var-get throws on a forward-declared var). Outside a def,
;; resolve per access.
:else
(let [cells @cache-cells
nslit (chez-str-lit (:ns node)) nmlit (chez-str-lit (:name node))]
(if (and @var-cache? cells)
(let [c (fresh-label "_vc$")]
(swap! cells conj c)
(str "(var-cell-deref (or " c " (let ((_v (jolt-var " nslit " " nmlit "))) (set! " c " _v) _v)))"))
(str "(var-deref " nslit " " nmlit ")")))))
:else (str "(var-deref " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) ")")))
:the-var (str "(jolt-var " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) ")")
;; (set! *var* val) -> set the var's innermost binding (else root); returns val.
:set-var (str "(jolt-var-set " (emit (:the-var node)) " " (emit (:val node)) ")")
@ -853,14 +659,11 @@
:host-new (str "(host-new " (chez-str-lit (:class node))
(let [args (map emit (:args node))]
(if (empty? args) "" (str " " (str/join " " args)))) ")")
;; the test is non-tail; then/else inherit the if's tail position
:if (let [test (:test node)
t (binding [*tail?* false]
(if (returns-scheme-bool? test) (emit test)
(str "(jolt-truthy? " (emit test) ")")))]
t (if (returns-scheme-bool? test) (emit test)
(str "(jolt-truthy? " (emit test) ")"))]
(str "(if " t " " (emit (:then node)) " " (emit (:else node)) ")"))
;; non-last statements are non-tail; the ret inherits the do's tail position
:do (str "(begin " (binding [*tail?* false] (str/join " " (mapv emit (:statements node))))
:do (str "(begin " (str/join " " (map emit (:statements node)))
(if (empty? (:statements node)) "" " ") (emit (:ret node)) ")")
:invoke (emit-invoke node)
;; collection literals -> rt constructors (collections.ss). Elements are
@ -904,17 +707,15 @@
:fn (emit-fn node)
;; (def name) with no init (declare): reserve the cell. A def with non-empty
;; reader metadata lowers to def-var-with-meta! (ported in a later increment).
:def (let [reg (trace-source-reg node)
d (cond
(:no-init node)
(str "(declare-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) ")")
(jmeta-nonempty? (:meta node))
(str "(def-var-with-meta! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " "
(emit-with-cells #(emit (:init node))) " " (emit-def-meta node) ")")
:else
(str "(def-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " "
(emit-with-cells #(emit (:init node))) ")"))]
(if (= reg "") d (str "(begin " d reg ")")))
:def (cond
(:no-init node)
(str "(declare-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) ")")
(jmeta-nonempty? (:meta node))
(str "(def-var-with-meta! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " "
(emit (:init node)) " " (emit-def-meta node) ")")
:else
(str "(def-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " "
(emit (:init node)) ")"))
(throw (ex-info (str "emit: op not yet ported / unhandled: " (pr-str (:op node))) {}))))
;; ^:dynamic / ^:redef on a def opts it out of direct-linking: it stays redefinable,
@ -927,53 +728,37 @@
;; Off direct-link mode this is exactly `emit`, so the seed mint and runtime eval are
;; byte-unchanged. Nested defs (a defonce's inner def) never reach a top-level branch
;; here, so they stay indirect — a `define` would be illegal in their position.
;; Emit a def, wrapping its init in a let that binds each per-site cache cell
;; (var-ref + devirt) so a hot loop's lookups resolve once into the def's closure.
;; Runs in BOTH modes; in direct-link mode a non-opt-out def also binds jv$<fqn>
;; and registers it for app->app direct linking + a source-map frame.
(defn- emit-def-cached [node]
(let [ns (:ns node) nm (:name node)
dl? (and @direct-link? (not (dl-opt-out? (:meta node))))
b (dl-name ns nm)
fn? (= :fn (:op (:init node)))
;; A fn def gets a source-registry entry so a native backtrace can map its
;; frame to ns/name (file:line). Chez names the frame by whatever emit-fn
;; binds the lambda to: a NAMED fn (defn, or (fn foo …)) gets a letrec
;; self-binding = munge-name of the fn's own name; an ANONYMOUS fn def has
;; no letrec, so the lambda sits directly under (define jv$ns$name …) and
;; takes that name. Register under whichever Chez will report.
pos (:pos node)
frame-name (when fn? (if-let [fnm (:name (:init node))] (munge-name fnm) b))
reg (when (and dl? fn? pos)
(str " (jolt-register-source! " (chez-str-lit frame-name) " "
(chez-str-lit ns) " " (chez-str-lit nm) " "
(if (get pos :file) (chez-str-lit (get pos :file)) "jolt-nil") " "
(or (get pos :line) 0) ")"))
;; register before emitting the init so a self-referential body direct-links.
_ (when dl? (swap! direct-link-defined conj (dl-fqn ns nm))
(when fn? (swap! direct-link-fns conj (dl-fqn ns nm))))
init (emit-with-cells #(emit (:init node)))]
(cond
dl?
(if (jmeta-nonempty? (:meta node))
(str "(begin (define " b " " init ") (def-var-with-meta! "
(chez-str-lit ns) " " (chez-str-lit nm) " " b " " (emit-def-meta node) ")" (or reg "") ")")
(str "(begin (define " b " " init ") (def-var! "
(chez-str-lit ns) " " (chez-str-lit nm) " " b ")" (or reg "") ")"))
(jmeta-nonempty? (:meta node))
(str "(def-var-with-meta! " (chez-str-lit ns) " " (chez-str-lit nm) " " init " " (emit-def-meta node) ")")
:else
(str "(def-var! " (chez-str-lit ns) " " (chez-str-lit nm) " " init ")"))))
(defn emit-top-form [node]
(cond
;; off direct-link (the seed mint + runtime-via-image) this is exactly `emit`,
;; whose :def case already wraps cache cells, so the seed stays byte-unchanged.
(not @direct-link?) (emit node)
;; top-level do splices: each statement/ret is itself a top-level form.
(= :do (:op node))
(str "(begin " (str/join " " (map emit-top-form (:statements node)))
(if (empty? (:statements node)) "" " ") (emit-top-form (:ret node)) ")")
(and (= :def (:op node)) (not (:no-init node)) (not (dl-opt-out? (:meta node))))
(emit-def-cached node)
(let [ns (:ns node) nm (:name node) b (dl-name ns nm)
fn? (= :fn (:op (:init node)))
;; A fn def gets a source-registry entry so a native backtrace can map its
;; frame to ns/name (file:line). Chez names the frame by whatever emit-fn
;; binds the lambda to: a NAMED fn (defn, or (fn foo …)) gets a letrec
;; self-binding = munge-name of the fn's own name; an ANONYMOUS fn def has
;; no letrec, so the lambda sits directly under (define jv$ns$name …) and
;; takes that name. Register under whichever Chez will report.
pos (:pos node)
frame-name (when fn?
(if-let [fnm (:name (:init node))] (munge-name fnm) b))
reg (when (and fn? pos)
(str " (jolt-register-source! " (chez-str-lit frame-name) " "
(chez-str-lit ns) " " (chez-str-lit nm) " "
(if (get pos :file) (chez-str-lit (get pos :file)) "jolt-nil") " "
(or (get pos :line) 0) ")"))]
;; register before emitting the init so a self-referential body direct-links.
(swap! direct-link-defined conj (dl-fqn ns nm))
(when fn? (swap! direct-link-fns conj (dl-fqn ns nm)))
(let [init (emit (:init node))]
(if (jmeta-nonempty? (:meta node))
(str "(begin (define " b " " init ") (def-var-with-meta! "
(chez-str-lit ns) " " (chez-str-lit nm) " " b " " (emit-def-meta node) ")" (or reg "") ")")
(str "(begin (define " b " " init ") (def-var! "
(chez-str-lit ns) " " (chez-str-lit nm) " " b ")" (or reg "") ")"))))
:else (emit node)))

View file

@ -66,10 +66,6 @@
(if-let [root (:deps/root spec)] (str checkout "/" root) checkout))
(:jolt/module spec)
(do (warn "skipping janet dependency " coord " (:jolt/module is obsolete on Chez)") nil)
;; jolt IS Clojure — a dependency on org.clojure/clojure is satisfied
;; intrinsically, so skip it silently rather than warning about the (unusable)
;; :mvn/version coordinate.
(= coord 'org.clojure/clojure) nil
:else
(do (warn "skipping unsupported coordinate " coord " " (pr-str spec)) nil)))

View file

@ -8,8 +8,6 @@
(defn- project-dir [] (or (jolt.host/getenv "JOLT_PWD") "."))
(defn- version [] (jolt.host/jolt-version))
(defn- current-platform []
(let [os (str/lower-case (or (System/getProperty "os.name") ""))]
(cond (str/includes? os "mac") :darwin
@ -30,11 +28,7 @@
(let [c (get spec plat)
cands (if (string? c) [c] (vec c))
hit (some #(when (jolt.ffi/loaded? %) %) cands)]
;; A :static spec has no runtime shared object (it's linked into a
;; built binary), so an interpreted `run`/`repl` has nothing to load —
;; skip it rather than fail. Its foreign calls only resolve in a static
;; build; document a dynamic candidate too to use it under `run`.
(when (and (nil? hit) (not (:optional spec)) (not (:static spec)))
(when (and (nil? hit) (not (:optional spec)))
(throw (ex-info (str "required native library "
(or (:name spec) (first cands) "?")
" not found — tried " (pr-str cands) " for " (name plat))
@ -94,79 +88,22 @@
(let [{:keys [roots]} (deps/resolve-project (project-dir))]
(println (str/join ":" roots))))
(defn- repl-form-complete?
"True when `s` has balanced ()/[]/{}, no open string/char/regex, and at most
a trailing comment past the last form. Drives the REPL's read-until-complete
decision so a form split across lines is accumulated, not evaluated half-read."
[s]
(let [n (count s)]
(loop [i 0 depth 0 state :code] ; state: :code :string :regex :comment
(if (>= i n)
(and (<= depth 0) (#{:code :comment} state))
(let [c (get s i)]
(case state
:code (cond
(= c \;) (recur (inc i) depth :comment)
(= c \\) (recur (+ i 2) depth :code) ; char literal: \(
(= c \") (recur (inc i) depth :string)
(= c \#) (if (= (get s (inc i)) \")
(recur (+ i 2) depth :regex) ; consume the #" together
(recur (inc i) depth :code))
(#{\( \[ \{} c) (recur (inc i) (inc depth) :code)
(#{\) \] \}} c) (recur (inc i) (dec depth) :code)
:else (recur (inc i) depth :code))
:string (cond
(= c \\) (recur (+ i 2) depth :string) ; escaped char
(= c \") (recur (inc i) depth :code)
:else (recur (inc i) depth :string))
:regex (cond
(= c \\) (recur (+ i 2) depth :regex)
(= c \") (recur (inc i) depth :code)
:else (recur (inc i) depth :regex))
:comment (recur (inc i) depth
(if (#{\newline \return} c) :code :comment))))))))
(defn- repl-read-form []
;; Read lines — printing a secondary prompt for continuations — until the
;; accumulated buffer is a complete form. Returns the (possibly multi-line)
;; buffer, or nil on EOF at the primary prompt.
(loop [buf nil]
(print (if buf "... " "user=> ")) (flush)
(let [line (read-line)]
(cond
(nil? line) buf ; EOF: nil at primary, partial mid-form
(nil? buf) (cond
(str/blank? line) (recur nil) ; skip a blank first line
(repl-form-complete? line) line
:else (recur line))
:else (let [nb (str buf "\n" line)]
(if (repl-form-complete? nb) nb (recur nb)))))))
(defn- repl []
;; resolve the project so deps (git libs) are on the roots and native libs are
;; loaded — same context a run gets, so (require '[some.lib]) works in the REPL.
(try (apply-project! (deps/resolve-project (project-dir)))
(catch :default _ nil))
;; REPL-driven development: trace by default so an uncaught error in evaluated
;; code shows a tail-frame backtrace, no JOLT_TRACE needed (JOLT_TRACE=0 opts out).
(jolt.host/enable-trace!)
(println (str ";; jolt " (version) " repl — :repl/quit or ^D to exit"))
(println ";; jolt repl — ^D to exit")
(loop []
(let [form (repl-read-form)]
(when form
;; :repl/quit / :exit exit the loop — a reliable gesture that works in any
;; terminal, unlike ^D (some terminals/editors don't deliver it as EOF).
(if (#{:repl/quit :exit} (try (read-string form) (catch :default _ nil)))
nil
(do
(try (println (pr-str (load-string form)))
(catch :default e
(println "error:" (or (ex-message e)
(try ((resolve 'jolt.host/condition-message) e) (catch :default _ nil))
(pr-str e)))
(when-let [bt (jolt.host/backtrace-string)]
(print bt))))
(recur)))))))
(print "user=> ") (flush)
(let [line (read-line)]
(when line
(try (println (pr-str (load-string line)))
(catch :default e
(println "error:" (or (ex-message e)
(try ((resolve 'jolt.host/condition-message) e) (catch :default _ nil))
(pr-str e)))))
(recur)))))
;; A deps.edn :tasks entry: a string is a shell command; a map is {:main-opts …}.
(defn- run-task [name more]
@ -185,38 +122,18 @@
;; --direct-link (or deps.edn :jolt/build {:direct-link true}) opts into closed-world
;; direct-linking: app->app calls bind directly, giving up runtime redefinition of
;; those vars and eval/load-string. Off by default — release stays dynamically linked.
;; The static-link description of a :jolt/native spec for this platform, or nil.
;; :static may be flat ({:archive "…"} / {:lib "z" :libdir "…"}) or per-platform
;; ({:darwin {…} :linux {…}}). Returns a vector build.ss reads and wraps in the
;; platform's force-load flags: ["archive" abspath] or ["lib" name libdir].
(defn- static-link-spec [spec plat]
(when-let [s (:static spec)]
(let [p (get s plat)
s (if (map? p) p s)]
(cond
(:archive s) ["archive" (:archive s)]
(:lib s) ["lib" (:lib s) (or (:libdir s) "")]
:else nil))))
;; Encode a deps.edn :jolt/native spec for the build launcher, resolving the
;; current platform's candidate list now (the binary runs on this OS). Each entry
;; becomes a vector the launcher (build.ss) reads:
;; ["process"] — the running binary's own symbols (libc)
;; ["static" form …] — the lib's archive, cc-linked into the binary; its
;; symbols load from the process (default when :static
;; is present and --dynamic wasn't passed)
;; ["req"|"opt" cand…] — load a shared object at runtime, trying each in turn
;; dynamic? forces the runtime path for every lib (the --dynamic build flag).
(defn- encode-natives [natives dynamic?]
;; becomes a vector the launcher (build.ss) reads: ["process"] for the running
;; binary's own symbols, else ["req"|"opt" cand…] to try in turn.
(defn- encode-natives [natives]
(let [plat (current-platform)]
(vec (for [spec natives]
(let [static (and (not dynamic?) (static-link-spec spec plat))]
(cond
(:process spec) ["process"]
static (into ["static"] static)
:else (let [c (get spec plat)
cands (if (string? c) [c] (vec c))]
(into [(if (:optional spec) "opt" "req")] cands))))))))
(if (:process spec)
["process"]
(let [c (get spec plat)
cands (if (string? c) [c] (vec c))]
(into [(if (:optional spec) "opt" "req")] cands)))))))
(defn- cmd-build [more]
(let [{:keys [project-paths embed-dirs build] :as resolved}
@ -250,11 +167,7 @@
(nil? o) (str pdir "/target/" (if (= mode "dev") "debug" "release") "/" proj)
(str/starts-with? o "/") o
:else (str pdir "/" o)))
;; :jolt/native libs with a :static archive are cc-linked into the
;; binary by default; --dynamic (or deps.edn :jolt/build {:dynamic-natives
;; true}) keeps the old behavior — load a shared object at runtime.
dynamic-natives? (boolean (or (some #{"--dynamic"} more) (:dynamic-natives build)))
natives (encode-natives (:natives resolved) dynamic-natives?)
natives (encode-natives (:natives resolved))
;; closed-world direct-linking is opt-in: the --direct-link flag or a
;; deps.edn :jolt/build {:direct-link true}. Off otherwise.
direct-link? (boolean (or (some #{"--direct-link"} more) (:direct-link build)))
@ -275,57 +188,27 @@
(let [port (or (some-> (first (filter #(not (str/starts-with? % "-")) more)) parse-long)
(parse-long (or (jolt.host/getenv "JOLT_NREPL_PORT") "7888")))]
(require 'jolt.nrepl)
;; start binds the socket synchronously on this (primordial) thread, so a
;; failure like the port already being in use surfaces here and exits rather
;; than being swallowed by a background thread. It then runs the accept loop
;; on a worker thread and returns a stop fn, leaving this thread free to own
;; the GUI main loop: glimmer's run marshals its startup here via
;; jolt.host/call-on-main-thread — on macOS GTK quartz, g_application_run
;; must run on the main thread or AppKit aborts when it sets the main menu.
;; Block SIGINT in this (primordial) thread before starting the server so the
;; accept-loop future — and the conn-handler futures it spawns — inherit a
;; blocked SIGINT mask. Without this, ^C lands on the accept loop blocked in
;; c-accept (a foreign call), where Chez can't fire the keyboard-interrupt
;; handler, and the server hangs. park-until-interrupt unblocks SIGINT here
;; once its own ^C handler is installed, so ^C reaches this thread and the
;; shutdown hooks run cleanly.
(jolt.host/block-sigint)
(let [stop ((resolve 'jolt.nrepl/start) port (:nrepl-middleware resolved))]
;; register stop so ^C (handled by park-until-interrupt) closes the socket
;; and drops .nrepl-port on the way out.
(jolt.host/add-shutdown-hook stop)
;; park here until ^C (handled by park-until-interrupt's keyboard-interrupt-
;; handler, which runs the shutdown hooks and exits). The accept loop
;; inherited SIGINT-blocked above, so ^C is delivered to this thread.
(jolt.host/park-until-interrupt)
(when stop (stop))))))
((resolve 'jolt.nrepl/start) port (:nrepl-middleware resolved)))))
(defn- usage []
(println (str "jolt " (version)))
(println "usage: jolt <command> [args]")
(println " -e EXPR evaluate EXPR and print the result")
(println " run -m NS [args] resolve deps.edn, load NS, call its -main")
(println " run FILE load a Clojure file")
(println " build -m NS [-o OUT] [--opt|--dev] [--direct-link] [--tree-shake] [--dynamic] compile a standalone binary")
(println " -M:alias [args] run the alias's :main-opts")
(println " -A:alias [args] add the alias's paths/deps")
(println " repl start a line REPL")
(println " --nrepl-server [port] start an nREPL server (default 7888) for editors")
(println " path print the resolved source roots")
(println " <task> run a deps.edn :tasks entry")
(println " --version print the jolt version")
(println " --help print this message"))
(println " run -m NS [args] resolve deps.edn, load NS, call its -main")
(println " run FILE load a Clojure file")
(println " build -m NS [-o OUT] [--opt|--dev] [--direct-link] [--tree-shake] compile a standalone binary")
(println " -M:alias [args] run the alias's :main-opts")
(println " -A:alias [args] add the alias's paths/deps")
(println " repl start a line REPL")
(println " nrepl [port] start an nREPL server (default 7888) for editors")
(println " path print the resolved source roots")
(println " <task> run a deps.edn :tasks entry"))
(defn -main [& args]
(let [[cmd & more] args]
(cond
(nil? cmd) (usage)
(= cmd "--help") (usage)
(= cmd "-h") (usage)
(#{"--version" "-V"} cmd) (println (str "jolt " (version)))
(= cmd "run") (cmd-run more)
(= cmd "repl") (repl)
(= cmd "--nrepl-server") (nrepl more)
(= cmd "nrepl") (nrepl more)
(= cmd "path") (cmd-path)
(str/starts-with? cmd "-M") (cmd-M cmd more)
(str/starts-with? cmd "-A") (cmd-A cmd more)

View file

@ -17,70 +17,28 @@
Writes .nrepl-port in the project dir so editors auto-detect the port."
(:require [clojure.string :as str]
[clojure.java.io :as io]
[jolt.ffi :as ffi]))
;; --- sockets (loopback server) ---------------------------------------------
(def ^:private os-name
(str/lower-case (or (System/getProperty "os.name") "")))
(def ^:private macos? (str/includes? os-name "mac"))
(def ^:private windows? (str/includes? os-name "win"))
;; Load the library that provides the socket symbols BEFORE the foreign-fn
;; bindings below — defcfn resolves the C entry point when the def is evaluated
;; (at ns load), so the symbols must already be available. POSIX: the running
;; process's own libc symbols. Windows: the Winsock DLL (ws2_32), whose symbols
;; are NOT in joltc.exe's export table even though it's linked in — without this
;; explicit load, (ffi/defcfn c-socket "socket" ...) fails at load with
;; "no entry for socket".
(if windows?
(ffi/load-library "ws2_32.dll")
(ffi/load-library))
;; A socket is an int fd on POSIX; on Win64 it's a SOCKET (uintptr_t) handle, but
;; those are small kernel handle values that round-trip through :int, and the
;; INVALID_SOCKET error sentinel (~0) reads back as -1 — so the fd checks below
;; work unchanged on both.
;; Load libc (the running process's symbols) BEFORE the foreign-fn bindings below
;; — defcfn resolves the C entry point when the def is evaluated (at ns load), so
;; the socket symbols must already be available.
(ffi/load-library)
(ffi/defcfn c-socket "socket" [:int :int :int] :int)
(ffi/defcfn c-bind "bind" [:int :pointer :int] :int)
(ffi/defcfn c-listen "listen" [:int :int] :int)
(ffi/defcfn c-setsockopt "setsockopt" [:int :int :int :pointer :int] :int)
(ffi/defcfn c-accept "accept" [:int :pointer :pointer] :int :blocking)
;; recv/send and the socket-close call differ by platform. Winsock's recv/send
;; take an int length and return int (not ssize_t), and a socket is closed with
;; closesocket, not close. A symbol that exists on only one OS (closesocket on
;; Windows, close on POSIX) can only be bound there, so these live in the taken
;; platform branch — jolt interns the vars from both branches at analysis time,
;; so later references resolve either way.
(if windows?
(do
(ffi/defcfn c-recv "recv" [:int :pointer :int :int] :int :blocking)
(ffi/defcfn c-send "send" [:int :pointer :int :int] :int :blocking)
(ffi/defcfn c-close "closesocket" [:int] :int)
;; Winsock must be initialized once per process before any socket call.
(ffi/defcfn c-wsastartup "WSAStartup" [:int :pointer] :int))
(do
(ffi/defcfn c-recv "recv" [:int :pointer :size_t :int] :ssize_t :blocking)
(ffi/defcfn c-send "send" [:int :pointer :size_t :int] :ssize_t :blocking)
(ffi/defcfn c-close "close" [:int] :int)))
(ffi/defcfn c-recv "recv" [:int :pointer :size_t :int] :ssize_t :blocking)
(ffi/defcfn c-send "send" [:int :pointer :size_t :int] :ssize_t :blocking)
(ffi/defcfn c-close "close" [:int] :int)
(def ^:private AF-INET 2)
(def ^:private SOCK-STREAM 1)
;; SOL_SOCKET / SO_REUSEADDR: 0xffff / 4 on macOS and Windows, 1 / 2 on Linux.
(def ^:private sol-socket (if (or macos? windows?) 0xffff 1))
(def ^:private so-reuse (if (or macos? windows?) 4 2))
;; Initialize Winsock (a no-op off Windows). WSAStartup is refcounted and must
;; precede any socket call; WSADATA is ~408 bytes on x64, so 512 is ample.
(defn- ensure-winsock! []
(when windows?
(let [wsadata (ffi/alloc 512)]
(try
(let [r (c-wsastartup 0x0202 wsadata)]
(when-not (zero? r)
(throw (ex-info (str "WSAStartup failed: " r) {}))))
(finally (ffi/free wsadata))))))
(def ^:private macos?
(str/includes? (str/lower-case (or (System/getProperty "os.name") "")) "mac"))
(def ^:private sol-socket (if macos? 0xffff 1))
(def ^:private so-reuse (if macos? 4 2))
(defn- make-sockaddr [port]
(let [sa (ffi/alloc 16)]
@ -94,7 +52,7 @@
sa))
(defn- listen-socket [port]
(ensure-winsock!) ; no-op off Windows
(ffi/load-library) ; libc process symbols
(let [fd (c-socket AF-INET SOCK-STREAM 0)]
(when (neg? fd) (throw (ex-info "socket() failed" {})))
(let [opt (ffi/alloc 4)] (ffi/write opt :int 0 1) (c-setsockopt fd sol-socket so-reuse opt 4) (ffi/free opt))
@ -188,10 +146,7 @@
(try (when (and ns-str (not (str/blank? ns-str)) (find-ns (symbol ns-str)))
(in-ns (symbol ns-str)))
(reset! result (load-string code))
(catch :default e
(reset! err (str (err-msg e)
(when-let [bt (jolt.host/backtrace-string)]
(str "\n" bt)))))))]
(catch :default e (reset! err (err-msg e)))))]
{:value (when (nil? @err) (pr-str @result))
:out out
:ns (str (ns-name *ns*))
@ -267,44 +222,18 @@
(defn start
"Start the nREPL server on `port` (a concrete port; loopback only). `middleware`
is a vector of deps.edn :nrepl/middleware symbols to compose over the built-in
handler.
Binds the socket synchronously, so a startup failure (e.g. the port is already
in use) is thrown to the caller rather than swallowed by the accept thread, then
accepts connections on a background thread and returns immediately. Writes
.nrepl-port. Does NOT block the caller keeps the process alive (jolt.main
parks the main thread in jolt.host/run-main-pump).
Returns a zero-arg stop fn: it stops the accept loop, closes the listen socket
(freeing the port), and removes .nrepl-port. Calling it more than once is a
no-op."
handler. Writes .nrepl-port. Blocks accepting connections."
([port] (start port nil))
([port middleware]
;; An nREPL session is REPL-driven development: trace by default so an uncaught
;; error in code evaluated over the connection shows a tail-frame backtrace, with
;; no JOLT_TRACE needed. Covers both `--nrepl-server` and an app that starts its
;; own server under `-M:run` (reload a namespace to trace already-loaded code).
(jolt.host/enable-trace!)
(let [handler (build-handler (resolve-middleware (or middleware [])))
fd (listen-socket port) ; throws on bind/listen failure
stopped (atom false)]
fd (listen-socket port)]
(try (spit ".nrepl-port" (str port)) (catch :default _ nil))
(println (str "jolt " (jolt.host/jolt-version) " nREPL server started on port "
port " (127.0.0.1) — .nrepl-port written"))
(println (str "nREPL server started on port " port " (127.0.0.1) — .nrepl-port written"))
(when (seq middleware) (println (str ";; middleware: " (str/join " " middleware))))
(println ";; connect your editor; ^C to stop")
(future
;; A stop closes fd, which makes the blocking accept() return an error; the
;; @stopped check then breaks the loop instead of spinning on the dead fd.
(loop []
(let [conn (c-accept fd ffi/null ffi/null)]
(when-not @stopped
(when (>= conn 0)
(future (try (handle-conn conn handler)
(catch :default e (println "nrepl conn error:" (err-msg e)) (c-close conn)))))
(recur)))))
(fn stop []
(when (compare-and-set! stopped false true)
(c-close fd)
(jolt.host/delete-file ".nrepl-port"))
nil))))
(loop []
(let [conn (c-accept fd ffi/null ffi/null)]
(when (>= conn 0)
(future (try (handle-conn conn handler)
(catch :default e (println "nrepl conn error:" (err-msg e)) (c-close conn)))))
(recur))))))

View file

@ -546,13 +546,161 @@
(recur (inc i))))
node))))
;; --- reduce-accumulator scalar replacement ----------------------------------
;; (reduce (fn [acc x] body) (->Rec inits..) coll) where acc is a non-escaping
;; record — read only via its fields, returned each step as a same-shape ctor or
;; carried forward unchanged — allocates one record PER ELEMENT. Lower it to a seq
;; loop that carries acc's fields as scalar loop vars and rebuilds the record once
;; at exit, so the per-step allocation disappears. This is the ray tracer's hit-all
;; (a HitAcc per sphere test). Closed-world (--opt) only, like the rest of this pass.
(defn- local-node [nm] {:op :local :name nm})
(defn- core-call [nm cargs] {:op :invoke :fn {:op :var :ns "clojure.core" :name nm} :args (vec cargs)})
(defn- reduce3-callee?
"node is a (clojure.core/reduce f init coll) the 3-arg form with an explicit
initial value (the 2-arg form seeds from the collection, a different shape)."
[node]
(let [f (get node :fn)]
(and (= :invoke (get node :op))
(= :var (get f :op)) (= "clojure.core" (get f :ns)) (= "reduce" (get f :name))
(= 3 (count (get node :args))))))
(defn- same-shape-ctor? [node rs]
(let [cs (ctor-shape node)] (and cs (= (get cs :type) (get rs :type)))))
(defn- acc-ok?
"Is acc (local nm, record shape rs) safe to scalarize across body? It may appear
ONLY as a constant-field-read subject, or in tail position as the bare
carried-forward value. tail? marks whether node is the reduce-fn's return value.
A binding/control form that could capture or rebind acc bails (false)."
[node nm rs tail?]
(let [op (get node :op)
k (lookup-key node nm)]
(cond
;; a field read of acc: nm is consumed as the subject; a get-default (extra
;; arg) is non-tail and must not leak acc either.
k (let [args (get node :args)]
(if (> (count args) 1)
(every? (fn [a] (acc-ok? a nm rs false)) (subvec args 1 (count args)))
true))
(= op :local) (or (not= nm (get node :name)) tail?) ;; bare acc only ok in tail
(= op :const) true (= op :var) true (= op :host) true
(= op :the-var) true (= op :quote) true
(= op :if) (and (acc-ok? (get node :test) nm rs false)
(acc-ok? (get node :then) nm rs tail?)
(acc-ok? (get node :else) nm rs tail?))
(= op :do) (and (every? (fn [s] (acc-ok? s nm rs false)) (get node :statements))
(acc-ok? (get node :ret) nm rs tail?))
(= op :let) (and (every? (fn [b] (acc-ok? (nth b 1) nm rs false)) (get node :bindings))
(or (any-binding-named? (get node :bindings) nm) ;; nm shadowed below
(acc-ok? (get node :body) nm rs tail?)))
(= op :invoke) (and (acc-ok? (get node :fn) nm rs false)
(every? (fn [a] (acc-ok? a nm rs false)) (get node :args)))
(= op :throw) (acc-ok? (get node :expr) nm rs false)
(= op :vector) (every? (fn [a] (acc-ok? a nm rs false)) (get node :items))
(= op :set) (every? (fn [a] (acc-ok? a nm rs false)) (get node :items))
(= op :map) (every? (fn [p] (and (acc-ok? (nth p 0) nm rs false)
(acc-ok? (nth p 1) nm rs false))) (get node :pairs))
;; :fn/:loop/:recur/:try/:def — acc could be captured, or a nested recur would
;; collide with the loop we synthesize; conservatively bail.
:else false)))
(defn- tails-valid?
"Every tail position of body returns a same-shape ctor or the bare acc the
values the recur can carry as exploded scalars. (A `reduced` tail, or any other
shape, isn't one of these, so it keeps the ordinary reduce.)"
[node nm rs]
(let [op (get node :op)]
(cond
(= op :if) (and (tails-valid? (get node :then) nm rs) (tails-valid? (get node :else) nm rs))
(= op :do) (tails-valid? (get node :ret) nm rs)
(= op :let) (tails-valid? (get node :body) nm rs)
(and (= op :local) (= nm (get node :name))) true
:else (same-shape-ctor? node rs))))
(defn- subst-acc-fields
"Replace every (:k acc)/(get acc :k) in node with the scalar loop var for field k.
acc-ok? guarantees acc appears only as such reads (or the bare tail), so a uniform
recursion is safe."
[node nm fields acc-locals]
(let [k (lookup-key node nm)]
(if k
(nth acc-locals (field-index fields k))
(map-ir-children (fn [c] (subst-acc-fields c nm fields acc-locals)) node))))
(defn- tail->recur
"Convert each tail of body (already field-substituted) into a recur that advances
the seq and carries the next accumulator components: a same-shape ctor explodes
into its positional args, the bare acc carries the current components forward."
[node nm acc-locals snm]
(let [op (get node :op)
step (fn [t] (tail->recur t nm acc-locals snm))
recur-with (fn [comps] {:op :recur :args (reduce conj [(core-call "next" [(local-node snm)])] comps)})]
(cond
(= op :if) (assoc node :then (step (get node :then)) :else (step (get node :else)))
(= op :do) (assoc node :ret (step (get node :ret)))
(= op :let) (assoc node :body (step (get node :body)))
(and (= op :local) (= nm (get node :name))) (recur-with acc-locals)
:else (recur-with (get node :args))))) ;; a same-shape ctor: its args are the new components
(defn- lower-reduce
"Rewrite a lowerable (reduce (fn [acc x] body) (->Rec inits) coll) into a seq loop
with acc's fields carried as scalar vars. Caller has validated the shape."
[node]
(let [args (get node :args)
closure (nth args 0) init (nth args 1) coll (nth args 2)
ar (first (get closure :arities))
params (get ar :params)
nm (nth params 0) xnm (nth params 1)
body (get ar :body)
rs (ctor-shape init)
fields (get rs :fields)
snm (fresh "rseq")
accnms (mapv (fn [_] (fresh "racc")) fields)
acc-locals (mapv local-node accnms)
body' (tail->recur (subst-acc-fields body nm fields acc-locals) nm acc-locals snm)]
{:op :loop
:bindings (reduce conj [[snm (core-call "seq" [coll])]]
(mapv (fn [an ia] [an ia]) accnms (get init :args)))
:body {:op :if
:test (core-call "nil?" [(local-node snm)])
;; exhausted: rebuild the record once from the final components
:then {:op :invoke :fn (get init :fn) :args acc-locals}
:else {:op :let :bindings [[xnm (core-call "first" [(local-node snm)])]]
:body body'}}}))
(defn- try-lower-reduce
"Lower a (reduce closure (->Rec inits) coll) when the closure is a single-arity
2-param literal fn and acc is a non-escaping record; else nil."
[node]
(when (reduce3-callee? node)
(let [closure (nth (get node :args) 0)
init (nth (get node :args) 1)
ars (get closure :arities)]
(when (and (= :fn (get closure :op)) (= 1 (count ars))
(= 2 (count (get (first ars) :params)))
(not (get (first ars) :rest))
(ctor-shape init))
(let [ar (first ars)
nm (nth (get ar :params) 0)
body (get ar :body)
rs (ctor-shape init)]
(when (and (acc-ok? body nm rs true) (tails-valid? body nm rs))
(lower-reduce node)))))))
(defn scalar-replace
"Bottom-up: scalar-replace children, then apply (a) at invokes / (b) at lets."
[node]
(let [op (get node :op)]
(cond
;; (a) fold (:k <map|ctor>) at invokes, after scalar-replacing children
(= op :invoke) (fold-kw-literal (map-ir-children scalar-replace node))
;; (a) at invokes: lower a reduce-over-record-accumulator to a loop, else fold
;; (:k <map|ctor>) — both after scalar-replacing children.
(= op :invoke)
(let [n (map-ir-children scalar-replace node)]
(if-let [low (try-lower-reduce n)]
(do (mark!) low)
(fold-kw-literal n)))
;; (b) drop a non-escaping foldable-struct let binding, after children
(= op :let) (elim-let-structs (map-ir-children scalar-replace node))
:else (map-ir-children scalar-replace node))))

View file

@ -183,12 +183,7 @@
ls (lng-spec nm n)
bs (bd-spec nm n)]
(cond
(and ds (ok? :double :double)
;; min/max return the ORIGINAL operand (Numbers.min: an integer
;; literal stays exact), so an int-literal operand blocks the
;; flonum lowering there — flmin would coerce it.
(or (not (contains? #{"min" "max"} nm))
(every? (fn [c] (= c :double)) cls)))
(and ds (ok? :double :double))
;; coerce integer-literal operands to flonum so fl-ops never see an exact int.
(let [args' (mapv (fn [nd] (if (int-lit? nd) (assoc nd :val (double (get nd :val))) nd))
argnodes)]

View file

@ -5,15 +5,14 @@
checker. Also the inter-procedural driver API the back end calls to
propagate param types across a unit / the whole program. Weakly coupled to the
IR-rewriting passes shares the const-shape predicates (jolt.passes.fold)."
(:require [jolt.ir :refer [reduce-ir-children]]
[jolt.passes.fold :refer [scalar-const? kw-callee? get-callee?]]
(:require [jolt.passes.fold :refer [scalar-const? kw-callee? get-callee?]]
[jolt.passes.types.check :refer
[not-callable? type-name check-invoke register-user-fn!]]
[jolt.passes.types.lattice :refer
[velem selem sfields vec-type? set-type? struct-type? mk-vec mk-set
mk-struct union-cap scalar-t? union-type? umembers union-of merge-fields
join-t join type-depth cap struct-safe? field-type shape-order type-shape
mark-struct truthy-type? num-ret-fns vector-ret-fns nilable? strip-nilable]]))
mark-struct truthy-type? num-ret-fns vector-ret-fns]]))
;; --- engine state ------------------------------------------------------------
;; The walk threads an immutable `env` (mk-env) instead of reading scattered
@ -46,11 +45,6 @@
(def ^:private last-diags-box (atom []))
;; Whether run-inference also checks, and strictly. Set by set-check-mode!.
(def ^:private check-mode-box (atom {:on false :strict false}))
;; "Proto/method" -> the join of its impls' return types, so a protocol-method call
;; types as that record when every impl returns the same one (monomorphic return —
;; e.g. all Scatter impls return a ScatterResult). Set by collect-pm-rets! before
;; the fixpoint, read by call-ret-type. A disagreeing impl widens it to :any.
(def ^:private pm-rets-box (atom {}))
;; build a per-run env: a snapshot of the installed config plus this run's flags
;; and fresh accumulator/guard cells. escapes/user-sigs reference the sweep-level
@ -110,18 +104,11 @@
;; declared hints so nested records stay typed
(record-type-from-entry rs type-depth shapes)
(let [r (get (get env :rtenv) (var-key fnode))]
(if r r
;; a protocol-method call types as its impls' joined return
;; (monomorphic): so (:ray (scatter m ..)) reads off a Ray.
(let [pm (get (get env :protocol-methods) (var-key fnode))
pmr (when pm (get @pm-rets-box (str (nth pm 0) "/" (nth pm 1))))]
(if (and pmr (not= pmr :any))
pmr
(let [nm (and (= "clojure.core" (get fnode :ns)) (get fnode :name))]
(cond (nil? nm) :any
(contains? num-ret-fns nm) :num
(contains? vector-ret-fns nm) (mk-vec :any)
:else :any))))))))
(if r r (let [nm (and (= "clojure.core" (get fnode :ns)) (get fnode :name))]
(cond (nil? nm) :any
(contains? num-ret-fns nm) :num
(contains? vector-ret-fns nm) (mk-vec :any)
:else :any))))))
(= op :host) (let [nm (get fnode :name)]
(cond (contains? num-ret-fns nm) :num
(contains? vector-ret-fns nm) (mk-vec :any)
@ -143,9 +130,6 @@
(defn- pred-on [pname t]
(cond
(or (= t :any) (= t :truthy)) nil
;; a nilable struct might be nil — nil?/some?/record? can't be proven, so the
;; runtime guard must stay (this is what makes the narrowing sound).
(nilable? t) nil
;; a bounded scalar union folds only when every member agrees
(union-type? t)
(let [vs (map (fn [m] (pred-on pname m)) (umembers t))]
@ -163,28 +147,6 @@
;; folds away (a wider purity analysis can broaden this later).
(defn- pure-node? [n] (let [op (get n :op)] (or (= op :const) (= op :local))))
;; Flow-sensitive nil narrowing: in (if (some? x) ..) / (if x ..) / (if (nil? x) ..)
;; a nilable-struct local x is proven non-nil in one branch, so its field reads
;; bare-index and unbox there. Only a nilable local narrows — nothing else changes.
(defn- test-local [test pred-name]
(when (= :invoke (get test :op))
(let [f (get test :fn) args (get test :args)]
(when (and (= :var (get f :op)) (= "clojure.core" (get f :ns))
(= pred-name (get f :name))
(= 1 (count args)) (= :local (get (nth args 0) :op)))
(get (nth args 0) :name)))))
(defn- narrow-nonnil [tenv nm]
(let [t (get tenv nm)] (if (nilable? t) (assoc tenv nm (strip-nilable t)) tenv)))
;; [then-tenv else-tenv] for an `if` whose test narrows a nilable local.
(defn- if-narrow [test tenv]
(let [somev (test-local test "some?")
nilv (test-local test "nil?")]
(cond
(= :local (get test :op)) [(narrow-nonnil tenv (get test :name)) tenv]
somev [(narrow-nonnil tenv somev) tenv]
nilv [tenv (narrow-nonnil tenv nilv)]
:else [tenv tenv])))
(declare infer)
;; infer (and infer-fn-seeded) return a [type node'] tuple — the result type plus
@ -193,22 +155,6 @@
(defn- ty [r] (nth r 0))
(defn- nd [r] (nth r 1))
;; Arg types for a self-recursive call. A same-position pass-through of the
;; enclosing param (arg i is the bare param i) contributes nil — the join identity —
;; instead of its type: it can't add information (param i ⊇ param i is trivial), but
;; its type is :any until external callers determine it, and :any is absorbing, so
;; collecting it would pin the param at :any forever (a recursive fn that threads a
;; param straight through, e.g. ray-cast passing `hittables` unchanged). A computed
;; arg, or a DIFFERENT param at this position, is a real constraint and is collected.
(defn- self-rec-argtys [args ares self-params]
(mapv (fn [i]
(let [a (nth args i)]
(if (and self-params (< i (count self-params))
(= :local (get a :op)) (= (get a :name) (nth self-params i)))
nil
(ty (nth ares i)))))
(range (count ares))))
;; arithmetic core ops that yield a flonum when their operands are flonums — a
;; mirror of jolt.passes.numeric/dbl-spec's arithmetic set, used to flow :double
;; across fn boundaries so a hintless fn whose callers all pass doubles is unboxed.
@ -359,15 +305,7 @@
callee-t (if iscall-var (get (get env :vtypes) (var-key fnode)) (ty fr))
ares (mapv (fn [a] (infer a tenv env)) args)]
(when iscall-var
;; a `defn` recurses through its own VAR, so a self-recursion is a var-call
;; here (not the :local case below). When the callee is the enclosing def,
;; drop same-position pass-through args so threading a param straight through
;; the recursion doesn't poison it to :any.
(swap! (get env :calls) conj
[(var-key fnode)
(if (= (var-key fnode) (get env :self-key))
(self-rec-argtys args ares (get env :self-params))
(mapv (fn [r] (ty r)) ares))]))
(swap! (get env :calls) conj [(var-key fnode) (mapv (fn [r] (ty r)) ares)]))
;; a named fn calling itself binds its name as a :local, so the recursion is
;; invisible to the var-call collection above — yet it constrains the fn's own
;; params. Collect it under the fn's var-key so the whole-program fixpoint joins
@ -375,8 +313,7 @@
;; callers alone and may be specialized to a type the recursion violates).
(when (and (= :local (get fnode :op)) (get env :self-key)
(= (get fnode :name) (get env :self-name)))
(swap! (get env :calls) conj
[(get env :self-key) (self-rec-argtys args ares (get env :self-params))]))
(swap! (get env :calls) conj [(get env :self-key) (mapv (fn [r] (ty r)) ares)]))
;; success-type check at this call, reusing the arg types just computed (jolt
;; audit): core error domains always, user-fn domains in strict mode.
(when (get env :checking?)
@ -448,8 +385,7 @@
(number? v) :num
(string? v) :str
(keyword? v) :kw
(nil? v) :nil ; a record|nil branch types as a nilable record
(= false v) :any ; false is not struct-eligible
(or (nil? v) (= false v)) :any ; nil/false are not struct-eligible
:else :truthy)) ; true, char, ... -> non-nil
node]
(= op :local)
@ -489,11 +425,9 @@
el (if (empty? ets) :any (reduce join (first ets) (rest ets)))]
[(cap (mk-set el) type-depth) (assoc node :items (mapv (fn [r] (nth r 1)) irs))])
(= op :if)
(let [test (get node :test)
tr (infer test tenv env)
nr (if-narrow test tenv) ; narrow a nilable local in the proven branch
thn (infer (get node :then) (nth nr 0) env)
els (infer (get node :else) (nth nr 1) env)]
(let [tr (infer (get node :test) tenv env)
thn (infer (get node :then) tenv env)
els (infer (get node :else) tenv env)]
[(join (nth thn 0) (nth els 0))
(assoc node :test (nth tr 1) :then (nth thn 1) :else (nth els 1))])
(= op :do)
@ -531,8 +465,7 @@
;; a fn-level recur (not inside a loop) rebinds the enclosing fn's params,
;; so its args constrain them like a self-call — collect under the fn key.
(when (and (not (get env :in-loop?)) (get env :self-key))
(swap! (get env :calls) conj
[(get env :self-key) (self-rec-argtys (get node :args) ares (get env :self-params))]))
(swap! (get env :calls) conj [(get env :self-key) (mapv (fn [r] (ty r)) ares)]))
[:any (assoc node :args (mapv (fn [r] (nd r)) ares))])
(= op :fn)
;; a closure inherits the enclosing tenv so CAPTURED locals keep their
@ -545,7 +478,7 @@
;; a nested closure resets the self/loop context: its own recur/self-call
;; targets IT, not the enclosing whole-program def, so it must not collect
;; into that def's param key.
(let [fenv (assoc env :self-name nil :self-key nil :self-params nil :in-loop? false)]
(let [fenv (assoc env :self-name nil :self-key nil :in-loop? false)]
[:any (assoc node :arities
(mapv (fn [a]
(let [shapes (get env :record-shapes)
@ -701,44 +634,12 @@
collected-escapes after a full sweep). With self-name/self-key, a recursive
self-call or fn-level recur in `body` is collected under self-key too, so a
self-recursive fn's params are constrained by its recursion, not just callers."
([body tenv] (infer-body body tenv nil nil nil))
([body tenv self-name self-key] (infer-body body tenv self-name self-key nil))
([body tenv self-name self-key self-params]
(let [env (assoc (mk-env false false)
:self-name self-name :self-key self-key :self-params self-params)
([body tenv] (infer-body body tenv nil nil))
([body tenv self-name self-key]
(let [env (assoc (mk-env false false) :self-name self-name :self-key self-key)
r (infer body tenv env)]
[(nth r 0) (nth r 1) @(get env :calls)])))
;; --- protocol-method return types -------------------------------------------
;; An impl is emitted as (register-(inline-)method TAG "Proto" "method" (fn ...)).
;; Its fn body's return type is one impl's contribution to the method's return; the
;; join over every impl is the method's return type (monomorphic when all agree).
(defn- impl-reg-ret [node]
(when (= :invoke (get node :op))
(let [f (get node :fn) args (get node :args)]
(when (and (= :var (get f :op))
(or (= "register-inline-method" (get f :name))
(= "register-method" (get f :name)))
(= 4 (count args)))
(let [proto (get (nth args 1) :val)
method (get (nth args 2) :val)
fnn (nth args 3)]
(when (and (string? proto) (string? method)
(= :fn (get fnn :op)) (seq (get fnn :arities)))
[(str proto "/" method)
(nth (infer-body (get (first (get fnn :arities)) :body) {}) 0)]))))))
(defn- walk-pm-rets [node acc]
(let [kr (impl-reg-ret node)
acc (if kr (update acc (nth kr 0) (fn [t] (if t (join t (nth kr 1)) (nth kr 1)))) acc)]
(reduce-ir-children (fn [a c] (walk-pm-rets c a)) acc node)))
(defn collect-pm-rets!
"Scan the unit's nodes for protocol-method impl registrations and stash each
method's joined impl-return type (record-shapes must already be installed)."
[nodes]
(reset! pm-rets-box (reduce (fn [acc n] (walk-pm-rets n acc)) {} nodes)))
(defn reinfer-def
"Re-run inference on a stashed :def's fn arity bodies with param types seeded
(ptmap: param-name -> type), returning the def with annotated bodies. The back
@ -851,7 +752,7 @@
(let [k (when (= :def (get node :op)) (str (get node :ns) "/" (get node :name)))
s (and k (get spec k))]
(if s
(let [r (infer-body (:body s) (zipmap (:params s) (get ptypes k)) (:name s) k (:params s))]
(let [r (infer-body (:body s) (zipmap (:params s) (get ptypes k)) (:name s) k)]
(-> acc (assoc-in [:rets k] (nth r 0))
(update :ptypes wp-accum spec (nth r 2))))
(update acc :ptypes wp-accum spec (nth (infer-body node {}) 2)))))
@ -863,7 +764,6 @@
record-shapes / protocol-methods must already be installed. Idempotent resets
the seed box; called once per build before per-form emit."
[nodes]
(collect-pm-rets! nodes)
(let [spec (wp-specializable nodes)
ks (keys spec)]
(loop [iter 0 ptypes (wp-empty-ptypes spec ks) rets {}]

View file

@ -79,15 +79,6 @@
(= a b) a
(nil? a) b
(nil? b) a
;; :nil is the type of a literal nil. With a struct it forms a NILABLE struct —
;; field reads still bare-index (jrec-field-at falls back to jolt-get on nil), but
;; some?/nil? won't fold and a guard narrows it back to non-nil. With anything
;; else it widens to :any (nil is not a safe scalar/vec — no fl/fx, no bare elem).
(or (= a :nil) (= b :nil))
(let [o (if (= a :nil) b a)]
(cond (= o :nil) :nil
(struct-type? o) (assoc o :nilable true)
:else :any))
;; :double is a flonum refinement of :num: two doubles stay :double (caught by
;; = above), but a double joined with anything else loses the flonum guarantee
;; and widens to :num before joining — so a param is :double only when EVERY
@ -95,18 +86,13 @@
(or (= a :double) (= b :double))
(join-t (if (= a :double) :num a) (if (= b :double) :num b))
(and (struct-type? a) (struct-type? b))
(let [merged (mk-struct (merge-fields (sfields a) (sfields b)))
;; joining two values of the SAME complete shape / record type preserves
;; it — the merged struct has the same key set. Different shapes/types
;; (or an incomplete side) drop it, as the layout is no longer proven.
merged (if (and (get a :shape) (= (get a :shape) (get b :shape)))
(assoc merged :shape (get a :shape)) merged)
merged (if (and (get a :type) (= (get a :type) (get b :type)))
(assoc merged :type (get a :type)) merged)
;; nilability is contagious: a nilable side makes the join nilable.
merged (if (or (get a :nilable) (get b :nilable))
(assoc merged :nilable true) merged)]
merged)
(let [merged (mk-struct (merge-fields (sfields a) (sfields b)))]
;; joining two values of the SAME complete shape preserves it — the
;; merged struct has the same key set. Different shapes
;; (or an incomplete side) drop it, as the layout is no longer proven.
(if (and (get a :shape) (= (get a :shape) (get b :shape)))
(assoc merged :shape (get a :shape))
merged))
(and (vec-type? a) (vec-type? b)) (mk-vec (join-t (velem a) (velem b)))
(and (set-type? a) (set-type? b)) (mk-set (join-t (selem a) (selem b)))
;; differing kinds: form a scalar union when both sides reduce to scalars
@ -141,12 +127,7 @@
;; raw-get-safe (a struct / record): a struct type. The field type of key
;; k, if known, else :any.
(defn struct-safe? [t] (struct-type? t))
;; a nilable struct yields :any for every field (the whole value might be nil, so a
;; field read can be nil) — conservative + sound. A guard narrows it to non-nil first
;; (strip-nilable), after which the real field types flow.
(defn field-type [t k] (if (and (struct-type? t) (not (get t :nilable))) (get (sfields t) k :any) :any))
(defn nilable? [t] (and (map? t) (get t :nilable) true))
(defn strip-nilable [t] (if (and (map? t) (get t :nilable)) (dissoc t :nilable) t))
(defn field-type [t k] (if (struct-type? t) (get (sfields t) k :any) :any))
;; Shape (hidden class). A struct type built from a map LITERAL carries
;; its complete layout — :shape, the canonical (str-sorted) key vector. The back
;; end represents such a map as a shape tuple and reads a field by bare index.
@ -171,8 +152,7 @@
;; only when all its values have such a type. Collections are non-nil.
(defn truthy-type? [t]
(or (= t :num) (= t :double) (= t :str) (= t :kw) (= t :truthy) (= t :phm)
(and (struct-type? t) (not (get t :nilable))) ; a nilable struct may be nil
(vec-type? t) (set-type? t)))
(struct-type? t) (vec-type? t) (set-type? t)))
;; core fns whose result is a number (so it is non-nil/non-false and, for the
;; success-type checker, provably numeric).

View file

@ -1,667 +0,0 @@
;; clojure.core.async — higher-level dataflow API over the channel primitives.
;;
;; The primitives (chan, <!, >!, <!!, >!!, close!, put!, take!, offer!, timeout,
;; promise-chan, buffer/dropping-buffer/sliding-buffer, go/go-loop/thread, go-spawn)
;; are provided natively (host/chez/java/async.ss) on real OS threads. This overlay
;; adds the portable dataflow operators — alts!, pipe, pipeline, split, reduce,
;; transduce, mult, mix, pub/sub, map, merge, and the deprecated map</map>/… —
;; ported from clojure.core.async over those primitives. Because go blocks are real
;; threads, parking ops are ordinary blocking ops and work anywhere; this is a
;; superset of the JVM model (no fixed thread pool, no pending-op limit).
(ns clojure.core.async
(:refer-clojure :exclude [reduce transduce into merge map take partition partition-by]))
;; --- alts -------------------------------------------------------------------
;; do-alts polls each port non-blockingly under its own channel lock; the first
;; ready op wins. A take port is ready when a value (or closed nil) is available;
;; a put spec [ch val] is ready when the value can be offered. Polls with a 1ms
;; backoff (no cross-channel wait-set).
(defn- alt-attempt [port]
(if (vector? port)
(let [ch (nth port 0) v (nth port 1)]
(assert (some? v) "Can't put nil on channel")
(let [r (clojure.core.async/__offer! ch v)] ; true | false (closed) | nil (would block)
(when (some? r) [r ch])))
(let [r (clojure.core.async/__poll! port)] ; value | nil (closed) | ::none
(when (not= r ::none) [r port]))))
(defn do-alts
"Returns [val port] for the first ready op among ports. ports is a vector of
take ports and/or [channel val] put specs. opts may include :priority true
(try in order) and :default val (return [val :default] if none ready)."
[ports opts]
(assert (pos? (count ports)) "alts must have at least one channel operation")
(let [ports (vec ports)
n (count ports)
priority (:priority opts)
has-default (contains? opts :default)]
;; Scan ports from a random start (sequential, wrapping) so a non-priority alts
;; is fair without allocating a fresh shuffle every poll. With :priority the scan
;; starts at 0 (declared order). Returns the first ready op.
(loop [first? true]
(let [start (if priority 0 (rand-int n))
hit (loop [k 0]
(when (< k n)
(let [j (+ start k) i (if (< j n) j (- j n))]
(or (alt-attempt (nth ports i))
(recur (inc k))))))]
(cond
hit hit
(and first? has-default) [(:default opts) :default]
:else (do (Thread/sleep 1) (recur false)))))))
(defn alts!!
"Completes at most one of several channel operations. ports is a vector of take
ports and/or [channel val] put specs. Returns [val port]. Blocks until ready."
[ports & {:as opts}]
(do-alts ports opts))
(defn alts!
"Like alts!!. In jolt a go block is a real thread, so parking and blocking alts
are the same operation."
[ports & {:as opts}]
(do-alts ports opts))
(defn poll!
"Takes a val from port if possible immediately. Never blocks. Returns the value
or nil."
[port]
(let [r (clojure.core.async/__poll! port)]
(when (not= r ::none) r)))
;; --- thread variants --------------------------------------------------------
(defn thread-call
"Executes f in another thread, returning a channel that receives f's result then
closes."
([f] (clojure.core.async/go-spawn f))
([f _workload] (clojure.core.async/go-spawn f)))
(defmacro io-thread
"Executes body in another thread, returning a channel that receives the result
then closes."
[& body]
`(thread-call (fn [] ~@body) :io))
;; --- pipe / pipeline --------------------------------------------------------
(defn pipe
"Takes elements from the from channel and supplies them to the to channel.
Closes to when from closes unless close? is false."
([from to] (pipe from to true))
([from to close?]
(go-loop []
(let [v (<! from)]
(if (nil? v)
(when close? (close! to))
(when (>! to v)
(recur)))))
to))
(defn- pipeline*
[n to xf from close? ex-handler type]
(assert (pos? n))
(let [jobs (chan n)
results (chan n)
process (fn [job]
(if (nil? job)
(do (close! results) nil)
(let [v (nth job 0) p (nth job 1)
res (chan 1 xf ex-handler)]
(>!! res v)
(close! res)
(put! p res)
true)))
afn (fn [job]
(if (nil? job)
(do (close! results) nil)
(let [v (nth job 0) p (nth job 1)
res (chan 1)]
(xf v res)
(put! p res)
true)))]
(dotimes [_ n]
(case type
(:blocking :compute) (thread
(loop []
(let [job (<!! jobs)]
(when (process job)
(recur)))))
:async (go-loop []
(let [job (<! jobs)]
(when (afn job)
(recur))))))
(go-loop []
(let [v (<! from)]
(if (nil? v)
(close! jobs)
(let [p (chan 1)]
(>! jobs [v p])
(>! results p)
(recur)))))
(go-loop []
(let [p (<! results)]
(if (nil? p)
(when close? (close! to))
(let [res (<! p)]
(loop []
(let [v (<! res)]
(when (and (not (nil? v)) (>! to v))
(recur))))
(recur)))))))
(defn pipeline
"Takes elements from from, applies transducer xf with parallelism n, supplies to
to. Outputs are ordered relative to inputs."
([n to xf from] (pipeline n to xf from true))
([n to xf from close?] (pipeline n to xf from close? nil))
([n to xf from close? ex-handler] (pipeline* n to xf from close? ex-handler :compute)))
(defn pipeline-blocking
"Like pipeline, for blocking operations."
([n to xf from] (pipeline-blocking n to xf from true))
([n to xf from close?] (pipeline-blocking n to xf from close? nil))
([n to xf from close? ex-handler] (pipeline* n to xf from close? ex-handler :blocking)))
(defn pipeline-async
"Like pipeline, for async fns af of two args [input result-channel]."
([n to af from] (pipeline-async n to af from true))
([n to af from close?] (pipeline* n to af from close? nil :async)))
(defn split
"Splits ch by predicate p into [true-chan false-chan]."
([p ch] (split p ch nil nil))
([p ch t-buf-or-n f-buf-or-n]
(let [tc (chan t-buf-or-n)
fc (chan f-buf-or-n)]
(go-loop []
(let [v (<! ch)]
(if (nil? v)
(do (close! tc) (close! fc))
(when (>! (if (p v) tc fc) v)
(recur)))))
[tc fc])))
;; --- reduce / transduce / collection sinks ----------------------------------
(defn reduce
"Returns a channel with the single result of reducing ch with f from init."
[f init ch]
(go-loop [ret init]
(let [v (<! ch)]
(if (nil? v)
ret
(let [ret' (f ret v)]
(if (reduced? ret')
@ret'
(recur ret')))))))
(defn transduce
"async/reduces ch with the transformation (xform f), returning a channel with the
result."
[xform f init ch]
(let [f (xform f)]
(go
(let [ret (<! (reduce f init ch))]
(f ret)))))
(defn- bounded-count [n coll]
(if (counted? coll)
(min n (count coll))
(loop [i 0 s (seq coll)]
(if (and s (< i n))
(recur (inc i) (next s))
i))))
(defn onto-chan!
"Puts the contents of coll into ch, closing ch after unless close? is false.
Returns a channel that closes when done."
([ch coll] (onto-chan! ch coll true))
([ch coll close?]
(go-loop [vs (seq coll)]
(if (and vs (>! ch (first vs)))
(recur (next vs))
(when close?
(close! ch))))))
(defn to-chan!
"Returns a channel containing the contents of coll, closing when exhausted."
[coll]
(let [c (bounded-count 100 coll)]
(if (pos? c)
(let [ch (chan c)]
(onto-chan! ch coll)
ch)
(let [ch (chan)]
(close! ch)
ch))))
(defn onto-chan!!
"Like onto-chan! for use when accessing coll might block."
([ch coll] (onto-chan!! ch coll true))
([ch coll close?]
(thread
(loop [vs (seq coll)]
(if (and vs (>!! ch (first vs)))
(recur (next vs))
(when close?
(close! ch)))))))
(defn to-chan!!
"Like to-chan! for use when accessing coll might block."
[coll]
(let [c (bounded-count 100 coll)]
(if (pos? c)
(let [ch (chan c)]
(onto-chan!! ch coll)
ch)
(let [ch (chan)]
(close! ch)
ch))))
(defn onto-chan
"Deprecated - use onto-chan! or onto-chan!!"
([ch coll] (onto-chan! ch coll true))
([ch coll close?] (onto-chan! ch coll close?)))
(defn to-chan
"Deprecated - use to-chan! or to-chan!!"
[coll]
(to-chan! coll))
(defn into
"Returns a channel with the single collection result of conjoining items from ch
onto coll. ch must close first."
[coll ch]
(reduce conj coll ch))
(defn take
"Returns a channel that returns at most n items from ch, then closes."
([n ch] (take n ch nil))
([n ch buf-or-n]
(let [out (chan buf-or-n)]
(go (loop [x 0]
(when (< x n)
(let [v (<! ch)]
(when (not (nil? v))
(>! out v)
(recur (inc x))))))
(close! out))
out)))
;; --- mult / tap -------------------------------------------------------------
(defprotocol Mux
(muxch* [_]))
(defprotocol Mult
(tap* [m ch close?])
(untap* [m ch])
(untap-all* [m]))
(defn mult
"Creates a mult of ch. Copies can be created with tap and removed with untap.
Each item is distributed to all taps synchronously."
[ch]
(let [cs (atom {})
m (reify
Mux
(muxch* [_] ch)
Mult
(tap* [_ ch close?] (swap! cs assoc ch close?) nil)
(untap* [_ ch] (swap! cs dissoc ch) nil)
(untap-all* [_] (reset! cs {}) nil))
dchan (chan 1)
dctr (atom nil)
done (fn [_] (when (zero? (swap! dctr dec))
(put! dchan true)))]
(go-loop []
(let [val (<! ch)]
(if (nil? val)
(doseq [[c close?] @cs]
(when close? (close! c)))
(let [chs (keys @cs)]
(reset! dctr (count chs))
(doseq [c chs]
(when-not (put! c val done)
(untap* m c)))
(when (seq chs)
(<! dchan))
(recur)))))
m))
(defn tap
"Copies the mult source onto ch. Closes ch when the source closes unless close?
is false."
([mult ch] (tap mult ch true))
([mult ch close?] (tap* mult ch close?) ch))
(defn untap
"Disconnects ch from a mult."
[mult ch]
(untap* mult ch))
(defn untap-all
"Disconnects all channels from a mult."
[mult]
(untap-all* mult))
;; --- mix --------------------------------------------------------------------
(defprotocol Mix
(admix* [m ch])
(unmix* [m ch])
(unmix-all* [m])
(toggle* [m state-map])
(solo-mode* [m mode]))
(defn mix
"Creates a mix of input channels put onto out. Inputs are added with admix,
removed with unmix, and toggled (:mute/:pause/:solo) with toggle."
[out]
(let [cs (atom {})
solo-modes #{:mute :pause}
solo-mode (atom :mute)
change (chan (sliding-buffer 1))
changed #(put! change true)
pick (fn [attr chs]
(reduce-kv
(fn [ret c v]
(if (attr v) (conj ret c) ret))
#{} chs))
calc-state (fn []
(let [chs @cs
mode @solo-mode
solos (pick :solo chs)
pauses (pick :pause chs)]
{:solos solos
:mutes (pick :mute chs)
:reads (conj
(if (and (= mode :pause) (seq solos))
(vec solos)
(vec (remove pauses (keys chs))))
change)}))
m (reify
Mux
(muxch* [_] out)
Mix
(admix* [_ ch] (swap! cs assoc ch {}) (changed))
(unmix* [_ ch] (swap! cs dissoc ch) (changed))
(unmix-all* [_] (reset! cs {}) (changed))
(toggle* [_ state-map] (swap! cs (partial merge-with clojure.core/merge) state-map) (changed))
(solo-mode* [_ mode]
(assert (solo-modes mode) (str "mode must be one of: " solo-modes))
(reset! solo-mode mode)
(changed)))]
(go-loop [state (calc-state)]
(let [{:keys [solos mutes reads]} state
[v c] (alts! reads)]
(if (or (nil? v) (= c change))
(do (when (nil? v)
(swap! cs dissoc c))
(recur (calc-state)))
(if (or (solos c)
(and (empty? solos) (not (mutes c))))
(when (>! out v)
(recur state))
(recur state)))))
m))
(defn admix
"Adds ch as an input to the mix."
[mix ch]
(admix* mix ch))
(defn unmix
"Removes ch as an input to the mix."
[mix ch]
(unmix* mix ch))
(defn unmix-all
"Removes all inputs from the mix."
[mix]
(unmix-all* mix))
(defn toggle
"Atomically sets the state of one or more channels in a mix."
[mix state-map]
(toggle* mix state-map))
(defn solo-mode
"Sets the solo mode of the mix (:mute or :pause)."
[mix mode]
(solo-mode* mix mode))
;; --- pub / sub --------------------------------------------------------------
(defprotocol Pub
(sub* [p v ch close?])
(unsub* [p v ch])
(unsub-all* [p] [p v]))
(defn pub
"Creates a pub of ch partitioned by topic-fn. Subscribe with sub."
([ch topic-fn] (pub ch topic-fn (constantly nil)))
([ch topic-fn buf-fn]
(let [mults (atom {})
ensure-mult (fn [topic]
(or (get @mults topic)
(get (swap! mults
#(if (% topic) % (assoc % topic (mult (chan (buf-fn topic))))))
topic)))
p (reify
Mux
(muxch* [_] ch)
Pub
(sub* [_p topic ch close?]
(let [m (ensure-mult topic)]
(tap m ch close?)))
(unsub* [_p topic ch]
(when-let [m (get @mults topic)]
(untap m ch)))
(unsub-all* [_] (reset! mults {}))
(unsub-all* [_ topic] (swap! mults dissoc topic)))]
(go-loop []
(let [val (<! ch)]
(if (nil? val)
(doseq [m (vals @mults)]
(close! (muxch* m)))
(let [topic (topic-fn val)
m (get @mults topic)]
(when m
(when-not (>! (muxch* m) val)
(swap! mults dissoc topic)))
(recur)))))
p)))
(defn sub
"Subscribes ch to a topic of pub p."
([p topic ch] (sub p topic ch true))
([p topic ch close?] (sub* p topic ch close?)))
(defn unsub
"Unsubscribes ch from a topic of pub p."
[p topic ch]
(unsub* p topic ch))
(defn unsub-all
"Unsubscribes all channels from a pub, or from a topic."
([p] (unsub-all* p))
([p topic] (unsub-all* p topic)))
;; --- map / merge ------------------------------------------------------------
(defn map
"Applies f to the set of first items from each source channel, then second, etc.
Closes the output channel when any source closes."
([f chs] (map f chs nil))
([f chs buf-or-n]
(let [chs (vec chs)
out (chan buf-or-n)
cnt (count chs)
rets (atom (vec (repeat cnt nil)))
dchan (chan 1)
dctr (atom nil)
done (mapv (fn [i]
(fn [ret]
(swap! rets assoc i ret)
(when (zero? (swap! dctr dec))
(put! dchan @rets))))
(range cnt))]
(if (zero? cnt)
(close! out)
(go-loop []
(reset! dctr cnt)
(dotimes [i cnt]
(take! (nth chs i) (nth done i)))
(let [rets (<! dchan)]
(if (some nil? rets)
(close! out)
(do (>! out (apply f rets))
(recur))))))
out)))
(defn merge
"Returns a channel with all values taken from the source channels chs. Closes
after all sources close."
([chs] (merge chs nil))
([chs buf-or-n]
(let [out (chan buf-or-n)]
(go-loop [cs (vec chs)]
(if (pos? (count cs))
(let [[v c] (alts! cs)]
(if (nil? v)
(recur (filterv #(not= c %) cs))
(do (>! out v)
(recur cs))))
(close! out)))
out)))
;; --- deprecated channel ops (rewritten as go-loops) -------------------------
(defn map<
"Deprecated - use a transducer. Returns a read-side channel mapping f over ch."
[f ch]
(let [out (chan)]
(go-loop []
(let [v (<! ch)]
(if (nil? v) (close! out) (do (>! out (f v)) (recur)))))
out))
(defn map>
"Deprecated - use a transducer. Returns a write-side channel mapping f into out."
[f out]
(let [in (chan)]
(go-loop []
(let [v (<! in)]
(if (nil? v) (close! out) (do (>! out (f v)) (recur)))))
in))
(defn filter<
"Deprecated - use a transducer."
([p ch] (filter< p ch nil))
([p ch buf-or-n]
(let [out (chan buf-or-n)]
(go-loop []
(let [val (<! ch)]
(if (nil? val)
(close! out)
(do (when (p val) (>! out val))
(recur)))))
out)))
(defn remove<
"Deprecated - use a transducer."
([p ch] (remove< p ch nil))
([p ch buf-or-n] (filter< (complement p) ch buf-or-n)))
(defn filter>
"Deprecated - use a transducer."
[p out]
(let [in (chan)]
(go-loop []
(let [v (<! in)]
(if (nil? v)
(close! out)
(do (when (p v) (>! out v))
(recur)))))
in))
(defn remove>
"Deprecated - use a transducer."
[p out]
(filter> (complement p) out))
(defn- mapcat* [f in out]
(go-loop []
(let [val (<! in)]
(if (nil? val)
(close! out)
(do (doseq [v (f val)]
(>! out v))
(recur))))))
(defn mapcat<
"Deprecated - use a transducer."
([f in] (mapcat< f in nil))
([f in buf-or-n]
(let [out (chan buf-or-n)]
(mapcat* f in out)
out)))
(defn mapcat>
"Deprecated - use a transducer."
([f out] (mapcat> f out nil))
([f out buf-or-n]
(let [in (chan buf-or-n)]
(mapcat* f in out)
in)))
(defn unique
"Deprecated - use a transducer. Drops consecutive duplicates."
([ch] (unique ch nil))
([ch buf-or-n]
(let [out (chan buf-or-n)]
(go (loop [last nil]
(let [v (<! ch)]
(when (not (nil? v))
(if (= v last)
(recur last)
(do (>! out v)
(recur v))))))
(close! out))
out)))
(defn partition
"Deprecated - use a transducer. Partitions ch into vectors of n."
([n ch] (partition n ch nil))
([n ch buf-or-n]
(let [out (chan buf-or-n)]
(go-loop [arr [] idx 0]
(let [v (<! ch)]
(if (not (nil? v))
(let [arr (conj arr v) new-idx (inc idx)]
(if (< new-idx n)
(recur arr new-idx)
(do (>! out arr) (recur [] 0))))
(do (when (> idx 0) (>! out arr))
(close! out)))))
out)))
(defn partition-by
"Deprecated - use a transducer. Partitions ch by runs of (f v)."
([f ch] (partition-by f ch nil))
([f ch buf-or-n]
(let [out (chan buf-or-n)]
(go-loop [lst [] last ::nothing]
(let [v (<! ch)]
(if (not (nil? v))
(let [new-itm (f v)]
(if (or (= new-itm last) (identical? last ::nothing))
(recur (conj lst v) new-itm)
(do (>! out lst) (recur [v] new-itm))))
(do (when (> (count lst) 0) (>! out lst))
(close! out)))))
out)))

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