Compare commits
No commits in common. "main" and "improved-error-handling" have entirely different histories.
main
...
improved-e
90 changed files with 4950 additions and 8790 deletions
135
.github/workflows/release.yml
vendored
135
.github/workflows/release.yml
vendored
|
|
@ -12,7 +12,6 @@ on:
|
|||
push:
|
||||
tags:
|
||||
- 'v*'
|
||||
workflow_dispatch: {} # dry-run the build matrix without tagging
|
||||
|
||||
permissions:
|
||||
contents: write # create/update the GitHub Release and upload assets
|
||||
|
|
@ -27,18 +26,10 @@ jobs:
|
|||
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-13
|
||||
target: x86_64-macos
|
||||
- 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:
|
||||
|
|
@ -87,65 +78,6 @@ jobs:
|
|||
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
|
||||
|
||||
|
|
@ -154,19 +86,6 @@ jobs:
|
|||
# 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
|
||||
|
|
@ -174,63 +93,21 @@ jobs:
|
|||
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 target/release/joltc "dist/${name}/joltc"
|
||||
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
|
||||
tar -C dist -czf "dist/${name}.tar.gz" "${name}"
|
||||
( cd dist && shasum -a 256 "${name}.tar.gz" > "${name}.tar.gz.sha256" )
|
||||
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
|
||||
fail_on_unmatched_files: true
|
||||
|
|
|
|||
6
.github/workflows/tests.yml
vendored
6
.github/workflows/tests.yml
vendored
|
|
@ -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
|
||||
|
||||
|
|
|
|||
3
.gitmodules
vendored
3
.gitmodules
vendored
|
|
@ -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
|
||||
|
|
|
|||
22
Makefile
22
Makefile
|
|
@ -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 protoret narrow directlink numeric inline shakesmoke remint joltc joltc-release joltc-debug joltcsmoke
|
||||
|
||||
# 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 protoret narrow directlink numeric inline certify
|
||||
@echo "OK: CI gates passed"
|
||||
|
||||
# Self-host fixpoint: bootstrap.ss rebuild == checked-in seed.
|
||||
|
|
@ -47,11 +42,6 @@ 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
|
||||
|
|
@ -73,12 +63,6 @@ joltcsmoke:
|
|||
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:
|
||||
|
|
|
|||
37
README.md
37
README.md
|
|
@ -7,31 +7,6 @@ Jolt reads Clojure source, analyzes it to a host-neutral IR, emits Scheme, and
|
|||
runs it on Chez. The compiler is self-hosted: it is written in Clojure
|
||||
(`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:
|
||||
|
|
|
|||
25
bin/joltc
25
bin/joltc
|
|
@ -14,28 +14,5 @@
|
|||
# JOLT_PWD.
|
||||
root="$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd)"
|
||||
export JOLT_PWD="${JOLT_PWD:-$PWD}"
|
||||
|
||||
# Identify the Chez Scheme executable
|
||||
while read -r CHEZ
|
||||
do
|
||||
if [ `which ${CHEZ}` ]
|
||||
then
|
||||
break;
|
||||
fi
|
||||
done <<EOF
|
||||
chez
|
||||
chezscheme
|
||||
EOF
|
||||
|
||||
# If we failed to find one, whinge and exit.
|
||||
if [ ! `which ${CHEZ}` ]
|
||||
then
|
||||
echo "No valid Chez Scheme executable found: please install Chez Scheme."
|
||||
exit 1
|
||||
fi
|
||||
|
||||
# Version for --version / banners: git describe of this checkout, else "dev".
|
||||
export JOLT_VERSION="${JOLT_VERSION:-$(git -C "$root" describe --tags --always --dirty 2>/dev/null || echo dev)}"
|
||||
cd "$root" || exit 1
|
||||
exec ${CHEZ} --script host/chez/cli.ss "$@"
|
||||
|
||||
exec chez --script host/chez/cli.ss "$@"
|
||||
|
|
|
|||
|
|
@ -240,32 +240,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).
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -70,11 +72,6 @@ e.g. the [ring-app example](https://github.com/jolt-lang/examples/tree/main/ring
|
|||
[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
|
||||
|
|
|
|||
|
|
@ -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 1–12, day valid
|
||||
for the month including leap years, hour < 24, minute < 60); `#uuid`
|
||||
demands canonical 8-4-4-4-12 hex.
|
||||
|
||||
clojure.edn adds on top of that (`__read-form-edn` seam): auto-resolved
|
||||
keywords (`::k`) are invalid (no resolution context), each `#_` discarded
|
||||
form is validated through the same `:readers`/`:default` pipeline (an
|
||||
unreadable tagged element throws even when discarded), `M` literals
|
||||
construct BigDecimals, lists satisfy `list?`, and end-of-input honors the
|
||||
`:eof` option — an opts map without `:eof` makes EOF an error, while the
|
||||
no-opts arity returns nil.
|
||||
|
|
|
|||
|
|
@ -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**
|
||||
|
||||
S1–S3 → `test/chez/clojure-test.clj` (are with quoted template var);
|
||||
clojure-test-suite `core_test/special_symbol_qmark.cljc` and every
|
||||
`are`-based suite namespace.
|
||||
|
||||
---
|
||||
|
||||
### make-hierarchy, derive, underive, isa?, parents, ancestors, descendants — since 1.0
|
||||
|
||||
```
|
||||
(make-hierarchy)
|
||||
(derive tag parent) (derive h tag parent)
|
||||
(underive tag parent) (underive h tag parent)
|
||||
(isa? child parent) (isa? h child parent)
|
||||
(parents tag) (ancestors tag) (descendants tag) ; + (f h tag) forms
|
||||
```
|
||||
|
||||
**Semantics**
|
||||
|
||||
- S1. A hierarchy is a pure value `{:parents {tag #{...}} :ancestors {...}
|
||||
:descendants {...}}`; the 3-arity forms are pure, the shorter arities read and
|
||||
mutate the global hierarchy.
|
||||
- S2. `isa?` is true when `(= child parent)`, when the host type system says
|
||||
parent is assignable from child (both classes), when the relationship was
|
||||
`derive`d — including a relationship derived on one of a class child's
|
||||
supers — or component-wise for equal-length vectors.
|
||||
- S3. Class tags answer through the host type hierarchy: `(parents c)` includes
|
||||
the class's direct supers (`bases` — a concrete class's chain roots at
|
||||
`java.lang.Object`, an interface's does not); `(ancestors c)` is the
|
||||
transitive set plus anything `derive`d on the class or its supers. A
|
||||
deftype/defrecord class's ancestry includes its implemented protocol
|
||||
interfaces and, for records, the record interfaces
|
||||
(`clojure.lang.IRecord`/`IPersistentMap`/`Associative`/…; `clojure.lang.IType`
|
||||
for a bare deftype).
|
||||
- S4. `derive` returns the updated hierarchy (3-arity) or nil (2-arity);
|
||||
deriving a relationship that already holds transitively, or one that would
|
||||
create a cycle, throws.
|
||||
|
||||
**Errors**
|
||||
|
||||
- X1. `derive` asserts its argument shapes: parent must be a namespaced Named
|
||||
value; tag must be a class or a Named value (namespaced in the 2-arity
|
||||
global form); `(derive h tag tag)` fails the `not=` assert. AssertionError.
|
||||
- X2. `underive`/`derive` with a non-hierarchy `h` throw at the parents
|
||||
lookup (the map is called as a function, like the reference).
|
||||
- X3. `(descendants h SomeClass)` throws UnsupportedOperationException
|
||||
("Can't get descendants of classes") — Java type inheritance is not
|
||||
enumerable downward.
|
||||
|
||||
**Conformance**
|
||||
|
||||
S1–S4, X1–X3 → corpus `hierarchy / *` rows; clojure-test-suite
|
||||
`core_test/{derive,underive,isa_…,parents,ancestors,descendants}.cljc`
|
||||
(all fully passing).
|
||||
|
||||
---
|
||||
|
||||
### atom, add-watch, remove-watch, set-validator!, get-validator — since 1.0
|
||||
|
||||
```
|
||||
(atom x & {:keys [meta validator]})
|
||||
(add-watch iref key f) (remove-watch iref key)
|
||||
(set-validator! iref f) (get-validator iref)
|
||||
```
|
||||
|
||||
**Semantics**
|
||||
|
||||
- S1. Watches, validators, and reference metadata are one contract (the JVM's
|
||||
ARef/IRef) shared by atoms, vars, and agents. `add-watch`/`remove-watch`
|
||||
return the reference; re-adding a key replaces that watch in place.
|
||||
- S2. A watch is called `(f key ref old new)` after a state change: atom
|
||||
swap!/reset!/compare-and-set!, var ROOT changes (`def` on a watched var,
|
||||
`var-set` outside a thread binding, `alter-var-root` — a thread-binding set
|
||||
does not notify), and each agent action's state change.
|
||||
- S3. A validator gates every state change and, via the `:validator` ctor
|
||||
option, the initial value — an invalid initial value never constructs the
|
||||
reference.
|
||||
- S4. The `:meta` ctor option attaches reference metadata (`meta` reads it,
|
||||
`alter-meta!`/`reset-meta!` update it); nil is allowed.
|
||||
|
||||
**Errors**
|
||||
|
||||
- X1. A rejected value (validator returns logical false or the ctor option
|
||||
fails on the initial value) throws IllegalStateException "Invalid reference
|
||||
state".
|
||||
- X2. A non-map `:meta` ctor option throws ClassCastException.
|
||||
|
||||
**Conformance**
|
||||
|
||||
S1–S4, X1–X2 → corpus `iref / *` rows; clojure-test-suite
|
||||
`core_test/{atom,add-watch,remove-watch}.cljc` (the remaining baselined error
|
||||
in the watch namespaces is their STM `ref` section — refs are out of scope,
|
||||
`stm-refs` in `coverage.md`).
|
||||
|
||||
---
|
||||
|
||||
### clojure.string coercion, some-fn, ifn? — since 1.2/1.3
|
||||
|
||||
```
|
||||
(clojure.string/upper-case s) … (some-fn p & ps) (ifn? x)
|
||||
```
|
||||
|
||||
**Semantics**
|
||||
|
||||
- S1. The clojure.string case fns and searches (`upper-case`, `lower-case`,
|
||||
`capitalize`, `starts-with?`, `ends-with?`, `includes?`, `index-of`,
|
||||
`replace`) take any Object `s` through its `toString`, like the reference's
|
||||
`^CharSequence`+`.toString` signatures: `(upper-case :kw)` is `":KW"`,
|
||||
`(capitalize 1)` is `"1"`. nil throws (method call on null); a nil `substr`
|
||||
throws.
|
||||
- S2. `some-fn` follows the reference arities: at least one predicate
|
||||
(`(some-fn)` is an arity error) and the returned fn chains with `or`, so a
|
||||
no-match result is the last predicate's own falsy value (`false` stays
|
||||
`false`).
|
||||
- S3. `ifn?` covers fns, keywords, symbols, maps, sets, vectors, vars,
|
||||
multimethods, promises (invoking a promise delivers it), and a
|
||||
deftype/defrecord implementing `clojure.lang.IFn`'s `invoke`.
|
||||
- S4. A `defmulti`/`defmethod` deferred inside a fn body interns/resolves in
|
||||
the namespace it was WRITTEN in (the macros bake their expansion ns), not
|
||||
whatever namespace is current when it runs.
|
||||
|
||||
**Conformance**
|
||||
|
||||
S1–S4 → corpus `string / toString coercion`, `core / some-fn`, `core / ifn?`,
|
||||
`multimethods / deferred definition`; clojure-test-suite string/some-fn/
|
||||
ifn-qmark/boolean-qmark/reduce namespaces (all fully passing).
|
||||
|
||||
---
|
||||
|
||||
## Authoring notes
|
||||
|
||||
- Source examples from the ClojureDocs export (`clojuredocs-export.edn`,
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -46,15 +46,6 @@
|
|||
(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 "'"))
|
||||
|
|
@ -89,32 +80,6 @@
|
|||
(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
|
||||
|
|
@ -136,19 +101,17 @@
|
|||
(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\")))))
|
||||
(\"stub/launcher\" \"jolt_stub\" \"jolt_stub_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)))
|
||||
(guard (v (#t (jolt-report-throwable v (current-error-port))
|
||||
(let ((bt (jolt-backtrace-string v)))
|
||||
(when bt (display \" trace:\\n\" (current-error-port))
|
||||
(display bt (current-error-port))))
|
||||
(exit 1)))
|
||||
(cond
|
||||
((and (= (length args) 2) (string=? (car args) \"-e\"))
|
||||
(let ((result (jolt-final-str
|
||||
|
|
@ -168,14 +131,8 @@
|
|||
(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))
|
||||
|
|
@ -225,13 +182,6 @@
|
|||
(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)))
|
||||
|
|
@ -242,9 +192,6 @@
|
|||
"#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"
|
||||
|
|
@ -253,12 +200,7 @@
|
|||
" 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 "' '"
|
||||
"cc -O2 -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"))
|
||||
|
|
|
|||
|
|
@ -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)"
|
||||
|
|
|
|||
|
|
@ -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,7 +37,7 @@
|
|||
(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)))))
|
||||
|
||||
|
|
@ -57,24 +57,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 +80,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 +91,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 +138,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)
|
||||
|
|
@ -310,24 +271,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 +293,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 +334,10 @@
|
|||
;; direct-link?: opt-in closed-world direct-linking (app->app calls bind directly,
|
||||
;; no runtime redefinition). Off by default in every mode — release stays
|
||||
;; dynamically linked.
|
||||
(define (bld-suffix? s suf)
|
||||
(let ((n (string-length s)) (m (string-length suf)))
|
||||
(and (>= n m) (string=? (substring s (- n m) n) suf))))
|
||||
(define (build-binary entry-ns out-path mode natives embed-dirs ext-roots direct-link? tree-shake?)
|
||||
;; Windows executables carry .exe; normalize here so the append-payload and
|
||||
;; cc paths agree and the shell can run the result.
|
||||
(let ((out-path (if (and bld-nt? (not (bld-suffix? out-path ".exe")))
|
||||
(string-append out-path ".exe")
|
||||
out-path)))
|
||||
;; The self-contained path (jolt-embedded-bytes "stub/launcher") needs no csv
|
||||
;; kernel files, no Chez, no cc — only the legacy cc path does.
|
||||
(unless (jolt-embedded-bytes "stub/launcher") (bld-check-toolchain))
|
||||
(when (> (string-length (bld-native-link-flags natives)) 0)
|
||||
;; :static natives are cc-linked into the binary, so a C compiler must be on
|
||||
;; PATH — the self-contained joltc bundles the Chez kernel (libkernel.a +
|
||||
;; scheme.h) and relinks a custom stub (see build-self-contained), but still
|
||||
;; needs the system cc for that link. Fail early (before the app's foreign-
|
||||
;; procedure forms eval below) with an actionable message.
|
||||
(unless (bld-have-cc?)
|
||||
(error 'jolt-build
|
||||
"static native linking needs a C compiler (cc) on PATH; install one, or pass --dynamic to load the library at runtime."))
|
||||
;; Preload static archives' symbols into this process so step 1's foreign-
|
||||
;; procedure evals resolve; the .build dir must exist first.
|
||||
(bld-mkdir-p (string-append out-path ".build"))
|
||||
(bld-preload-static-natives! natives (string-append out-path ".build")))
|
||||
;; 1. record app namespaces in dependency order as they finish loading.
|
||||
(let ((app-order '()))
|
||||
(set-ns-loaded-hook!
|
||||
|
|
@ -493,11 +370,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")
|
||||
|
|
@ -522,7 +394,7 @@
|
|||
(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)))))
|
||||
|
|
@ -571,23 +443,11 @@
|
|||
"))\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
|
||||
|
|
@ -600,81 +460,27 @@
|
|||
;; 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)))))))))
|
||||
(build-self-contained entry-ns out-path mode builddir flat-ss flat-so boot)
|
||||
(build-with-cc entry-ns out-path mode builddir flat-ss flat-so boot boot-h main-c)))))))
|
||||
|
||||
;; --- 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)
|
||||
;; compile-file runs with a FRESH scheme-environment as the interaction
|
||||
;; environment: the loaded jolt runtime redefines `error` (regex.ss), and flat.ss
|
||||
;; inlines that same runtime, so an early reference to `error` (before its define
|
||||
;; runs) must bind to the kernel primitive — a clean env gives exactly that, the
|
||||
;; same as the legacy path compiling in a fresh Chez process. Without it the boot
|
||||
;; dies at startup with "variable error is not bound".
|
||||
(define (build-self-contained entry-ns out-path mode builddir flat-ss flat-so boot)
|
||||
(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))
|
||||
(parameterize ((interaction-environment (copy-environment (scheme-environment))))
|
||||
(compile-file flat-ss flat-so)
|
||||
(make-boot-file boot '() petite scheme flat-so))
|
||||
;; link: stub bytes ++ boot ++ frame, then make it executable.
|
||||
(jolt-spill-embedded! "stub/launcher" out-path)
|
||||
(jolt-append-payload! out-path (read-file-bytes boot))
|
||||
(jolt-chmod-755 out-path)
|
||||
(display (string-append "jolt build: wrote " out-path "\n"))
|
||||
|
|
@ -683,27 +489,8 @@
|
|||
"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)
|
||||
(define (build-with-cc entry-ns out-path mode builddir flat-ss flat-so boot boot-h main-c)
|
||||
(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)))
|
||||
|
|
@ -733,13 +520,9 @@
|
|||
" 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))
|
||||
"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"
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
@ -66,9 +46,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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
@ -298,21 +298,8 @@
|
|||
(define empty-pmap-hash (make-pmap empty-hnode 0 #f)) ; hash-order backing (sets)
|
||||
(define pmap-absent (list 'absent)) ; unique missing-key sentinel
|
||||
;; PersistentArrayMap threshold: assoc of a new key promotes to hash mode once the
|
||||
;; map already holds 8 entries (array.length >= 16 in the reference). Clojure 1.13
|
||||
;; raised the limit to 64 for maps whose keys are ALL keywords (the common
|
||||
;; keyword-map case); mixed-key maps still cap at 8.
|
||||
;; map already holds 8 entries (array.length >= 16 in the reference).
|
||||
(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)))))))
|
||||
|
||||
|
|
@ -323,7 +310,7 @@
|
|||
(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))
|
||||
(if (and ord (fx<? cnt array-map-limit))
|
||||
(make-pmap r (fx+ cnt 1) (append-key ord k))
|
||||
(make-pmap r (fx+ cnt 1) #f))
|
||||
(make-pmap r cnt ord))))
|
||||
|
|
@ -365,14 +352,10 @@
|
|||
(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).
|
||||
;; map LITERAL ({...}): array map up to 8 entries, hash map beyond (RT.map).
|
||||
(define (jolt-hash-map . kvs)
|
||||
(let loop ((m empty-pmap) (kvs kvs))
|
||||
(cond ((null? kvs)
|
||||
(let ((cnt (pmap-cnt m)) (ord (pmap-order m)))
|
||||
(if (fx>? cnt (if (all-keywords? ord) array-map-limit-kw array-map-limit))
|
||||
(pmap->hash m) m)))
|
||||
(cond ((null? kvs) (if (fx>? (pmap-cnt m) array-map-limit) (pmap->hash m) m))
|
||||
((null? (cdr kvs)) (error 'hash-map "odd number of map literal entries"))
|
||||
(else (loop (pmap-put-ordered m (car kvs) (cadr kvs)) (cddr kvs))))))
|
||||
;; array-map ctor: insertion-ordered regardless of size (createAsIfByAssoc).
|
||||
|
|
@ -421,11 +404,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 +443,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 +502,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 +514,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)
|
||||
|
|
|
|||
|
|
@ -110,48 +110,6 @@
|
|||
;; 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 +135,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 +193,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 +211,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)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -117,21 +117,20 @@
|
|||
(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)))
|
||||
|
|
@ -156,12 +155,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 +172,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 +195,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)
|
||||
|
|
|
|||
120
host/chez/cts.sh
120
host/chez/cts.sh
|
|
@ -1,120 +0,0 @@
|
|||
#!/bin/bash
|
||||
# clojure-test-suite gate: run the vendored jank-lang/clojure-test-suite
|
||||
# (vendor/clojure-test-suite) against joltc, one process per test namespace (a
|
||||
# hang or crash is contained), and compare per-namespace fail/error counts
|
||||
# against the checked-in baseline test/chez/cts-known-failures.txt.
|
||||
#
|
||||
# The comparison is exact, like certify's allowlist: a namespace doing WORSE
|
||||
# than the baseline fails the gate (regression), and one doing BETTER also
|
||||
# fails (stale baseline — update the file in the same change that improved it).
|
||||
#
|
||||
# JOLT_CTS_JOBS=N parallel workers (default 4)
|
||||
# JOLT_CTS_TIMEOUT=SECS per-namespace timeout (default 120)
|
||||
# JOLT_CTS_WRITE_BASELINE=1 regenerate the baseline file instead of gating
|
||||
# JOLT_CTS_NS=ns1,ns2 run only these namespaces, verbose, no gating
|
||||
set -u
|
||||
root="$(CDPATH= cd -- "$(dirname -- "$0")/../.." && pwd)"
|
||||
cd "$root"
|
||||
|
||||
suite="vendor/clojure-test-suite/test"
|
||||
baseline="test/chez/cts-known-failures.txt"
|
||||
app="$root/test/chez/cts-app"
|
||||
jobs="${JOLT_CTS_JOBS:-4}"
|
||||
tmo="${JOLT_CTS_TIMEOUT:-120}"
|
||||
|
||||
if [ ! -d "$suite/clojure" ]; then
|
||||
echo "cts: skipped (git submodule update --init vendor/clojure-test-suite)"
|
||||
exit 0
|
||||
fi
|
||||
|
||||
work="$(mktemp -d)"
|
||||
trap 'rm -rf "$work"' EXIT
|
||||
|
||||
# test namespaces from the .cljc files (portability is a helper, not a test ns)
|
||||
find "$suite" -name '*.cljc' | sed "s|^$suite/||;s|\.cljc$||;s|/|.|g;s|_|-|g" \
|
||||
| grep -v '\.portability$' | sort > "$work/nses"
|
||||
if [ -n "${JOLT_CTS_NS:-}" ]; then
|
||||
echo "${JOLT_CTS_NS}" | tr ',' '\n' > "$work/nses"
|
||||
fi
|
||||
|
||||
# round-robin the namespaces over N sequential workers; each worker appends
|
||||
# "ns pass fail error" lines (HUNG/CRASH in the pass column) to its own file.
|
||||
awk -v j="$jobs" '{print > ("'"$work"'/chunk." (NR % j))}' "$work/nses"
|
||||
run_chunk() {
|
||||
chunk="$1"; out="$2"
|
||||
while IFS= read -r ns; do
|
||||
res=$(JOLT_PWD="$app" perl -e "alarm $tmo; exec @ARGV" -- "$root/bin/joltc" -M:cts "$ns" 2>&1 </dev/null)
|
||||
rc=$?
|
||||
line=$(echo "$res" | grep '^CTS-RESULT' | head -1)
|
||||
if [ -n "$line" ]; then
|
||||
echo "$line" | awk '{print $2, $3, $4, $5}' >> "$out"
|
||||
if [ -n "${JOLT_CTS_NS:-}" ]; then
|
||||
echo "$res" | grep -E 'FAIL:|ERROR:|LOAD:' | sed 's/^/ /' >> "$out"
|
||||
fi
|
||||
elif [ $rc -ge 128 ]; then
|
||||
echo "$ns HUNG 0 0" >> "$out"
|
||||
else
|
||||
echo "$ns CRASH 0 0" >> "$out"
|
||||
fi
|
||||
done < "$chunk"
|
||||
}
|
||||
for c in "$work"/chunk.*; do
|
||||
run_chunk "$c" "$c.res" &
|
||||
done
|
||||
wait
|
||||
cat "$work"/chunk.*.res 2>/dev/null | sort > "$work/results"
|
||||
|
||||
if [ -n "${JOLT_CTS_NS:-}" ]; then
|
||||
cat "$work/results"
|
||||
exit 0
|
||||
fi
|
||||
|
||||
summary=$(awk '$2!="HUNG" && $2!="CRASH" {p+=$2; f+=$3; e+=$4; c++}
|
||||
$2=="HUNG" {h++} $2=="CRASH" {x++}
|
||||
END {printf "%d namespaces: pass %d, fail %d, error %d, hung %d, crash %d",
|
||||
c+h+x, p, f, e, h, x}' "$work/results")
|
||||
|
||||
if [ "${JOLT_CTS_WRITE_BASELINE:-0}" = "1" ]; then
|
||||
{
|
||||
echo "# clojure-test-suite known failures: <namespace> <fail> <error>"
|
||||
echo "# The gate fails on any per-namespace change, worse OR better; regenerate"
|
||||
echo "# with: JOLT_CTS_WRITE_BASELINE=1 host/chez/cts.sh"
|
||||
awk '$2=="HUNG" || $2=="CRASH" {print $1, $2, $2; next}
|
||||
$3 != 0 || $4 != 0 {print $1, $3, $4}' "$work/results"
|
||||
} > "$baseline"
|
||||
echo "cts: $summary"
|
||||
echo "cts: baseline written to $baseline ($(grep -cv '^#' "$baseline") namespaces)"
|
||||
exit 0
|
||||
fi
|
||||
|
||||
if [ ! -f "$baseline" ]; then
|
||||
echo "cts: FAIL — no baseline; run JOLT_CTS_WRITE_BASELINE=1 host/chez/cts.sh"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
status=0
|
||||
while read -r ns p f e; do
|
||||
case "$p" in HUNG|CRASH) f="$p"; e="$p" ;; esac
|
||||
bl=$(grep -v '^#' "$baseline" | awk -v n="$ns" '$1==n {print $2, $3; exit}')
|
||||
if [ -n "$bl" ]; then bf="${bl%% *}"; be="${bl##* }"; else bf=0; be=0; fi
|
||||
if [ "$f" = "$bf" ] && [ "$e" = "$be" ]; then
|
||||
continue
|
||||
elif [ "$f" = "HUNG" ] || [ "$f" = "CRASH" ] \
|
||||
|| { [ "$bf" != "HUNG" ] && [ "$bf" != "CRASH" ] \
|
||||
&& { [ "$f" -gt "$bf" ] || [ "$e" -gt "$be" ]; }; }; then
|
||||
echo "cts: NEW regression in $ns — fail $f error $e (baseline $bf $be)"
|
||||
status=1
|
||||
else
|
||||
echo "cts: STALE baseline for $ns — now fail $f error $e (baseline $bf $be); update $baseline"
|
||||
status=1
|
||||
fi
|
||||
done < "$work/results"
|
||||
|
||||
# a baseline entry whose namespace no longer reports is stale too
|
||||
while read -r ns bf be; do
|
||||
grep -q "^$ns " "$work/results" || { echo "cts: STALE baseline entry $ns (namespace gone)"; status=1; }
|
||||
done < <(grep -v '^#' "$baseline")
|
||||
|
||||
echo "cts: $summary"
|
||||
if [ $status -eq 0 ]; then echo "cts: passed (matches baseline)"; else echo "cts: FAILED"; fi
|
||||
exit $status
|
||||
|
|
@ -90,10 +90,7 @@
|
|||
;; str re-serializes the read form (compiled identically; comments/whitespace are
|
||||
;; 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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -46,10 +46,6 @@
|
|||
;; 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 +63,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 +89,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))
|
||||
|
||||
|
|
|
|||
|
|
@ -430,19 +430,6 @@
|
|||
(define (hc-record-ctor-key ctx name)
|
||||
(let ((nm (hc-record-tag-name name)))
|
||||
(or (and nm (chez-find-ctor-key nm (chez-current-ns))) jolt-nil)))
|
||||
;; The fully-qualified deftype tag ("ns.Name") IFF `class` names a deftype DEFINED
|
||||
;; in the ctx's compile ns — the analyzer qualifies a bare (Name. …) to it, so a
|
||||
;; deftype doesn't shadow a same-named built-in host class in an unrelated ns
|
||||
;; (rewrite-clj imports java.io.PushbackReader; tools.reader defines its own). Strict:
|
||||
;; only this ns's own def (the preferred shape key) counts, not the global
|
||||
;; simple-name fallback, so a ns that merely uses the built-in resolves nil.
|
||||
(define (hc-deftype-ctor-class ctx class)
|
||||
(let* ((nm (jolt-str-render-one class))
|
||||
(cns (hc-current-ns ctx))
|
||||
(key (string-append cns "/->" nm)))
|
||||
(if (hashtable-ref chez-record-shapes-tbl key #f)
|
||||
(string-append cns "." nm)
|
||||
jolt-nil)))
|
||||
;; record + protocol-method shapes for the inference, from the runtime registries
|
||||
;; (records.ss) populated as deftype/defprotocol forms load.
|
||||
(define (hc-record-shapes ctx) (chez-record-shapes-map))
|
||||
|
|
@ -518,7 +505,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?)
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -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)
|
||||
|
|
@ -574,14 +547,10 @@
|
|||
;; 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))
|
||||
(foreign-procedure "pthread_sigmask" (int u8* u8*) int))
|
||||
(define c-sigemptyset (foreign-procedure "sigemptyset" (u8*) int))
|
||||
(define c-sigaddset (foreign-procedure "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".
|
||||
|
|
@ -594,13 +563,12 @@
|
|||
((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)
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -60,12 +62,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 +84,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,6 +93,9 @@
|
|||
(substring method-name 1 (string-length method-name))
|
||||
method-name)))
|
||||
(cond
|
||||
;; (.getClass x) universal — the class token for any value, before the
|
||||
;; collection/map field-lookup arms below would read it as a missing key.
|
||||
((string=? method-name "getClass") (jolt-class obj))
|
||||
;; clojure.lang.MultiFn .dispatchFn / .getMethod — clojure.spec.alpha's
|
||||
;; multi-spec walks a multimethod through these.
|
||||
((jolt-multifn? obj)
|
||||
|
|
@ -108,7 +107,7 @@
|
|||
(mm-find-isa obj dv)
|
||||
(hashtable-ref methods (jolt-multifn-default obj) #f)
|
||||
jolt-nil)))
|
||||
(else 'pass)))
|
||||
(else (%dot-rmd obj method-name rest-args))))
|
||||
;; (.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)))))
|
||||
|
|
@ -120,7 +119,7 @@
|
|||
((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)))
|
||||
(else (%dot-rmd obj method-name rest-args))))
|
||||
;; 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
|
||||
|
|
@ -146,4 +145,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))))))
|
||||
|
|
|
|||
|
|
@ -176,26 +176,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 +375,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 +438,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)
|
||||
|
|
@ -642,7 +617,8 @@
|
|||
;; 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
|
||||
|
|
@ -666,7 +642,7 @@
|
|||
((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)))))
|
||||
(else (%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,14 +684,15 @@
|
|||
|
||||
;; 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))
|
||||
|
|
@ -765,12 +742,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))
|
||||
|
|
@ -831,7 +802,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 +812,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))))
|
||||
|
|
@ -994,20 +960,9 @@
|
|||
(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 '()))))
|
||||
(or (hashtable-ref class-supers-tbl name #f)
|
||||
(and (str-has-dollar? name) '("clojure.lang.AFunction"))
|
||||
'()))
|
||||
;; transitive closure of direct supers (set semantics via an accumulator list)
|
||||
(define (class-ancestors-list name)
|
||||
(let loop ((pending (class-direct-supers name)) (seen '()))
|
||||
|
|
@ -1052,62 +1007,18 @@
|
|||
#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)))))
|
||||
|
|
|
|||
|
|
@ -55,7 +55,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)))
|
||||
|
||||
|
|
@ -200,8 +202,7 @@
|
|||
(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))))
|
||||
|
|
@ -213,8 +214,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"))))
|
||||
|
|
@ -228,14 +227,12 @@
|
|||
;; 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))
|
||||
(list (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))
|
||||
(list (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))))))
|
||||
|
|
@ -250,15 +247,13 @@
|
|||
(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 +261,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.
|
||||
|
|
|
|||
|
|
@ -90,9 +90,13 @@
|
|||
(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))))
|
||||
|
|
@ -100,7 +104,7 @@
|
|||
(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))))
|
||||
(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
|
||||
|
|
@ -113,12 +117,7 @@
|
|||
((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))))
|
||||
|
|
@ -194,9 +193,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 +208,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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -562,7 +562,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 +586,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.
|
||||
|
|
|
|||
|
|
@ -80,18 +80,13 @@
|
|||
;; 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)))
|
||||
(let ((c (guard (e (#t #f))
|
||||
(load-shared-object #f)
|
||||
(foreign-procedure "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 "'")))))))
|
||||
(if c
|
||||
(c path #o755)
|
||||
(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
|
||||
|
|
@ -245,13 +240,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
|
||||
|
|
@ -416,11 +412,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))
|
||||
|
|
@ -629,31 +620,6 @@
|
|||
;; (Long. n) / (Long. "n"): a Long is just jolt's integer; return it (parse a string).
|
||||
(register-class-ctor! "Long" (lambda (x) (if (string? x) (parse-int-or-throw x 10 "Long") (->num (jnum->exact x)))))
|
||||
(register-class-ctor! "java.lang.Long" (lambda (x) (if (string? x) (parse-int-or-throw x 10 "Long") (->num (jnum->exact x)))))
|
||||
;; (Integer. n) / (Integer. "n"): jolt's integer, range-checked like intCast.
|
||||
(define (integer-ctor x)
|
||||
(jolt-int-cast (if (string? x) (parse-int-or-throw x 10 "Integer") x)))
|
||||
(register-class-ctor! "Integer" integer-ctor)
|
||||
(register-class-ctor! "java.lang.Integer" integer-ctor)
|
||||
;; (Double. x) / (Double. "x"): jolt's double.
|
||||
(define (double-ctor x)
|
||||
(if (string? x)
|
||||
(let ((n (string->number x)))
|
||||
(if n (exact->inexact n)
|
||||
(jolt-throw (jolt-host-throwable "java.lang.NumberFormatException"
|
||||
(string-append "For input string: \"" x "\"")))))
|
||||
(jolt-double x)))
|
||||
(register-class-ctor! "Double" double-ctor)
|
||||
(register-class-ctor! "java.lang.Double" double-ctor)
|
||||
|
||||
;; (Boolean. "true") / (Boolean. b): true for the string "true" (case-insensitive,
|
||||
;; anything else false) or the boolean itself — Boolean.valueOf semantics; the
|
||||
;; box is jolt's plain boolean.
|
||||
(define (boolean-ctor x)
|
||||
(cond ((string? x) (string-ci=? x "true"))
|
||||
((boolean? x) x)
|
||||
(else #f)))
|
||||
(register-class-ctor! "Boolean" boolean-ctor)
|
||||
(register-class-ctor! "java.lang.Boolean" boolean-ctor)
|
||||
|
||||
;; --- java.net.URI -----------------------------------------------------------
|
||||
;; A minimal RFC-3986 split into scheme/authority/host/port/path/query/fragment,
|
||||
|
|
|
|||
|
|
@ -85,8 +85,10 @@
|
|||
(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)
|
||||
|
|
@ -115,11 +117,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/
|
||||
|
|
|
|||
|
|
@ -10,12 +10,47 @@
|
|||
(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")
|
||||
("ArityException" . "IllegalArgumentException")
|
||||
("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))
|
||||
(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))))))))
|
||||
|
||||
;; 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
|
||||
|
|
|
|||
|
|
@ -42,20 +42,6 @@ if [ "$got_e" != "45" ]; then
|
|||
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.
|
||||
|
|
@ -87,36 +73,4 @@ if [ "$got" != "$want" ]; then
|
|||
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)"
|
||||
echo "joltc self-build smoke: passed (joltc runs + builds a working app with no external toolchain)"
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
@ -384,14 +368,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")))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -27,9 +27,9 @@
|
|||
;; 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.
|
||||
|
|
|
|||
|
|
@ -260,9 +260,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.
|
||||
|
|
@ -309,24 +306,13 @@
|
|||
(loop (cddr a)))))
|
||||
jolt-nil)
|
||||
|
||||
;; alter-meta! / reset-meta!: a var's metadata lives in var-meta-table (rt.ss);
|
||||
;; any other reference (atom/agent/namespace) uses the identity meta side-table
|
||||
;; jolt-meta reads.
|
||||
;; 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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -48,24 +48,12 @@
|
|||
|
||||
(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 +61,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 +115,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)))
|
||||
|
|
@ -157,11 +139,6 @@
|
|||
;; 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)))))
|
||||
|
|
@ -213,10 +190,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))))))
|
||||
(loop j (cons (integer->char val) acc)))))
|
||||
((#\u)
|
||||
(let-values (((cp j) (rdr-hex->int s (+ i 2) 4)))
|
||||
;; A \u escape is a UTF-16 code unit. jolt chars are Unicode scalars,
|
||||
|
|
@ -234,8 +208,7 @@
|
|||
(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.
|
||||
|
|
@ -267,10 +240,7 @@
|
|||
((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)))))
|
||||
|
||||
|
|
@ -288,39 +258,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).
|
||||
|
|
@ -344,14 +289,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))
|
||||
|
|
@ -611,12 +548,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)))
|
||||
|
|
@ -668,17 +601,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))
|
||||
|
|
@ -813,86 +735,20 @@
|
|||
(let ((v (var-deref "clojure.core" "*default-data-reader-fn*")))
|
||||
(and (not (jolt-nil? v)) (procedure? v) v))))
|
||||
|
||||
;; strict #inst validation: RFC-3339 calendar fields must be real (month 1-12,
|
||||
;; day valid for the month incl. leap years, hour < 24, minute/second < 60).
|
||||
(define (rdr-2dig s i)
|
||||
(and (< (+ i 1) (string-length s))
|
||||
(rdr-digit? (string-ref s i)) (rdr-digit? (string-ref s (+ i 1)))
|
||||
(+ (* 10 (- (char->integer (string-ref s i)) 48))
|
||||
(- (char->integer (string-ref s (+ i 1))) 48))))
|
||||
(define (rdr-leap? y) (and (= 0 (modulo y 4)) (or (not (= 0 (modulo y 100))) (= 0 (modulo y 400)))))
|
||||
(define (rdr-inst-throw s)
|
||||
(jolt-throw (jolt-host-throwable "java.lang.RuntimeException"
|
||||
(string-append "Unrecognized date/time syntax: " s))))
|
||||
(define (rdr-validate-inst! s)
|
||||
;; progressive RFC-3339 like clojure.instant: yyyy[-MM[-dd[Thh[:mm[:ss[.f]]]]]]
|
||||
;; with an optional Z/±hh:mm offset; each present field must be in range
|
||||
;; (months 1-12, day valid for the month incl. leap years, hour < 24, min < 60).
|
||||
(let* ((len (string-length s))
|
||||
(y (and (>= len 4) (rdr-all-digits? s 0 4) (string->number (substring s 0 4)))))
|
||||
(unless y (rdr-inst-throw s))
|
||||
(when (>= len 5)
|
||||
(unless (char=? (string-ref s 4) #\-) (rdr-inst-throw s))
|
||||
(let ((mo (rdr-2dig s 5)))
|
||||
(unless (and mo (>= mo 1) (<= mo 12)) (rdr-inst-throw s))
|
||||
(when (>= len 8)
|
||||
(unless (char=? (string-ref s 7) #\-) (rdr-inst-throw s))
|
||||
(let ((d (rdr-2dig s 8)))
|
||||
(unless (and d (>= d 1)
|
||||
(<= d (vector-ref (if (rdr-leap? y)
|
||||
'#(31 29 31 30 31 30 31 31 30 31 30 31)
|
||||
'#(31 28 31 30 31 30 31 31 30 31 30 31))
|
||||
(- mo 1))))
|
||||
(rdr-inst-throw s))
|
||||
(when (>= len 11)
|
||||
(unless (char=? (string-ref s 10) #\T) (rdr-inst-throw s))
|
||||
(let ((h (rdr-2dig s 11)))
|
||||
(unless (and h (<= h 23)) (rdr-inst-throw s))
|
||||
(when (>= len 14)
|
||||
(when (char=? (string-ref s 13) #\:)
|
||||
(let ((mi (rdr-2dig s 14)))
|
||||
(unless (and mi (<= mi 59)) (rdr-inst-throw s)))))))))))))
|
||||
;; strict #uuid: canonical 8-4-4-4-12 hex groups.
|
||||
(define (rdr-validate-uuid! s)
|
||||
(define (hexrun? from to)
|
||||
(let loop ((i from))
|
||||
(cond ((>= i to) #t)
|
||||
((let ((c (char-downcase (string-ref s i))))
|
||||
(or (rdr-digit? c) (and (char>=? c #\a) (char<=? c #\f))))
|
||||
(loop (+ i 1)))
|
||||
(else #f))))
|
||||
(unless (and (= (string-length s) 36)
|
||||
(char=? (string-ref s 8) #\-) (char=? (string-ref s 13) #\-)
|
||||
(char=? (string-ref s 18) #\-) (char=? (string-ref s 23) #\-)
|
||||
(hexrun? 0 8) (hexrun? 9 13) (hexrun? 14 18) (hexrun? 19 23) (hexrun? 24 36))
|
||||
(jolt-throw (jolt-host-throwable "java.lang.IllegalArgumentException"
|
||||
(string-append "Invalid UUID string: " s)))))
|
||||
|
||||
;; read-string / read data seam: construct the value for a #tag literal. #inst,
|
||||
;; #uuid and #"regex" are built in; any other tag is applied from *data-readers*,
|
||||
;; then *default-data-reader-fn*. An unregistered tag with no default handler stays
|
||||
;; a tagged FORM (lenient — clojure.edn raises instead).
|
||||
(define (rdr-construct-tag tag inner)
|
||||
(cond
|
||||
((eq? tag (keyword #f "#inst"))
|
||||
(when (string? inner) (rdr-validate-inst! inner))
|
||||
(jolt-inst-from-string inner))
|
||||
((eq? tag (keyword #f "#uuid"))
|
||||
(when (string? inner) (rdr-validate-uuid! inner))
|
||||
(jolt-uuid-from-string inner))
|
||||
((eq? tag (keyword #f "#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))))))))
|
||||
(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.
|
||||
|
|
@ -904,11 +760,7 @@
|
|||
(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)))))))
|
||||
(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)))
|
||||
|
|
@ -933,35 +785,12 @@
|
|||
(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 +798,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,13 +807,8 @@
|
|||
;; 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))
|
||||
((eq? tag (keyword #f "#uuid")) (jolt-uuid-from-string form))
|
||||
((eq? tag (keyword #f "#inst")) (jolt-inst-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
|
||||
|
|
@ -1004,4 +828,3 @@
|
|||
;; :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)
|
||||
|
|
|
|||
|
|
@ -44,10 +44,6 @@
|
|||
;; 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-
|
||||
|
|
@ -308,25 +304,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)))
|
||||
|
|
@ -495,22 +473,24 @@
|
|||
((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"))
|
||||
((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"))
|
||||
;; 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"))
|
||||
((or (cseq? obj) (empty-list-t? obj)) '("PersistentList" "IPersistentList" "IPersistentStack" "ASeq" "ISeq" "IPersistentCollection" "Sequential" "Collection" "Iterable" "java.lang.Iterable" "Object"))
|
||||
;; 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"))
|
||||
((jolt-lazyseq? obj) '("LazySeq" "ISeq" "IPersistentCollection" "Sequential" "Collection" "Iterable" "java.lang.Iterable" "Object"))
|
||||
;; 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"))
|
||||
((var-cell? obj) '("Var" "clojure.lang.Var" "IDeref" "IFn" "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).
|
||||
|
|
@ -561,7 +541,7 @@
|
|||
;; 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
|
||||
|
|
@ -607,26 +587,14 @@
|
|||
(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))
|
||||
;; 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)
|
||||
;; index the tag so a cross-ns extend-protocol resolves the bare type name.
|
||||
(hashtable-set! chez-deftype-tag-set tag #t)
|
||||
(hashtable-set! chez-simple-name-tag (symbol-t-name name-sym) tag)
|
||||
;; graft the type onto the class graph so isa?/supers/ancestors see it. A
|
||||
;; bare deftype is an IType; defrecord (which runs register-record-type!
|
||||
;; right after) replaces the row with the record interface set.
|
||||
(jch-set-supers! tag '("clojure.lang.IType"))
|
||||
(hashtable-set! chez-deftype-ctor-tag ctor tag)
|
||||
;; record the shape for whole-program inference, keyed by the positional
|
||||
;; ctor var "ns/->Name" the analyzer resolves a (->Name …) call to.
|
||||
(register-record-shape! (string-append (chez-current-ns) "/->" (symbol-t-name name-sym))
|
||||
|
|
@ -696,17 +664,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
|
||||
|
|
@ -745,12 +703,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,9 +787,14 @@
|
|||
;; "#<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
|
||||
;; (.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-arity (jrec-tag obj) method-name (+ 1 (length rest))))
|
||||
=> (lambda (f) (apply jolt-invoke f obj rest)))
|
||||
;; (.field inst): a deftype/record field read with no matching method.
|
||||
|
|
@ -969,36 +926,6 @@
|
|||
(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))
|
||||
|
|
@ -1070,18 +997,8 @@
|
|||
;; 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")))))
|
||||
(hashtable-set! chez-record-type-tbl
|
||||
(string-append (chez-current-ns) "." (symbol-t-name name-sym)) #t)
|
||||
jolt-nil)
|
||||
(def-var! "clojure.core" "register-record-type!" register-record-type!)
|
||||
(def-var! "clojure.core" "make-protocol" make-protocol)
|
||||
|
|
|
|||
|
|
@ -159,23 +159,10 @@
|
|||
;; 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 (escape-class-shorthand-dash pat)) opts))))
|
||||
(define (jolt-regex? x) (regex-t? x))
|
||||
(define (jolt-re-pattern x) (if (regex-t? x) x (jolt-regex x)))
|
||||
|
||||
|
|
|
|||
122
host/chez/rt.ss
122
host/chez/rt.ss
|
|
@ -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")
|
||||
|
||||
|
|
@ -60,112 +49,6 @@
|
|||
;; 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))
|
||||
|
|
@ -473,11 +356,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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
301
host/chez/seq.ss
301
host/chez/seq.ss
|
|
@ -152,224 +152,23 @@
|
|||
(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 ...))))
|
||||
;; 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))
|
||||
|
||||
;; --- unchecked (Java long) arithmetic: wrap to signed 64 bits ----------------
|
||||
;; Clojure's unchecked-* (and +/-/* under *unchecked-math*) are long ops that
|
||||
|
|
@ -445,26 +244,11 @@
|
|||
;; 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,21 +257,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"))))))
|
||||
(string-append (guard (e (#t "value")) (jolt-pr-str f))
|
||||
" cannot be cast to clojure.lang.IFn"))))))
|
||||
|
||||
;; ============================================================================
|
||||
;; chunked-seq accessors — the host side of the Clojure IChunkedSeq contract
|
||||
|
|
@ -646,11 +421,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,14 +436,8 @@
|
|||
;; 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
|
||||
|
|
@ -773,14 +542,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 +552,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);
|
||||
|
|
|
|||
|
|
@ -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,12 +43,6 @@ 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
|
||||
|
|
@ -93,53 +54,6 @@ check '(try (load-string "(+") (catch :default e (ex-message e)))' 'EOF while re
|
|||
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
|
||||
|
|
@ -161,29 +75,6 @@ else
|
|||
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.
|
||||
|
|
@ -239,25 +130,5 @@ else
|
|||
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 ]
|
||||
|
|
|
|||
|
|
@ -57,36 +57,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,84 +70,39 @@
|
|||
(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
|
||||
|
|
|
|||
|
|
@ -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)"
|
||||
|
|
@ -26,12 +26,6 @@ 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) {
|
||||
|
|
|
|||
|
|
@ -44,16 +44,7 @@
|
|||
(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"))))))
|
||||
(else (make-jolt-transient 'cow coll 0 #t #f))))
|
||||
|
||||
;; map put/delete that maintain the reverse insertion-order list in `ord`.
|
||||
(define (tmap-put! t k v)
|
||||
|
|
@ -86,11 +77,7 @@
|
|||
(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)))
|
||||
(let* ((ht (jolt-transient-buf t)) (cnt (hashtable-size ht)) (cap (jolt-transient-n t)))
|
||||
(if (fx>? cnt cap)
|
||||
;; promoted past the array capacity: hash order
|
||||
(let ((m empty-pmap-hash))
|
||||
|
|
|
|||
|
|
@ -96,16 +96,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
161
install
|
|
@ -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
|
||||
|
|
@ -188,23 +188,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)))
|
||||
|
|
@ -245,45 +231,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 +262,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 +273,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]
|
||||
|
|
@ -546,9 +514,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 +543,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))))
|
||||
|
|
|
|||
|
|
@ -155,43 +155,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)))
|
||||
|
||||
|
|
@ -219,8 +184,7 @@
|
|||
;; 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)))
|
||||
(defn rational? [x] (and (number? x) (jolt.host/exact? x)))
|
||||
;; No first-class Class objects: class names are symbols the evaluator handles in
|
||||
;; instance?/new positions, never values — so nothing is a class.
|
||||
(defn class? [x] false)
|
||||
|
|
@ -275,8 +239,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,28 +298,16 @@
|
|||
(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]
|
||||
|
|
@ -365,10 +316,6 @@
|
|||
;; 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 +325,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 +350,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 +367,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 +386,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 +394,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 +426,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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
@ -354,8 +348,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
|
||||
|
|
|
|||
|
|
@ -89,21 +89,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))]
|
||||
|
|
@ -151,9 +136,6 @@
|
|||
;; 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 +183,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
|
||||
|
|
@ -222,9 +198,10 @@
|
|||
(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.
|
||||
;; variants) and -divide-int / -remainder-int are host-defined (host/chez/seq.ss):
|
||||
;; they WRAP to signed 64 bits like the JVM, which a plain (+ x y) overlay can't do.
|
||||
(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 +263,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 +300,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 +316,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 +331,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)))))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
@ -396,18 +385,11 @@
|
|||
;; field binds / live-read instance (see defrecord's mk-clause).
|
||||
(let [argv (mapv (fn [p] (if (= p (quote _)) (gensym "_p") p)) (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
|
||||
|
|
@ -634,11 +616,7 @@
|
|||
(let [argv (mapv (fn [p] (if (= p (quote _)) (gensym "_p") p)) (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
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@
|
|||
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)
|
||||
|
|
@ -394,18 +394,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))
|
||||
|
|
@ -493,12 +482,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:
|
||||
|
|
|
|||
|
|
@ -17,17 +17,13 @@
|
|||
|
||||
;; 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"
|
||||
"min" "min" "max" "max"
|
||||
"mod" "modulo" "rem" "remainder" "quot" "quotient"
|
||||
"vector" "jolt-vector" "hash-map" "jolt-hash-map-fn" "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?"
|
||||
|
|
@ -57,12 +53,12 @@
|
|||
"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).
|
||||
|
|
@ -87,7 +83,7 @@
|
|||
|
||||
;; 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 +93,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?"})
|
||||
|
||||
|
|
@ -172,14 +168,6 @@
|
|||
(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,13 +187,6 @@
|
|||
;; 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)))
|
||||
|
|
@ -268,17 +249,6 @@
|
|||
(if (or (contains? scheme-reserved s) (contains? bare-native-names 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
|
||||
|
|
@ -407,14 +377,6 @@
|
|||
;; 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 +401,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 +411,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 +474,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 +499,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 "
|
||||
|
|
@ -615,31 +561,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 +574,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
|
||||
|
|
@ -700,16 +624,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 +645,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 +655,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,7 +664,7 @@
|
|||
(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
|
||||
|
|
@ -790,22 +711,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))
|
||||
|
|
@ -853,14 +759,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 +807,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-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))) ")"))
|
||||
(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,
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -147,10 +141,7 @@
|
|||
;; 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 — :repl/quit or ^D to exit")
|
||||
(loop []
|
||||
(let [form (repl-read-form)]
|
||||
(when form
|
||||
|
|
@ -163,9 +154,7 @@
|
|||
(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))))
|
||||
(pr-str e)))))
|
||||
(recur)))))))
|
||||
|
||||
;; A deps.edn :tasks entry: a string is a shell command; a map is {:main-opts …}.
|
||||
|
|
@ -185,38 +174,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 +219,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)))
|
||||
|
|
@ -301,19 +266,16 @@
|
|||
(when stop (stop))))))
|
||||
|
||||
(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 " 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-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"))
|
||||
|
||||
(defn -main [& args]
|
||||
|
|
@ -322,7 +284,6 @@
|
|||
(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)
|
||||
|
|
|
|||
|
|
@ -21,66 +21,25 @@
|
|||
[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-accept "accept" [:int :pointer :pointer] :int :blocking)
|
||||
(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 +53,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 +147,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*))
|
||||
|
|
@ -280,17 +236,11 @@
|
|||
no-op."
|
||||
([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)]
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -16,15 +16,7 @@
|
|||
;; Reader FORMS are detected by :jolt/type tag, never by map? — strict map?
|
||||
;; (correctly) excludes tagged structs, so the old (and (map? x) ...) guard
|
||||
;; would skip them.
|
||||
(= :jolt/set (get x :jolt/type))
|
||||
(let [vs (map (fn [v] (edn->value opts v)) (get x :value))
|
||||
st (set vs)]
|
||||
;; duplicate literal elements are invalid edn
|
||||
(when (< (count st) (count vs))
|
||||
(throw (new IllegalArgumentException
|
||||
(str "Duplicate key: " (pr-str (some (fn [[k n]] (when (< 1 n) k))
|
||||
(frequencies vs)))))))
|
||||
(with-meta st (edn->value opts (meta x))))
|
||||
(= :jolt/set (get x :jolt/type)) (with-meta (set (map (fn [v] (edn->value opts v)) (get x :value))) (edn->value opts (meta x)))
|
||||
;; Tagged elements: a reader from the :readers opt wins, then the built-in
|
||||
;; data readers (#uuid/#inst + registered); an unknown tag falls to the
|
||||
;; :default opt fn (called with tag and value, as in Clojure) or throws.
|
||||
|
|
@ -38,9 +30,6 @@
|
|||
custom (get (get opts :readers) tag-sym)]
|
||||
(cond
|
||||
custom (custom v)
|
||||
;; the built-in edn tags win over :default (a :readers entry can
|
||||
;; override them; an unknown-tag :default never sees #inst/#uuid)
|
||||
(contains? #{'inst 'uuid 'bigdec} tag-sym) (__read-tagged tag v)
|
||||
;; Clojure calls :default with the tag as a SYMBOL and the value.
|
||||
(get opts :default) ((get opts :default) tag-sym v)
|
||||
:else (__read-tagged tag v)))
|
||||
|
|
@ -50,30 +39,25 @@
|
|||
;; a constructed set: recurse into its elements too, so a tagged literal
|
||||
;; inside #{…} gets the :readers/:default treatment (aero's #ref in a set).
|
||||
(set? x) (with-meta (set (map (fn [v] (edn->value opts v)) x)) (edn->value opts (meta x)))
|
||||
;; edn lists are lists (list? holds), not lazy seqs
|
||||
(seq? x) (with-meta (apply list (map (fn [v] (edn->value opts v)) x)) (edn->value opts (meta x)))
|
||||
(seq? x) (with-meta (map (fn [v] (edn->value opts v)) x) (edn->value opts (meta x)))
|
||||
:else x))
|
||||
|
||||
;; Private helper, NOT named read-string: an unqualified (read-string …) call
|
||||
;; dispatches the core read-string SPECIAL FORM (by name, regardless of ns), so
|
||||
;; the 1-arity can't delegate to the 2-arity through that name.
|
||||
(defn- read-edn [opts s]
|
||||
;; the strict edn seam: no auto-resolved keywords, invalid tokens throw, and
|
||||
;; each #_ discard is validated through the same :readers/:default pipeline.
|
||||
;; EOF (blank/comment-only/nil input) honors :eof; an opts map WITHOUT :eof
|
||||
;; makes end-of-input an error, like the reference.
|
||||
(let [v (__read-form-edn s (fn [form] (edn->value opts form) nil))]
|
||||
(if (= v :jolt/reader-eof)
|
||||
(if (contains? opts :eof)
|
||||
(get opts :eof)
|
||||
(throw (ex-info "EOF while reading" {})))
|
||||
(edn->value opts v))))
|
||||
(if (or (nil? s) (cstr/blank? s))
|
||||
(get opts :eof nil)
|
||||
;; read the RAW form (tagged/set literals stay forms) so edn->value applies
|
||||
;; every #tag through :readers/:default — read-string would build the built-in
|
||||
;; #inst/#uuid eagerly, ignoring an override and failing on a non-string form.
|
||||
(edn->value opts (__read-form-raw s))))
|
||||
|
||||
(defn read-string
|
||||
"Reads one object from the string s. The no-opts arity returns nil at end of
|
||||
input; with an opts map, :eof sets the value returned at end of input and its
|
||||
absence makes end-of-input an error."
|
||||
([s] (read-edn {:eof nil} s))
|
||||
"Reads one object from the string s. Returns the :eof option value (default
|
||||
nil) for nil or blank input. opts is an options map; :eof sets the value
|
||||
returned at end of input."
|
||||
([s] (read-edn {} s))
|
||||
([opts s] (read-edn opts s)))
|
||||
|
||||
(defn- drain-reader
|
||||
|
|
|
|||
|
|
@ -6,32 +6,28 @@
|
|||
(if (nil? s) true
|
||||
(= 0 (count (str-trim s)))))
|
||||
|
||||
;; The case fns and the searches take any Object s through its toString, like
|
||||
;; the reference ((upper-case :kw) is ":KW", (capitalize 1) is "1"); nil throws
|
||||
;; like calling a method on null.
|
||||
(defn- to-str [s]
|
||||
(if (nil? s)
|
||||
(throw (new NullPointerException "s"))
|
||||
(.toString s)))
|
||||
(defn capitalize
|
||||
|
||||
[s]
|
||||
(let [s (to-str s)]
|
||||
(if (< 1 (count s))
|
||||
(str (str-upper (subs s 0 1))
|
||||
(str-lower (subs s 1)))
|
||||
(str-upper s))))
|
||||
(if (< 1 (count s))
|
||||
(str (str-upper (subs s 0 1))
|
||||
(str-lower (subs s 1)))
|
||||
(str-upper s)))
|
||||
|
||||
(defn lower-case
|
||||
|
||||
[s]
|
||||
(str-lower (to-str s)))
|
||||
(str-lower s))
|
||||
|
||||
(defn upper-case
|
||||
|
||||
[s]
|
||||
(str-upper (to-str s)))
|
||||
(str-upper s))
|
||||
|
||||
(defn includes?
|
||||
|
||||
[s substr]
|
||||
(not (nil? (str-find substr (to-str s)))))
|
||||
(not (nil? (str-find substr s))))
|
||||
|
||||
(defn join
|
||||
|
||||
|
|
@ -40,11 +36,11 @@
|
|||
|
||||
(defn replace
|
||||
[s match replacement]
|
||||
(str-replace-all match replacement (to-str s)))
|
||||
(str-replace-all match replacement s))
|
||||
|
||||
(defn replace-first
|
||||
[s match replacement]
|
||||
(str-replace match replacement (to-str s)))
|
||||
(str-replace match replacement s))
|
||||
|
||||
(defn reverse
|
||||
[s]
|
||||
|
|
@ -72,18 +68,16 @@
|
|||
(vec (str-split #"\r?\n" s)))
|
||||
|
||||
(defn starts-with?
|
||||
|
||||
[s substr]
|
||||
(when (nil? substr) (throw (new NullPointerException "substr")))
|
||||
(let [s (to-str s)
|
||||
slen (count s) slen2 (count substr)]
|
||||
(let [slen (count s) slen2 (count substr)]
|
||||
(and (>= slen slen2)
|
||||
(= (subs s 0 slen2) substr))))
|
||||
|
||||
(defn ends-with?
|
||||
|
||||
[s substr]
|
||||
(when (nil? substr) (throw (new NullPointerException "substr")))
|
||||
(let [s (to-str s)
|
||||
slen (count s) slen2 (count substr)]
|
||||
(let [slen (count s) slen2 (count substr)]
|
||||
(and (>= slen slen2)
|
||||
(= (subs s (- slen slen2)) substr))))
|
||||
|
||||
|
|
@ -103,8 +97,8 @@
|
|||
(str-trimr s))
|
||||
|
||||
(defn escape
|
||||
|
||||
[s cmap]
|
||||
(when (nil? s) (throw (new NullPointerException "s")))
|
||||
(apply str
|
||||
(map (fn [ch]
|
||||
(if-let [rep (cmap ch)] rep (str ch)))
|
||||
|
|
@ -113,9 +107,9 @@
|
|||
(defn index-of
|
||||
"0-based index of the first occurrence of value in s, or nil."
|
||||
([s value]
|
||||
(str-find value (to-str s)))
|
||||
(str-find value s))
|
||||
([s value from]
|
||||
(let [idx (str-find value (subs (to-str s) from))]
|
||||
(let [idx (str-find value (subs s from))]
|
||||
(when idx (+ from idx)))))
|
||||
|
||||
(defn last-index-of
|
||||
|
|
|
|||
|
|
@ -11,8 +11,7 @@
|
|||
; is a drop-in superset.
|
||||
|
||||
(ns clojure.test
|
||||
(:require [clojure.string :as str]
|
||||
[clojure.template :as temp]))
|
||||
(:require [clojure.string :as str]))
|
||||
|
||||
;; --- state -----------------------------------------------------------------
|
||||
|
||||
|
|
@ -20,8 +19,8 @@
|
|||
(def jolt-report counters) ;; alias used by the suite harness
|
||||
(def ctx-stack (atom []))
|
||||
(def registry (atom [])) ;; [{:name sym :fn thunk}]
|
||||
(def once-fixtures (atom {})) ;; ns-sym -> [fixture-fns]
|
||||
(def each-fixtures (atom {})) ;; ns-sym -> [fixture-fns]
|
||||
(def once-fixtures (atom []))
|
||||
(def each-fixtures (atom []))
|
||||
|
||||
;; clojure.test/*testing-vars* — the stack of vars under test. Real clojure.test
|
||||
;; binds it around each test var; test.check's default reporter reads it, so a
|
||||
|
|
@ -33,8 +32,8 @@
|
|||
(reset! counters {:test 0 :pass 0 :fail 0 :error 0 :fails []})
|
||||
(reset! ctx-stack [])
|
||||
(reset! registry [])
|
||||
(reset! once-fixtures {})
|
||||
(reset! each-fixtures {}))
|
||||
(reset! once-fixtures [])
|
||||
(reset! each-fixtures []))
|
||||
|
||||
(defn- ctx-str [] (str/join " " @ctx-stack))
|
||||
|
||||
|
|
@ -103,12 +102,6 @@
|
|||
(clojure.test/do-report {:type :error :message ~msg :form '~form
|
||||
:actual (clojure.test/err-text e#)}))))
|
||||
|
||||
;; The common pure predicates whose args `is` evaluates so a failure shows the
|
||||
;; actual values — (is (= expected got)) prints `got`, not just the form. A macro
|
||||
;; head (not in this set) keeps the plain form-only path.
|
||||
(def ^:private reported-preds
|
||||
'#{= not= == < > <= >= identical? contains? instance? nil? some? empty? even? odd? pos? neg? zero?})
|
||||
|
||||
;; --- class matching for thrown? --------------------------------------------
|
||||
|
||||
(defn- last-seg [s]
|
||||
|
|
@ -136,15 +129,6 @@
|
|||
([form] `(is ~form nil))
|
||||
([form msg]
|
||||
(cond
|
||||
;; a library-registered custom assertion (the assert-expr extension point)
|
||||
;; wins over every inline path, like clojure.test, where each `is` dispatches
|
||||
;; assert-expr on the exact head symbol and the built-ins are just
|
||||
;; pre-registered methods. In particular a registered alias-qualified
|
||||
;; `p/thrown?` must not be captured by the by-name thrown? path below.
|
||||
(and (seq? form) (symbol? (first form))
|
||||
(contains? (methods clojure.test/assert-expr) (first form)))
|
||||
(clojure.test/assert-expr msg form)
|
||||
|
||||
;; (is (thrown? Class body...))
|
||||
(thrown-form? form "thrown?")
|
||||
(let [klass-sym (second form)
|
||||
|
|
@ -182,17 +166,12 @@
|
|||
(clojure.test/inc-pass!)
|
||||
(clojure.test/fail! (str "expected throw of " ~klass " matching " ~re " but got " (clojure.core/class e#) ": " m#)))))))
|
||||
|
||||
;; a predicate call — (= a b), (< x y), (pred? v): evaluate the args so a
|
||||
;; failure shows the actual values, like clojure.test's assert-predicate.
|
||||
(and (seq? form) (contains? clojure.test/reported-preds (first form)))
|
||||
`(try
|
||||
(let [vs# (list ~@(rest form))]
|
||||
(if (apply ~(first form) vs#)
|
||||
(clojure.test/inc-pass!)
|
||||
(clojure.test/fail! (str (pr-str (list '~'not (cons '~(first form) vs#)))
|
||||
(when ~msg (str " — " ~msg))))))
|
||||
(catch Throwable e#
|
||||
(clojure.test/err! (str (pr-str '~form) " threw: " (clojure.test/err-text e#)))))
|
||||
;; a library-registered custom assertion (the assert-expr extension point);
|
||||
;; only fires for a symbol with an explicitly registered method, so built-in
|
||||
;; predicate forms keep the inline path below.
|
||||
(and (seq? form) (symbol? (first form))
|
||||
(contains? (methods clojure.test/assert-expr) (first form)))
|
||||
(clojure.test/assert-expr msg form)
|
||||
|
||||
:else
|
||||
`(try
|
||||
|
|
@ -212,33 +191,23 @@
|
|||
(defmacro deftest [name & body]
|
||||
`(do
|
||||
(defn ~name [] ~@body)
|
||||
(swap! clojure.test/registry conj {:name '~name
|
||||
:ns (clojure.core/ns-name clojure.core/*ns*)
|
||||
:fn ~name})
|
||||
(swap! clojure.test/registry conj {:name '~name :fn ~name})
|
||||
(var ~name)))
|
||||
|
||||
;; Template substitution (not let-binding), so argv symbols substitute inside
|
||||
;; quote and nested forms: (are [x] (special-symbol? 'x) if def) tests 'if.
|
||||
(defmacro are [argv expr & args]
|
||||
(if (or (and (empty? argv) (empty? args))
|
||||
(and (pos? (count argv))
|
||||
(pos? (count args))
|
||||
(zero? (mod (count args) (count argv)))))
|
||||
`(clojure.template/do-template ~argv (clojure.test/is ~expr) ~@args)
|
||||
(throw (IllegalArgumentException.
|
||||
"The number of args doesn't match are's argv or neither are empty"))))
|
||||
(defmacro are [argv expr & data]
|
||||
(let [n (count argv)
|
||||
rows (partition n data)]
|
||||
`(do ~@(map (fn [row]
|
||||
`(let [~@(interleave argv row)]
|
||||
(clojure.test/is ~expr)))
|
||||
rows))))
|
||||
|
||||
;; --- fixtures + run --------------------------------------------------------
|
||||
|
||||
;; Fixtures are per-namespace, like clojure.test (which stores them in ns
|
||||
;; metadata): use-fixtures records them under the calling ns, and only that
|
||||
;; ns's tests run through them — a suite loading many test namespaces into one
|
||||
;; process doesn't cross-apply or clobber another ns's fixtures.
|
||||
(defn use-fixtures [kind & fns]
|
||||
(let [n (ns-name *ns*)]
|
||||
(cond
|
||||
(= kind :once) (swap! once-fixtures assoc n (vec fns))
|
||||
(= kind :each) (swap! each-fixtures assoc n (vec fns)))))
|
||||
(cond
|
||||
(= kind :once) (reset! once-fixtures (vec fns))
|
||||
(= kind :each) (reset! each-fixtures (vec fns))))
|
||||
|
||||
(defn- wrap-fixtures [fixtures body-fn]
|
||||
(if (empty? fixtures)
|
||||
|
|
@ -247,46 +216,25 @@
|
|||
|
||||
(defn- run-one [t]
|
||||
(swap! counters update :test inc)
|
||||
(wrap-fixtures (get @each-fixtures (:ns t) [])
|
||||
(wrap-fixtures @each-fixtures
|
||||
(fn []
|
||||
(try
|
||||
((:fn t))
|
||||
(catch Throwable e
|
||||
(err! (str (:name t) " crashed: " (err-text e))))))))
|
||||
|
||||
;; Run the registered tests grouped by namespace (registration order preserved
|
||||
;; within each ns), each group wrapped in its ns's :once fixtures. ns-set nil
|
||||
;; means all.
|
||||
(defn- run-selected [ns-set]
|
||||
(let [ts (if ns-set (filter (fn [t] (contains? ns-set (:ns t))) @registry) @registry)]
|
||||
(doseq [n (distinct (map :ns ts))]
|
||||
(wrap-fixtures (get @once-fixtures n [])
|
||||
(fn [] (doseq [t ts :when (= n (:ns t))] (run-one t))))))
|
||||
(defn run-registered []
|
||||
(doseq [t @registry] (run-one t))
|
||||
nil)
|
||||
|
||||
(defn run-registered [] (run-selected nil))
|
||||
|
||||
;; (run-tests 'ns1 'ns2 …) runs only those namespaces' tests, like clojure.test.
|
||||
;; With no args it runs everything registered (a deliberate superset of the
|
||||
;; JVM's current-ns default — jolt's harnesses load then run whole suites).
|
||||
;; Prints and returns THIS call's summary; the global counters stay cumulative
|
||||
;; for the n-pass/n-fail harness API.
|
||||
(defn run-tests [& nses]
|
||||
(let [before @counters
|
||||
ns-set (when (seq nses)
|
||||
(set (map (fn [n] (if (symbol? n) n (ns-name n))) nses)))]
|
||||
(run-selected ns-set)
|
||||
(let [r @counters
|
||||
d {:type :summary
|
||||
:test (- (:test r) (:test before))
|
||||
:pass (- (:pass r) (:pass before))
|
||||
:fail (- (:fail r) (:fail before))
|
||||
:error (- (:error r) (:error before))}]
|
||||
(println)
|
||||
(println (str "Ran " (:test d) " tests. "
|
||||
(:pass d) " assertions passed, "
|
||||
(:fail d) " failures, " (:error d) " errors."))
|
||||
d)))
|
||||
(defn run-tests [& _nses]
|
||||
(wrap-fixtures @once-fixtures (fn [] (run-registered)))
|
||||
(let [r @counters]
|
||||
(println)
|
||||
(println (str "Ran " (:test r) " tests. "
|
||||
(:pass r) " assertions passed, "
|
||||
(:fail r) " failures, " (:error r) " errors."))
|
||||
r))
|
||||
|
||||
(defn run-test [& _] nil)
|
||||
(defn test-var [& _] nil)
|
||||
|
|
|
|||
|
|
@ -19,10 +19,7 @@
|
|||
; concat/lazy-seq) walk too — without this, postwalk-replace silently no-op'd
|
||||
; a quoted list, breaking clojure.template/apply-template
|
||||
(list? form) (outer (with-meta (apply list (map inner form)) (meta form)))
|
||||
; doall like Clojure: walk must be eager so an `inner` with side effects
|
||||
; (rewrite-clj's #() reader bumps an arg-count atom during the walk, read right
|
||||
; after) runs now, not lazily when the result is later realized.
|
||||
(seq? form) (outer (with-meta (doall (map inner form)) (meta form)))
|
||||
(seq? form) (outer (with-meta (map inner form) (meta form)))
|
||||
:else (outer form)))
|
||||
|
||||
(defn postwalk
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ test` from the repo root.
|
|||
|
||||
## The spec corpus
|
||||
|
||||
`corpus.edn` is the contract: ~3570 rows `{:suite :label :expected :actual :portability}`, with
|
||||
`corpus.edn` is the contract: ~2920 rows `{:suite :label :expected :actual}`, with
|
||||
`:expected` sourced from reference JVM Clojure by `test/conformance/regen-corpus.clj`.
|
||||
It is frozen (the canonical source) — add or change cases here, then re-source the
|
||||
answers with `regen-corpus.clj` and re-certify with `test/conformance/certify.clj`.
|
||||
|
|
@ -22,7 +22,7 @@ answers with `regen-corpus.clj` and re-certify with `test/conformance/certify.cl
|
|||
|
||||
chez --script host/chez/run-corpus.ss
|
||||
JOLT_CORPUS_LIMIT=200 … # every-Nth stride, fast iteration
|
||||
JOLT_CHEZ_ZJ_FLOOR=N … # override the floor (see run-corpus.ss)
|
||||
JOLT_CHEZ_ZJ_FLOOR=N … # override the floor (default 2678)
|
||||
|
||||
- `run-unit.ss` — host-specific unit cases (`test/chez/unit.edn`) that aren't in the
|
||||
JVM-portable corpus: dot-forms, java statics, io, reader, walk, vars/namespaces,
|
||||
|
|
@ -32,16 +32,6 @@ answers with `regen-corpus.clj` and re-certify with `test/conformance/certify.cl
|
|||
- `selfcheck.sh` — self-host fixpoint: `bootstrap.ss` rebuild byte-equals the
|
||||
checked-in seed (`host/chez/seed/`).
|
||||
- `smoke.sh` — real `bin/joltc -e` CLI smoke.
|
||||
- `cts.sh` — the vendored [jank-lang/clojure-test-suite](https://github.com/jank-lang/clojure-test-suite)
|
||||
(`vendor/clojure-test-suite`, a per-core-fn clojure.test suite shared across
|
||||
Clojure dialects), run one namespace per `joltc` process (a hang or crash is
|
||||
contained) through the `test/chez/cts-app` project and `cts-run` runner.
|
||||
Per-namespace fail/error counts must exactly match the checked-in baseline
|
||||
`test/chez/cts-known-failures.txt` — a namespace doing worse fails the gate,
|
||||
and one doing better fails as stale until the baseline is updated in the same
|
||||
change. `make cts`;
|
||||
`JOLT_CTS_NS=ns1,ns2` runs a subset verbosely,
|
||||
`JOLT_CTS_WRITE_BASELINE=1` regenerates the baseline.
|
||||
|
||||
## Other Chez tests
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
{:paths ["src"]}
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
(ns fix.lib
|
||||
(:require [clojure.set :as ss]))
|
||||
(defn u [] (ss/union #{1} #{2}))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
(ns fix.main
|
||||
(:require [clojure.string :as ss]
|
||||
[fix.lib :as lib]))
|
||||
(defn -main [& _]
|
||||
(println (ss/upper-case "hi") (lib/u)))
|
||||
|
|
@ -11,17 +11,6 @@
|
|||
(clojure.test/do-report {:type :pass})
|
||||
(clojure.test/do-report {:type :fail :message ~msg :form '~form}))))
|
||||
|
||||
;; an ALIAS-QUALIFIED registered assertion whose simple name collides with the
|
||||
;; built-in thrown? — the registered method must win over the by-name inline
|
||||
;; path (clojure-test-suite's portability/thrown? registers exactly this shape).
|
||||
(defmethod t/assert-expr 'p/thrown? [msg form]
|
||||
`(try
|
||||
(do ~@(rest form))
|
||||
(clojure.test/do-report {:type :fail :message ~msg :form '~form})
|
||||
(catch Throwable e#
|
||||
(clojure.test/do-report {:type :pass})
|
||||
e#)))
|
||||
|
||||
;; a custom report type (how test.check surfaces trial/shrink progress)
|
||||
(def trials (atom 0))
|
||||
(defmethod t/report ::trial [_m] (swap! trials inc))
|
||||
|
|
@ -36,34 +25,23 @@
|
|||
(are [x y] (= x y)
|
||||
2 (+ 1 1)
|
||||
6 (* 2 3))
|
||||
;; template vars substitute inside quote (are is clojure.template, not let)
|
||||
(are [x] (special-symbol? 'x)
|
||||
if
|
||||
def)
|
||||
(is (thrown? clojure.lang.ExceptionInfo (throw (ex-info "x" {}))))
|
||||
(is (thrown-with-msg? Exception #"bad" (throw (ex-info "bad" {}))))
|
||||
(is (near? 1.0 1.005))
|
||||
(is (p/thrown? (throw (ex-info "boom" {})))))
|
||||
(is (near? 1.0 1.005)))
|
||||
|
||||
(deftest expected-fail
|
||||
(is (= 1 2))
|
||||
(is (near? 1.0 5.0)))
|
||||
|
||||
;; run-tests returns THIS call's summary; with explicit nses it runs only their
|
||||
;; tests (an unknown ns runs nothing).
|
||||
(def r1 (run-tests))
|
||||
(def r2 (run-tests 'no.such.test-ns))
|
||||
(run-tests)
|
||||
(t/do-report {:type ::trial})
|
||||
(t/do-report {:type ::trial})
|
||||
|
||||
;; 10 pass (= + vector? + 4 are rows + thrown? + thrown-with-msg? + near? + p/thrown?),
|
||||
;; 7 pass (= + vector? + 2 are rows + thrown? + thrown-with-msg? + near?),
|
||||
;; 2 fail (= 1 2, near? 1.0 5.0), 0 error, 2 fixture runs, 2 custom reports
|
||||
(let [ok (and (= (t/n-pass) 10) (= (t/n-fail) 2) (= (t/n-error) 0)
|
||||
(= 2 (:test r1)) (= 10 (:pass r1)) (= 2 (:fail r1))
|
||||
(= 0 (:test r2)) (= 0 (:pass r2))
|
||||
(let [ok (and (= (t/n-pass) 7) (= (t/n-fail) 2) (= (t/n-error) 0)
|
||||
(= @setups 2) (= @trials 2))]
|
||||
(println (if ok
|
||||
"CLOJURE-TEST OK"
|
||||
(str "CLOJURE-TEST FAIL pass=" (t/n-pass) " fail=" (t/n-fail)
|
||||
" error=" (t/n-error) " r1=" (pr-str r1) " r2=" (pr-str r2)
|
||||
" setups=" @setups " trials=" @trials))))
|
||||
" error=" (t/n-error) " setups=" @setups " trials=" @trials))))
|
||||
|
|
|
|||
7040
test/chez/corpus.edn
7040
test/chez/corpus.edn
File diff suppressed because it is too large
Load diff
|
|
@ -1,2 +0,0 @@
|
|||
{:paths ["src" "../../../vendor/clojure-test-suite/test"]
|
||||
:aliases {:cts {:main-opts ["-m" "cts-run"]}}}
|
||||
|
|
@ -1,18 +0,0 @@
|
|||
(ns cts-run
|
||||
"Runner for the vendored jank-lang/clojure-test-suite (vendor/clojure-test-suite):
|
||||
requires each test namespace given on the command line and runs its clojure.test
|
||||
tests, printing one machine-readable result line per namespace. Driven per-process
|
||||
by host/chez/cts.sh so a hang or crash in one namespace can't take out the run."
|
||||
(:require [clojure.test :as t]))
|
||||
|
||||
(defn -main [& nses]
|
||||
(doseq [n nses]
|
||||
(let [ns-sym (symbol n)]
|
||||
(try
|
||||
(require ns-sym)
|
||||
(let [r (t/run-tests ns-sym)]
|
||||
(println "CTS-RESULT" n (:pass r 0) (:fail r 0) (:error r 0)))
|
||||
(catch Throwable e
|
||||
(println "CTS-RESULT" n 0 0 1
|
||||
(str "LOAD: " (.getName (class e)) ": " (.getMessage e)))))))
|
||||
(System/exit 0))
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
# clojure-test-suite known failures: <namespace> <fail> <error>
|
||||
# The gate fails on any per-namespace change, worse OR better; regenerate
|
||||
# with: JOLT_CTS_WRITE_BASELINE=1 host/chez/cts.sh
|
||||
clojure.core-test.abs 1 0
|
||||
clojure.core-test.add-watch 0 1
|
||||
clojure.core-test.bigint 6 0
|
||||
clojure.core-test.bit-set 1 0
|
||||
clojure.core-test.dec 1 0
|
||||
clojure.core-test.double-qmark 3 0
|
||||
clojure.core-test.eq 2 0
|
||||
clojure.core-test.float 1 0
|
||||
clojure.core-test.inc 1 0
|
||||
clojure.core-test.int-qmark 3 0
|
||||
clojure.core-test.lazy-seq 1 2
|
||||
clojure.core-test.minus 2 0
|
||||
clojure.core-test.mod 18 0
|
||||
clojure.core-test.neg-int-qmark 1 0
|
||||
clojure.core-test.not-eq 3 0
|
||||
clojure.core-test.num 2 0
|
||||
clojure.core-test.parse-uuid 3 0
|
||||
clojure.core-test.peek 1 0
|
||||
clojure.core-test.plus 11 0
|
||||
clojure.core-test.plus-squote 11 0
|
||||
clojure.core-test.pos-int-qmark 1 0
|
||||
clojure.core-test.quot 25 0
|
||||
clojure.core-test.realized-qmark 1 0
|
||||
clojure.core-test.rem 16 0
|
||||
clojure.core-test.remove-watch 0 1
|
||||
clojure.core-test.star 13 0
|
||||
clojure.core-test.star-squote 13 0
|
||||
clojure.core-test.transient 4 0
|
||||
clojure.core-test.vec 1 0
|
||||
|
|
@ -1 +0,0 @@
|
|||
{:paths ["src"]}
|
||||
|
|
@ -1 +0,0 @@
|
|||
{code drtest.reader/code-reader}
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
(ns drtest.main
|
||||
(:require drtest.reader))
|
||||
(defn -main [& _]
|
||||
(println #code [:ignored]))
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
(ns drtest.reader)
|
||||
(defn code-reader [_form] (list '+ 40 2))
|
||||
|
|
@ -36,7 +36,7 @@
|
|||
(ev "(def add1 (fn* ([x] (+ x 1))))")
|
||||
(let ((e (emitf "u" "(fn* ([y] (add1 y)))")))
|
||||
(ok "plain fn is inlined (call to add1 gone)" (not (has? e "add1")))
|
||||
(ok "inlined body present (jolt-n+ ... 1)" (has? e "(jolt-n+")))
|
||||
(ok "inlined body present (+ ... 1)" (has? e "(+")))
|
||||
(ok "inlined plain fn runtime: (add1 41) = 42" (= 42 (jnum->exact (ev "((fn* ([y] (add1 y))) 41)"))))
|
||||
|
||||
;; a ^double fn: body fl-ops fire after inlining, and the call is gone.
|
||||
|
|
|
|||
|
|
@ -226,7 +226,6 @@
|
|||
{:suite "ioreader" :expr "(let [log (atom [])] (try (with-open [c {:close (fn [] (swap! log conj :closed))}] (throw (ex-info \"boom\" {}))) (catch Exception e nil)) (deref log))" :expected "[:closed]"}
|
||||
{:suite "ioreader" :expr "(let [log (atom [])] (with-open [a {:close (fn [] (swap! log conj :outer))} b {:close (fn [] (swap! log conj :inner))}] :r) (deref log))" :expected "[:inner :outer]"}
|
||||
{:suite "ioreader" :expr "(with-open [c {:close (fn [] nil) :v 5}] (:v c))" :expected "5"}
|
||||
{:suite "ioreader" :expr "(do (defrecord RC [log] java.io.Closeable (close [_] (swap! log conj :closed))) (let [log (atom [])] (with-open [r (->RC log)] :body) @log))" :expected "[:closed]"}
|
||||
{:suite "javastatic" :expr "(Math/sqrt 16)" :expected "4.0"}
|
||||
{:suite "javastatic" :expr "(Math/abs -3)" :expected "3"}
|
||||
{:suite "javastatic" :expr "(Math/max 2 7)" :expected "7"}
|
||||
|
|
@ -312,8 +311,6 @@
|
|||
{:suite "reader" :expr "(nil? (read-string \"nil\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(true? (read-string \"true\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(false? (read-string \"false\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(let [r (read-string \"#foo bar\")] (and (tagged-literal? r) (= (quote foo) (:tag r)) (= (quote bar) (:form r)) (= \"#foo bar\" (pr-str r))))" :expected "true"}
|
||||
{:suite "reader" :expr "(let [t (first (quote [#foo bar]))] (and (tagged-literal? t) (= (quote foo) (:tag t)) (= \"#foo bar\" (pr-str t))))" :expected "true"}
|
||||
{:suite "reader" :expr "(= \\a (read-string \"\\\\a\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(= \\newline (read-string \"\\\\newline\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(= \\space (read-string \"\\\\space\"))" :expected "true"}
|
||||
|
|
@ -576,26 +573,4 @@
|
|||
{:suite "deftype-method" :expr "(do (defprotocol P (m [_ o])) (defrecord R [n] P (m [_ _] n)) (m (->R 5) :x))" :expected "5"}
|
||||
{:suite "deftype-method" :expr "(do (defprotocol P2 (m2 [_ o])) (deftype T [n] P2 (m2 [_ _] n)) (m2 (->T 7) :x))" :expected "7"}
|
||||
{:suite "protocol-host" :expr "(do (defprotocol Q (e [_])) (extend-protocol Q clojure.lang.Var (e [_] :var)) [(satisfies? Q (var map)) (e (var map))])" :expected "[true :var]"}
|
||||
|
||||
;; Clojure 1.13 (1.13.0-alpha1) parity. Ahead of the JVM 1.12.5 the corpus
|
||||
;; certifies against, so these live here rather than as certified corpus rows.
|
||||
{:suite "clj-1.13 req!" :expr "(req! {:a 1} :a)" :expected "1"}
|
||||
{:suite "clj-1.13 req!" :expr "(req! [10 20 30] 1)" :expected "20"}
|
||||
{:suite "clj-1.13 req!" :expr "(nil? (req! {:a nil} :a))" :expected "true"}
|
||||
{:suite "clj-1.13 req!" :expr "(req! {:a 1} :b)" :expected :throws}
|
||||
{:suite "clj-1.13 amp-binding" :expr "(let [& 42] &)" :expected :throws}
|
||||
{:suite "clj-1.13 amp-binding" :expr "(loop [& 42] &)" :expected :throws}
|
||||
{:suite "clj-1.13 checked-keys" :expr "(let [{:keys! [a b]} {:a 1 :b 2}] [a b])" :expected "[1 2]"}
|
||||
{:suite "clj-1.13 checked-keys" :expr "(let [{:keys! [a b]} {:a 1}] [a b])" :expected :throws}
|
||||
{:suite "clj-1.13 checked-keys" :expr "(nil? (let [{:keys! [a]} {:a nil}] a))" :expected "true"}
|
||||
{:suite "clj-1.13 checked-keys" :expr "(let [{:strs! [a]} {\"a\" 5}] a)" :expected "5"}
|
||||
{:suite "clj-1.13 checked-keys" :expr "(let [{:keys! [a & b]} {:a 1 :b 2}] a)" :expected "1"}
|
||||
{:suite "clj-1.13 checked-keys" :expr "(let [{:keys! [a & b]} {:a 1}] a)" :expected :throws}
|
||||
{:suite "clj-1.13 checked-keys" :expr "(let [{:keys [a & b]} {:a 1 :b 2}] a)" :expected "1"}
|
||||
{:suite "clj-1.13 checked-keys" :expr "(let [{:foo/keys! [a]} {:foo/a 7}] a)" :expected "7"}
|
||||
{:suite "clj-1.13 checked-keys" :expr "(let [{:foo/keys! [a]} {}] a)" :expected :throws}
|
||||
{:suite "clj-1.13 array-map-64" :expr "(keys {:a 1 :b 2 :c 3 :d 4 :e 5 :f 6 :g 7 :h 8 :i 9 :j 10})" :expected "(:a :b :c :d :e :f :g :h :i :j)"}
|
||||
{:suite "clj-1.13 array-map-64" :expr "(= (map (fn [i] (keyword (str \"k\" i))) (range 20)) (keys (into {} (map (fn [i] [(keyword (str \"k\" i)) i]) (range 20)))))" :expected "true"}
|
||||
{:suite "clj-1.13 array-map-64" :expr "(= (map (fn [i] (keyword (str \"k\" i))) (range 64)) (keys (reduce (fn [m i] (assoc m (keyword (str \"k\" i)) i)) {} (range 64))))" :expected "true"}
|
||||
{:suite "clj-1.13 array-map-64" :expr "(= (map (fn [i] (keyword (str \"k\" i))) (range 65)) (keys (into {} (map (fn [i] [(keyword (str \"k\" i)) i]) (range 65)))))" :expected "false"}
|
||||
]
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ read one data file, run each case, compare, report.
|
|||
|
||||
| File | Role | Generated by |
|
||||
|------|------|--------------|
|
||||
| `test/chez/corpus.edn` | **The spec.** ~3570 cases of `{:suite :label :expected :actual :portability}`, `:expected` **sourced from reference JVM Clojure**. | `test/conformance/regen-corpus.clj` |
|
||||
| `test/chez/corpus.edn` | **The spec.** ~2900 cases of `{:suite :label :expected :actual}`, `:expected` **sourced from reference JVM Clojure**. | `test/conformance/regen-corpus.clj` |
|
||||
| `test/conformance/profile.edn` | Per-case **feature classification** — which non-portable cases need which host capability. | `certify.clj --profile` |
|
||||
| `test/conformance/known-divergences.edn` | The few rows whose JVM value is an opaque host object that can't round-trip to readable source (Java arrays/transients/atoms/beans/proxies print as `#object[..@addr]`), so the corpus keeps jolt's value. | `regen-corpus.clj` leftovers, hand-checked |
|
||||
| `test/conformance/regen-corpus.clj` | Sources every `:expected` from reference **JVM Clojure** in one process. | — |
|
||||
|
|
@ -24,17 +24,11 @@ the canonical, frozen contract**: it is what every runtime consumes, what
|
|||
## Row schema
|
||||
|
||||
```edn
|
||||
{:suite "numbers / arithmetic" ; grouping; "<suite> :: <label>" is the case id
|
||||
:label "integer add" ; unique within a suite
|
||||
:actual "(+ 1 2)" ; Clojure source to evaluate
|
||||
:expected "3" ; Clojure source whose value it must equal,
|
||||
{:suite "numbers / arithmetic" ; grouping; "<suite> :: <label>" is the case id
|
||||
:label "integer add" ; unique within a suite
|
||||
:actual "(+ 1 2)" ; Clojure source to evaluate
|
||||
:expected "3"} ; Clojure source whose value it must equal,
|
||||
; or the keyword :throws
|
||||
:portability :common} ; :common = portable Clojure any dialect
|
||||
; must satisfy; :jvm = exercises host
|
||||
; interop (java.*/clojure.lang.* classes,
|
||||
; dot forms, ctors, statics, arrays,
|
||||
; proxy/bean) — skip on a non-JVM-shaped
|
||||
; dialect
|
||||
```
|
||||
|
||||
- `[:suite :label]` is the **canonical, unique case id** (the generator
|
||||
|
|
@ -54,8 +48,8 @@ the canonical, frozen contract**: it is what every runtime consumes, what
|
|||
Historically every `:expected` was hand-written. `certify.clj` removes that
|
||||
weakness: it evaluates every `:actual` (and `:expected`) on **JVM Clojure** in a
|
||||
fresh `user` namespace and checks jolt's `:expected` against what real Clojure
|
||||
produces. Of ~3400 vanilla-certifiable rows, **all but ~26 allowlisted rows
|
||||
match reference Clojure exactly**. The rest are classified (see below) — none are silently wrong.
|
||||
produces. Of ~2740 vanilla-certifiable rows, **>2730 match reference Clojure
|
||||
exactly**. The rest are classified (see below) — none are silently wrong.
|
||||
|
||||
```sh
|
||||
clojure -M test/conformance/certify.clj # gate
|
||||
|
|
@ -133,49 +127,10 @@ arithmetic, `=`, and `hash` behave exactly as the JVM — but report `Long`, not
|
|||
`Byte`/`Short`/`Integer`, so `(class (byte 5))` and `(instance? Byte (byte 5))`
|
||||
diverge. This is substrate-inherent: a Chez fixnum is an immediate `identical?`
|
||||
to the plain integer (nothing to tag, and numbers carry no metadata), so the only
|
||||
faithful representation is a boxed type — which would crash the compiled
|
||||
arithmetic fast path (both operands Chez numbers → the raw Chez op) or force
|
||||
every `+`/`-`/`*` through an unwrapping dispatcher, de-optimizing all
|
||||
arithmetic. Same shape as the accepted BigInt-vs-Long unification.
|
||||
|
||||
The cast RANGE contract is full parity (corpus `casts / *`): `byte`/`short`/
|
||||
`int`/`long`/`char` range-check like `RT.byteCast` — an out-of-range value is
|
||||
IllegalArgumentException "Value out of range for byte: 128". A double operand
|
||||
range-checks ITSELF before truncating (`(byte 1.1)` is `1`, `(byte 127.000001)`
|
||||
throws), NaN casts to 0, ratios and bigdecs truncate, a non-number is
|
||||
ClassCastException. `float` range-checks against Float/MAX_VALUE. The
|
||||
`unchecked-*` casts wrap and sign-fold like the JVM primitive conversions
|
||||
(`(unchecked-byte 200)` is `-56`; a double saturates instead of wrapping).
|
||||
What jolt does NOT model is a distinct single-float type: `(float x)` keeps
|
||||
the double VALUE, so a double below Float/MIN_VALUE stays nonzero and float
|
||||
rounding does not occur (the accepted no-single-float residue, baselined with
|
||||
`:integer-box-model`'s class residue).
|
||||
|
||||
## Number operations
|
||||
|
||||
Binary arithmetic and comparisons follow the JVM's `Numbers.ops(x, y)` category
|
||||
dispatch. Every position (call, value, higher-order) funnels a binary op through
|
||||
one seam (`host/chez/seq.ss`): operands inside Chez's tower take the native op
|
||||
with the JVM contagion rules patched in; an operand outside it (BigDecimal)
|
||||
falls to a slow hook the numeric shim extends (`host/chez/java/bigdec.ss`); a
|
||||
non-numeric operand throws `ClassCastException`. The rules the corpus pins
|
||||
(`numbers / ops dispatch`, `numbers / with-precision`, `numbers / rationalize`):
|
||||
|
||||
- A double operand wins: `(* 1.0 0)` is `0.0` (Chez's exact-zero shortcut must
|
||||
not leak), `(* ##Inf 0)` is `##NaN`, `(+ 1.5M 2.0)` is `3.5`.
|
||||
- Division: an exact zero divisor throws `ArithmeticException`; a double zero
|
||||
divisor yields `##Inf`/`##-Inf`/`##NaN`. `(/ 1M 3M)` with no bound
|
||||
`*math-context*` throws (non-terminating); under `with-precision` it rounds.
|
||||
- `quot`/`rem`/`mod` cover the full tower (ratios truncate; doubles keep double;
|
||||
`mod` takes the divisor's sign; zero divisor throws in both worlds).
|
||||
- `min`/`max` return the *original* operand (`(min 1 2.0)` is `1`, exact); a
|
||||
`##NaN` operand wins.
|
||||
- `with-precision` binds `*math-context*`; BigDecimal results round to the
|
||||
precision with the `java.math.RoundingMode` semantics (default `HALF_UP`,
|
||||
`UNNECESSARY` throws).
|
||||
- `rationalize` routes a double through its shortest decimal print
|
||||
(`BigDecimal.valueOf`), so `(rationalize 1.1)` is `11/10`, not the exact
|
||||
binary expansion.
|
||||
faithful representation is a boxed type — which would crash raw compiled `(+ …)`
|
||||
(arithmetic emits a bare Chez `+`) or force every `+`/`-`/`*` through an
|
||||
unwrapping dispatcher, de-optimizing all arithmetic. Same shape as the accepted
|
||||
BigInt-vs-Long unification.
|
||||
|
||||
## Hosting jolt on a new runtime
|
||||
|
||||
|
|
@ -211,39 +166,3 @@ corpus`.
|
|||
deliberate delta (classify it in `known-divergences.edn`).
|
||||
- **Refresh the profile**: re-run with `--profile test/conformance/profile.edn`.
|
||||
- **Re-floor the runtime gate** when parity rises (`host/chez/run-corpus.ss`).
|
||||
|
||||
## clojure-test-suite baseline traceability
|
||||
|
||||
Every residual entry in `test/chez/cts-known-failures.txt` traces to one
|
||||
documented model divergence — nothing in the baseline is an unexplained bug:
|
||||
|
||||
- `:integer-box-model` (this file, above): every `big-int?`/`instance?
|
||||
Byte…BigInt` class check, the overflow-throw rows (`(+ max-long 1)` is a
|
||||
bignum, not ArithmeticException — abs/inc/dec/minus/plus/star/quot/rem/mod/
|
||||
bit-set and the `+'`/`*'` promotion-identity namespaces), boxed-identity
|
||||
rows (`(identical? (Boolean. "true") true)`, `(= x x)` on a boxed NaN — jolt
|
||||
numbers are immediates, there is no box to distinguish), and `num`'s
|
||||
primitive-overload reflection rows.
|
||||
- **no single float** (Narrow integer types, above): `(float Double/MIN_VALUE)`
|
||||
keeps the double value instead of rounding to 0.0f; `(double? (float x))`
|
||||
is true.
|
||||
- **RFC 0003 transients**: `(transient sorted/list/lazy-seq)` succeeds through
|
||||
the copy-on-write fallback (a deliberate superset; non-collections now throw
|
||||
like the JVM), and double-transient is idempotent rather than throwing.
|
||||
- `:seq-type-model`/`:chunking-model` (Seq semantics, above): `realized?` on
|
||||
the rest of a realized chain (a plain seq cell on jolt, a cached LazySeq on
|
||||
the JVM), `p/lazy-seq?` on forced rest chains, and chunk-granularity
|
||||
realization counts (lazy-seq namespace).
|
||||
- **stm-refs** (`coverage.md`): the `(ref …)`/`dosync` sections of the watch
|
||||
namespaces (add-watch/remove-watch) — refs are out of scope pending the
|
||||
concurrency design note.
|
||||
- **parse-uuid strictness** (spec §9, parse-uuid S3): jolt is deliberately
|
||||
strict where the reference's java.util.UUID accepts non-canonical forms
|
||||
like `"0-0-0-0-0"`.
|
||||
- **vec of an array copies**: the reference ADOPTS an Object array (mutating
|
||||
the array mutates the vector); jolt copies — immutable semantics win over
|
||||
the implementation leak (`vec` namespace, one row).
|
||||
|
||||
|
||||
A future change that makes any of these rows pass will fail the cts gate as
|
||||
STALE, forcing this section and the baseline to be updated together.
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
"Rows of test/chez/corpus.edn whose :expected differs from reference JVM Clojure. The corpus is JVM-sourced (regen-corpus.clj), so this list is only the rows whose JVM value is an opaque host object that cannot round-trip to readable source — Java arrays, transients, atoms, beans, proxies, and chunks print as #object[..@addr] with a per-run identity — plus the (fn* foo) strictness case. For that the corpus keeps jolt's value. certify.clj gates on NEW (unlisted) divergences and STALE entries. Keyed by [suite label].",
|
||||
:legend
|
||||
{:numeric-model
|
||||
"jolt has the full numeric tower (exact integer / Ratio / double / BigDecimal); binary ops dispatch by operand category with JVM contagion rules",
|
||||
"jolt has a numeric tower (exact integer / Ratio / double); no BigDecimal",
|
||||
:host-model
|
||||
"no JVM host: classes->name strings, type->symbol, *in* is a map, inline-impl extenders, duck-typed with-open close",
|
||||
:reader-model
|
||||
|
|
|
|||
|
|
@ -99,12 +99,11 @@
|
|||
[row :kept])))
|
||||
|
||||
;; --- corpus writer (preserves the one-row-per-line layout) -------------------
|
||||
(defn row-str [{:keys [suite label expected actual portability]}]
|
||||
(defn row-str [{:keys [suite label expected actual]}]
|
||||
(str " {:suite " (pr-str suite)
|
||||
" :label " (pr-str label)
|
||||
" :expected " (if (= expected :throws) ":throws" (pr-str expected))
|
||||
" :actual " (pr-str actual)
|
||||
(when portability (str " :portability " portability)) "}"))
|
||||
" :actual " (pr-str actual) "}"))
|
||||
|
||||
(defn -main [& _]
|
||||
(let [corpus (edn/read-string (slurp corpus-path))
|
||||
|
|
|
|||
1
vendor/clojure-test-suite
vendored
1
vendor/clojure-test-suite
vendored
|
|
@ -1 +0,0 @@
|
|||
Subproject commit 489b6743e8421687ef96cec557830acf258d1886
|
||||
Loading…
Add table
Add a link
Reference in a new issue