Compare commits

..

No commits in common. "main" and "string/tostring-coercion" have entirely different histories.

49 changed files with 4552 additions and 5835 deletions

View file

@ -12,7 +12,6 @@ on:
push: push:
tags: tags:
- 'v*' - 'v*'
workflow_dispatch: {} # dry-run the build matrix without tagging
permissions: permissions:
contents: write # create/update the GitHub Release and upload assets contents: write # create/update the GitHub Release and upload assets
@ -27,18 +26,10 @@ jobs:
include: include:
- os: ubuntu-latest - os: ubuntu-latest
target: x86_64-linux target: x86_64-linux
shell: bash
# No x86_64-macos: GitHub is retiring the macos-13 Intel runner (jobs # No x86_64-macos: GitHub is retiring the macos-13 Intel runner (jobs
# queue forever). Intel Macs build from source. macos-14 is arm64. # queue forever). Intel Macs build from source. macos-14 is arm64.
- os: macos-14 - os: macos-14
target: aarch64-macos target: aarch64-macos
shell: bash
- os: windows-latest
target: x86_64-windows
shell: msys2 {0}
defaults:
run:
shell: ${{ matrix.shell }}
steps: steps:
- uses: actions/checkout@v5 - uses: actions/checkout@v5
with: with:
@ -87,65 +78,6 @@ jobs:
if: runner.os == 'macOS' if: runner.os == 'macOS'
run: brew install chezscheme lz4 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 - name: Show Chez version
run: chez --version run: chez --version
@ -154,19 +86,6 @@ jobs:
# dev-machine check — see jolt-8479). `make joltc-release`, not `make joltc`. # dev-machine check — see jolt-8479). `make joltc-release`, not `make joltc`.
- name: Build joltc (release) - name: Build joltc (release)
run: make 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. # Sanity: the built binary runs (no Chez needed) and self-reports a value.
- name: Smoke the binary - name: Smoke the binary
@ -213,24 +132,16 @@ jobs:
ver="${GITHUB_REF_NAME}" ver="${GITHUB_REF_NAME}"
name="joltc-${ver}-${{ matrix.target }}" name="joltc-${ver}-${{ matrix.target }}"
mkdir -p "dist/${name}" mkdir -p "dist/${name}"
cp README.md LICENSE "dist/${name}/"
if [ "${{ runner.os }}" = "Windows" ]; then
cp target/release/joltc.exe "dist/${name}/joltc.exe"
( cd dist && zip -r "${name}.zip" "${name}" && sha256sum "${name}.zip" > "${name}.zip.sha256" )
else
cp target/release/joltc "dist/${name}/joltc" cp target/release/joltc "dist/${name}/joltc"
cp README.md LICENSE "dist/${name}/"
tar -C dist -czf "dist/${name}.tar.gz" "${name}" tar -C dist -czf "dist/${name}.tar.gz" "${name}"
( cd dist && shasum -a 256 "${name}.tar.gz" > "${name}.tar.gz.sha256" ) ( cd dist && shasum -a 256 "${name}.tar.gz" > "${name}.tar.gz.sha256" )
fi
ls -la dist ls -la dist
- name: Upload to the GitHub Release - name: Upload to the GitHub Release
if: startsWith(github.ref, 'refs/tags/')
uses: softprops/action-gh-release@v2 uses: softprops/action-gh-release@v2
with: with:
files: | files: |
dist/*.tar.gz dist/*.tar.gz
dist/*.tar.gz.sha256 dist/*.tar.gz.sha256
dist/*.zip fail_on_unmatched_files: true
dist/*.zip.sha256
fail_on_unmatched_files: false

View file

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

View file

@ -4,23 +4,18 @@
# build step. `make test` is the full gate. `make remint` rebuilds the seed after a # build step. `make test` is the full gate. `make remint` rebuilds the seed after a
# source change. # source change.
.PHONY: test ci values corpus unit smoke buildsmoke staticnativesmoke selfhost sci cts certify ffi transient infer wp devirt fieldread numwp fieldnum protoret narrow directlink numeric inline shakesmoke remint joltc joltc-release joltc-debug joltcsmoke submodules .PHONY: test ci values corpus unit smoke buildsmoke 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
# Every target needs the vendored submodules; fail with the fix, not a load error.
submodules:
@test -f vendor/irregex/irregex.scm || { \
echo "vendor submodules missing; run: git submodule update --init --recursive"; exit 1; }
# Full gate (dev machine). Includes the self-host byte-fixpoint, which only holds # Full gate (dev machine). Includes the self-host byte-fixpoint, which only holds
# on the same Chez that minted the seed. # on the same Chez that minted the seed.
test: submodules selfhost ci test: selfhost ci
@echo "OK: all gates passed" @echo "OK: all gates passed"
# CI gate: behavior only. The checked-in seed is a minted artifact (like a # CI gate: behavior only. The checked-in seed is a minted artifact (like a
# lockfile) — it RUNS correctly on any Chez, but `selfhost` rebuilds it and a # lockfile) — it RUNS correctly on any Chez, but `selfhost` rebuilds it and a
# different Chez version may emit byte-different (gensym/order) output, so the # different Chez version may emit byte-different (gensym/order) output, so the
# byte-fixpoint is a dev-machine check, not a CI one (jolt-8479). # byte-fixpoint is a dev-machine check, not a CI one (jolt-8479).
ci: submodules values corpus unit smoke buildsmoke staticnativesmoke sci cts ffi transient infer wp devirt fieldread numwp fieldnum protoret narrow directlink numeric inline certify ci: values corpus unit smoke buildsmoke staticnativesmoke sci cts ffi transient infer wp devirt fieldread numwp fieldnum protoret narrow directlink numeric inline certify
@echo "OK: CI gates passed" @echo "OK: CI gates passed"
# Self-host fixpoint: bootstrap.ss rebuild == checked-in seed. # Self-host fixpoint: bootstrap.ss rebuild == checked-in seed.

View file

@ -9,12 +9,8 @@ runs it on Chez. The compiler is self-hosted: it is written in Clojure
## Install ## Install
Grab the self-contained `joltc` binary (Linux/macOS/Windows) — it bundles the Grab the self-contained `joltc` binary (Linux/macOS) — it bundles the runtime,
runtime, compiler, and standard library, so there is nothing else to install. 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: With Homebrew:
@ -49,18 +45,6 @@ cd jolt
bin/joltc -e '(+ 1 2)' # => 3 bin/joltc -e '(+ 1 2)' # => 3
``` ```
The `--recurse-submodules` matters: jolt vendors its regex engine and test
suites as git submodules. In a checkout that's missing them (a plain
`git clone`, or after pulling a commit that adds one), fetch them with:
```bash
git submodule update --init --recursive
```
Note that GitHub's auto-generated "Source code (zip/tar.gz)" archives on the
releases page do **not** contain submodules, so they can't run or build —
clone the repo instead (or grab a prebuilt binary from the same page).
After changing a compiler source — the reader (`host/chez/reader.ss`), the After changing a compiler source — the reader (`host/chez/reader.ss`), the
analyzer/IR/backend (`jolt-core/jolt/*.clj`), or the `clojure.core` overlay analyzer/IR/backend (`jolt-core/jolt/*.clj`), or the `clojure.core` overlay
(`jolt-core/clojure/core/*.clj`) — re-mint the seed: (`jolt-core/clojure/core/*.clj`) — re-mint the seed:

View file

@ -14,28 +14,5 @@
# JOLT_PWD. # JOLT_PWD.
root="$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd)" root="$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd)"
export JOLT_PWD="${JOLT_PWD:-$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 cd "$root" || exit 1
exec ${CHEZ} --script host/chez/cli.ss "$@" exec chez --script host/chez/cli.ss "$@"

View file

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

View file

@ -182,30 +182,6 @@ a root, transitively.
- Source only; compiled `.class` files in a git dep are ignored. - Source only; compiled `.class` files in a git dep are ignored.
- git `:git/sha` must be a full SHA (`git fetch` can't resolve a short one). - git `:git/sha` must be a full SHA (`git fetch` can't resolve a short one).
## Stack traces
An uncaught error prints the message, the top-level source location, and — when
frames are available — a `trace:` backtrace. In an AOT `jolt build --direct-link`
binary the frames map to `ns/name (file:line)`; on the runtime eval path they are
the surviving fn names. Tail-call optimization erases tail-called frames, so the
default trace shows only the non-tail spine.
A fuller **tail-frame history** recovers the frames TCO erases: each compiled fn
records itself on entry into a bounded ring-of-rings buffer, so the trace shows
TCO-elided frames (including the immediate error site) while a tight tail loop
stays bounded and its non-tail caller context is preserved.
It is **on by default in REPL-driven development** — a `repl` or nREPL session
turns it on, so an error in code you evaluate or reload shows a tail-frame trace
with no setup. Because the recording is baked in at compile time, only code
compiled while a session is live is traced; reload a namespace to trace code that
was already loaded (e.g. an app's initial `-M:run` load before its nREPL started).
Elsewhere it is off (a small per-call cost, and never emitted into a `jolt build`
binary). Override with the environment: `JOLT_TRACE=1` forces it on for a whole
run — including a plain `-M:run`, so the app's own load is traced — and
`JOLT_TRACE=0` forces it off, even in a REPL/nREPL session.
## Conformance ## Conformance
The known-working libraries (see [libraries.md](libraries.md)) and the The known-working libraries (see [libraries.md](libraries.md)) and the

View file

@ -46,15 +46,6 @@
(unless (or jb-release? (string=? jb-profile "debug")) (unless (or jb-release? (string=? jb-profile "debug"))
(error 'build-joltc "profile must be \"release\" or \"debug\"" jb-profile)) (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")) (define jb-build (string-append jb-out ".build"))
(bld-check-toolchain) (bld-check-toolchain)
(bld-system (string-append "mkdir -p '" (path-parent jb-out) "' '" jb-build "'")) (bld-system (string-append "mkdir -p '" (path-parent jb-out) "' '" jb-build "'"))
@ -145,10 +136,11 @@
(scheme-start (scheme-start
(lambda args (lambda args
(set-source-roots! (list \"jolt-core\" \"stdlib\")) (set-source-roots! (list \"jolt-core\" \"stdlib\"))
;; JOLT_TRACE at RUNTIME (the env is unset at heap-build), before any app ns (guard (v (#t (jolt-report-throwable v (current-error-port))
;; compiles, so a `-M:run` traces the app's own code. (let ((bt (jolt-backtrace-string v)))
(jolt-trace-init-from-env!) (when bt (display \" trace:\\n\" (current-error-port))
(guard (v (#t (jolt-report-throwable v (current-error-port)) (exit 1))) (display bt (current-error-port))))
(exit 1)))
(cond (cond
((and (= (length args) 2) (string=? (car args) \"-e\")) ((and (= (length args) 2) (string=? (car args) \"-e\"))
(let ((result (jolt-final-str (let ((result (jolt-final-str
@ -172,10 +164,6 @@
(jb-emit-runtime-embeds out) (jb-emit-runtime-embeds out)
(put-string out "\n;; === embedded jolt-core + stdlib source ===\n") (put-string out "\n;; === embedded jolt-core + stdlib source ===\n")
(jb-emit-source-embeds out) (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") (put-string out "\n;; === joltc launcher ===\n")
(jb-emit-launcher out) (jb-emit-launcher out)
(close-port out)) (close-port out))
@ -257,8 +245,6 @@
;; table so `build` can foreign-entry them to spill the bundled Chez boots. On ;; 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). ;; Linux dlsym can't see executable symbols otherwise (macOS exports them anyway).
(bld-system (string-append (bld-system (string-append
;; the embedded jolt_* arrays must be foreign-entry-visible at runtime: "cc -O2 -rdynamic -I'" bld-csv-dir "' -I'" jb-build "' '" jb-main-c "' '"
;; -rdynamic on ELF; on Windows an exe needs an export table (GetProcAddress).
"cc -O2 " (if bld-nt? "-Wl,--export-all-symbols " "-rdynamic ") "-I'" bld-csv-dir "' -I'" jb-build "' '" jb-main-c "' '"
bld-csv-dir "/libkernel.a' -o '" jb-out "' " (bld-link-libs))) bld-csv-dir "/libkernel.a' -o '" jb-out "' " (bld-link-libs)))
(display (string-append "build-joltc: wrote " jb-out "\n")) (display (string-append "build-joltc: wrote " jb-out "\n"))

View file

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

View file

@ -23,7 +23,7 @@
;; --- shell helpers ---------------------------------------------------------- ;; --- shell helpers ----------------------------------------------------------
;; Run a command, return its stdout as one trimmed string ("" on no output). ;; Run a command, return its stdout as one trimmed string ("" on no output).
(define (bld-sh-capture cmd) (define (bld-sh-capture cmd)
(let* ((p (process (bld-sh-wrap cmd))) (in (car p))) (let* ((p (process cmd)) (in (car p)))
(let loop ((acc '())) (let loop ((acc '()))
(let ((l (get-line in))) (let ((l (get-line in)))
(if (eof-object? l) (if (eof-object? l)
@ -37,7 +37,7 @@
(loop (cons l acc))))))) (loop (cons l acc)))))))
(define (bld-system cmd) (define (bld-system cmd)
(let ((rc (system (bld-sh-wrap cmd)))) (let ((rc (system cmd)))
(unless (zero? rc) (unless (zero? rc)
(error 'jolt-build (string-append "command failed (" (number->string rc) "): " cmd))))) (error 'jolt-build (string-append "command failed (" (number->string rc) "): " cmd)))))
@ -57,24 +57,6 @@
;; --- toolchain discovery ---------------------------------------------------- ;; --- toolchain discovery ----------------------------------------------------
(define bld-machine (symbol->string (machine-type))) (define bld-machine (symbol->string (machine-type)))
(define bld-osx? (bld-contains? bld-machine "osx")) (define bld-osx? (bld-contains? bld-machine "osx"))
(define bld-nt? (bld-contains? bld-machine "nt"))
;; Chez's system/process run through cmd.exe on Windows; every build command
;; here is written for sh (MSYS2 provides it). On nt, spill the command to a
;; script and run `sh <file>` — workspace paths carry no spaces, and the
;; script file sidesteps cmd's quoting entirely. Identity elsewhere.
(define bld-shell-counter 0)
(define (bld-sh-wrap cmd)
(if bld-nt?
(let* ((tmp (or (getenv "TEMP") (getenv "TMP") "."))
(f (begin (set! bld-shell-counter (+ bld-shell-counter 1))
(string-append tmp "\\jolt-sh-"
(number->string bld-shell-counter) ".sh"))))
(let ((p (open-output-file f 'replace)))
(put-string p cmd)
(close-port p))
(string-append "sh " f))
cmd))
;; The Chez executable, for the isolated compile pass (see build-binary step 4). ;; The Chez executable, for the isolated compile pass (see build-binary step 4).
(define bld-chez (define bld-chez
@ -112,21 +94,14 @@
;; Link flags. macOS Homebrew layout for the kernel's lz4/zlib/ncurses deps. ;; Link flags. macOS Homebrew layout for the kernel's lz4/zlib/ncurses deps.
(define (bld-link-libs) (define (bld-link-libs)
(cond (if bld-osx?
(bld-osx?
(let ((lz4 (bld-sh-capture "brew --prefix lz4 2>/dev/null"))) (let ((lz4 (bld-sh-capture "brew --prefix lz4 2>/dev/null")))
(string-append (string-append
(if (> (string-length lz4) 0) (string-append "-L" lz4 "/lib ") "") (if (> (string-length lz4) 0) (string-append "-L" lz4 "/lib ") "")
"-llz4 -lz -lncurses -framework Foundation -liconv -lm"))) "-llz4 -lz -lncurses -framework Foundation -liconv -lm"))
;; 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 ;; Linux: the Chez kernel pulls in compression (lz4/z), the expression
;; editor (ncurses + terminfo), threads, dlopen, libuuid, and clock_gettime. ;; editor (ncurses + terminfo), threads, dlopen, libuuid, and clock_gettime.
(else "-llz4 -lz -lncurses -ltinfo -ldl -lm -lpthread -luuid -lrt"))) "-llz4 -lz -lncurses -ltinfo -ldl -lm -lpthread -luuid -lrt"))
;; --- runtime manifest (mirrors host/chez/cli.ss's load order) --------------- ;; --- runtime manifest (mirrors host/chez/cli.ss's load order) ---------------
;; A line is either literal Scheme text to inline, or a tag whose emission the build ;; A line is either literal Scheme text to inline, or a tag whose emission the build
@ -436,15 +411,7 @@
;; direct-link?: opt-in closed-world direct-linking (app->app calls bind directly, ;; direct-link?: opt-in closed-world direct-linking (app->app calls bind directly,
;; no runtime redefinition). Off by default in every mode — release stays ;; no runtime redefinition). Off by default in every mode — release stays
;; dynamically linked. ;; dynamically linked.
(define (bld-suffix? s suf)
(let ((n (string-length s)) (m (string-length suf)))
(and (>= n m) (string=? (substring s (- n m) n) suf))))
(define (build-binary entry-ns out-path mode natives embed-dirs ext-roots direct-link? tree-shake?) (define (build-binary entry-ns out-path mode natives embed-dirs ext-roots direct-link? tree-shake?)
;; Windows executables carry .exe; normalize here so the append-payload and
;; 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 ;; The self-contained path (jolt-embedded-bytes "stub/launcher") needs no csv
;; kernel files, no Chez, no cc — only the legacy cc path does. ;; kernel files, no Chez, no cc — only the legacy cc path does.
(unless (jolt-embedded-bytes "stub/launcher") (bld-check-toolchain)) (unless (jolt-embedded-bytes "stub/launcher") (bld-check-toolchain))
@ -571,23 +538,11 @@
"))\n" "))\n"
" (list \"jolt-core\" \"stdlib\"))))\n")) " (list \"jolt-core\" \"stdlib\"))))\n"))
(put-string out (string-append (put-string out (string-append
;; Call -main only if the entry namespace defines one; " (let ((mainv (var-deref " (ei-str-lit entry-ns) " \"-main\")))\n"
;; a script ns (top-level side effects, no -main) has
;; already run its forms at heap build, so invoking a nil
;; -main would crash ("nil cannot be cast to IFn") — just
;; exit cleanly instead.
" (let ((maincell (var-cell-lookup " (ei-str-lit entry-ns) " \"-main\")))\n"
;; render an uncaught throw (+ Clojure backtrace) instead ;; render an uncaught throw (+ Clojure backtrace) instead
;; of Chez's opaque dump, then exit non-zero. ;; of Chez's opaque dump, then exit non-zero.
" (guard (v (#t (jolt-report-throwable v (current-error-port)) (exit 1)))\n" " (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 " (apply jolt-invoke mainv args)))\n"
;; it to `user` before -main, matching clojure.main (*ns* is
;; `user` when a `-m` -main runs, so a runtime resolve of an
;; aliased symbol behaves the same as on the JVM / interpreted
;; joltc, not off the entry ns's alias table).
" (set-chez-ns! \"user\")\n"
" (when (and maincell (var-cell-defined? maincell))\n"
" (apply jolt-invoke (var-cell-root maincell) args))))\n"
" (exit 0)))\n")) " (exit 0)))\n"))
(close-port out)) (close-port out))
;; 4. compile -> boot -> link. Two paths, chosen by whether this process ;; 4. compile -> boot -> link. Two paths, chosen by whether this process
@ -603,7 +558,7 @@
(build-self-contained entry-ns out-path mode builddir flat-ss flat-so boot (build-self-contained entry-ns out-path mode builddir flat-ss flat-so boot
(bld-native-link-flags natives)) (bld-native-link-flags natives))
(build-with-cc entry-ns out-path mode builddir flat-ss flat-so boot boot-h main-c (build-with-cc entry-ns out-path mode builddir flat-ss flat-so boot boot-h main-c
(bld-native-link-flags natives))))))))) (bld-native-link-flags natives))))))))
;; --- self-contained link (in-process compile + append the boot to the stub) --- ;; --- self-contained link (in-process compile + append the boot to the stub) ---
;; compile-file runs against the DEFAULT interaction environment, so the boot's ;; compile-file runs against the DEFAULT interaction environment, so the boot's

View file

@ -11,26 +11,6 @@
(define cli-args (cdr (command-line))) ; drop the script name (define cli-args (cdr (command-line))) ; drop the script name
;; Fail early and actionably when the vendored submodules aren't checked out —
;; a plain `git clone` or GitHub's auto-generated "Source code" release archive
;; lacks them, and the raw failure ("load failed for vendor/irregex/irregex.scm")
;; doesn't say how to fix it. (The self-contained joltc binary embeds these and
;; never runs this file.)
(unless (file-exists? "vendor/irregex/irregex.scm")
(display "jolt: vendor submodules are missing (vendor/irregex).
" (current-error-port))
(display "GitHub's 'Source code' release archives don't include submodules.
" (current-error-port))
(display "Clone the repo instead:
" (current-error-port))
(display " git clone --recurse-submodules https://github.com/jolt-lang/jolt.git
" (current-error-port))
(display "or, in an existing checkout:
" (current-error-port))
(display " git submodule update --init --recursive
" (current-error-port))
(exit 1))
(load "host/chez/rt.ss") (load "host/chez/rt.ss")
(set-chez-ns! "clojure.core") (set-chez-ns! "clojure.core")
(load "host/chez/seed/prelude.ss") (load "host/chez/seed/prelude.ss")
@ -66,9 +46,6 @@
(when bt (display " trace:\n" port) (display bt port))) (when bt (display " trace:\n" port) (display bt port)))
(exit 1))) (exit 1)))
;; JOLT_TRACE opt-in, at runtime (before any app ns compiles) so the app is traced.
(jolt-trace-init-from-env!)
(guard (v (#t (jolt-report-uncaught v))) (guard (v (#t (jolt-report-uncaught v)))
(cond (cond
;; -e EXPR — evaluate one expression and print it (blank for nil). Wrapped in ;; -e EXPR — evaluate one expression and print it (blank for nil). Wrapped in

View file

@ -298,21 +298,8 @@
(define empty-pmap-hash (make-pmap empty-hnode 0 #f)) ; hash-order backing (sets) (define empty-pmap-hash (make-pmap empty-hnode 0 #f)) ; hash-order backing (sets)
(define pmap-absent (list 'absent)) ; unique missing-key sentinel (define pmap-absent (list 'absent)) ; unique missing-key sentinel
;; PersistentArrayMap threshold: assoc of a new key promotes to hash mode once the ;; 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 ;; map already holds 8 entries (array.length >= 16 in the reference).
;; raised the limit to 64 for maps whose keys are ALL keywords (the common
;; keyword-map case); mixed-key maps still cap at 8.
(define array-map-limit 8) (define array-map-limit 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 (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))))))) (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)) (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))) (cnt (pmap-cnt m)) (ord (pmap-order m)))
(if (unbox added) (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) (append-key ord k))
(make-pmap r (fx+ cnt 1) #f)) (make-pmap r (fx+ cnt 1) #f))
(make-pmap r cnt ord)))) (make-pmap r cnt ord))))
@ -365,14 +352,10 @@
(let loop ((ks ord) (a acc)) (let loop ((ks ord) (a acc))
(if (null? ks) a (loop (cdr ks) (proc (car ks) (pmap-get m (car ks) jolt-nil) a)))) (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)))) (node-fold (pmap-root m) proc acc))))
;; map LITERAL ({...}): array map up to 8 entries (64 if keyword-only, per 1.13), ;; map LITERAL ({...}): array map up to 8 entries, hash map beyond (RT.map).
;; hash map beyond (RT.map).
(define (jolt-hash-map . kvs) (define (jolt-hash-map . kvs)
(let loop ((m empty-pmap) (kvs kvs)) (let loop ((m empty-pmap) (kvs kvs))
(cond ((null? kvs) (cond ((null? kvs) (if (fx>? (pmap-cnt m) array-map-limit) (pmap->hash m) m))
(let ((cnt (pmap-cnt m)) (ord (pmap-order m)))
(if (fx>? cnt (if (all-keywords? ord) array-map-limit-kw array-map-limit))
(pmap->hash m) m)))
((null? (cdr kvs)) (error 'hash-map "odd number of map literal entries")) ((null? (cdr kvs)) (error 'hash-map "odd number of map literal entries"))
(else (loop (pmap-put-ordered m (car kvs) (cadr kvs)) (cddr kvs)))))) (else (loop (pmap-put-ordered m (car kvs) (cadr kvs)) (cddr kvs))))))
;; array-map ctor: insertion-ordered regardless of size (createAsIfByAssoc). ;; array-map ctor: insertion-ordered regardless of size (createAsIfByAssoc).
@ -421,11 +404,9 @@
(if (null? args) (if (null? args)
(jolt-vector) (jolt-vector)
(let ((coll (car args)) (xs (cdr args))) (let ((coll (car args)) (xs (cdr args)))
(cond (if (jolt-nil? coll)
;; 1-arity returns the coll untouched — (conj nil) is nil (fold-left jolt-conj1 jolt-empty-list xs)
((null? xs) coll) (meta-carry coll (fold-left jolt-conj1 coll xs))))))
((jolt-nil? coll) (fold-left jolt-conj1 jolt-empty-list xs))
(else (meta-carry coll (fold-left jolt-conj1 coll xs)))))))
;; A host shim registers a type's get via register-get-arm! (handler: (coll k d) -> ;; A host shim registers a type's get via register-get-arm! (handler: (coll k d) ->
;; value) instead of set!-wrapping jolt-get — disjoint coll types, checked before the ;; value) instead of set!-wrapping jolt-get — disjoint coll types, checked before the
@ -462,16 +443,11 @@
(define (rec-coll-method coll name) (define (rec-coll-method coll name)
(and (jrec? coll) (find-method-any-protocol (jrec-tag coll) name))) (and (jrec? coll) (find-method-any-protocol (jrec-tag coll) name)))
(define (jolt-nth-nil-idx! i)
(when (jolt-nil? i)
(jolt-throw (jolt-host-throwable "java.lang.NullPointerException" "nth index"))))
(define jolt-nth (define jolt-nth
(case-lambda (case-lambda
((coll i) ((coll i)
(jolt-nth-nil-idx! i)
(let ((i (->idx i))) (let ((i (->idx i)))
(cond ((jolt-nil? coll) jolt-nil) ; RT.nth(nil, i) is nil at any index (cond ((pvec? coll) (let ((v (pvec-v coll)))
((pvec? coll) (let ((v (pvec-v coll)))
(if (and (fx>=? i 0) (fx<? i (vector-length v))) (vector-ref v i) (if (and (fx>=? i 0) (fx<? i (vector-length v))) (vector-ref v i)
(jolt-throw (jolt-host-throwable "java.lang.IndexOutOfBoundsException" "index out of bounds"))))) (jolt-throw (jolt-host-throwable "java.lang.IndexOutOfBoundsException" "index out of bounds")))))
((string? coll) (if (and (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i) ((string? coll) (if (and (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i)
@ -480,10 +456,8 @@
((rec-coll-method coll "nth") => (lambda (m) (jolt-invoke m coll i))) ((rec-coll-method coll "nth") => (lambda (m) (jolt-invoke m coll i)))
(else (error 'nth "unsupported collection"))))) (else (error 'nth "unsupported collection")))))
((coll i d) ((coll i d)
(jolt-nth-nil-idx! i)
(let ((i (->idx i))) (let ((i (->idx i)))
(cond ((jolt-nil? coll) d) ; RT.nth(nil, i, notFound) is notFound (cond ((pvec? coll) (pvec-nth-d coll i d))
((pvec? coll) (pvec-nth-d coll i d))
((string? coll) (if (and (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i) d)) ((string? coll) (if (and (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i) d))
((or (cseq? coll) (empty-list-t? coll)) (seq-nth coll i #t d)) ((or (cseq? coll) (empty-list-t? coll)) (seq-nth coll i #t d))
((rec-coll-method coll "nth") => (lambda (m) (jolt-invoke m coll i d))) ((rec-coll-method coll "nth") => (lambda (m) (jolt-invoke m coll i d)))
@ -528,21 +502,6 @@
((pset? coll) (pset-contains? coll k)) ((pset? coll) (pset-contains? coll k))
((pvec? coll) (let ((k (->idx k))) (and (fixnum? k) (fx>=? k 0) (fx<? k (pvec-count coll))))) ((pvec? coll) (let ((k (->idx k))) (and (fixnum? k) (fx>=? k 0) (fx<? k (pvec-count coll)))))
((jolt-nil? coll) #f) ((jolt-nil? coll) #f)
;; a string supports contains? by INDEX only (RT.contains: CharSequence +
;; Number key); any other key — or any unsupported type — is the JVM's
;; IllegalArgumentException.
((string? coll)
(if (and (number? k) (exact? k) (integer? k))
(and (>= k 0) (< k (string-length coll)))
(jolt-throw (jolt-host-throwable
"java.lang.IllegalArgumentException"
"contains? not supported on type: java.lang.String"))))
((or (cseq? coll) (empty-list-t? coll) (number? coll) (boolean? coll)
(keyword? coll) (jolt-symbol? coll) (char? coll))
(jolt-throw (jolt-host-throwable
"java.lang.IllegalArgumentException"
(string-append "contains? not supported on type: "
(guard (e (#t "?")) (jolt-class-name coll))))))
(else #f))) (else #f)))
(define (jolt-empty? coll) (define (jolt-empty? coll)
@ -555,25 +514,15 @@
((cseq? coll) #f) ; a cseq is non-empty by construction ((cseq? coll) #f) ; a cseq is non-empty by construction
(else (error 'empty? "unsupported collection")))) (else (error 'empty? "unsupported collection"))))
(define (jolt-stack-throw coll)
(jolt-throw (jolt-host-throwable
"java.lang.ClassCastException"
(string-append "class " (guard (e (#t "?")) (jolt-class-name coll))
" cannot be cast to class clojure.lang.IPersistentStack"))))
(define (jolt-peek coll) (define (jolt-peek coll)
(cond ((pvec? coll) (pvec-peek coll)) (cond ((pvec? coll) (pvec-peek coll))
;; list peek = first; a non-list seq (range, a rest chain) is not an ((or (cseq? coll) (empty-list-t? coll)) (jolt-first coll)) ; list peek = first
;; IPersistentStack on the JVM ((jolt-nil? coll) jolt-nil) (else (error 'peek "unsupported collection"))))
((and (cseq? coll) (cseq-list? coll)) (jolt-first coll))
((empty-list-t? coll) (jolt-first coll))
((jolt-nil? coll) jolt-nil)
(else (jolt-stack-throw coll))))
(define (jolt-pop coll) (define (jolt-pop coll)
(cond ((jolt-nil? coll) jolt-nil) ; RT.pop(nil) is nil (cond ((pvec? coll) (meta-carry coll (pvec-pop coll)))
((pvec? coll) (meta-carry coll (pvec-pop coll))) ((cseq? coll) (meta-carry coll (jolt-rest coll))) ; list pop = rest
((and (cseq? coll) (cseq-list? coll)) (meta-carry coll (jolt-rest coll)))
((empty-list-t? coll) (error 'pop "can't pop empty list")) ((empty-list-t? coll) (error 'pop "can't pop empty list"))
(else (jolt-stack-throw coll)))) (else (error 'pop "unsupported collection"))))
;; ============================================================================ ;; ============================================================================
;; equality / hash hooks called from values.ss (jolt=2 / jolt-hash) ;; equality / hash hooks called from values.ss (jolt=2 / jolt-hash)

View file

@ -110,38 +110,6 @@
;; older seed during the first re-mint pass. ;; older seed during the first re-mint pass.
(let ((scv (var-deref "jolt.backend-scheme" "set-var-cache!"))) (let ((scv (var-deref "jolt.backend-scheme" "set-var-cache!")))
(when (procedure? scv) (scv #t))) (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 ;; (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. ;; reader metadata as a with-meta form; strip it to read the bare ns symbol.
@ -243,13 +211,7 @@
;; A top-level (do ...) is UNROLLED — each subform compiled+eval'd in turn, like ;; A top-level (do ...) is UNROLLED — each subform compiled+eval'd in turn, like
;; Clojure's top-level do — so a runtime defmacro/def in an earlier subform is ;; Clojure's top-level do — so a runtime defmacro/def in an earlier subform is
;; visible (macro flag set, var interned) before a later subform is analyzed. ;; visible (macro flag set, var interned) before a later subform is analyzed.
;; a non-form VALUE (a function object, a BigDecimal, a reference type)
;; self-evaluates, like eval on the JVM.
(define (jolt-compile-eval-form form ns) (define (jolt-compile-eval-form form ns)
(if (or (procedure? form) (jbigdec? form) (jolt-atom? form) (jolt-multifn? form))
form
(jolt-compile-eval-form* form ns)))
(define (jolt-compile-eval-form* form ns)
(cond (cond
;; thread the current ns: an earlier subform may switch it (ns/in-ns call ;; thread the current ns: an earlier subform may switch it (ns/in-ns call
;; set-chez-ns!), and the next subform must be ANALYZED in that ns so its defs ;; set-chez-ns!), and the next subform must be ANALYZED in that ns so its defs
@ -267,9 +229,6 @@
;; record this form's source location first, so a compile- or run-time error ;; record this form's source location first, so a compile- or run-time error
;; in it reports the right place. ;; in it reports the right place.
(jolt-enter-form! form) (jolt-enter-form! form)
;; drop tail-frame history from earlier top-level forms, so an error's trace
;; shows only this form's own call history (a no-op unless JOLT_TRACE is on).
(jolt-trace-reset!)
(eval (read (open-input-string (jolt-analyze-emit-form form ns))) (eval (read (open-input-string (jolt-analyze-emit-form form ns)))
(interaction-environment))))) (interaction-environment)))))

View file

@ -117,21 +117,20 @@
(let ((a (car args))) (let ((a (car args)))
(cond (cond
((jolt-symbol? a) a) ((jolt-symbol? a) a)
;; (symbol "ns/name") splits the namespace at the FIRST "/" (JVM ;; (symbol "ns/name") splits the namespace at the LAST "/" (JVM
;; Symbol.intern), so (namespace (symbol "foo/bar/baz")) => "foo" with ;; Symbol.intern), so (namespace (symbol "foo/bar")) => "foo". A lone "/"
;; name "bar/baz". A lone "/" or a leading slash has no namespace. The ;; or a leading slash has no namespace. The no-ns sentinel is #f — matches
;; no-ns sentinel is #f — matches emit's quoted-symbol lowering ;; emit's quoted-symbol lowering (jolt-symbol #f "x"), so (= 'x (symbol
;; (jolt-symbol #f "x"), so (= 'x (symbol "x")) holds (jolt= compares ;; "x")) holds (jolt= compares ns with strict equal?).
;; ns with strict equal?).
((string? a) ((string? a)
(let ((slen (string-length a))) (let ((slen (string-length a)))
(if (string=? a "/") (if (string=? a "/")
(jolt-symbol #f "/") (jolt-symbol #f "/")
(let loop ((i 1)) (let loop ((i (- slen 1)))
(cond ((>= i slen) (jolt-symbol #f a)) (cond ((<= i 0) (jolt-symbol #f a))
((char=? (string-ref a i) #\/) ((char=? (string-ref a i) #\/)
(jolt-symbol (substring a 0 i) (substring a (+ i 1) slen))) (jolt-symbol (substring a 0 i) (substring a (+ i 1) slen)))
(else (loop (+ i 1)))))))) (else (loop (- i 1))))))))
((keyword? a) (jolt-symbol (keyword-t-ns a) (keyword-t-name a))) ((keyword? a) (jolt-symbol (keyword-t-ns a) (keyword-t-name a)))
;; (symbol a-var) -> the var's qualified symbol (clojure.spec.alpha/->sym). ;; (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))) ((var-cell? a) (jolt-symbol (var-cell-ns a) (var-cell-name a)))
@ -178,11 +177,7 @@
((jolt-nil? b) 1) ((jolt-nil? b) 1)
((and (number? a) (number? b)) (jolt-cmp3 a b)) ((and (number? a) (number? b)) (jolt-cmp3 a b))
((and (string? a) (string? b)) (jolt-strcmp a b)) ((and (string? a) (string? b)) (jolt-strcmp a b))
;; keywords order like symbols: a nil namespace sorts before any namespace, ((and (keyword? a) (keyword? b)) (jolt-strcmp (jolt-kw->string a) (jolt-kw->string b)))
;; then by namespace, then by name (Keyword.compareTo -> Symbol.compareTo)
((and (keyword? a) (keyword? b))
(let ((r (jolt-strcmp (or (keyword-t-ns a) "") (or (keyword-t-ns b) ""))))
(if (= r 0) (jolt-strcmp (keyword-t-name a) (keyword-t-name b)) r)))
((and (jolt-symbol? a) (jolt-symbol? b)) ((and (jolt-symbol? a) (jolt-symbol? b))
(let ((r (jolt-strcmp (jolt-sym-ns-string a) (jolt-sym-ns-string b)))) (let ((r (jolt-strcmp (jolt-sym-ns-string a) (jolt-sym-ns-string b))))
(if (= r 0) (jolt-strcmp (symbol-t-name a) (symbol-t-name b)) r))) (if (= r 0) (jolt-strcmp (symbol-t-name a) (symbol-t-name b)) r)))
@ -273,16 +268,4 @@
(jolt-cast-range-throw "float" x) (jolt-cast-range-throw "float" x)
d))) d)))
(def-var! "clojure.core" "float" jolt-float) (def-var! "clojure.core" "float" jolt-float)
;; numerator/denominator: jolt ratios are Chez exact rationals; a non-ratio is
;; the JVM's Ratio cast failure.
(define (jolt-ratio-part name f)
(lambda (x)
(if (and (number? x) (exact? x) (rational? x) (not (integer? x)))
(f x)
(jolt-throw (jolt-host-throwable
"java.lang.ClassCastException"
(string-append "class " (guard (e (#t "?")) (jolt-class-name x))
" cannot be cast to class clojure.lang.Ratio"))))))
(def-var! "clojure.core" "numerator" (jolt-ratio-part "numerator" numerator))
(def-var! "clojure.core" "denominator" (jolt-ratio-part "denominator" denominator))
(def-var! "clojure.core" "compare" jolt-compare) (def-var! "clojure.core" "compare" jolt-compare)

View file

@ -46,10 +46,6 @@
;; after it). Guarded for the first re-mint pass off an older seed. ;; after it). Guarded for the first re-mint pass off an older seed.
(let ((scv (var-deref "jolt.backend-scheme" "set-var-cache!"))) (let ((scv (var-deref "jolt.backend-scheme" "set-var-cache!")))
(when (procedure? scv) (scv #f))) (when (procedure? scv) (scv #f)))
;; Tail-frame tracing off for the mint + `jolt build`: the seed must stay a
;; byte-fixpoint, and a built app should carry no per-call trace overhead.
(let ((stf (var-deref "jolt.backend-scheme" "set-trace-frames!")))
(when (procedure? stf) (stf #f)))
(define (ei-compile-form ctx f optimize?) (define (ei-compile-form ctx f optimize?)
(let ((ir (jolt-ce-analyze ctx f))) (let ((ir (jolt-ce-analyze ctx f)))
(jolt-ce-emit-top (if optimize? (jolt-ce-run-passes ir ctx) ir)))) (jolt-ce-emit-top (if optimize? (jolt-ce-run-passes ir ctx) ir))))

View file

@ -334,11 +334,6 @@
(set! jolt-zero? (let ((prev jolt-zero?)) (lambda (x) (if (jbigdec? x) (jbd-zero? x) (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-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))))) (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" "inc" jolt-inc)
(def-var! "clojure.core" "dec" jolt-dec) (def-var! "clojure.core" "dec" jolt-dec)
(def-var! "clojure.core" "zero?" jolt-zero?) (def-var! "clojure.core" "zero?" jolt-zero?)

View file

@ -579,9 +579,9 @@
;; pthread_sigmask"). Guard so a non-POSIX host yields #f; jolt-set-sigint-blocked ;; 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). ;; then no-ops (Windows delivers ^C through the console, not a per-thread mask).
(define c-pthread-sigmask (define c-pthread-sigmask
(jolt-foreign-proc-safe "pthread_sigmask" '(int u8* u8*) 'int)) (guard (e (#t #f)) (foreign-procedure "pthread_sigmask" (int u8* u8*) int)))
(define c-sigemptyset (jolt-foreign-proc-safe "sigemptyset" '(u8*) 'int)) (define c-sigemptyset (guard (e (#t #f)) (foreign-procedure "sigemptyset" (u8*) int)))
(define c-sigaddset (jolt-foreign-proc-safe "sigaddset" '(u8* int) 'int)) (define c-sigaddset (guard (e (#t #f)) (foreign-procedure "sigaddset" (u8* int) int)))
;; POSIX SIG_BLOCK/SIG_UNBLOCK numerics differ by platform: Linux/glibc 0/1, ;; 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 ;; 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". ;; this host from the machine-type symbol — macOS builds contain "osx".

View file

@ -55,7 +55,9 @@
(lambda () (lambda ()
(unless tried? (unless tried?
(set! tried? #t) (set! tried? #t)
(set! fp (jolt-foreign-proc-safe "sched_yield" '() 'int))) (set! fp (guard (e (#t #f))
(load-shared-object #f)
(foreign-procedure "sched_yield" () int))))
(if fp (fp) (sleep (make-time 'time-duration 0 0))) (if fp (fp) (sleep (make-time 'time-duration 0 0)))
jolt-nil))) jolt-nil)))

View file

@ -80,18 +80,13 @@
;; every Chez binary) — no external toolchain. Falls back to /bin/sh chmod if the ;; every Chez binary) — no external toolchain. Falls back to /bin/sh chmod if the
;; symbol can't be resolved. ;; symbol can't be resolved.
(define jolt-chmod-755 (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) (lambda (path)
(cond (if c
(c (c path #o755)) (c path #o755)
;; Windows has no chmod and needs none (execute is by extension) (system (string-append "chmod 755 '" path "'"))))))
((let ((m (symbol->string (machine-type))))
(let loop ((i 0))
(cond ((> (+ i 2) (string-length m)) #f)
((string=? (substring m i (+ i 2)) "nt") #t)
(else (loop (+ i 1))))))
0)
(else (system (string-append "chmod 755 '" path "'")))))))
;; A user-facing relative path resolves against JOLT_PWD — the user's cwd before ;; A user-facing relative path resolves against JOLT_PWD — the user's cwd before
;; the launcher cd'd to the jolt repo root — matching the JVM, where io/file is ;; the launcher cd'd to the jolt repo root — matching the JVM, where io/file is

View file

@ -115,11 +115,10 @@
(let ((v (jolt-array-vec c)) (j (exact (na-idx i)))) (let ((v (jolt-array-vec c)) (j (exact (na-idx i))))
(if (and (>= j 0) (< j (vector-length v))) (vector-ref v j) d)) (if (and (>= j 0) (< j (vector-length v))) (vector-ref v j) d))
(%na-nth c i d))))) (%na-nth c i d)))))
(def-var! "jolt.host" "array-value?" (lambda (x) (if (jolt-array? x) #t jolt-nil)))
(define %na-get jolt-get) (define %na-get jolt-get)
(set! jolt-get (set! jolt-get
(case-lambda (case-lambda
((c k) (if (jolt-array? c) (jolt-nth c k jolt-nil) (%na-get c k))) ((c k) (if (jolt-array? c) (jolt-nth c k) (%na-get c k)))
((c k d) (if (jolt-array? c) (jolt-nth c k d) (%na-get c k d))))) ((c k d) (if (jolt-array? c) (jolt-nth c k d) (%na-get c k d)))))
;; aset (overlay) writes through jolt.host/ref-put! — mutate the slot, return arr. ;; aset (overlay) writes through jolt.host/ref-put! — mutate the slot, return arr.
;; count/nth/seq/get above are NATIVE-OPS (inlined at call sites), so aget/alength/ ;; count/nth/seq/get above are NATIVE-OPS (inlined at call sites), so aget/alength/

View file

@ -42,20 +42,6 @@ if [ "$got_e" != "45" ]; then
exit 1 exit 1
fi 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 # 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 # 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. # guarantee: joltc compiles apps entirely on its own.

View file

@ -384,14 +384,3 @@
(def-var! "jolt.host" "load-namespace" (lambda (n) (load-namespace n) jolt-nil)) (def-var! "jolt.host" "load-namespace" (lambda (n) (load-namespace n) jolt-nil))
(def-var! "jolt.host" "file-exists?" (lambda (p) (if (file-exists? p) #t #f))) (def-var! "jolt.host" "file-exists?" (lambda (p) (if (file-exists? p) #t #f)))
(def-var! "jolt.host" "getenv" (lambda (n) (let ((v (getenv n))) (if v v jolt-nil)))) (def-var! "jolt.host" "getenv" (lambda (n) (let ((v (getenv n))) (if v v jolt-nil))))
;; jolt version string. A self-contained binary build bakes the real tag into the
;; saved heap by emitting (set! jolt-baked-version "…") in flat.ss; a dev run off
;; the seed leaves it #f and falls back to $JOLT_VERSION (bin/joltc sets it from
;; `git describe`), then "dev".
(define jolt-baked-version #f)
(def-var! "jolt.host" "jolt-version"
(lambda ()
(or jolt-baked-version
(let ((v (getenv "JOLT_VERSION"))) (and v (> (string-length v) 0) v))
"dev")))

View file

@ -260,9 +260,6 @@
;; intern: create/set a var ns/sym to val (or an unbound cell). Returns the var. ;; intern: create/set a var ns/sym to val (or an unbound cell). Returns the var.
(define (jolt-intern ns-desig sym . vopt) (define (jolt-intern ns-desig sym . vopt)
(let ((nm (ns-desig->name ns-desig)) (s (symbol-t-name sym))) (let ((nm (ns-desig->name ns-desig)) (s (symbol-t-name sym)))
;; the namespace must exist (Namespace.find), like the JVM's intern
(unless (hashtable-ref ns-registry nm #f)
(jolt-throw (jolt-ex-info (string-append "No namespace: " nm " found") empty-pmap)))
(if (pair? vopt) (def-var! nm s (car vopt)) (declare-var! nm s)))) (if (pair? vopt) (def-var! nm s (car vopt)) (declare-var! nm s))))
;; alias / ns-unalias: register/drop an :as alias under the current (or given) ns. ;; alias / ns-unalias: register/drop an :as alias under the current (or given) ns.

View file

@ -67,13 +67,8 @@
;; chain is a cseq under jolt's seq model, and (realized? (rest s)) after ;; 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 ;; a next must be true like the JVM's realized LazySeq — never a throw
;; whose message renders the (possibly infinite) seq. ;; whose message renders the (possibly infinite) seq.
;; a PLAIN seq (list/cons/range — not a lazy-seq wrapper) is not an ((cseq? x) (if (cseq-forced? x) #t #f))
;; IPending on the JVM: realized? throws. ((empty-list-t? x) #t)
((or (cseq? x) (empty-list-t? x))
(jolt-throw (jolt-host-throwable
"java.lang.ClassCastException"
(string-append "class " (guard (e (#t "?")) (jolt-class-name x))
" cannot be cast to class clojure.lang.IPending"))))
(else (jolt-invoke overlay-realized? x)))))) (else (jolt-invoke overlay-realized? x))))))
;; clojure.edn/read over a reader: drain the jhost reader, then read through the ;; clojure.edn/read over a reader: drain the jhost reader, then read through the
;; overlay read-string so the opts map (:readers/:default/:eof) is honored. ;; overlay read-string so the opts map (:readers/:default/:eof) is honored.

View file

@ -48,24 +48,12 @@
(define (rdr-digit? c) (and (char>=? c #\0) (char<=? c #\9))) (define (rdr-digit? c) (and (char>=? c #\0) (char<=? c #\9)))
(define (rdr-octal? c) (and (char>=? c #\0) (char<=? c #\7))) (define (rdr-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). ;; every char of s in [from,to) is an octal digit (and the span is non-empty).
(define (rdr-all-octal? s from to) (define (rdr-all-octal? s from to)
(and (fx<? 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))))) (let loop ((i from)) (cond ((fx=? i to) #t) ((rdr-octal? (string-ref s i)) (loop (fx+ i 1))) (else #f)))))
;; Advance past whitespace, commas, and ;-to-end-of-line comments. ;; Advance past whitespace, commas, and ;-to-end-of-line comments.
;; EDN strict mode (clojure.edn): auto-resolved keywords are invalid, and each
;; discarded (#_) form is handed to rdr-discard-cb so the edn layer validates
;; its tagged elements through :readers/:default like the JVM.
(define rdr-edn-mode (make-parameter #f))
(define rdr-discard-cb (make-parameter #f))
(define (rdr-skip-ws s i end) (define (rdr-skip-ws s i end)
(let loop ((i i)) (let loop ((i i))
(cond (cond
@ -73,8 +61,7 @@
((rdr-ws? (string-ref s i)) (loop (+ i 1))) ((rdr-ws? (string-ref s i)) (loop (+ i 1)))
((char=? (string-ref s i) #\;) ((char=? (string-ref s i) #\;)
(let eol ((j (+ i 1))) (let eol ((j (+ i 1)))
(if (or (>= j end) (char=? (string-ref s j) #\newline) (if (or (>= j end) (char=? (string-ref s j) #\newline))
(char=? (string-ref s j) #\return))
(loop j) (loop j)
(eol (+ j 1))))) (eol (+ j 1)))))
(else i)))) (else i))))
@ -128,17 +115,12 @@
(slash (rdr-string-index-char body #\/))) (slash (rdr-string-index-char body #\/)))
(cond (cond
;; ratio a/b -> exact rational (= JVM Ratio); reduces to an exact integer ;; ratio a/b -> exact rational (= JVM Ratio); reduces to an exact integer
;; when d divides n. Both parts must be plain digit runs (1/-1 is an ;; when d divides n.
;; invalid token); a zero denominator is the JVM's divide error.
(slash (slash
(let ((ns (substring body 0 slash)) (let ((n (string->number (substring body 0 slash)))
(ds (substring body (+ slash 1) blen))) (d (string->number (substring body (+ slash 1) blen))))
(and (rdr-all-digits? ns 0 (string-length ns)) (and (integer? n) (integer? d) (not (= d 0))
(rdr-all-digits? ds 0 (string-length ds)) (* sign (/ n d)))))
(let ((n (string->number ns)) (d (string->number ds)))
(when (= d 0)
(jolt-throw (jolt-host-throwable "java.lang.ArithmeticException" "Divide by zero")))
(* sign (/ n d))))))
;; hex 0x.. ;; hex 0x..
((and (>= blen 2) (char=? (string-ref body 0) #\0) ((and (>= blen 2) (char=? (string-ref body 0) #\0)
(or (char=? (string-ref body 1) #\x) (char=? (string-ref body 1) #\X))) (or (char=? (string-ref body 1) #\x) (char=? (string-ref body 1) #\X)))
@ -157,11 +139,6 @@
;; elsewhere or fall through (a non-octal digit fails rdr-all-octal?). ;; 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)) ((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)))) (let ((o (rdr-parse-radix (substring body 1 blen) 8))) (and o (* sign o))))
;; a leading zero on a plain multi-digit integer is invalid (the octal
;; branch above accepted real octals; 08/09 match the JVM's trailing
;; "invalid number" alternative)
((and (>= blen 2) (char=? (string-ref body 0) #\0) (rdr-all-digits? body 1 blen))
#f)
;; bigint suffix N ;; bigint suffix N
((and (> blen 1) (char=? (string-ref body (- blen 1)) #\N)) ((and (> blen 1) (char=? (string-ref body (- blen 1)) #\N))
(let ((n (string->number (substring body 0 (- blen 1))))) (let ((n (string->number (substring body 0 (- blen 1)))))
@ -213,10 +190,7 @@
(let oct ((j (+ i 1)) (val 0) (cnt 0)) (let oct ((j (+ i 1)) (val 0) (cnt 0))
(if (and (fx<? cnt 3) (fx<? j end) (rdr-octal? (string-ref s j))) (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)) (oct (fx+ j 1) (fx+ (fx* val 8) (fx- (char->integer (string-ref s j)) 48)) (fx+ cnt 1))
(begin (loop j (cons (integer->char val) acc)))))
(when (> val 255)
(jolt-throw (jolt-ex-info "Octal escape sequence must be in range [0, 377]" empty-pmap)))
(loop j (cons (integer->char val) acc))))))
((#\u) ((#\u)
(let-values (((cp j) (rdr-hex->int s (+ i 2) 4))) (let-values (((cp j) (rdr-hex->int s (+ i 2) 4)))
;; A \u escape is a UTF-16 code unit. jolt chars are Unicode scalars, ;; A \u escape is a UTF-16 code unit. jolt chars are Unicode scalars,
@ -234,8 +208,7 @@
(loop j (cons #\xFFFD acc))))) (loop j (cons #\xFFFD acc)))))
((and (fx>=? cp #xD800) (fx<=? cp #xDFFF)) (loop j (cons #\xFFFD acc))) ((and (fx>=? cp #xD800) (fx<=? cp #xDFFF)) (loop j (cons #\xFFFD acc)))
(else (loop j (cons (integer->char cp) acc)))))) (else (loop j (cons (integer->char cp) acc))))))
(else (jolt-throw (jolt-ex-info (string-append "Unsupported escape character: \\" (string e)) (else (loop (+ i 2) (cons e acc))))))
empty-pmap))))))
(else (loop (+ i 1) (cons c acc))))))) (else (loop (+ i 1) (cons c acc)))))))
;; backslash already consumed; read a Clojure character literal. ;; backslash already consumed; read a Clojure character literal.
@ -267,10 +240,7 @@
((char=? (string-ref name 0) #\u) ((char=? (string-ref name 0) #\u)
(integer->char (string->number (substring name 1 (string-length name)) 16))) (integer->char (string->number (substring name 1 (string-length name)) 16)))
((char=? (string-ref name 0) #\o) ((char=? (string-ref name 0) #\o)
(let ((v (string->number (substring name 1 (string-length name)) 8))) (integer->char (string->number (substring name 1 (string-length name)) 8)))
(when (or (not v) (> v 255))
(jolt-throw (jolt-ex-info "Octal escape sequence must be in range [0, 377]" empty-pmap)))
(integer->char v)))
(else (jolt-throw (jolt-ex-info (string-append "Unsupported character: \\" name) (else (jolt-throw (jolt-ex-info (string-append "Unsupported character: \\" name)
empty-pmap))))) empty-pmap)))))
@ -288,39 +258,14 @@
(values #f tok) (values #f tok)
(values (substring tok 0 slash) (substring tok (+ slash 1) (string-length tok)))))) (values (substring tok 0 slash) (substring tok (+ slash 1) (string-length tok))))))
(define (rdr-numeric-lead? tok)
(let ((len (string-length tok)))
(and (> len 0)
(let ((c0 (string-ref tok 0)))
(or (rdr-digit? c0)
(and (or (char=? c0 #\+) (char=? c0 #\-)) (> len 1)
(rdr-digit? (string-ref tok 1))))))))
(define (rdr-invalid-token tok)
(jolt-throw (jolt-host-throwable "java.lang.RuntimeException"
(string-append "Invalid token: " tok))))
(define (rdr-token->value tok) (define (rdr-token->value tok)
(let ((n (rdr-try-number tok))) (let ((n (rdr-try-number tok)))
(cond (cond
(n n) (n n)
;; a token that starts like a number but doesn't parse as one is an
;; invalid number (1a, 08, 0x2g, 2r2), never a symbol — like the JVM.
((rdr-numeric-lead? tok)
(jolt-throw (jolt-host-throwable "java.lang.NumberFormatException"
(string-append "Invalid number: " tok))))
((string=? tok "nil") jolt-nil) ((string=? tok "nil") jolt-nil)
((string=? tok "true") #t) ((string=? tok "true") #t)
((string=? tok "false") #f) ((string=? tok "false") #f)
(else (else (let-values (((ns name) (rdr-sym-parts tok))) (jolt-symbol ns name))))))
(let ((len (string-length tok)))
;; a lone "/" is the division symbol, and "ns//" names it in a
;; namespace (clojure.core//); otherwise a leading or trailing slash
;; leaves an empty ns/name part — an invalid token.
(when (and (> len 1)
(or (char=? (string-ref tok 0) #\/)
(and (char=? (string-ref tok (- len 1)) #\/)
(not (and (> len 2) (char=? (string-ref tok (- len 2)) #\/))))))
(rdr-invalid-token tok))
(let-values (((ns name) (rdr-sym-parts tok))) (jolt-symbol ns name)))))))
;; --- collections ------------------------------------------------------------ ;; --- collections ------------------------------------------------------------
;; Read forms until the close delimiter; returns (values reversed?-no list j). ;; Read forms until the close delimiter; returns (values reversed?-no list j).
@ -344,14 +289,6 @@
;; sequence in a weak side-table the host contract's form-map-pairs consults. ;; sequence in a weak side-table the host contract's form-map-pairs consults.
(define rdr-map-order (make-weak-eq-hashtable)) (define rdr-map-order (make-weak-eq-hashtable))
(define (rdr-make-map es) (define (rdr-make-map es)
;; the JVM reader rejects duplicate literal keys before building the map
(let dupchk ((kvs es) (seen empty-pset))
(when (pair? kvs)
(let ((k (car kvs)))
(when (jolt-truthy? (jolt-contains? seen k))
(jolt-throw (jolt-host-throwable "java.lang.IllegalArgumentException"
(string-append "Duplicate key: " (jolt-pr-str k)))))
(dupchk (cddr kvs) (pset-conj seen k)))))
(let ((m (apply jolt-hash-map es))) (let ((m (apply jolt-hash-map es)))
(when (pair? es) (hashtable-set! rdr-map-order m es)) (when (pair? es) (hashtable-set! rdr-map-order m es))
m)) m))
@ -611,12 +548,8 @@
(let-values (((src j) (rdr-read-regex s (+ i 1) end))) (let-values (((src j) (rdr-read-regex s (+ i 1) end)))
(values (jolt-re-pattern src) j))) (values (jolt-re-pattern src) j)))
((char=? c #\_) ; #_ discard the next form ((char=? c #\_) ; #_ discard the next form
(let-values (((d j) (rdr-read-form s (+ i 1) end))) (let-values (((_ j) (rdr-read-form s (+ i 1) end)))
(when (rdr-eof? d) (jolt-throw (jolt-ex-info "EOF after #_" empty-pmap))) (when (rdr-eof? _) (jolt-throw (jolt-ex-info "EOF after #_" empty-pmap)))
;; edn validates the discarded element (its tags go through the same
;; :readers/:default pipeline; an unreadable one throws)
(let ((cb (rdr-discard-cb)))
(when cb (jolt-invoke cb d)))
(rdr-read-form s j end))) (rdr-read-form s j end)))
((char=? c #\') ; #'x var-quote -> (var x) ((char=? c #\') ; #'x var-quote -> (var x)
(let-values (((form j) (rdr-read-form s (+ i 1) end))) (let-values (((form j) (rdr-read-form s (+ i 1) end)))
@ -668,17 +601,6 @@
(let ((auto? (and (< i end) (char=? (string-ref s i) #\:)))) (let ((auto? (and (< i end) (char=? (string-ref s i) #\:))))
(let ((i (if auto? (+ i 1) i))) (let ((i (if auto? (+ i 1) i)))
(let-values (((tok j) (rdr-read-token s i end))) (let-values (((tok j) (rdr-read-token s i end)))
(let ((len (string-length tok)))
;; ":" and "::" alone, a leading or trailing slash (a name of exactly
;; "/" is fine, :ns//), or an auto-resolved keyword in edn (no
;; resolution context) are invalid tokens.
(when (or (= len 0)
(and (> len 1) (char=? (string-ref tok 0) #\/))
(and (> len 1) (char=? (string-ref tok (- len 1)) #\/)
(not (and (> len 2) (char=? (string-ref tok (- len 2)) #\/)))))
(rdr-invalid-token (string-append (if auto? "::" ":") tok)))
(when (and auto? (rdr-edn-mode))
(rdr-invalid-token (string-append "::" tok))))
(let-values (((ns name) (rdr-sym-parts tok))) (let-values (((ns name) (rdr-sym-parts tok)))
(if auto? (if auto?
(let* ((cur (chez-current-ns)) (let* ((cur (chez-current-ns))
@ -813,76 +735,15 @@
(let ((v (var-deref "clojure.core" "*default-data-reader-fn*"))) (let ((v (var-deref "clojure.core" "*default-data-reader-fn*")))
(and (not (jolt-nil? v)) (procedure? v) v)))) (and (not (jolt-nil? v)) (procedure? v) v))))
;; strict #inst validation: RFC-3339 calendar fields must be real (month 1-12,
;; day valid for the month incl. leap years, hour < 24, minute/second < 60).
(define (rdr-2dig s i)
(and (< (+ i 1) (string-length s))
(rdr-digit? (string-ref s i)) (rdr-digit? (string-ref s (+ i 1)))
(+ (* 10 (- (char->integer (string-ref s i)) 48))
(- (char->integer (string-ref s (+ i 1))) 48))))
(define (rdr-leap? y) (and (= 0 (modulo y 4)) (or (not (= 0 (modulo y 100))) (= 0 (modulo y 400)))))
(define (rdr-inst-throw s)
(jolt-throw (jolt-host-throwable "java.lang.RuntimeException"
(string-append "Unrecognized date/time syntax: " s))))
(define (rdr-validate-inst! s)
;; progressive RFC-3339 like clojure.instant: yyyy[-MM[-dd[Thh[:mm[:ss[.f]]]]]]
;; with an optional Z/±hh:mm offset; each present field must be in range
;; (months 1-12, day valid for the month incl. leap years, hour < 24, min < 60).
(let* ((len (string-length s))
(y (and (>= len 4) (rdr-all-digits? s 0 4) (string->number (substring s 0 4)))))
(unless y (rdr-inst-throw s))
(when (>= len 5)
(unless (char=? (string-ref s 4) #\-) (rdr-inst-throw s))
(let ((mo (rdr-2dig s 5)))
(unless (and mo (>= mo 1) (<= mo 12)) (rdr-inst-throw s))
(when (>= len 8)
(unless (char=? (string-ref s 7) #\-) (rdr-inst-throw s))
(let ((d (rdr-2dig s 8)))
(unless (and d (>= d 1)
(<= d (vector-ref (if (rdr-leap? y)
'#(31 29 31 30 31 30 31 31 30 31 30 31)
'#(31 28 31 30 31 30 31 31 30 31 30 31))
(- mo 1))))
(rdr-inst-throw s))
(when (>= len 11)
(unless (char=? (string-ref s 10) #\T) (rdr-inst-throw s))
(let ((h (rdr-2dig s 11)))
(unless (and h (<= h 23)) (rdr-inst-throw s))
(when (>= len 14)
(when (char=? (string-ref s 13) #\:)
(let ((mi (rdr-2dig s 14)))
(unless (and mi (<= mi 59)) (rdr-inst-throw s)))))))))))))
;; strict #uuid: canonical 8-4-4-4-12 hex groups.
(define (rdr-validate-uuid! s)
(define (hexrun? from to)
(let loop ((i from))
(cond ((>= i to) #t)
((let ((c (char-downcase (string-ref s i))))
(or (rdr-digit? c) (and (char>=? c #\a) (char<=? c #\f))))
(loop (+ i 1)))
(else #f))))
(unless (and (= (string-length s) 36)
(char=? (string-ref s 8) #\-) (char=? (string-ref s 13) #\-)
(char=? (string-ref s 18) #\-) (char=? (string-ref s 23) #\-)
(hexrun? 0 8) (hexrun? 9 13) (hexrun? 14 18) (hexrun? 19 23) (hexrun? 24 36))
(jolt-throw (jolt-host-throwable "java.lang.IllegalArgumentException"
(string-append "Invalid UUID string: " s)))))
;; read-string / read data seam: construct the value for a #tag literal. #inst, ;; read-string / read data seam: construct the value for a #tag literal. #inst,
;; #uuid and #"regex" are built in; any other tag is applied from *data-readers*, ;; #uuid and #"regex" are built in; any other tag is applied from *data-readers*,
;; then *default-data-reader-fn*. An unregistered tag with no default handler stays ;; then *default-data-reader-fn*. An unregistered tag with no default handler stays
;; a tagged FORM (lenient — clojure.edn raises instead). ;; a tagged FORM (lenient — clojure.edn raises instead).
(define (rdr-construct-tag tag inner) (define (rdr-construct-tag tag inner)
(cond (cond
((eq? tag (keyword #f "#inst")) ((eq? tag (keyword #f "#inst")) (jolt-inst-from-string inner))
(when (string? inner) (rdr-validate-inst! inner)) ((eq? tag (keyword #f "#uuid")) (jolt-uuid-from-string inner))
(jolt-inst-from-string inner))
((eq? tag (keyword #f "#uuid"))
(when (string? inner) (rdr-validate-uuid! inner))
(jolt-uuid-from-string inner))
((eq? tag (keyword #f "regex")) (jolt-re-pattern inner)) ((eq? tag (keyword #f "regex")) (jolt-re-pattern inner))
;; the M-literal form: construct the BigDecimal from its numeric text
((eq? tag (keyword #f "bigdec")) (jolt-bigdec-from-string inner))
(else (let ((fn (rdr-data-reader-fn tag))) (else (let ((fn (rdr-data-reader-fn tag)))
(if fn (jolt-invoke fn inner) (if fn (jolt-invoke fn inner)
(let ((dfn (rdr-default-data-reader-fn))) (let ((dfn (rdr-default-data-reader-fn)))
@ -904,11 +765,7 @@
(let ((items (jolt-get x rdr-kw-value))) (let ((items (jolt-get x rdr-kw-value)))
(let loop ((i 0) (s empty-pset)) (let loop ((i 0) (s empty-pset))
(if (fx>=? i (pvec-count items)) s (if (fx>=? i (pvec-count items)) s
(let ((v (rdr-form->data (pvec-nth-d items i jolt-nil)))) (loop (fx+ i 1) (pset-conj s (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)))))))
((pvec? x) ((pvec? x)
(let-values (((items changed) (rdr-conv-each (vector->list (pvec-v x))))) (let-values (((items changed) (rdr-conv-each (vector->list (pvec-v x)))))
(if changed (apply jolt-vector items) x))) (if changed (apply jolt-vector items) x)))
@ -933,35 +790,12 @@
(if (jolt-nil? m) v (jolt-with-meta v (rdr-form->data m))))) (if (jolt-nil? m) v (jolt-with-meta v (rdr-form->data m)))))
;; --- the two host seams ----------------------------------------------------- ;; --- the two host seams -----------------------------------------------------
;; a top-level read: a stray close delimiter is unmatched (read-seq consumes the
;; close of an open collection; anything reaching here is unbalanced input).
(define (rdr-read-top s i end)
(let ((k (rdr-skip-ws s i end)))
(when (and (< k end)
(let ((c (string-ref s k)))
(or (char=? c #\)) (char=? c #\]) (char=? c #\}))))
(jolt-throw (jolt-ex-info (string-append "Unmatched delimiter: "
(string (string-ref s k)))
empty-pmap)))
(rdr-read-form s k end)))
;; clojure.core/read-string: first form, or nil for blank / comment-only input ;; clojure.core/read-string: first form, or nil for blank / comment-only input
;; (parse-string wart, matched deliberately). jolt-read-form-raw keeps set FORMS ;; (parse-string wart, matched deliberately). jolt-read-form-raw keeps set FORMS
;; for the compiler spine (compile-eval); the data seam converts them to sets. ;; for the compiler spine (compile-eval); the data seam converts them to sets.
(define (jolt-read-form-raw s) (define (jolt-read-form-raw s)
(let-values (((form j) (rdr-read-top s 0 (string-length s)))) (let-values (((form j) (rdr-read-form s 0 (string-length s))))
(if (rdr-eof? form) jolt-nil form))) (if (rdr-eof? form) jolt-nil form)))
;; the edn seam: strict mode (no auto-resolved keywords), each #_ discard handed
;; to the callback for tag validation, and a distinct EOF sentinel so the edn
;; layer can honor its :eof option (nil input is a plain EOF).
(define (jolt-read-form-edn s cb)
(if (jolt-nil? s)
(keyword "jolt" "reader-eof")
(parameterize ((rdr-edn-mode #t)
(rdr-discard-cb (if (jolt-nil? cb) #f cb)))
(let-values (((form j) (rdr-read-top s 0 (string-length s))))
(if (rdr-eof? form) (keyword "jolt" "reader-eof") form)))))
(define (jolt-read-string s) (define (jolt-read-string s)
(let ((form (jolt-read-form-raw s))) (let ((form (jolt-read-form-raw s)))
(if (jolt-nil? form) form (rdr-form->data form)))) (if (jolt-nil? form) form (rdr-form->data form))))
@ -969,7 +803,7 @@
;; __parse-next: [form rest-of-string] or nil when only whitespace/comments left. ;; __parse-next: [form rest-of-string] or nil when only whitespace/comments left.
(define (jolt-parse-next s) (define (jolt-parse-next s)
(let ((end (string-length s))) (let ((end (string-length s)))
(let-values (((form j) (rdr-read-top s 0 end))) (let-values (((form j) (rdr-read-form s 0 end)))
(if (rdr-eof? form) (if (rdr-eof? form)
jolt-nil jolt-nil
(jolt-vector (rdr-form->data form) (substring s j end)))))) (jolt-vector (rdr-form->data form) (substring s j end))))))
@ -978,13 +812,8 @@
;; is the :#name keyword the reader produced; #uuid/#inst reuse the inst-time ctors. ;; is the :#name keyword the reader produced; #uuid/#inst reuse the inst-time ctors.
(define (jolt-read-tagged tag form) (define (jolt-read-tagged tag form)
(cond (cond
((eq? tag (keyword #f "#uuid")) ((eq? tag (keyword #f "#uuid")) (jolt-uuid-from-string form))
(when (string? form) (rdr-validate-uuid! form)) ((eq? tag (keyword #f "#inst")) (jolt-inst-from-string form))
(jolt-uuid-from-string form))
((eq? tag (keyword #f "#inst"))
(when (string? form) (rdr-validate-inst! form))
(jolt-inst-from-string form))
((eq? tag (keyword #f "bigdec")) (jolt-bigdec-from-string form))
;; No registered reader: consult *default-data-reader-fn*, else throw a clean, ;; 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 ;; 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 ;; foobar" (empty-pmap is a VALUE — the old (empty-pmap) applied it as a
@ -1004,4 +833,3 @@
;; :default (a #inst can be overridden to defer), rather than read-string building ;; :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 […]). ;; 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-raw" jolt-read-form-raw)
(def-var! "clojure.core" "__read-form-edn" jolt-read-form-edn)

View file

@ -11,17 +11,6 @@
;; Emitted programs do `(load "host/chez/rt.ss")`; this loads values.ss in turn. ;; Emitted programs do `(load "host/chez/rt.ss")`; this loads values.ss in turn.
(load "host/chez/values.ss") (load "host/chez/values.ss")
;; Resolve a libc entry point at RUN time. A literal (foreign-procedure "name" …)
;; in COMPILED code becomes a fasl relocation resolved when the boot loads — on a
;; platform lacking the symbol (chmod/sigaddset on Windows) that kills the boot
;; before any guard can run. eval defers the lookup to evaluation time, where the
;; guard works; returns #f when the entry doesn't exist.
(define (jolt-foreign-proc-safe name args res)
(guard (e (#t #f))
(load-shared-object #f)
(and (foreign-entry? name)
(eval `(foreign-procedure ,name ,args ,res)))))
(load "host/chez/collections.ss") (load "host/chez/collections.ss")
(load "host/chez/seq.ss") (load "host/chez/seq.ss")
@ -60,112 +49,6 @@
;; stack trace (source-registry.ss). call/cc is paid only on a throw, never per ;; stack trace (source-registry.ss). call/cc is paid only on a throw, never per
;; call; the captured k is walked, never invoked. ;; call; the captured k is walked, never invoked.
(define jolt-throw-cont (make-thread-parameter #f)) (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 (define-condition-type &jolt-throw &condition
make-jolt-throw-condition jolt-throw-condition? make-jolt-throw-condition jolt-throw-condition?
(value jolt-throw-condition-value)) (value jolt-throw-condition-value))

View file

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

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

View file

@ -237,12 +237,7 @@
(cond ((not (and (number? a) (number? b))) (jolt-quot-slow a b)) (cond ((not (and (number? a) (number? b))) (jolt-quot-slow a b))
((or (flonum? a) (flonum? b)) ((or (flonum? a) (flonum? b))
(let ((n (real->flonum a)) (d (real->flonum b))) (let ((n (real->flonum a)) (d (real->flonum b)))
(if (fl= d 0.0) (jolt-div0-throw) (if (fl= d 0.0) (jolt-div0-throw) (fltruncate (fl/ n d)))))
(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)) ((eqv? b 0) (jolt-div0-throw))
((and (integer? a) (integer? b)) (quotient a b)) ((and (integer? a) (integer? b)) (quotient a b))
(else (truncate (/ a b))))) (else (truncate (/ a b)))))
@ -251,11 +246,7 @@
((or (flonum? a) (flonum? b)) ((or (flonum? a) (flonum? b))
(let ((n (real->flonum a)) (d (real->flonum b))) (let ((n (real->flonum a)) (d (real->flonum b)))
(if (fl= d 0.0) (jolt-div0-throw) (if (fl= d 0.0) (jolt-div0-throw)
(let ((q (fl/ n d))) (fl- n (fl* d (fltruncate (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)) ((eqv? b 0) (jolt-div0-throw))
((and (integer? a) (integer? b)) (remainder a b)) ((and (integer? a) (integer? b)) (remainder a b))
(else (- a (* b (truncate (/ a b))))))) (else (- a (* b (truncate (/ a b)))))))
@ -460,11 +451,6 @@
((procedure? f) (apply f args)) ((procedure? f) (apply f args))
((keyword? f) (apply jolt-get (car args) f (cdr args))) ; (:k m [d]) -> (get m :k [d]) ((keyword? f) (apply jolt-get (car args) f (cdr args))) ; (:k m [d]) -> (get m :k [d])
((jolt-symbol? f) (apply jolt-get (car args) f (cdr args))) ; ('s m [d]) -> (get m 's [d]) ((jolt-symbol? f) (apply jolt-get (car args) f (cdr args))) ; ('s m [d]) -> (get m 's [d])
;; a VECTOR invokes as nth (a bad index throws, like IPersistentVector.invoke);
;; maps and sets invoke as get.
((pvec? f) (if (and (pair? args) (null? (cdr args)))
(jolt-nth f (car args))
(apply jolt-get f args)))
((jolt-coll? f) (apply jolt-get f args)) ; (coll k [d]) -> (get coll k [d]) ((jolt-coll? f) (apply jolt-get f args)) ; (coll k [d]) -> (get coll k [d])
((jolt-transient? f) (apply jolt-get f args)) ; a transient vec/map/set is callable on the JVM ((jolt-transient? f) (apply jolt-get f args)) ; a transient vec/map/set is callable on the JVM
;; a record/reify implementing clojure.lang.IFn is callable: dispatch to its ;; a record/reify implementing clojure.lang.IFn is callable: dispatch to its
@ -661,14 +647,8 @@
;; falls back to a copy-on-write wrapper for other targets (lists, sorted colls, ;; falls back to a copy-on-write wrapper for other targets (lists, sorted colls,
;; nil), so those keep the old per-step jolt-conj behaviour. ;; nil), so those keep the old per-step jolt-conj behaviour.
(define (jolt-into to from) (define (jolt-into to from)
;; only an editable collection rides the transient path; anything else
;; (PersistentQueue, sorted colls, seqs) folds through conj, like RT's
;; instanceof IEditableCollection split.
(if (or (pvec? to) (pmap? to) (pset? to))
(meta-carry to (meta-carry to
(jolt-persistent! (reduce-seq (lambda (t x) (jolt-conj! t x)) (jolt-transient-new to) (jolt-seq from)))) (jolt-persistent! (reduce-seq (lambda (t x) (jolt-conj! t x)) (jolt-transient-new to) (jolt-seq from)))))
(meta-carry to
(reduce-seq (lambda (acc x) (jolt-conj1 acc x)) to (jolt-seq from)))))
(define (range-from n) (cseq-lazy n (lambda () (range-from (+ n 1))))) (define (range-from n) (cseq-lazy n (lambda () (range-from (+ n 1)))))
;; A bounded range is a real chunked-seq, like clojure.lang.LongRange: eager, with ;; A bounded range is a real chunked-seq, like clojure.lang.LongRange: eager, with
@ -773,14 +753,8 @@
;; Parity over the full integer range (JVM even?/odd? accept any integer, ;; Parity over the full integer range (JVM even?/odd? accept any integer,
;; bignums included); a fixnum-only fxand crashes on a large value (e.g. a hash). ;; bignums included); a fixnum-only fxand crashes on a large value (e.g. a hash).
(define (parity-int n) (if (flonum? n) (exact (floor n)) n)) (define (parity-int n) (if (flonum? n) (exact (floor n)) n))
(define (jolt-parity-check n) (define (jolt-even? n) (even? (parity-int n)))
(unless (and (number? n) (exact? n) (integer? n)) (define (jolt-odd? n) (odd? (parity-int n)))
(jolt-throw (jolt-host-throwable
"java.lang.IllegalArgumentException"
(string-append "Argument must be an integer: "
(guard (e (#t "?")) (jolt-str n)))))))
(define (jolt-even? n) (jolt-parity-check n) (even? (parity-int n)))
(define (jolt-odd? n) (jolt-parity-check n) (odd? (parity-int n)))
(define (jolt-pos? n) (> n 0)) (define (jolt-pos? n) (> n 0))
(define (jolt-neg? n) (< n 0)) (define (jolt-neg? n) (< n 0))
(define (jolt-zero? n) (= n 0)) (define (jolt-zero? n) (= n 0))
@ -789,18 +763,8 @@
;; ============================================================================ ;; ============================================================================
;; keys / vals — return seqs (nil on the empty map), HAMT-iteration order ;; keys / vals — return seqs (nil on the empty map), HAMT-iteration order
;; ============================================================================ ;; ============================================================================
;; keys/vals of anything empty is nil (RT.keys over a nil seq); a non-empty (define (jolt-keys m) (if (jolt-nil? m) jolt-nil (list->cseq (pmap-fold m (lambda (k v a) (cons k a)) '()))))
;; non-map still fails (its elements are not MapEntries). (define (jolt-vals m) (if (jolt-nil? m) jolt-nil (list->cseq (pmap-fold m (lambda (k v a) (cons v a)) '()))))
(define (jolt-keys m)
(cond ((jolt-nil? m) jolt-nil)
((pmap? m) (list->cseq (pmap-fold m (lambda (k v a) (cons k a)) '())))
((jolt-nil? (jolt-seq m)) jolt-nil)
(else (list->cseq (pmap-fold m (lambda (k v a) (cons k a)) '())))))
(define (jolt-vals m)
(cond ((jolt-nil? m) jolt-nil)
((pmap? m) (list->cseq (pmap-fold m (lambda (k v a) (cons v a)) '())))
((jolt-nil? (jolt-seq m)) jolt-nil)
(else (list->cseq (pmap-fold m (lambda (k v a) (cons v a)) '())))))
;; ============================================================================ ;; ============================================================================
;; sequential equality + hash (hooks called from values.ss / collections.ss); ;; sequential equality + hash (hooks called from values.ss / collections.ss);

View file

@ -30,39 +30,6 @@ check_loc() {
fi fi
} }
# An uncaught error's stack trace must name the runtime-eval'd fn frames that
# survive TCO (the non-tail spine), even though the eval path registers no source
# map — "print what is available". Asserts a substring appears under " trace:".
check_trace() {
err="$(bin/joltc -e "$1" 2>&1 >/dev/null)"
if printf '%s' "$err" | grep -q ' trace:' && printf '%s' "$err" | grep -q "$2"; then
pass=$((pass + 1))
else
echo " FAIL (trace): $1"
echo " want stderr trace to contain \`$2\`, got \`$err\`"
fails=$((fails + 1))
fi
}
# JOLT_TRACE opts into the tail-frame history (the ring of rings): every $2 (an
# ERE) must match the " trace:" block. Used to assert TCO-elided frames are
# recovered and non-tail caller context survives a tail loop.
check_trace_on() {
err="$(JOLT_TRACE=1 bin/joltc -e "$1" 2>&1 >/dev/null)"
ok=1
printf '%s' "$err" | grep -q ' trace:' || ok=0
shift
for want in "$@"; do
printf '%s' "$err" | grep -Eq "$want" || ok=0
done
if [ "$ok" = 1 ]; then
pass=$((pass + 1))
else
echo " FAIL (trace-on): want [$*] in trace, got \`$err\`"
fails=$((fails + 1))
fi
}
check '(+ 1 2)' '3' check '(+ 1 2)' '3'
check '(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (fib 15)' '610' check '(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (fib 15)' '610'
check '(->> (range 10) (filter even?) (map (fn [x] (* x x))) (reduce +))' '120' check '(->> (range 10) (filter even?) (map (fn [x] (* x x))) (reduce +))' '120'
@ -93,53 +60,6 @@ check '(try (load-string "(+") (catch :default e (ex-message e)))' 'EOF while re
check_loc '(throw (ex-info "boom" {}))' 'boom' check_loc '(throw (ex-info "boom" {}))' 'boom'
check_loc '(do (+ 1 1) (/ 1 0))' ' at 1:' 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 prints usage, and lists the nREPL server under its real flag name.
help_out="$(bin/joltc --help 2>/dev/null)" help_out="$(bin/joltc --help 2>/dev/null)"
if printf '%s' "$help_out" | grep -q -- '--nrepl-server'; then if printf '%s' "$help_out" | grep -q -- '--nrepl-server'; then
@ -239,25 +159,5 @@ else
fails=$((fails + 1)) fails=$((fails + 1))
fi fi
# REPL-driven development traces by default: an error in an evaluated form shows a
# tail-frame backtrace with no JOLT_TRACE set. rb tail-calls ra tail-calls +, all
# TCO-elided from the continuation — only the history recovers them.
repl_err="$(printf '(defn ra [x] (+ x 1))\n(defn rb [x] (ra x))\n(rb :nan)\n:exit\n' | bin/joltc repl 2>&1)"
if printf '%s' "$repl_err" | grep -q ' trace:' && printf '%s' "$repl_err" | grep -q 'rb'; then
pass=$((pass + 1))
else
echo " FAIL: a REPL error should show a tail-frame trace by default"
printf '%s\n' "$repl_err" | sed 's/^/ | /'
fails=$((fails + 1))
fi
# JOLT_TRACE=0 opts out — no trace in the REPL.
repl_off="$(printf '(defn ra [x] (+ x 1))\n(defn rb [x] (ra x))\n(rb :nan)\n:exit\n' | JOLT_TRACE=0 bin/joltc repl 2>&1)"
if printf '%s' "$repl_off" | grep -q ' trace:'; then
echo " FAIL: JOLT_TRACE=0 should suppress the REPL trace"
fails=$((fails + 1))
else
pass=$((pass + 1))
fi
echo "cli smoke: $pass passed, $fails failed" echo "cli smoke: $pass passed, $fails failed"
[ "$fails" -eq 0 ] [ "$fails" -eq 0 ]

View file

@ -57,36 +57,10 @@
((symbol? nm) (symbol->string nm)) ((symbol? nm) (symbol->string nm))
(else #f))))))) (else #f)))))))
;; Frame names that are pure Chez / jolt-runtime plumbing — the eval boundary, ;; Walk a continuation, returning the registered jolt frames (innermost first) as
;; the var-cell trampoline, continuation/winder internals. They carry no Clojure ;; (frame-name . record) pairs, where record is #(ns name file line) or the symbol
;; meaning, so an unmapped frame with one of these names is dropped from the trace ;; 'ambiguous. Unmapped frames (host spine, anonymous lambdas) are skipped; raw
;; (a MAPPED frame is always kept — a jolt fn that happens to share the name still ;; depth is capped.
;; resolves to its source). Any name Chez prefixes with `$` (system) or that jolt
;; prefixes with `jolt-` (host runtime) is plumbing too.
(define srcreg-plumbing-names
(let ((h (make-hashtable string-hash string=?)))
(for-each (lambda (s) (hashtable-set! h s #t))
'("dynamic-wind" "winder-dummy" "ksrc" "invoke" "apply"
"call-with-values" "call/cc" "call-with-current-continuation"
"raise" "raise-continuable" "with-exception-handler" "guard"
"eval" "compile" "interpret" "expand" "read" "load"
;; host dispatch/coercion helpers (not `jolt-` prefixed) that carry
;; no Clojure meaning in a trace
"record-method-dispatch" "protocol-resolve" "devirt-resolve"
"list->cseq" "host-static-call" "host-call"))
h))
(define (srcreg-plumbing-name? nm)
(or (hashtable-ref srcreg-plumbing-names nm #f)
(and (fx>? (string-length nm) 0) (char=? (string-ref nm 0) #\$))
(and (fx>=? (string-length nm) 5) (string=? (substring nm 0 5) "jolt-"))))
;; Walk a continuation, returning its frames (innermost first) as (frame-name .
;; record) pairs. record is a source vector #(ns name file line) for a frame that
;; maps to registered Clojure source, the symbol 'ambiguous for a short name shared
;; across namespaces, or #f for an unmapped-but-named frame (the common case on the
;; open-world eval path, where nothing is registered — the bare frame name is still
;; a useful trace line). Plumbing frames (host spine, eval boundary) and unnamed
;; frames are skipped; raw depth is capped.
(define (jolt-frame-records k) (define (jolt-frame-records k)
;; read the env at call time, not load time: a built binary runs top-level forms ;; 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. ;; at heap-build time, where this would always be unset.
@ -96,32 +70,26 @@
(if (or (not io) (fx>=? n 400)) (if (or (not io) (fx>=? n 400))
(reverse acc) (reverse acc)
(let* ((nm (srcreg-frame-name io)) (let* ((nm (srcreg-frame-name io))
(src (and nm (hashtable-ref source-registry nm #f))) (src (and nm (hashtable-ref source-registry nm #f))))
;; keep a frame that maps, or any named frame that isn't plumbing
(keep? (and nm (or src (not (srcreg-plumbing-name? nm))))))
(when (and debug? nm) (when (and debug? nm)
(display (string-append " [frame] " nm (if src " *MAPPED*" (display (string-append " [frame] " nm (if src " *MAPPED*" "") "\n")
(if keep? "" " (skipped)")) "\n")
(current-error-port))) (current-error-port)))
(loop (guard (e (#t #f)) (io 'link)) (fx+ n 1) (loop (guard (e (#t #f)) (io 'link)) (fx+ n 1)
(if keep? (cons (cons nm src) acc) acc)))))))) (if src (cons (cons nm src) acc) acc))))))))
;; Render a list of (frame-name . record) pairs (innermost/deepest first) to a ;; Multi-line backtrace for an uncaught value — " ns/name (file:line)" for a
;; backtrace string. record is a source vector #(ns name file line) -> "ns/name ;; mapped frame, the bare frame name for an ambiguous one — or #f when no jolt
;; (file:line)", or 'ambiguous / #f -> the bare frame name. A run of the same ;; frame maps (the caller then prints just the top-level location). Capped to the
;; frame-name collapses to one "name (xN)" line (deep recursion, or a hot fn a ;; innermost frames.
;; loop re-enters), and the number of distinct lines is capped. (define (jolt-backtrace-string v)
(define (jolt-render-recs recs) (let ((k (jolt-error-continuation v)))
(and k
(let ((recs (jolt-frame-records k)))
(and (pair? recs)
(let ((port (open-output-string))) (let ((port (open-output-string)))
(let loop ((rs recs) (shown 0)) (let loop ((rs recs) (shown 0))
(if (or (null? rs) (fx>=? shown 30)) (when (and (pair? rs) (fx<? shown 30))
(get-output-string port)
(let* ((p (car rs)) (frame-name (car p)) (r (cdr p))) (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 " ") (put-string port " ")
(if (vector? r) (if (vector? r)
(let ((ns (vector-ref r 0)) (nm (vector-ref r 1)) (let ((ns (vector-ref r 0)) (nm (vector-ref r 1))
@ -131,49 +99,10 @@
(put-string port " (") (put-string port file) (put-string port " (") (put-string port file)
(put-string port ":") (put-string port (number->string line)) (put-string port ":") (put-string port (number->string line))
(put-string port ")"))) (put-string port ")")))
(put-string port frame-name)) ; 'ambiguous / unmapped: bare name (put-string port frame-name)) ; 'ambiguous: bare name
(when (fx>? cnt 1) (put-char port #\newline))
(put-string port " (x") (put-string port (number->string cnt)) (put-string port ")")) (loop (cdr rs) (fx+ shown 1))))
(put-char port #\newline) (get-output-string port)))))))
(loop tail (fx+ shown 1))))))))))
;; Multi-line backtrace for an uncaught value. Two sources, in preference order:
;; 1. The tail-frame history ring (rt.ss), when JOLT_TRACE enabled it — an
;; execution history of the runtime-compiled fns entered before the throw,
;; INCLUDING ones TCO erased from the live continuation. Most-recent first.
;; 2. Otherwise the live continuation (jolt-frame-records) — the accurate but
;; TCO-truncated non-tail spine.
;; Each frame maps to "ns/name (file:line)" when registered, else its bare name.
;; #f when neither source yields a frame (the caller then prints just the location).
;; The tail-frame history ring rendered as a backtrace, or #f when tracing is off /
;; empty. A mapped frame is kept; else drop plumbing (same rule as the continuation
;; path) so the two sources read consistently.
(define (jolt-history-backtrace)
(let* ((hist (jolt-trace-snapshot))
(recs (let loop ((ns hist) (acc '()))
(if (null? ns)
(reverse acc)
(let* ((nm (car ns)) (src (hashtable-ref source-registry nm #f)))
(loop (cdr ns)
(if (or src (not (srcreg-plumbing-name? nm)))
(cons (cons nm src) acc) acc)))))))
(and (pair? recs) (jolt-render-recs recs))))
(define (jolt-backtrace-string v)
(or (jolt-history-backtrace)
(let ((k (jolt-error-continuation v)))
(and k
(let ((recs (jolt-frame-records k)))
(and (pair? recs) (jolt-render-recs recs)))))))
;; Exposed for the REPL / nREPL error paths, which catch errors themselves instead
;; of going through the uncaught reporter. Returns the " trace:\n<frames>" block
;; from the tail-frame HISTORY only — the live continuation in a REPL is just the
;; REPL's own machinery — or nil when tracing is off (so a caller can when-let).
(def-var! "jolt.host" "backtrace-string"
(lambda ()
(let ((bt (jolt-history-backtrace)))
(if bt (string-append " trace:\n" bt) jolt-nil))))
;; Render an uncaught jolt throw (any value, not just a Chez condition) to a port: ;; 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 ;; an ex-info shows its message + ex-data (+ a host cause); anything else is

View file

@ -26,12 +26,6 @@ static int self_path(char *buf, uint32_t size) {
/* _NSGetExecutablePath fills buf and reports the needed size on overflow. */ /* _NSGetExecutablePath fills buf and reports the needed size on overflow. */
return _NSGetExecutablePath(buf, &size); 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 #else
#include <unistd.h> #include <unistd.h>
static int self_path(char *buf, uint32_t size) { static int self_path(char *buf, uint32_t size) {

View file

@ -44,16 +44,7 @@
(let ((ht (make-hashtable key-hash jolt=2))) (let ((ht (make-hashtable key-hash jolt=2)))
(pset-fold coll (lambda (e acc) (hashtable-set! ht e #t) acc) 0) (pset-fold coll (lambda (e acc) (hashtable-set! ht e #t) acc) 0)
(make-jolt-transient 'set ht 0 #t #f))) (make-jolt-transient 'set ht 0 #t #f)))
;; RFC 0003: any COLLECTION transients (the sorted/list/seq superset rides (else (make-jolt-transient 'cow coll 0 #t #f))))
;; the copy-on-write fallback); a non-collection is the JVM's cast failure.
((or (cseq? coll) (empty-list-t? coll) (jolt-lazyseq? coll)
(htable? coll) (jrec? coll))
(make-jolt-transient 'cow coll 0 #t #f))
(else
(jolt-throw (jolt-host-throwable
"java.lang.ClassCastException"
(string-append "class " (guard (e (#t "?")) (jolt-class-name coll))
" cannot be cast to class clojure.lang.IEditableCollection"))))))
;; map put/delete that maintain the reverse insertion-order list in `ord`. ;; map put/delete that maintain the reverse insertion-order list in `ord`.
(define (tmap-put! t k v) (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))) (if (fx<? i cnt) (begin (vector-set! out i (vector-ref buf i)) (loop (fx+ i 1)))
(make-pvec out))))))) (make-pvec out)))))))
((map) ((map)
(let* ((ht (jolt-transient-buf t)) (cnt (hashtable-size ht)) (cap (jolt-transient-n t)) (let* ((ht (jolt-transient-buf t)) (cnt (hashtable-size ht)) (cap (jolt-transient-n t)))
;; Clojure 1.13: a keyword-only map stays an array map up to 64 entries,
;; so a keyword map built through a transient (into {} …) keeps insertion
;; order to 64, matching the literal/assoc paths.
(cap (if (all-keywords? (jolt-transient-ord t)) (fxmax array-map-limit-kw cap) cap)))
(if (fx>? cnt cap) (if (fx>? cnt cap)
;; promoted past the array capacity: hash order ;; promoted past the array capacity: hash order
(let ((m empty-pmap-hash)) (let ((m empty-pmap-hash))

View file

@ -188,23 +188,9 @@
[false nil] [false nil]
(if or-map (keys or-map) []))) (if or-map (keys or-map) [])))
amp? (fn* [x] (and (symbol? x) (= "&" (name x)))) 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 proc
(fn* proc [pat init acc] (fn* proc [pat init acc]
(cond (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) (symbol? pat) (conj (conj acc pat) init)
(vector? pat) (vector? pat)
(let* [g (symbol (str (gensym))) (let* [g (symbol (str (gensym)))
@ -245,45 +231,30 @@
;; group binds a :keys/:strs/:syms list. dnsp is the destructuring ;; group binds a :keys/:strs/:syms list. dnsp is the destructuring
;; namespace from a qualified key like :ns/keys — it both prefixes ;; namespace from a qualified key like :ns/keys — it both prefixes
;; the lookup key and overrides a bare symbol's namespace. ;; 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 group
(fn* group [a names kind dnsp checked?] (fn* group [a names kind dnsp]
(if names (if names
(reduce (reduce
;; s is a symbol (a b) or a keyword (:a :b); name/ ;; s is a symbol (a b) or a keyword (:a :b); name/
;; namespace handle both, so :keys [:major] binds ;; namespace handle both, so :keys [:major] binds
;; `major` looking up :major (str would keep the colon). ;; `major` looking up :major (str would keep the colon).
(fn* [aa pair] (fn* [aa s]
(let* [s (nth pair 0) (let* [local (name s)
bind? (nth pair 1)
local (name s)
nsp (or (namespace s) dnsp) nsp (or (namespace s) dnsp)
keyform (cond keyform (cond
(= kind :kw) (keyword (if nsp (str nsp "/" local) local)) (= kind :kw) (keyword (if nsp (str nsp "/" local) local))
(= kind :str) local (= kind :str) local
:else `(quote ~(symbol nsp local))) :else `(quote ~(symbol nsp local)))
fo (find-or or-map local) fo (find-or or-map local)]
lookup (cond (conj (conj aa (symbol local))
checked? `(req! ~gm ~keyform) (if (nth fo 0)
(nth fo 0) `(get ~gm ~keyform ~(nth fo 1)) `(get ~gm ~keyform ~(nth fo 1))
:else `(get ~gm ~keyform))] `(get ~gm ~keyform)))))
(cond a names)
bind? (conj (conj aa (symbol local)) lookup)
checked? (conj (conj aa (symbol (str (gensym)))) lookup)
:else aa)))
a (classify names))
a)) a))
g1 (group base (get pat :keys) :kw nil false) g1 (group base (get pat :keys) :kw nil)
g2 (group g1 (get pat :strs) :str nil false) g2 (group g1 (get pat :strs) :str nil)
g3 (group g2 (get pat :syms) :sym nil false) g3 (group g2 (get pat :syms) :sym nil)]
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)]
;; remaining keys: a qualified :ns/keys|:ns/strs|:ns/syms groups under ;; remaining keys: a qualified :ns/keys|:ns/strs|:ns/syms groups under
;; its namespace; any other keyword is skipped; a non-keyword is a ;; its namespace; any other keyword is skipped; a non-keyword is a
;; nested binding pattern. ;; nested binding pattern.
@ -291,12 +262,9 @@
(if (keyword? k) (if (keyword? k)
(let* [kn (name k) kns (namespace k)] (let* [kn (name k) kns (namespace k)]
(cond (cond
(and kns (= kn "keys")) (group a (get pat k) :kw kns false) (and kns (= kn "keys")) (group a (get pat k) :kw kns)
(and kns (= kn "strs")) (group a (get pat k) :str kns false) (and kns (= kn "strs")) (group a (get pat k) :str kns)
(and kns (= kn "syms")) (group a (get pat k) :sym kns false) (and kns (= kn "syms")) (group a (get pat k) :sym kns)
(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)
:else a)) :else a))
;; a direct binding {x :x}: apply its :or default ;; a direct binding {x :x}: apply its :or default
;; (keyed by the local symbol) when the key is absent. ;; (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) ~(nth fo 1))
`(get ~gm ~(get pat k))) `(get ~gm ~(get pat k)))
a)))) a))))
g6 (keys pat))) g3 (keys pat)))
:else (throw (str "unsupported destructuring pattern: " (pr-str pat))))) :else (throw (str "unsupported destructuring pattern: " (pr-str pat)))))
ploop ploop
(fn* ploop [i acc] (fn* ploop [i acc]
@ -577,8 +545,6 @@
;; name binds only in the taken branch (temp# tests the value); via `let` so the ;; name binds only in the taken branch (temp# tests the value); via `let` so the
;; binding form may itself destructure, matching Clojure. ;; binding form may itself destructure, matching Clojure.
(defmacro when-let [bindings & body] (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 [form (bindings 0) tst (bindings 1)]
`(let [temp# ~tst] `(let [temp# ~tst]
(if temp# (let [~form temp#] ~@body) nil)))) (if temp# (let [~form temp#] ~@body) nil))))

View file

@ -219,8 +219,7 @@
;; compiler emit/inference path) — see predicates.ss. ;; compiler emit/inference path) — see predicates.ss.
(defn ratio? [x] (defn ratio? [x]
(and (number? x) (jolt.host/exact? x) (jolt.host/rational-type? x) (not (integer? x)))) (and (number? x) (jolt.host/exact? x) (jolt.host/rational-type? x) (not (integer? x))))
(defn rational? [x] (defn rational? [x] (and (number? x) (jolt.host/exact? x)))
(or (and (number? x) (jolt.host/exact? x)) (decimal? x)))
;; No first-class Class objects: class names are symbols the evaluator handles in ;; No first-class Class objects: class names are symbols the evaluator handles in
;; instance?/new positions, never values — so nothing is a class. ;; instance?/new positions, never values — so nothing is a class.
(defn class? [x] false) (defn class? [x] false)
@ -275,8 +274,7 @@
(loop [i 0 s (seq coll)] (loop [i 0 s (seq coll)]
(if (and s (< i n)) (recur (inc i) (next s)) i)))) (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) nil coll) nil)
(defn run! [proc coll] (reduce (fn [_ x] (proc x)) nil coll) nil)
(defn completing (defn completing
([f] (completing f identity)) ([f] (completing f identity))
@ -459,8 +457,7 @@
(defn sequential? [x] (or (vector? x) (seq? x))) (defn sequential? [x] (or (vector? x) (seq? x)))
(defn associative? [x] (or (map? x) (vector? x))) (defn associative? [x] (or (map? x) (vector? x)))
(defn counted? [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) (string? x)))
(or (vector? x) (map? x) (set? x) (list? x)))
(defn indexed? [x] (vector? x)) (defn indexed? [x] (vector? x))
;; sorted? is defined by the next tier (25-sorted) — declared here so this ;; sorted? is defined by the next tier (25-sorted) — declared here so this
;; tier compiles (forward references are analysis errors). ;; tier compiles (forward references are analysis errors).
@ -468,7 +465,7 @@
(defn reversible? [x] (or (vector? x) (sorted? x))) (defn reversible? [x] (or (vector? x) (sorted? x)))
(defn seqable? [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 boolean? [x] (or (true? x) (false? x)))
(defn double? [x] (and (number? x) (not (integer? x)))) (defn double? [x] (and (number? x) (not (integer? x))))

View file

@ -12,8 +12,7 @@
;; Clojure. Collections only — a string is seqable but not shuffleable, as on ;; Clojure. Collections only — a string is seqable but not shuffleable, as on
;; the JVM (Collections/shuffle wants a Collection). ;; the JVM (Collections/shuffle wants a Collection).
(defn shuffle [coll] (defn shuffle [coll]
;; Collections/shuffle wants a java.util.Collection — a map is not one (when-not (coll? coll)
(when (or (not (coll? coll)) (map? coll))
(throw (ex-info (str "shuffle requires a collection, got: " coll) {}))) (throw (ex-info (str "shuffle requires a collection, got: " coll) {})))
(loop [v (vec coll) i (dec (count v))] (loop [v (vec coll) i (dec (count v))]
(if (pos? i) (if (pos? i)
@ -29,10 +28,6 @@
(defn sort-by (defn sort-by
([keyfn coll] (sort-by keyfn compare coll)) ([keyfn coll] (sort-by keyfn compare coll))
([keyfn comp 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))) (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 ;; 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"}) \backspace "backspace" \space "space"})
(defn char-name-string [c] (get char-name-strings c)) (defn char-name-string [c] (get char-name-strings c))
;; Random selection over the host rand primitives — the reference shape: ;; Random selection over the host rand primitives.
;; nth directly (nil returns nil via RT.nth; a set throws like the JVM).
(defn rand-nth [coll] (defn rand-nth [coll]
(nth coll (rand-int (count coll)))) (let [v (vec coll)] (nth v (rand-int (count v)))))
(defn random-sample (defn random-sample
([prob] (filter (fn [_] (< (rand) prob)))) ([prob] (filter (fn [_] (< (rand) prob))))
@ -354,8 +348,8 @@
(defn clojure-version [] "1.11.0-jolt") (defn clojure-version [] "1.11.0-jolt")
;; bigdec is a host fn (host/chez/java/bigdec.ss) — a real BigDecimal value type. ;; 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 (defn numerator [x] (throw (ex-info "numerator requires a ratio (Jolt has no ratios)" {})))
;; rationals; a non-ratio is the Ratio cast failure. (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 ;; jolt has no reflection, but a few common JVM interfaces carry a modeled
;; ancestry (jolt.host/class-supers) so reflective checks like ;; ancestry (jolt.host/class-supers) so reflective checks like

View file

@ -89,21 +89,6 @@
(recur nxt (next ks)))) (recur nxt (next ks))))
m))))) 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. ;; find-based, so nil RESULTS are cached too; args canonicalize as a collection key.
(defn memoize [f] (defn memoize [f]
(let [mem (atom (hash-map))] (let [mem (atom (hash-map))]
@ -151,9 +136,6 @@
;; a deftype/record with its own empty (IPersistentCollection) — e.g. ;; a deftype/record with its own empty (IPersistentCollection) — e.g.
;; data.priority-map — uses it, before the generic map/set/vector arms. ;; data.priority-map — uses it, before the generic map/set/vector arms.
(jolt.host/jrec-method? coll "empty") (.empty coll) (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) (sorted? coll) ((get (jolt.host/ref-get coll :ops) :empty) coll)
(map? coll) (with-meta {} (meta coll)) (map? coll) (with-meta {} (meta coll))
(set? coll) (with-meta #{} (meta coll)) (set? coll) (with-meta #{} (meta coll))
@ -348,8 +330,7 @@
;; stays an unevaluated reader form on jolt and contains? can't see into it. ;; stays an unevaluated reader form on jolt and contains? can't see into it.
(def ^:private special-syms (def ^:private special-syms
#{'if 'do 'let* 'fn* 'quote 'var 'def 'loop* 'recur 'throw 'try 'catch #{'if 'do 'let* 'fn* 'quote 'var 'def 'loop* 'recur 'throw 'try 'catch
'finally 'new 'set! '. 'monitor-enter 'monitor-exit 'finally 'new 'set! '. 'monitor-enter 'monitor-exit})
'& 'case* 'deftype* 'letfn* 'reify*})
(defn special-symbol? [s] (contains? special-syms s)) (defn special-symbol? [s] (contains? special-syms s))

View file

@ -172,14 +172,6 @@
(def var-cache? (atom false)) (def var-cache? (atom false))
(defn set-var-cache! [on] (reset! var-cache? on)) (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 ;; 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 ;; jv$<ns>$<name>; chars that break a Scheme identifier or the `$` separator are
;; escaped so distinct vars never collide. ;; escaped so distinct vars never collide.
@ -199,13 +191,6 @@
;; recursion auto-restores them (no manual save/restore, no throw-leak). ;; recursion auto-restores them (no manual save/restore, no throw-leak).
(def ^:dynamic *recur-target* nil) (def ^:dynamic *recur-target* nil)
(def ^:dynamic *known-procs* #{}) (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)) (def ^:private gensym-counter (atom 0))
(defn- fresh-label [prefix] (str prefix (swap! gensym-counter inc))) (defn- fresh-label [prefix] (str prefix (swap! gensym-counter inc)))
@ -268,17 +253,6 @@
(if (or (contains? scheme-reserved s) (contains? bare-native-names s)) (str "_" s) s))) (if (or (contains? scheme-reserved s) (contains? bare-native-names s)) (str "_" s) s)))
(declare emit) (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 ;; A Chez string literal. Every char outside printable ASCII becomes a
;; codepoint hex escape \x<cp>; ; the named escapes (\n \t \r \" \\) match what ;; codepoint hex escape \x<cp>; ; the named escapes (\n \t \r \" \\) match what
@ -439,10 +413,9 @@
;; letfn lowers to a :let flagged :letrec (mutually-recursive named local fns): ;; 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*. ;; Scheme `letrec*` binds them so each sees its siblings. A plain let uses let*.
(defn- emit-let [node] (defn- emit-let [node]
(let [kw (if (:letrec node) "letrec*" "let*") (let [kw (if (:letrec node) "letrec*" "let*")]
;; bindings are non-tail; the body inherits the let's tail position (str "(" kw " (" (str/join " " (map emit-binding (:bindings node))) ") "
binds (binding [*tail?* false] (str/join " " (mapv emit-binding (:bindings node))))] (emit (:body node)) ")")))
(str "(" kw " (" binds ") " (emit (:body node)) ")")))
(defn- emit-loop [node] (defn- emit-loop [node]
(let [label (fresh-label "loop") (let [label (fresh-label "loop")
@ -450,10 +423,9 @@
names (map #(munge-name (nth % 0)) pairs) names (map #(munge-name (nth % 0)) pairs)
;; inits evaluate in the OUTER scope (recur-target unchanged) and, like ;; inits evaluate in the OUTER scope (recur-target unchanged) and, like
;; Clojure loop/let, SEQUENTIALLY — wrap a let* around the named let. ;; 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)) seq-bs (str/join " " (map (fn [n i] (str "(" n " " i ")")) names inits))
rebinds (str/join " " (map (fn [n] (str "(" n " " n ")")) names)) 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)))] body (binding [*recur-target* label] (emit (:body node)))]
(str "(let* (" seq-bs ") (let " label " (" rebinds ") " body "))"))) (str "(let* (" seq-bs ") (let " label " (" rebinds ") " body "))")))
@ -514,11 +486,7 @@
params (map munge-name orig) params (map munge-name orig)
restp (when-let [r (:rest a)] (munge-name r)) restp (when-let [r (:rest a)] (munge-name r))
label (fresh-label "fnrec") label (fresh-label "fnrec")
ret (:ret-nhint a) body (binding [*recur-target* label] (emit (:body 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)))
paramlist (cond paramlist (cond
(and restp (empty? params)) restp (and restp (empty? params)) restp
restp (str "(" (str/join " " params) " . " restp ")") restp (str "(" (str/join " " params) " . " restp ")")
@ -543,16 +511,6 @@
self (when-let [nm (:name node)] (munge-name nm)) self (when-let [nm (:name node)] (munge-name nm))
clauses (binding [*known-procs* (if self (conj *known-procs* self) *known-procs*)] clauses (binding [*known-procs* (if self (conj *known-procs* self) *known-procs*)]
(mapv emit-arity-clause arities)) (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)) lambda (if (= 1 (count clauses))
(let [c (first clauses)] (str "(lambda " (nth c 0) " " (nth c 1) ")")) (let [c (first clauses)] (str "(lambda " (nth c 0) " " (nth c 1) ")"))
(str "(case-lambda " (str "(case-lambda "
@ -615,30 +573,7 @@
(= (nth shape i) kw) i (= (nth shape i) kw) i
:else (recur (inc 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] (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) arg-nodes (:args node)
args (mapv emit arg-nodes) args (mapv emit arg-nodes)
@ -651,7 +586,8 @@
;; order [callee & args] together when ordering is observable. ;; order [callee & args] together when ordering is observable.
invoke (fn [] invoke (fn []
(ordered-call (cons fnode arg-nodes) (cons (emit fnode) args) (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 (cond
;; devirtualized protocol call: the inference proved the receiver (arg 0) is ;; 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 ;; one record type, so resolve the impl by that static tag instead of routing
@ -700,16 +636,11 @@
(if idx (if idx
(order-args (fn [as] (str "(jrec-field-at " (first as) " " idx " " (emit fnode) ")"))) (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) ")"))))) (order-args (fn [as] (str "(jolt-get " (first as) " " (emit fnode) (defstr as) ")")))))
;; (coll k [default]) -> lookup — coll (fnode) is the callee, evaluated ;; (coll k [default]) -> (jolt-get coll k [default]) — coll (fnode) is the
;; before the key/default args. A VECTOR literal invokes as nth (a bad ;; callee, evaluated before the key/default args.
;; index throws, IPersistentVector.invoke); maps/sets invoke as get.
(= kind :coll) (= kind :coll)
(ordered-call (cons fnode arg-nodes) (cons (emit fnode) args) (ordered-call (cons fnode arg-nodes) (cons (emit fnode) args)
(fn [[c & as]] (fn [[c & as]] (str "(jolt-get " c " " (str/join " " as) ")")))
(str (if (and (= :vector (:op fnode)) (= 1 (count as)))
"(jolt-nth "
"(jolt-get ")
c " " (str/join " " as) ")")))
(and (stdlib-var? fnode) (not (deref prelude-mode?))) (and (stdlib-var? fnode) (not (deref prelude-mode?)))
(throw (ex-info (str "emit: unsupported stdlib fn `" (:ns fnode) "/" (:name fnode) (throw (ex-info (str "emit: unsupported stdlib fn `" (:ns fnode) "/" (:name fnode)
"` (no core on Chez yet)") {})) "` (no core on Chez yet)") {}))
@ -726,7 +657,8 @@
;; holds an arbitrary IFn -> dynamic dispatch. ;; holds an arbitrary IFn -> dynamic dispatch.
(= :local (:op fnode)) (= :local (:op fnode))
(if (*known-procs* (munge-name (:name 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)) (invoke))
;; closed-world direct call: the callee var is an app fn def already emitted ;; 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. ;; with a Scheme binding — apply it directly, no var lookup, no jolt-invoke.
@ -735,7 +667,8 @@
;; below (which still uses the direct binding as the invoke target). ;; below (which still uses the direct binding as the invoke target).
(and (= :var (:op fnode)) (direct-linkable? (:ns fnode) (:name fnode)) (and (= :var (:op fnode)) (direct-linkable? (:ns fnode) (:name fnode))
(direct-link-fn? (: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 ;; a late-bound :var call head can hold a procedure OR a non-applicable
;; value the RT dispatches (multimethod, keyword/coll IFn) — route via ;; value the RT dispatches (multimethod, keyword/coll IFn) — route via
;; jolt-invoke (transparent for a procedure). ;; jolt-invoke (transparent for a procedure).
@ -743,7 +676,7 @@
(invoke) (invoke)
;; a computed callee can yield ANY IFn — route through jolt-invoke. ;; a computed callee can yield ANY IFn — route through jolt-invoke.
:else :else
(invoke)))))) (invoke))))
;; try/catch/finally. throw raises a Chez condition wrapping the jolt value ;; try/catch/finally. throw raises a Chez condition wrapping the jolt value
;; (jolt-throw = Scheme `raise` of a &jolt-throw condition); catch lowers to ;; (jolt-throw = Scheme `raise` of a &jolt-throw condition); catch lowers to
@ -790,22 +723,7 @@
(returns-scheme-bool? (:body node) bools')) (returns-scheme-bool? (:body node) bools'))
:else false))) :else false)))
;; In trace mode, a fn def also registers its source so the tail-frame history maps (defn emit [node]
;; 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]
(case (:op node) (case (:op node)
:const (emit-const (:val node)) :const (emit-const (:val node))
:local (munge-name (:name node)) :local (munge-name (:name node))
@ -853,14 +771,11 @@
:host-new (str "(host-new " (chez-str-lit (:class node)) :host-new (str "(host-new " (chez-str-lit (:class node))
(let [args (map emit (:args node))] (let [args (map emit (:args node))]
(if (empty? args) "" (str " " (str/join " " args)))) ")") (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) :if (let [test (:test node)
t (binding [*tail?* false] t (if (returns-scheme-bool? test) (emit test)
(if (returns-scheme-bool? test) (emit test) (str "(jolt-truthy? " (emit test) ")"))]
(str "(jolt-truthy? " (emit test) ")")))]
(str "(if " t " " (emit (:then node)) " " (emit (:else node)) ")")) (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 " (str/join " " (map emit (:statements node)))
:do (str "(begin " (binding [*tail?* false] (str/join " " (mapv emit (:statements node))))
(if (empty? (:statements node)) "" " ") (emit (:ret node)) ")") (if (empty? (:statements node)) "" " ") (emit (:ret node)) ")")
:invoke (emit-invoke node) :invoke (emit-invoke node)
;; collection literals -> rt constructors (collections.ss). Elements are ;; collection literals -> rt constructors (collections.ss). Elements are
@ -904,8 +819,7 @@
:fn (emit-fn node) :fn (emit-fn node)
;; (def name) with no init (declare): reserve the cell. A def with non-empty ;; (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). ;; reader metadata lowers to def-var-with-meta! (ported in a later increment).
:def (let [reg (trace-source-reg node) :def (cond
d (cond
(:no-init node) (:no-init node)
(str "(declare-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) ")") (str "(declare-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) ")")
(jmeta-nonempty? (:meta node)) (jmeta-nonempty? (:meta node))
@ -913,8 +827,7 @@
(emit-with-cells #(emit (:init node))) " " (emit-def-meta node) ")") (emit-with-cells #(emit (:init node))) " " (emit-def-meta node) ")")
:else :else
(str "(def-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " " (str "(def-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " "
(emit-with-cells #(emit (:init node))) ")"))] (emit-with-cells #(emit (:init node))) ")"))
(if (= reg "") d (str "(begin " d reg ")")))
(throw (ex-info (str "emit: op not yet ported / unhandled: " (pr-str (:op 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, ;; ^:dynamic / ^:redef on a def opts it out of direct-linking: it stays redefinable,

View file

@ -66,10 +66,6 @@
(if-let [root (:deps/root spec)] (str checkout "/" root) checkout)) (if-let [root (:deps/root spec)] (str checkout "/" root) checkout))
(:jolt/module spec) (:jolt/module spec)
(do (warn "skipping janet dependency " coord " (:jolt/module is obsolete on Chez)") nil) (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 :else
(do (warn "skipping unsupported coordinate " coord " " (pr-str spec)) nil))) (do (warn "skipping unsupported coordinate " coord " " (pr-str spec)) nil)))

View file

@ -8,8 +8,6 @@
(defn- project-dir [] (or (jolt.host/getenv "JOLT_PWD") ".")) (defn- project-dir [] (or (jolt.host/getenv "JOLT_PWD") "."))
(defn- version [] (jolt.host/jolt-version))
(defn- current-platform [] (defn- current-platform []
(let [os (str/lower-case (or (System/getProperty "os.name") ""))] (let [os (str/lower-case (or (System/getProperty "os.name") ""))]
(cond (str/includes? os "mac") :darwin (cond (str/includes? os "mac") :darwin
@ -147,10 +145,7 @@
;; loaded — same context a run gets, so (require '[some.lib]) works in the REPL. ;; loaded — same context a run gets, so (require '[some.lib]) works in the REPL.
(try (apply-project! (deps/resolve-project (project-dir))) (try (apply-project! (deps/resolve-project (project-dir)))
(catch :default _ nil)) (catch :default _ nil))
;; REPL-driven development: trace by default so an uncaught error in evaluated (println ";; jolt repl — :repl/quit or ^D to exit")
;; 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"))
(loop [] (loop []
(let [form (repl-read-form)] (let [form (repl-read-form)]
(when form (when form
@ -163,9 +158,7 @@
(catch :default e (catch :default e
(println "error:" (or (ex-message e) (println "error:" (or (ex-message e)
(try ((resolve 'jolt.host/condition-message) e) (catch :default _ nil)) (try ((resolve 'jolt.host/condition-message) e) (catch :default _ nil))
(pr-str e))) (pr-str e)))))
(when-let [bt (jolt.host/backtrace-string)]
(print bt))))
(recur))))))) (recur)))))))
;; A deps.edn :tasks entry: a string is a shell command; a map is {:main-opts …}. ;; A deps.edn :tasks entry: a string is a shell command; a map is {:main-opts …}.
@ -301,9 +294,7 @@
(when stop (stop)))))) (when stop (stop))))))
(defn- usage [] (defn- usage []
(println (str "jolt " (version)))
(println "usage: jolt <command> [args]") (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 -m NS [args] resolve deps.edn, load NS, call its -main")
(println " run FILE load a Clojure file") (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] [--dynamic] compile a standalone binary")
@ -313,7 +304,6 @@
(println " --nrepl-server [port] start an nREPL server (default 7888) for editors") (println " --nrepl-server [port] start an nREPL server (default 7888) for editors")
(println " path print the resolved source roots") (println " path print the resolved source roots")
(println " <task> run a deps.edn :tasks entry") (println " <task> run a deps.edn :tasks entry")
(println " --version print the jolt version")
(println " --help print this message")) (println " --help print this message"))
(defn -main [& args] (defn -main [& args]
@ -322,7 +312,6 @@
(nil? cmd) (usage) (nil? cmd) (usage)
(= cmd "--help") (usage) (= cmd "--help") (usage)
(= cmd "-h") (usage) (= cmd "-h") (usage)
(#{"--version" "-V"} cmd) (println (str "jolt " (version)))
(= cmd "run") (cmd-run more) (= cmd "run") (cmd-run more)
(= cmd "repl") (repl) (= cmd "repl") (repl)
(= cmd "--nrepl-server") (nrepl more) (= cmd "--nrepl-server") (nrepl more)

View file

@ -21,66 +21,25 @@
[jolt.ffi :as ffi])) [jolt.ffi :as ffi]))
;; --- sockets (loopback server) --------------------------------------------- ;; --- sockets (loopback server) ---------------------------------------------
(def ^:private os-name ;; Load libc (the running process's symbols) BEFORE the foreign-fn bindings below
(str/lower-case (or (System/getProperty "os.name") ""))) ;; — defcfn resolves the C entry point when the def is evaluated (at ns load), so
(def ^:private macos? (str/includes? os-name "mac")) ;; the socket symbols must already be available.
(def ^:private windows? (str/includes? os-name "win")) (ffi/load-library)
;; 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.
(ffi/defcfn c-socket "socket" [:int :int :int] :int) (ffi/defcfn c-socket "socket" [:int :int :int] :int)
(ffi/defcfn c-bind "bind" [:int :pointer :int] :int) (ffi/defcfn c-bind "bind" [:int :pointer :int] :int)
(ffi/defcfn c-listen "listen" [:int :int] :int) (ffi/defcfn c-listen "listen" [:int :int] :int)
(ffi/defcfn c-setsockopt "setsockopt" [:int :int :int :pointer :int] :int) (ffi/defcfn c-setsockopt "setsockopt" [:int :int :int :pointer :int] :int)
(ffi/defcfn c-accept "accept" [:int :pointer :pointer] :int :blocking) (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-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-send "send" [:int :pointer :size_t :int] :ssize_t :blocking)
(ffi/defcfn c-close "close" [:int] :int))) (ffi/defcfn c-close "close" [:int] :int)
(def ^:private AF-INET 2) (def ^:private AF-INET 2)
(def ^:private SOCK-STREAM 1) (def ^:private SOCK-STREAM 1)
;; SOL_SOCKET / SO_REUSEADDR: 0xffff / 4 on macOS and Windows, 1 / 2 on Linux. (def ^:private macos?
(def ^:private sol-socket (if (or macos? windows?) 0xffff 1)) (str/includes? (str/lower-case (or (System/getProperty "os.name") "")) "mac"))
(def ^:private so-reuse (if (or macos? windows?) 4 2)) (def ^:private sol-socket (if macos? 0xffff 1))
(def ^:private so-reuse (if macos? 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))))))
(defn- make-sockaddr [port] (defn- make-sockaddr [port]
(let [sa (ffi/alloc 16)] (let [sa (ffi/alloc 16)]
@ -94,7 +53,7 @@
sa)) sa))
(defn- listen-socket [port] (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)] (let [fd (c-socket AF-INET SOCK-STREAM 0)]
(when (neg? fd) (throw (ex-info "socket() failed" {}))) (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)) (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))) (try (when (and ns-str (not (str/blank? ns-str)) (find-ns (symbol ns-str)))
(in-ns (symbol ns-str))) (in-ns (symbol ns-str)))
(reset! result (load-string code)) (reset! result (load-string code))
(catch :default e (catch :default e (reset! err (err-msg e)))))]
(reset! err (str (err-msg e)
(when-let [bt (jolt.host/backtrace-string)]
(str "\n" bt)))))))]
{:value (when (nil? @err) (pr-str @result)) {:value (when (nil? @err) (pr-str @result))
:out out :out out
:ns (str (ns-name *ns*)) :ns (str (ns-name *ns*))
@ -280,17 +236,11 @@
no-op." no-op."
([port] (start port nil)) ([port] (start port nil))
([port middleware] ([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 []))) (let [handler (build-handler (resolve-middleware (or middleware [])))
fd (listen-socket port) ; throws on bind/listen failure fd (listen-socket port) ; throws on bind/listen failure
stopped (atom false)] stopped (atom false)]
(try (spit ".nrepl-port" (str port)) (catch :default _ nil)) (try (spit ".nrepl-port" (str port)) (catch :default _ nil))
(println (str "jolt " (jolt.host/jolt-version) " nREPL server started on port " (println (str "nREPL server started on port " port " (127.0.0.1) — .nrepl-port written"))
port " (127.0.0.1) — .nrepl-port written"))
(when (seq middleware) (println (str ";; middleware: " (str/join " " middleware)))) (when (seq middleware) (println (str ";; middleware: " (str/join " " middleware))))
(println ";; connect your editor; ^C to stop") (println ";; connect your editor; ^C to stop")
(future (future

View file

@ -16,15 +16,7 @@
;; Reader FORMS are detected by :jolt/type tag, never by map? — strict map? ;; Reader FORMS are detected by :jolt/type tag, never by map? — strict map?
;; (correctly) excludes tagged structs, so the old (and (map? x) ...) guard ;; (correctly) excludes tagged structs, so the old (and (map? x) ...) guard
;; would skip them. ;; would skip them.
(= :jolt/set (get x :jolt/type)) (= :jolt/set (get x :jolt/type)) (with-meta (set (map (fn [v] (edn->value opts v)) (get x :value))) (edn->value opts (meta x)))
(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))))
;; Tagged elements: a reader from the :readers opt wins, then the built-in ;; Tagged elements: a reader from the :readers opt wins, then the built-in
;; data readers (#uuid/#inst + registered); an unknown tag falls to the ;; data readers (#uuid/#inst + registered); an unknown tag falls to the
;; :default opt fn (called with tag and value, as in Clojure) or throws. ;; :default opt fn (called with tag and value, as in Clojure) or throws.
@ -38,9 +30,6 @@
custom (get (get opts :readers) tag-sym)] custom (get (get opts :readers) tag-sym)]
(cond (cond
custom (custom v) 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. ;; Clojure calls :default with the tag as a SYMBOL and the value.
(get opts :default) ((get opts :default) tag-sym v) (get opts :default) ((get opts :default) tag-sym v)
:else (__read-tagged tag v))) :else (__read-tagged tag v)))
@ -50,30 +39,25 @@
;; a constructed set: recurse into its elements too, so a tagged literal ;; a constructed set: recurse into its elements too, so a tagged literal
;; inside #{…} gets the :readers/:default treatment (aero's #ref in a set). ;; 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))) (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 (map (fn [v] (edn->value opts v)) x) (edn->value opts (meta x)))
(seq? x) (with-meta (apply list (map (fn [v] (edn->value opts v)) x)) (edn->value opts (meta x)))
:else x)) :else x))
;; Private helper, NOT named read-string: an unqualified (read-string …) call ;; Private helper, NOT named read-string: an unqualified (read-string …) call
;; dispatches the core read-string SPECIAL FORM (by name, regardless of ns), so ;; 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. ;; the 1-arity can't delegate to the 2-arity through that name.
(defn- read-edn [opts s] (defn- read-edn [opts s]
;; the strict edn seam: no auto-resolved keywords, invalid tokens throw, and (if (or (nil? s) (cstr/blank? s))
;; each #_ discard is validated through the same :readers/:default pipeline. (get opts :eof nil)
;; EOF (blank/comment-only/nil input) honors :eof; an opts map WITHOUT :eof ;; read the RAW form (tagged/set literals stay forms) so edn->value applies
;; makes end-of-input an error, like the reference. ;; every #tag through :readers/:default — read-string would build the built-in
(let [v (__read-form-edn s (fn [form] (edn->value opts form) nil))] ;; #inst/#uuid eagerly, ignoring an override and failing on a non-string form.
(if (= v :jolt/reader-eof) (edn->value opts (__read-form-raw s))))
(if (contains? opts :eof)
(get opts :eof)
(throw (ex-info "EOF while reading" {})))
(edn->value opts v))))
(defn read-string (defn read-string
"Reads one object from the string s. The no-opts arity returns nil at end of "Reads one object from the string s. Returns the :eof option value (default
input; with an opts map, :eof sets the value returned at end of input and its nil) for nil or blank input. opts is an options map; :eof sets the value
absence makes end-of-input an error." returned at end of input."
([s] (read-edn {:eof nil} s)) ([s] (read-edn {} s))
([opts s] (read-edn opts s))) ([opts s] (read-edn opts s)))
(defn- drain-reader (defn- drain-reader

View file

@ -7,7 +7,7 @@ test` from the repo root.
## The spec corpus ## 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`. `: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 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`. 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 chez --script host/chez/run-corpus.ss
JOLT_CORPUS_LIMIT=200 … # every-Nth stride, fast iteration 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 - `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, JVM-portable corpus: dot-forms, java statics, io, reader, walk, vars/namespaces,

File diff suppressed because it is too large Load diff

View file

@ -5,28 +5,56 @@ clojure.core-test.abs 1 0
clojure.core-test.add-watch 0 1 clojure.core-test.add-watch 0 1
clojure.core-test.bigint 6 0 clojure.core-test.bigint 6 0
clojure.core-test.bit-set 1 0 clojure.core-test.bit-set 1 0
clojure.core-test.compare 1 0
clojure.core-test.conj 1 0
clojure.core-test.contains-qmark 3 0
clojure.core-test.counted-qmark 1 0
clojure.core-test.dec 1 0 clojure.core-test.dec 1 0
clojure.core-test.denominator 0 3
clojure.core-test.double-qmark 3 0 clojure.core-test.double-qmark 3 0
clojure.core-test.empty 1 0
clojure.core-test.eq 2 0 clojure.core-test.eq 2 0
clojure.core-test.eval 0 3
clojure.core-test.even-qmark 1 0
clojure.core-test.float 1 0 clojure.core-test.float 1 0
clojure.core-test.get 0 1
clojure.core-test.inc 1 0 clojure.core-test.inc 1 0
clojure.core-test.int-qmark 3 0 clojure.core-test.int-qmark 3 0
clojure.core-test.lazy-seq 1 2 clojure.core-test.intern 2 0
clojure.core-test.keys 0 4
clojure.core-test.lazy-seq 3 0
clojure.core-test.minus 2 0 clojure.core-test.minus 2 0
clojure.core-test.mod 18 0 clojure.core-test.mod 23 0
clojure.core-test.neg-int-qmark 1 0 clojure.core-test.neg-int-qmark 1 0
clojure.core-test.not-eq 3 0 clojure.core-test.not-eq 3 0
clojure.core-test.num 2 0 clojure.core-test.nth 0 1
clojure.core-test.num 2 1
clojure.core-test.number-qmark 3 0
clojure.core-test.numerator 0 3
clojure.core-test.odd-qmark 1 0
clojure.core-test.parse-uuid 3 0 clojure.core-test.parse-uuid 3 0
clojure.core-test.peek 1 0 clojure.core-test.peek 2 0
clojure.core-test.plus 11 0 clojure.core-test.plus 11 0
clojure.core-test.plus-squote 11 0 clojure.core-test.plus-squote 11 0
clojure.core-test.pop 0 1
clojure.core-test.pos-int-qmark 1 0 clojure.core-test.pos-int-qmark 1 0
clojure.core-test.quot 25 0 clojure.core-test.quot 30 0
clojure.core-test.realized-qmark 1 0 clojure.core-test.rand-nth 0 1
clojure.core-test.rem 16 0 clojure.core-test.rational-qmark 3 0
clojure.core-test.realized-qmark 3 0
clojure.core-test.rem 21 0
clojure.core-test.remove-watch 0 1 clojure.core-test.remove-watch 0 1
clojure.core-test.run-bang 1 0
clojure.core-test.select-keys 2 0
clojure.core-test.seqable-qmark 1 0
clojure.core-test.shuffle 1 0
clojure.core-test.sort-by 2 0
clojure.core-test.special-symbol-qmark 4 0
clojure.core-test.star 13 0 clojure.core-test.star 13 0
clojure.core-test.star-squote 13 0 clojure.core-test.star-squote 13 0
clojure.core-test.transient 4 0 clojure.core-test.transient 23 0
clojure.core-test.update 1 0
clojure.core-test.vals 0 3
clojure.core-test.vec 1 0 clojure.core-test.vec 1 0
clojure.core-test.when-let 1 0
clojure.edn-test.read-string 46 5

View file

@ -576,26 +576,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 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 "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]"} {: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"}
] ]

View file

@ -10,7 +10,7 @@ read one data file, run each case, compare, report.
| File | Role | Generated by | | 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/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/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. | — | | `test/conformance/regen-corpus.clj` | Sources every `:expected` from reference **JVM Clojure** in one process. | — |
@ -27,14 +27,8 @@ the canonical, frozen contract**: it is what every runtime consumes, what
{:suite "numbers / arithmetic" ; grouping; "<suite> :: <label>" is the case id {:suite "numbers / arithmetic" ; grouping; "<suite> :: <label>" is the case id
:label "integer add" ; unique within a suite :label "integer add" ; unique within a suite
:actual "(+ 1 2)" ; Clojure source to evaluate :actual "(+ 1 2)" ; Clojure source to evaluate
:expected "3" ; Clojure source whose value it must equal, :expected "3"} ; Clojure source whose value it must equal,
; or the keyword :throws ; 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 - `[: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 Historically every `:expected` was hand-written. `certify.clj` removes that
weakness: it evaluates every `:actual` (and `:expected`) on **JVM Clojure** in a weakness: it evaluates every `:actual` (and `:expected`) on **JVM Clojure** in a
fresh `user` namespace and checks jolt's `:expected` against what real Clojure fresh `user` namespace and checks jolt's `:expected` against what real Clojure
produces. Of ~3400 vanilla-certifiable rows, **all but ~26 allowlisted rows produces. Of ~2740 vanilla-certifiable rows, **>2730 match reference Clojure
match reference Clojure exactly**. The rest are classified (see below) — none are silently wrong. exactly**. The rest are classified (see below) — none are silently wrong.
```sh ```sh
clojure -M test/conformance/certify.clj # gate clojure -M test/conformance/certify.clj # gate
@ -211,39 +205,3 @@ corpus`.
deliberate delta (classify it in `known-divergences.edn`). deliberate delta (classify it in `known-divergences.edn`).
- **Refresh the profile**: re-run with `--profile test/conformance/profile.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`). - **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.

View file

@ -99,12 +99,11 @@
[row :kept]))) [row :kept])))
;; --- corpus writer (preserves the one-row-per-line layout) ------------------- ;; --- 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) (str " {:suite " (pr-str suite)
" :label " (pr-str label) " :label " (pr-str label)
" :expected " (if (= expected :throws) ":throws" (pr-str expected)) " :expected " (if (= expected :throws) ":throws" (pr-str expected))
" :actual " (pr-str actual) " :actual " (pr-str actual) "}"))
(when portability (str " :portability " portability)) "}"))
(defn -main [& _] (defn -main [& _]
(let [corpus (edn/read-string (slurp corpus-path)) (let [corpus (edn/read-string (slurp corpus-path))