diff --git a/.gitmodules b/.gitmodules index 0ae0a56..4c5a7e6 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,9 +1,3 @@ -[submodule "vendor/sci"] - path = vendor/sci - url = https://github.com/borkdude/sci.git -[submodule "vendor/clojure-test-suite"] - path = vendor/clojure-test-suite - url = https://github.com/jank-lang/clojure-test-suite.git [submodule "vendor/irregex"] path = vendor/irregex url = https://github.com/ashinn/irregex.git diff --git a/Makefile b/Makefile index f0ea4b8..c2a6621 100644 --- a/Makefile +++ b/Makefile @@ -4,16 +4,20 @@ # build step. `make test` is the full gate. `make remint` rebuilds the seed after a # source change. -.PHONY: test corpus unit smoke selfhost certify remint +.PHONY: test values corpus unit smoke selfhost certify remint # Full gate. Each step exits non-zero on failure, failing the target. -test: selfhost corpus unit smoke certify +test: selfhost values corpus unit smoke certify @echo "OK: all gates passed" # Self-host fixpoint: bootstrap.ss rebuild == checked-in seed. selfhost: @sh host/chez/selfcheck.sh +# Value-model unit tests (nil/truthiness/collections on Chez). +values: + @chez --script test/chez/values-test.ss + # Corpus conformance vs JVM-sourced expecteds (allowlist + floor). corpus: @chez --script host/chez/run-corpus.ss diff --git a/bench/dump-mandelbrot-emit.janet b/bench/dump-mandelbrot-emit.janet deleted file mode 100644 index 7b196c7..0000000 --- a/bench/dump-mandelbrot-emit.janet +++ /dev/null @@ -1,28 +0,0 @@ -# Dump the Janet that jolt's backend emits for the mandelbrot hot fns, so we can -# A/B it against bench/mandelbrot-hand.janet and localize the ~1.43x jolt-over- -# hand-Janet gap measured in the foundational-runtime spike (jolt-5vsp). -(import ../src/jolt/api :as api) -(import ../src/jolt/backend :as backend) -(import ../src/jolt/reader :as reader) - -(def ctx (api/init-cached {:compile? true})) -(put (ctx :env) :direct-linking? true) -(put (ctx :env) :inline? true) -(api/eval-string ctx "(ns mandelbrot)") - -(def count-point-src - "(defn count-point [cr ci cap] (loop [i 0 zr 0.0 zi 0.0] (if (or (>= i cap) (> (+ (* zr zr) (* zi zi)) 4.0)) i (recur (inc i) (+ (- (* zr zr) (* zi zi)) cr) (+ (* 2.0 (* zr zi)) ci)))))") - -(def run-src - "(defn run [n] (let [cap 200 nd (* 1.0 n)] (loop [y 0 acc 0] (if (< y n) (let [ci (- (/ (* 2.0 y) nd) 1.0) row (loop [x 0 a 0] (if (< x n) (let [cr (- (/ (* 2.0 x) nd) 1.5)] (recur (inc x) (+ a (count-point cr ci cap)))) a))] (recur (inc y) (+ acc row))) acc))))") - -(api/eval-string ctx count-point-src) -(api/eval-string ctx run-src) - -(defn emit [src] - (string/format "%p" (backend/emit-ir ctx (backend/analyze-form ctx (reader/parse-string src))))) - -(print "===== count-point emitted Janet =====") -(print (emit count-point-src)) -(print "\n===== run emitted Janet =====") -(print (emit run-src)) diff --git a/bench/mandelbrot-hand-rec.janet b/bench/mandelbrot-hand-rec.janet deleted file mode 100644 index d8e0249..0000000 --- a/bench/mandelbrot-hand-rec.janet +++ /dev/null @@ -1,49 +0,0 @@ -# mandelbrot — hand-written Janet that MIRRORS jolt's loop-lowering: every loop/ -# recur becomes a self-recursive local closure stored in a var and called once -# per iteration (see bench/dump-mandelbrot-emit.janet). If this lands at jolt's -# ~219ms (vs the while-loop mandelbrot-hand.janet's ~153ms), the ~1.43x jolt- -# over-hand-Janet gap is the recursive-closure loop lowering, not anything else. -# janet bench/mandelbrot-hand-rec.janet 200 - -(defn count-point [cr ci cap] - (var loopfn nil) - (set loopfn (fn [i zr zi] - (if (let [t (>= i cap)] (if t t (> (+ (* zr zr) (* zi zi)) 4))) - i - (loopfn (+ i 1) - (+ (- (* zr zr) (* zi zi)) cr) - (+ (* 2 (* zr zi)) ci))))) - (loopfn 0 0 0)) - -(defn run [n] - (def cap 200) - (def nd (* 1 n)) - (var yloop nil) - (set yloop (fn [y acc] - (if (< y n) - (let [ci (- (/ (* 2 y) nd) 1) - row (do - (var xloop nil) - (set xloop (fn [x a] - (if (< x n) - (let [cr (- (/ (* 2 x) nd) 1.5)] - (xloop (+ x 1) (+ a (count-point cr ci cap)))) - a))) - (xloop 0 0))] - (yloop (+ y 1) (+ acc row))) - acc))) - (yloop 0 0)) - -(defn main [& args] - (def n (if (> (length args) 1) (scan-number (get args 1)) 1000)) - (repeat 2 (run (div n 2))) - (def times @[]) - (var last-r 0) - (repeat 3 - (def t0 (os/clock)) - (def r (run n)) - (array/push times (* 1000.0 (- (os/clock) t0))) - (set last-r r)) - (printf "mandelbrot n %d result %d" n last-r) - (print "runs: " (string/join (map |(string (/ (math/round (* $ 10.0)) 10.0)) times) " ")) - (printf "mean: %.1f ms" (/ (sum times) 3))) diff --git a/bench/mandelbrot-hand.janet b/bench/mandelbrot-hand.janet deleted file mode 100644 index 08c8d53..0000000 --- a/bench/mandelbrot-hand.janet +++ /dev/null @@ -1,53 +0,0 @@ -# mandelbrot — hand-written idiomatic Janet, same nested loop as bench/mandelbrot.clj. -# This is the "optimal Janet" leg of the foundational-runtime spike (jolt-5vsp): -# comparing jolt-emitted Janet vs this vs JVM localizes the 15x compute floor — -# jolt-backend overhead vs the Janet VM's own floor. -# -# janet bench/mandelbrot-hand.janet 200 - -(defn count-point [cr ci cap] - (var i 0) - (var zr 0.0) - (var zi 0.0) - (while (and (< i cap) (<= (+ (* zr zr) (* zi zi)) 4.0)) - (def nzr (+ (- (* zr zr) (* zi zi)) cr)) - (def nzi (+ (* 2.0 (* zr zi)) ci)) - (set zr nzr) - (set zi nzi) - (++ i)) - i) - -(defn run [n] - (def cap 200) - (def nd (* 1.0 n)) - (var acc 0) - (var y 0) - (while (< y n) - (def ci (- (/ (* 2.0 y) nd) 1.0)) - (var x 0) - (var a 0) - (while (< x n) - (def cr (- (/ (* 2.0 x) nd) 1.5)) - (set a (+ a (count-point cr ci cap))) - (++ x)) - (set acc (+ acc a)) - (++ y)) - acc) - -(defn main [& args] - (def n (if (> (length args) 1) (scan-number (get args 1)) 1000)) - # warmup - (repeat 2 (run (div n 2))) - (def runs 3) - (def times @[]) - (var last-r 0) - (repeat runs - (def t0 (os/clock)) - (def r (run n)) - (def ms (* 1000.0 (- (os/clock) t0))) - (set last-r r) - (array/push times ms)) - (def mean (/ (sum times) runs)) - (printf "mandelbrot n %d result %d" n last-r) - (print "runs: " (string/join (map |(string (/ (math/round (* $ 10.0)) 10.0)) times) " ")) - (printf "mean: %.1f ms" mean)) diff --git a/bin/jolt-chez b/bin/jolt-chez deleted file mode 100755 index 7f8e389..0000000 --- a/bin/jolt-chez +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/sh -# -e-capable jolt-chez launcher (jolt-9ziu). Runs from the repo root so the -# assembled prelude can load host/chez/rt.ss by relative path. -# JOLT_BIN=bin/jolt-chez janet test/chez/run-corpus.janet -root="$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd)" -cd "$root" || exit 1 -exec janet host/chez/jolt-chez.janet "$@" diff --git a/chez-janet-removal-handoff.md b/chez-janet-removal-handoff.md deleted file mode 100644 index e53cfae..0000000 --- a/chez-janet-removal-handoff.md +++ /dev/null @@ -1,165 +0,0 @@ -# Handoff — removing Janet (Chez re-host, Phase 4 → Phase 5) - -**Branch:** `spike/chez-bootstrap` · **LOCAL COMMITS ONLY — NEVER push.** This -overrides the session-close git-push protocol. -**Epic:** jolt-cf1q (Re-host Jolt on Chez, zero Janet). **Last session:** finished -self-hosting (inc8/inc9) + the portable conformance spec + fixed 4 certified bugs. - -## Where we are - -Done and gated (all local commits, latest `6abbea3`): -- **Self-hosting proven.** The on-Chez compiler reproduces itself (stage2==stage3, - prelude pstage3==pstage4). `bin/joltc` + `host/chez/bootstrap.ss` build and run - jolt with **zero Janet in the loop**, off the checked-in seed `host/chez/seed/`. -- **Correctness proven.** Both Chez corpus gates at **2534/2756**, 0 divergences. - The corpus is a JVM-certified host-neutral spec (`test/conformance/`, see SPEC.md): - 2670 portable cases, 249 feature-gated. - -**We are NOT ready to delete Janet.** Ripping it out now regresses real capability -(below). The remaining work is Phase 4 (runtime features + deployment/perf) → then -Phase 5 (jolt-cf1q.6) deletes `src/jolt/*.janet` + the Janet cross-compile. - -## Hard rules (every batch) - -1. **Never `git push`.** Local commits only on this branch. -2. **Gate discipline.** After any change run, with a real exit code: - - `jpm build && janet run-tests.janet` (full Janet gate; must end `All tests passed.`) - - `JOLT_CHEZ_ZEROJANET_CORPUS=1 janet test/chez/run-corpus-zero-janet.janet` (fast, ~2s) - - `JOLT_CHEZ_PRELUDE_CORPUS=1 janet test/chez/run-corpus-prelude.janet` (~18min; run ISOLATED — no concurrent chez work) - - `clojure -M test/conformance/certify.clj` (JVM cert; fails on new/stale divergence) -3. **If `clojure.core` or any seed source changes, re-mint the Chez seed**, or - `test/chez/bootstrap-test.janet` fails (rebuilt ≠ committed seed). Re-mint: - ```janet - (import host/chez/driver :as d) (import host/chez/jolt-chez :as jc) - (def ctx (d/make-ctx)) - (d/mint-chez-seed* (jc/ensure-prelude ctx) - (d/ensure-compiler-image ctx "/tmp/stage1.ss") - "host/chez/seed/prelude.ss" "host/chez/seed/image.ss") - ``` - (run from repo root via a throwaway `test/chez/_x.janet`). Raise the corpus - floors when parity rises. -4. **Use beads** (`bd ready`, `bd show `, `bd update --claim`, `bd close`). - `bd remember` for persistent notes — see memories `chez-phase3-progress`, - `conformance-spec`. Run `bd close` as its own command then verify (close-race). - -## Verify current state (run these first next session) - -```sh -git log --oneline -8 -bin/joltc -e '(+ 1 2)' # => 3 (pure-Chez runtime works) -bin/joltc -e '(eval (quote (+ 1 2)))' # => FAILS today — that's blocker #1 -``` - -## The blockers, in priority order - -### 1. jolt-r8ku — runtime eval / load-string / defmacro on the Chez spine ⭐ DO FIRST -**Why first:** biggest functional gap, and mostly *wiring* — the compiler image is -already resident at runtime on Chez (`host/chez/compile-eval.ss` loads it). Turns -`joltc` from a one-shot `-e` into a real runtime/REPL. Unblocks ~the eval/load-string -corpus crashes too. - -**Symptoms (tested):** -``` -joltc -e '(eval (quote (+ 1 2)))' -> jolt/uncompilable: special form eval -joltc -e '(load-string "(+ 1 2)")' -> not a fn (jolt-nil) -joltc -e '(defmacro m [x] ...) (m 5)' -> jolt/uncompilable: special form defmacro -``` - -**Why they punt:** `eval`/`defmacro` are in the special-symbol list, so the analyzer -treats them as special forms and the `:else` arm punts: -- `host/chez/host-contract.ss:110` and `:183` — `hc-special-symbols` / `form-special?` - list (includes `eval`, `defmacro`). -- `jolt-core/jolt/analyzer.clj:216` `analyze-special` (`case op …`), `:279` - `(uncompilable (str "special form " op))`. - -**Approach:** -- **eval / load-string are FUNCTIONS, not special forms.** Remove `eval` from the - special-symbol lists so it resolves as a normal var, then `def-var!` them in a Chez - `.ss` (e.g. a new `host/chez/eval.ss` loaded by `compile-eval.ss`): - `eval` = `(lambda (form) (jolt-compile-eval-form form (current-ns)))` — but - `jolt-compile-eval` (compile-eval.ss) takes a SOURCE STRING and reads it; add a - sibling that takes an already-read FORM and runs analyze→emit→eval on it. - `load-string` = read-all + eval each form. - - Mirror the Janet seed semantics: check `src/jolt/eval_runtime.janet` / - `eval_base.janet` for what `eval`/`load-string` do there (the contract to match). -- **defmacro must stay special** (it defines a macro). The prelude already handles - defmacro at build time (`host/chez/emit-image.ss` → `ei-defmacro->fn` emits a def of - the expander fn + `mark-macro!`). For RUNTIME user defmacro, add a `defmacro` branch - to `analyze-special` that lowers to the same shape: a `def` of the `(fn …)` expander - + a runtime `mark-macro!` call, so the macro is usable in subsequent forms of the - same program. Re-analysis of later forms must see the macro flag (`hc-macro?` reads - `var-macro-table`). -- Watch `jolt-lpvi` (build-ctx vs eval-ctx isolation) — runtime eval defining vars - must land in the user ns, not leak into the compiler image ns. - -**Verify:** `joltc -e` of all three above; add cases to `test/chez/spine-test.janet`; -the eval/load-string corpus crashes (660/661/2157/2158/… per the old chez-phase2 -notes) should now run; re-run both corpus gates. - -### 2. jolt-byjr — concurrency (future / promise / agent / pmap / pvalues / pcalls) -`joltc -e '(deref (future (+ 1 2)))'` → `Unknown class clojure.core`. The Janet -oracle uses isolated-heap SNAPSHOT futures (the `:concurrency/snapshot` feature in -`test/conformance/profile.edn`) which neither a sync shim nor raw Chez threads -reproduce exactly. **Decision needed:** real Chez threads vs a sync shim vs snapshot -emulation. The corpus snapshot cases are oracle-coupled (JVM gives shared-heap -answers, jolt gives snapshot) — already classified as a deliberate delta, so don't -chase JVM parity; match the *jolt* documented semantics. Revisit with a Chez -thread-safety review of the RT (`host/chez/*.ss` mutable tables: var-table, -ns-registry, atoms). - -### 3. jolt-cf1q.7 — host/Java interop breadth -~167 runtime crashes in the corpus are host-coupled (`profile.edn`: -`:host/jvm-interop` 174, `:host/arrays` 12, `:host/janet` 16). Java class shims, -arrays, `bean`/`proxy`/`definterface`. **Apply `vendor-before-scratch`**: for -non-trivial interop (date/time, crypto, etc.) vendor a mature Chez lib rather than -hand-rolling. Many of these are intentionally non-portable — decide per case whether -Chez should implement it or it stays a host-gated feature. `janet.*` cases are N/A on -Chez (delete from corpus in Phase 5). - -### 4. jolt-cf1q.5 — Phase 4: deployment & optimization modes -The optimizing compiler is **Janet-only**: inference, direct-linking, cgen-to-C, -whole-program, and **native binary builds** (`jpm build`, the ring-app example). Chez -emits Scheme and relies on Chez's own native compiler — perf is **unmeasured**. The -Phase 5 bead literally gates on *"perf confirmed."* Tasks: benchmark the Chez path -vs the Janet/JVM baselines; decide the Chez deployment story (Chez `compile-program`/ -boot file vs script); decide which Janet optimization modes (if any) must be -reproduced. This is the largest unknown — scope it before committing to deletion. - -### 5. Move the test oracle off Janet, then Phase 5 (jolt-cf1q.6) delete -- Today `build/jolt` (Janet) is the oracle for `test/chez/_*.janet`, and - `run-corpus-prelude` analyzes on Janet. The corpus is now JVM-certified, so the - oracle can shift to **spec-corpus + JVM**. Do this swap before deleting Janet. -- Tooling still Janet: `jolt-deps`, `nrepl-server`, uberscript/DCE — port or drop. -- **Then** Phase 5: delete `src/jolt/*.janet` (reader, value layer, vars/ns, the - tree-walking interpreter `evaluator.janet`, the Janet backend) AND - `host/chez/emit.janet` + the Janet cross-compile in `driver.janet`. The - tree-walking interpreter (the literal "drop the interpreter" goal) dies here. - -## Sequencing - -``` -jolt-r8ku (eval/macros) ─┐ -jolt-byjr (concurrency) ├─► jolt-cf1q.7 (host interop) ─► jolt-cf1q.5 (Phase 4 perf/deploy) - ─┘ │ - oracle → JVM/corpus ◄───────┘ - │ - ▼ - jolt-cf1q.6 (Phase 5: DELETE Janet) -``` - -## Key file map - -| Area | File | -|---|---| -| Pure-Chez runtime CLI | `bin/joltc` → `host/chez/cli.ss` | -| Zero-Janet compile spine | `host/chez/compile-eval.ss` (`jolt-compile-eval`) | -| Host contract (special syms, resolve, macro?) | `host/chez/host-contract.ss` | -| On-Chez image/prelude emitter | `host/chez/emit-image.ss` | -| Pure-Chez self-build + seed | `host/chez/bootstrap.ss`, `host/chez/seed/` | -| Portable analyzer / backend | `jolt-core/jolt/analyzer.clj`, `…/backend_scheme.clj` | -| clojure.core overlay | `jolt-core/clojure/core/NN-*.clj` | -| Janet seed (to delete in Phase 5) | `src/jolt/*.janet` (reader, evaluator, host_iface, …) | -| Chez RT shims | `host/chez/*.ss` | -| Conformance spec | `test/conformance/` (SPEC.md, certify.clj, profile.edn, known-divergences.edn) | -| Corpus + gates | `test/chez/corpus.edn`, `run-corpus-{zero-janet,prelude}.janet`, `extract-corpus.janet` | -| Self-host gates | `test/chez/{spine,fixpoint,bootstrap,cli}-test.janet` | diff --git a/host/chez/driver.janet b/host/chez/driver.janet deleted file mode 100644 index c7f9fcf..0000000 --- a/host/chez/driver.janet +++ /dev/null @@ -1,648 +0,0 @@ -# Phase 1 (jolt-cf1q.2) — live-analyzer -> Chez driver. -# -# Boots a real jolt ctx, runs the EXISTING Janet-hosted analyzer on actual -# Clojure source to produce host-neutral IR, feeds that IR to the Scheme emitter -# (emit.janet), and assembles a runnable Chez program. This is the Option-2 -# backend swap end to end: same front end, Scheme back end, run on Chez. -# -# Analysis still happens on Janet here (the analyzer is portable Clojure but not -# yet bootstrapped onto Chez — that's Phase 2); EXECUTION happens on Chez. The -# point of this increment is to validate that the real IR the analyzer emits -# compiles to correct, fast Scheme. - -(import ../../src/jolt/api :as api) -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/reader :as r) -(import ../../src/jolt/evaluator :as evlr) -(import ../../src/jolt/types_ctx :as tctx) -(import ../../src/jolt/types_ns :as tns) -(import ../../src/jolt/types_var :as tvar) -(import ./emit :as emit) - -# Chez Phase 3 (jolt-duot): the IR->Scheme emitter is now the PORTABLE Clojure -# jolt.backend-scheme (jolt-core), not emit.janet. It's loaded into the ctx and -# called from here the same way the analyzer is. emit.janet stays only as the -# program-string wrapper (emit/program) until program assembly ports to Clojure -# with compile-from-source. This is the step that takes the emitter off Janet. -(defn- ensure-clj-emitter [ctx] - (def env (ctx :env)) - (unless (get env :clj-emit-fn) - (def src (get (get env :embedded-sources @{}) "jolt.backend-scheme")) - (assert src "jolt.backend-scheme not embedded (check stdlib_embed)") - (backend/bootstrap-load-source ctx "jolt.backend-scheme" src) - (def ns (tctx/ctx-find-ns ctx "jolt.backend-scheme")) - (put env :clj-emit-fn (tvar/var-get (tns/ns-find ns "emit"))) - (put env :clj-set-prelude-fn (tvar/var-get (tns/ns-find ns "set-prelude-mode!")))) - ctx) - -# Emit IR -> Scheme via the Clojure emitter (returns a Janet string). -(defn- cemit [ctx ir] (string ((get (ctx :env) :clj-emit-fn) ir))) -(defn- cset-prelude! [ctx on] ((get (ctx :env) :clj-set-prelude-fn) on)) - -# Public: emit IR -> Scheme via the portable Clojure emitter (jolt.backend-scheme). -# The single seam tests use so emit.janet's emit fn is no longer exercised. -(defn scheme-emit [ctx ir] (ensure-clj-emitter ctx) (cemit ctx ir)) - -(defn chez-available? - "True when a `chez` binary is on PATH — lets the chez tests skip cleanly on - hosts without it (CI without Chez), like the clojure-test-suite skips when its - corpus dir is absent." - [] - (def r (protect (let [p (os/spawn ["chez" "--version"] :p {:out :pipe :err :pipe})] - (ev/read (p :out) 1024) - (ev/read (p :err) 1024) - (os/proc-wait p)))) - (and (r 0) (zero? (r 1)))) - -(defn make-ctx [] - "A compile-mode jolt ctx (the analyzer pipeline is only built under :compile?). - Late-bind unresolved symbols: the Chez back end has no interpreter to punt to, - so a forward reference to a runtime-interned var (defmulti/defmethod's setup - call) lowers to a var-deref instead of failing to compile (jolt-9ls5)." - (def ctx (api/init {:compile? true})) - (put (get ctx :env) :late-bind-unresolved? true) - (ensure-clj-emitter ctx) - ctx) - -(defn- parse-all [src] - (def out @[]) - (var s src) - (while (> (length (string/trim s)) 0) - (def parsed (r/parse-next s)) - (set s (in parsed 1)) - (def f (in parsed 0)) - (unless (nil? f) (array/push out f))) - out) - -(defn compile-program - "Compile a Clojure program string to a runnable Chez program. Every top-level - form is analyzed to real IR and emitted to Scheme; all but the LAST form are - treated as defs (also interned in the ctx so later forms resolve their vars), - and the last form is the expression whose value the program prints." - [ctx src] - (ensure-clj-emitter ctx) - (def forms (parse-all src)) - (assert (> (length forms) 0) "compile-program: empty program") - (def n (length forms)) - (def def-scm @[]) - (for i 0 (- n 1) - (def f (in forms i)) - # emit the def, then intern it (interpreted) so a later form's reference to - # this var resolves to a :var node rather than an unresolved symbol. - (array/push def-scm (cemit ctx (backend/analyze-form ctx f))) - (evlr/eval-form ctx @{} f)) - (def final-scm (cemit ctx (backend/analyze-form ctx (in forms (- n 1))))) - (emit/program def-scm final-scm)) - -# Drain a pipe to EOF. A single (ev/read pipe N) can return BEFORE the child has -# flushed everything — a program with a stdout side effect (newline/print) flushes -# in two writes, and the first ev/read sometimes catches only the first chunk, so -# the trailing real value is lost (intermittent gate divergence). Loop until EOF. -(defn- drain [pipe] - (def b @"") - (var c (ev/read pipe 0x10000)) - (while c (buffer/push b c) (set c (ev/read pipe 0x10000))) - (string b)) - -(defn run-on-chez - "Compile `src` and run it on Chez; returns [exit-code stdout stderr]." - [ctx src &opt scheme-out] - (def prog (compile-program ctx src)) - (def path (or scheme-out "/tmp/chez-jolt-prog.ss")) - (spit path prog) - (def proc (os/spawn ["chez" "--script" path] :p {:out :pipe :err :pipe})) - (def out (drain (proc :out))) - (def err (drain (proc :err))) - (def code (os/proc-wait proc)) - [code (string/trim out) (string/trim err)]) - -# --- clojure.core prelude assembly (jolt-9ziu) -------------------------------- -# The -e-capable jolt-chez path: emit EVERY non-macro clojure.core form across -# the dependency-ordered tiers as a def-var! in prelude mode, concatenated into -# a Scheme prelude loaded before the user expression. var-deref then resolves any -# core fn at runtime from the prelude's own def-var! cells. Macros are skipped -# (analyze-time only — the Janet analyzer expands them before emit, so they have -# no runtime value). Each form is wrapped in a tolerant load guard so a form that -# fails to LOAD (currently only the Phase-2 multimethod defmulti/defmethod -# print-method forms) doesn't break the rest of the prelude; it logs to stderr -# and becomes a lazy gap rather than a hard prelude failure. - -(def core-tier-files - ["00-syntax" "00-kernel" "10-seq" "20-coll" "25-sorted" "30-macros" "40-lazy" "50-io"]) - -# stdlib namespaces (beyond clojure.core) emitted into the prelude as their own -# def-var! tier. Each is pure Clojure over clojure.core + host natives, so the -# same analyze->emit pipeline lowers it; an aliased ref resolves via var-deref at -# runtime once the alias is registered (the driver pre-evals requires). jolt-nfca. -(def stdlib-ns-files - [["clojure.string" "src/jolt/clojure/string.clj"] - ["clojure.walk" "src/jolt/clojure/walk.clj"] - # clojure.template requires clojure.walk (apply-template over postwalk-replace) - # — must follow it so the alias resolves at emit time. - ["clojure.template" "src/jolt/clojure/template.clj"] - # clojure.edn requires clojure.string; read-string/__read-tagged are the - # reader.ss seams. The reader-arity's drain-reader is Janet-coupled (janet/type) - # so it's a lazy gap on Chez — read-string/edn->value are the live path. jolt-r8ku. - ["clojure.edn" "src/jolt/clojure/edn.clj"] - # clojure.set / clojure.pprint: pure Clojure over core. set = relational ops - # (union/intersection/difference/join/index/...); pprint = the minimal jolt - # shim (pprint -> prn + recognized dispatch vars, with-pprint-dispatch macro). - # jolt-j5vg, clojure.pprint Phase-2 parity. - ["clojure.set" "src/jolt/clojure/set.clj"] - ["clojure.pprint" "src/jolt/clojure/pprint.clj"]]) - -(defn- sym-name [x] - (when (and (struct? x) (= :symbol (get x :jolt/type))) (get x :name))) - -(defn- macro-form? [f] - (and (indexed? f) (> (length f) 0) - (let [h (sym-name (in f 0))] (and h (or (= h "defmacro") (= h "definline")))))) - -# Extract [name-string fn-form] from (defmacro NAME ...rest): the macro's expander -# as a bare (fn ...rest), docstring/attr-map stripped. Mirrors eval_special.janet/ -# eval-defmacro's parsing — bare name (no metadata on the name in core/stdlib), -# optional docstring, optional attr-map, then a params vector + body (single arity) -# OR arity clauses. Uses the `fn` MACRO (not fn*) so a destructured macro arglist -# desugars before lowering, like api/macro-compile-hook. -# -# We emit the BARE fn (not (def NAME ...)) on purpose: analyzing a def would -# host-intern! NAME in the Janet build ctx as a non-macro nil-root stub, and that -# stub makes a later (require '[stdlib-ns]) skip loading the REAL macro — so the -# Janet-hosted analyzer (the parity oracle) would treat e.g. with-pprint-dispatch -# as a fn and return its unexpanded template. The caller wraps the emitted lambda -# in def-var! manually, so NAME is never interned and require still works (jolt-r9lm). -(defn- defmacro->fn [f] - (def name-sym (in f 1)) - (def after-name (tuple/slice f 2)) - (def a1 (if (and (> (length after-name) 0) (string? (first after-name))) - (tuple/slice after-name 1) after-name)) - (def after-meta (if (and (> (length a1) 0) (struct? (first a1)) - (not= :symbol (get (first a1) :jolt/type))) - (tuple/slice a1 1) a1)) - (def fn-sym {:jolt/type :symbol :ns nil :name "fn"}) - [(sym-name name-sym) (array fn-sym ;after-meta)]) - -# Cross-compile one top-level form to its guard-wrapped Scheme string, or nil if it -# doesn't emit (out of subset). A defmacro emits as (def-var! ns name ) -# plus (mark-macro! ns name) so the on-Chez analyzer expands it (jolt-r9lm). The -# caller handles ns forms (alias registration only) before calling this. -(defn- emit-form-scheme [ctx ns-name f] - (defn- jts [x] (string/format "%j" x)) - (if (macro-form? f) - (let [[nm fn-form] (defmacro->fn f)] - (when nm - (def res (protect (cemit ctx (backend/analyze-form ctx fn-form)))) - (when (res 0) - (string "(guard (e (#t #f))\n (def-var! " (jts ns-name) " " (jts nm) "\n " - (res 1) ")\n (mark-macro! " (jts ns-name) " " (jts nm) "))")))) - (let [res (protect (cemit ctx (backend/analyze-form ctx f)))] - (when (res 0) - (string "(guard (e (#t #f))\n " (res 1) ")"))))) - -(defn- form-label [f] - (if (and (indexed? f) (> (length f) 1)) - (let [h (or (sym-name (in f 0)) "?") n (sym-name (in f 1))] (if n (string h " " n) h)) - "?")) - -(defn- require-head? [f] - (and (indexed? f) (> (length f) 0) - (let [h (sym-name (in f 0))] (and h (or (= h "require") (= h "use")))))) - -(defn- scan-eval-requires! [ctx form] - "Recursively eval any (require ...)/(use ...) sub-form against the ctx so the - alias registers + the aliased ns loads BEFORE the AOT analyzer resolves its - qualified refs — the whole user form is analyzed up front, before any require - would run at eval time (jolt-nfca). Failures are swallowed (the ref then stays - an emit-err, the prior behavior)." - (when (indexed? form) - (if (require-head? form) - (protect (api/eval-one ctx form)) - (each sub form (scan-eval-requires! ctx sub))))) - -(defn emit-core-prelude - "Assemble the clojure.core prelude as a Scheme string. `ctx` must be a - compile-mode ctx; its current ns is set to clojure.core for the duration. - Returns [scheme emitted total skipped-load-guards-unknown]; `scheme` is the - joined, guard-wrapped def-var! forms (no rt.ss load — add that at program - assembly via emit/program or program-with-prelude)." - [ctx &opt core-dir] - (default core-dir "jolt-core/clojure/core/") - (ensure-clj-emitter ctx) - (cset-prelude! ctx true) - (def prev-ns (tctx/ctx-current-ns ctx)) - (tctx/ctx-set-current-ns ctx "clojure.core") - (def out @[]) - (var total 0) (var emitted 0) - (defn- emit-ns-forms [ns-name src] - (tctx/create-ns ctx ns-name) - (tctx/ctx-set-current-ns ctx ns-name) - (each f (parse-all src) - # Register any aliases this ns depends on before analyzing its forms, so an - # aliased ref (e.g. clojure.template's walk/postwalk-replace) resolves at emit - # time instead of lowering to an "Unknown class walk" host-static. The ns - # form's :require is a keyword-headed clause that scan-eval-requires! (matching - # the `require`/`use` symbol heads) doesn't catch, so eval the ns form whole. - (def ns-form? (and (indexed? f) (> (length f) 0) (= "ns" (sym-name (in f 0))))) - (if ns-form? (protect (api/eval-one ctx f)) (scan-eval-requires! ctx f)) - # Skip emitting ns forms: their only role here is alias registration, and a - # runtime ns-switch would leak into the prelude's trailing *ns* (the def-var!s - # already carry explicit ns names). Macros ARE emitted now (jolt-r9lm): each - # defmacro becomes a def of its expander fn + (mark-macro! ns name) so the - # on-Chez analyzer (inc6b) can expand it — previously skipped (the Janet - # analyzer expanded them at analyze time, before they reached the prelude). - # Tolerant load guard (inside emit-form-scheme): a form that fails to LOAD - # (the 8 Phase-2 multimethod print-method forms in 50-io) is swallowed so it - # doesn't break the rest of the prelude — it becomes a lazy gap. - (unless ns-form? - (++ total) - (def scm (emit-form-scheme ctx ns-name f)) - (when scm (++ emitted) (array/push out scm))))) - (each tf core-tier-files - (emit-ns-forms "clojure.core" (slurp (string core-dir tf ".clj")))) - # stdlib namespaces beyond clojure.core that are pure Clojure over core/host - # natives — emitted as their own def-var! tier so an aliased ref (e.g. s/split - # after (require '[clojure.string :as s])) resolves at runtime (jolt-nfca). - (each [ns-name path] stdlib-ns-files - (emit-ns-forms ns-name (slurp path))) - (tctx/ctx-set-current-ns ctx prev-ns) - (cset-prelude! ctx false) - [(string/join out "\n") emitted total]) - -# --- analyzer/emitter cross-compile (jolt-hs9n, the zero-Janet spine) --------- -# Phase 3 inc6: cross-compile the PORTABLE compiler (jolt.ir + jolt.analyzer + -# jolt.backend-scheme) to Scheme def-var! forms so analyze->IR->emit runs ON CHEZ. -# Same emit pipeline as the core prelude, but for jolt-core/jolt/* namespaces -# rather than clojure.core: jolt.* refs lower to var-deref (the prelude-mode gate -# only rejects clojure.* refs), clojure.core refs resolve from the loaded prelude, -# and the jolt.host form-*/resolve-global/... refs resolve from host-contract.ss. - -(defn- emit-ns-forms-list - "Cross-compile one namespace's source to a list of guard-wrapped def-var! Scheme - strings (prelude mode must already be ON). Registers the ns' requires/aliases in - ctx first so cross-ns refs resolve at emit time; skips ns + macro forms (macros - are analyze-time only, already expanded at their use sites)." - [ctx ns-name src] - (tctx/create-ns ctx ns-name) - (tctx/ctx-set-current-ns ctx ns-name) - (def out @[]) - (each f (parse-all src) - (def ns-form? (and (indexed? f) (> (length f) 0) (= "ns" (sym-name (in f 0))))) - (if ns-form? (protect (api/eval-one ctx f)) (scan-eval-requires! ctx f)) - # The compiler namespaces define no macros, but route through the shared helper - # anyway (a defmacro would emit as a def + mark-macro!, jolt-r9lm). - (unless ns-form? - (def scm (emit-form-scheme ctx ns-name f)) - (when scm (array/push out scm)))) - out) - -(def compiler-ns-files - [["jolt.ir" "jolt-core/jolt/ir.clj"] - ["jolt.analyzer" "jolt-core/jolt/analyzer.clj"] - ["jolt.backend-scheme" "jolt-core/jolt/backend_scheme.clj"]]) - -(defn emit-compiler-image - "Cross-compile the analyzer pipeline (jolt.ir + jolt.analyzer + - jolt.backend-scheme) to a Scheme string of prelude-mode def-var! forms — the - analyze->IR->emit spine running ON CHEZ (jolt-hs9n). Load AFTER rt.ss + - host-contract.ss + the core prelude. Returns [scheme total]." - [ctx] - (ensure-clj-emitter ctx) - # ensure-analyzer is lazy; a trivial analyze builds jolt.ir/jolt.analyzer/ - # jolt.passes in the Janet ctx so their vars resolve while we emit their source. - (protect (backend/analyze-form ctx (in (r/parse-next "nil") 0))) - (cset-prelude! ctx true) - (def prev-ns (tctx/ctx-current-ns ctx)) - (def out @[]) - (each [ns-name path] compiler-ns-files - (array/concat out (emit-ns-forms-list ctx ns-name (slurp path)))) - (tctx/ctx-set-current-ns ctx prev-ns) - (cset-prelude! ctx false) - [(string/join out "\n") (length out)]) - -(defn ensure-compiler-image - "Build (once) and return the path to the cross-compiled compiler image — the - jolt.ir/jolt.analyzer/jolt.backend-scheme def-var! forms (jolt-hs9n). Cached on - disk keyed by the same fingerprint scheme as the prelude; pass an explicit path - to control caching from the test harness." - [ctx path] - (unless (os/stat path) - (def [img _] (emit-compiler-image ctx)) - (spit path img)) - path) - -(defn program-zero-janet - "Assemble a fully self-hosted Chez program: rt.ss + the core prelude + - host-contract.ss + the cross-compiled compiler image + compile-eval.ss, then - compile AND eval `src` ON CHEZ (read->analyze->emit->eval, no Janet). The - zero-Janet spine (jolt-hs9n)." - [prelude-path image-path src ns] - (string - "(import (chezscheme))\n" - "(load \"host/chez/rt.ss\")\n" - "(set-chez-ns! \"clojure.core\")\n" - "(load " (string/format "%j" prelude-path) ")\n" - "(load \"host/chez/post-prelude.ss\")\n" - "(set-chez-ns! \"user\")\n" - "(load \"host/chez/host-contract.ss\")\n" - "(load " (string/format "%j" image-path) ")\n" - "(load \"host/chez/compile-eval.ss\")\n" - "(printf \"~a\\n\" (jolt-final-str (jolt-compile-eval " - (string/format "%j" src) " " (string/format "%j" ns) ")))\n")) - -(defn eval-zero-janet - "Compile+run `src` through the ON-CHEZ analyzer/emitter (zero Janet). Needs a - prebuilt core prelude (`prelude-path`) and compiler image (`image-path`). - Returns [code stdout stderr]." - [prelude-path image-path src &opt ns scheme-out] - (default ns "user") - (def prog (program-zero-janet prelude-path image-path src ns)) - (def path (or scheme-out (string "/tmp/jolt-zero-janet-" (os/getpid) ".ss"))) - (spit path prog) - (def proc (os/spawn ["chez" "--script" path] :p {:out :pipe :err :pipe})) - (def out (drain (proc :out))) - (def err (drain (proc :err))) - (def code (os/proc-wait proc)) - [code (string/trim out) (string/trim err)]) - -# --- self-hosting fixpoint (jolt-cf1q.4 inc8) --------------------------------- -# emit-compiler-image (above) builds stage1: the Janet analyzer/emitter -# cross-compiles the compiler sources to a Scheme def-var! image. To prove the -# ON-CHEZ compiler reproduces itself we recompile the SAME sources WITH the loaded -# image (emit-image.ss's jolt-emit-image runs analyze->emit on Chez): feeding it -# stage1 yields stage2, feeding it stage2 yields stage3, and stage2 == stage3 -# byte-for-byte is the fixpoint (self-hosting-bootstrap-research §4). - -(defn program-emit-image - "A Chez program that loads the zero-Janet runtime + the compiler `image-path`, - then re-emits the compiler image (or, with emit-fn \"jolt-emit-prelude\", the - clojure.core prelude) ON CHEZ and writes it to `out-path`. Running this with - image = stageN produces stage(N+1)." - [prelude-path image-path out-path &opt emit-fn] - (default emit-fn "jolt-emit-image") - (string - "(import (chezscheme))\n" - "(load \"host/chez/rt.ss\")\n" - "(set-chez-ns! \"clojure.core\")\n" - "(load " (string/format "%j" prelude-path) ")\n" - "(load \"host/chez/post-prelude.ss\")\n" - "(set-chez-ns! \"user\")\n" - "(load \"host/chez/host-contract.ss\")\n" - "(load " (string/format "%j" image-path) ")\n" - "(load \"host/chez/compile-eval.ss\")\n" - "(load \"host/chez/emit-image.ss\")\n" - "(let ((p (open-output-file " (string/format "%j" out-path) " 'replace)))\n" - " (put-string p (" emit-fn ")) (close-port p))\n")) - -(defn emit-image-on-chez - "Re-emit the compiler image on Chez: load `image-path` (stageN) and write the - re-emitted image (stage N+1) to `out-path`. Each runs in a fresh chez process so - gensym/state start clean (essential for a byte-stable fixpoint). emit-fn selects - jolt-emit-image (the compiler) or jolt-emit-prelude (clojure.core). Returns - [code stderr]." - [prelude-path image-path out-path &opt emit-fn] - (def prog (program-emit-image prelude-path image-path out-path emit-fn)) - (def path (string "/tmp/jolt-emit-image-" (os/getpid) "-" (hash out-path) ".ss")) - (spit path prog) - (def proc (os/spawn ["chez" "--script" path] :p {:out :pipe :err :pipe})) - (def out (drain (proc :out))) - (def err (drain (proc :err))) - (def code (os/proc-wait proc)) - [code (string/trim (string out err))]) - -# --- pure-Chez self-build (jolt-9phg, inc9a) ---------------------------------- -# host/chez/bootstrap.ss rebuilds the prelude + compiler image from source ON -# CHEZ given a seed (prelude, image) pair. run-bootstrap drives ONE bootstrap.ss -# pass (no Janet in the compile path — Janet only spawns chez). mint-chez-seed -# iterates it from the Janet seed to the joint fixpoint and writes the checked-in -# bootstrap seed under host/chez/seed/. - -(defn run-bootstrap - "Run one pure-Chez bootstrap pass: load (seed-prelude, seed-image), rebuild the - prelude + image from source on Chez, write them to (out-prelude, out-image). - Returns [code stdout stderr]. The compilation is 100% Chez; Janet only spawns - the process." - [seed-prelude seed-image out-prelude out-image] - (def proc (os/spawn ["chez" "--script" "host/chez/bootstrap.ss" - seed-prelude seed-image out-prelude out-image] - :p {:out :pipe :err :pipe})) - (def out (drain (proc :out))) - (def err (drain (proc :err))) - (def code (os/proc-wait proc)) - [code (string/trim out) (string/trim err)]) - -(defn mint-chez-seed* - "Mint the checked-in bootstrap seed. Takes the Janet-emitted starting pair - (janet-prelude + janet-image, e.g. from jolt-chez/ensure-prelude + - ensure-compiler-image) and iterates bootstrap.ss to the joint byte-fixpoint, then - writes the converged pair to seed-prelude/seed-image. Run once (and whenever the - seed sources change) to refresh the checked-in seed. Returns iteration count." - [janet-prelude janet-image seed-prelude seed-image &opt max-iter] - (default max-iter 8) - (defn b= [a b] (= (string (slurp a)) (string (slurp b)))) - (def tmp (or (os/getenv "TMPDIR") "/tmp")) - (var cur-pre janet-prelude) - (var cur-img janet-image) - (var converged false) - (var iters 0) - (for i 0 max-iter - (def npre (string tmp "/mint-pre-" i ".ss")) - (def nimg (string tmp "/mint-img-" i ".ss")) - (def [code _ err] (run-bootstrap cur-pre cur-img npre nimg)) - (unless (zero? code) (errorf "bootstrap pass %d failed: %s" i err)) - (set iters (inc i)) - # A pass is a fixpoint once its output equals its input AND the input is no - # longer the Janet seed (the Janet prelude/image differ only in gensym ids). - (when (and (not= cur-pre janet-prelude) - (b= cur-pre npre) (b= cur-img nimg)) - (set converged true) - (set cur-pre npre) (set cur-img nimg) - (break)) - (set cur-pre npre) (set cur-img nimg)) - (unless converged (errorf "seed did not converge in %d iterations" max-iter)) - (os/mkdir (string/slice seed-prelude 0 (last (string/find-all "/" seed-prelude)))) - (spit seed-prelude (slurp cur-pre)) - (spit seed-image (slurp cur-img)) - iters) - -# --- batched zero-Janet corpus runner (jolt-qjr0, inc7) ----------------------- -# eval-zero-janet spawns a fresh chez per case, each reloading rt.ss + the prelude -# (~282KB) + the compiler image (~89KB) from source — ~0.5s of pure reload per -# case, the entire cost. This runs ALL cases in ONE chez process: load the runtime -# once, then loop. Each case is guarded (errors isolated) and the user namespace is -# reset between cases (var-table keys added by a case are removed, *ns* restored) so -# there is no state leakage vs the per-process path. ~10-30x faster. - -(defn program-corpus-zero-janet - "A Chez program that loads the zero-Janet runtime once, then runs every case in - `cases-tsv` (labelsrc per line) through jolt-compile-eval, printing one - result line per case: PASSlabel | DIVERGElabelvalue | - CRASHlabelmessage." - [prelude-path image-path cases-tsv] - (string - "(import (chezscheme))\n" - "(load \"host/chez/rt.ss\")\n" - "(set-chez-ns! \"clojure.core\")\n" - "(load " (string/format "%j" prelude-path) ")\n" - "(load \"host/chez/post-prelude.ss\")\n" - "(set-chez-ns! \"user\")\n" - "(load \"host/chez/host-contract.ss\")\n" - "(load " (string/format "%j" image-path) ")\n" - "(load \"host/chez/compile-eval.ss\")\n" - # Snapshot mutable global state after setup so each case sees a clean world (as - # if it ran in its own process): (1) var-table keys a case ADDS (its defs) are - # removed; (2) a base cell whose ROOT a case mutated (e.g. in-ns rebinds - # clojure.core/*ns*) is restored; (3) the ns + type registries are pruned back to - # their base keys. Without this, *ns*/find-ns/all-ns/satisfies? leak across cases. - "(define zj-base (let ((h (make-hashtable string-hash string=?)))\n" - " (vector-for-each (lambda (k) (hashtable-set! h k #t)) (hashtable-keys var-table)) h))\n" - "(define zj-roots '())\n" - "(vector-for-each (lambda (k) (let ((c (hashtable-ref var-table k #f)))\n" - " (when c (set! zj-roots (cons (cons c (var-cell-root c)) zj-roots)))))\n" - " (hashtable-keys var-table))\n" - "(define (zj-snap ht) (let ((h (make-hashtable string-hash string=?)))\n" - " (vector-for-each (lambda (k) (hashtable-set! h k #t)) (hashtable-keys ht)) h))\n" - "(define (zj-prune! ht base) (vector-for-each\n" - " (lambda (k) (unless (hashtable-ref base k #f) (hashtable-delete! ht k))) (hashtable-keys ht)))\n" - "(define zj-ns-base (zj-snap ns-registry))\n" - "(define zj-type-base (zj-snap type-registry))\n" - # global-hierarchy is a core atom whose CONTENTS `derive` mutates (its var root - # stays the same atom object, so the root-restore above misses it). Reset its - # contents to a fresh hierarchy each case. - "(define zj-ghier (var-cell-lookup \"clojure.core\" \"global-hierarchy\"))\n" - "(define (zj-reset!)\n" - " (vector-for-each (lambda (k) (unless (hashtable-ref zj-base k #f) (hashtable-delete! var-table k)))\n" - " (hashtable-keys var-table))\n" - " (for-each (lambda (cr) (unless (eq? (var-cell-root (car cr)) (cdr cr))\n" - " (var-cell-root-set! (car cr) (cdr cr)))) zj-roots)\n" - " (zj-prune! ns-registry zj-ns-base)\n" - " (zj-prune! type-registry zj-type-base)\n" - " (hashtable-clear! ns-alias-table)\n" - " (hashtable-clear! ns-refer-table)\n" - " (when zj-ghier (jolt-invoke (var-deref \"clojure.core\" \"reset!\")\n" - " (var-cell-root zj-ghier) (jolt-invoke (var-deref \"clojure.core\" \"make-hierarchy\"))))\n" - " (set-chez-ns! \"user\"))\n" - "(define kw-message (keyword #f \"message\"))\n" - "(define (zj-err->str e)\n" - " (cond ((and (pmap? e) (string? (jolt-get e kw-message))) (jolt-get e kw-message))\n" - " ((condition? e) (call-with-string-output-port (lambda (p) (display-condition e p))))\n" - " ((string? e) e)\n" - " (else (call-with-string-output-port (lambda (p) (write e p))))))\n" - "(define (zj-clean s)\n" # strip tabs/newlines from a message so it stays one TSV line - " (list->string (map (lambda (c) (if (or (char=? c #\\tab) (char=? c #\\newline)) #\\space c))\n" - " (string->list s))))\n" - # cases are stored one-per-line with \\n / \\t / \\\\ escaped (a source may be - # multi-line — e.g. a ;comment\\n inside a map literal); unescape before eval. - "(define (zj-unescape s)\n" - " (let ((out (open-output-string)) (n (string-length s)))\n" - " (let loop ((i 0))\n" - " (if (>= i n) (get-output-string out)\n" - " (let ((c (string-ref s i)))\n" - " (if (and (char=? c #\\\\) (< (+ i 1) n))\n" - " (let ((d (string-ref s (+ i 1))))\n" - " (write-char (cond ((char=? d #\\n) #\\newline) ((char=? d #\\t) #\\tab) (else d)) out)\n" - " (loop (+ i 2)))\n" - " (begin (write-char c out) (loop (+ i 1)))))))))\n" - # ACTUAL is compiled+eval'd as its OWN top-level program (jolt-compile-eval - # unrolls a top-level do), so a macro defined earlier in the program is usable - # later (runtime defmacro) — matching certify.clj's eval-isolated. Then compare - # to EXPECTED with =. (Wrapping in (= E A) would nest ACTUAL's do; wrapping A in - # (eval (quote A)) would quote a map literal and lose its source eval-order.) - "(define (zj-run label e-esc a-esc)\n" - " (define esrc (zj-unescape e-esc))\n" - " (define asrc (zj-unescape a-esc))\n" - " (guard (e (#t (printf \"CRASH\\t~a\\t~a\\n\" label (zj-clean (zj-err->str e)))))\n" - " (let* ((av (jolt-compile-eval asrc \"user\")) (ev (jolt-compile-eval esrc \"user\")))\n" - " (if (jolt= ev av)\n" - " (printf \"PASS\\t~a\\n\" label)\n" - " (printf \"DIVERGE\\t~a\\t~a\\n\" label (zj-clean (jolt-final-str av))))))\n" - " (zj-reset!))\n" - "(define (zj-tab s from)\n" - " (let loop ((i from)) (cond ((>= i (string-length s)) #f)\n" - " ((char=? (string-ref s i) #\\tab) i) (else (loop (+ i 1))))))\n" - "(let ((p (open-input-file " (string/format "%j" cases-tsv) ")))\n" - " (let loop ()\n" - " (let ((line (get-line p)))\n" - " (unless (eof-object? line)\n" - " (let* ((t1 (zj-tab line 0)) (t2 (and t1 (zj-tab line (+ t1 1)))))\n" - " (when (and t1 t2)\n" - " (zj-run (substring line 0 t1) (substring line (+ t1 1) t2)\n" - " (substring line (+ t2 1) (string-length line)))))\n" - " (loop)))))\n")) - -(defn eval-corpus-zero-janet - "Run all `cases` ([label src] pairs) through the ON-CHEZ analyzer in ONE chez - process. Returns a struct mapping label -> [:pass] | [:diverge value] | - [:crash message]. Vastly faster than per-case eval-zero-janet (single runtime - load); use eval-zero-janet to isolate a single case for debugging." - [prelude-path image-path cases &opt scheme-out cases-out] - (def tsv-path (or cases-out (string "/tmp/jolt-zj-cases-" (os/getpid) ".tsv"))) - (def buf @"") - # escape so each case is one TSV line even if its source is multi-line; the - # runner's zj-unescape reverses it. Backslash first, then newline/tab. - (defn- tsv-esc [s] - (->> s (string/replace-all "\\" "\\\\") (string/replace-all "\n" "\\n") - (string/replace-all "\t" "\\t"))) - (each [label e a] cases (buffer/push buf label "\t" (tsv-esc e) "\t" (tsv-esc a) "\n")) - (spit tsv-path buf) - (def prog (program-corpus-zero-janet prelude-path image-path tsv-path)) - (def path (or scheme-out (string "/tmp/jolt-zj-runner-" (os/getpid) ".ss"))) - (spit path prog) - (def proc (os/spawn ["chez" "--script" path] :p {:out :pipe :err :pipe})) - (def out (drain (proc :out))) - (def err (drain (proc :err))) - (def code (os/proc-wait proc)) - (def res @{}) - (each line (string/split "\n" (string/trim out)) - (when (> (length line) 0) - (def parts (string/split "\t" line)) - (def status (in parts 0)) - (def label (get parts 1 "")) - (cond - (= status "PASS") (put res label [:pass]) - (= status "DIVERGE") (put res label [:diverge (get parts 2 "")]) - (= status "CRASH") (put res label [:crash (get parts 2 "")])))) - # If chez died mid-run (e.g. an uncatchable error), surface what we have + stderr. - {:results res :code code :stderr (string/trim err) :count (length res)}) - -(defn program-with-prelude - "Assemble a runnable Chez program that loads rt.ss, loads the assembled core - prelude from `prelude-path` (a file written once), then prints `final-scm`." - [prelude-path final-scm] - (string - "(import (chezscheme))\n" - "(load \"host/chez/rt.ss\")\n" - # the prelude's defmultis (print-method/print-dup) must land in clojure.core, - # not the default user ns (jolt-9ls5); set the multimethod current-ns around - # the prelude load, then restore it to user for the program form. - "(set-chez-ns! \"clojure.core\")\n" - "(load " (string/format "%j" prelude-path) ")\n" - # native-wins overrides for overlay predicates that read :jolt/type (char?, - # atom?) — must load AFTER the prelude's own def-var! to take effect. - "(load \"host/chez/post-prelude.ss\")\n" - "(set-chez-ns! \"user\")\n" - "(printf \"~a\\n\" (jolt-final-str " final-scm "))\n")) - -(defn eval-e-with-prelude - "Run a single user expression `src` on Chez with the full clojure.core prelude - (loaded from `prelude-path`). Emits `src` in prelude mode so any core ref - resolves via var-deref. Returns [code stdout stderr], or [:emit-err msg \"\"] - if the user form itself can't be emitted." - [ctx src prelude-path &opt scheme-out] - (ensure-clj-emitter ctx) - (cset-prelude! ctx true) - (def form (in (r/parse-next src) 0)) - (scan-eval-requires! ctx form) - (def res (protect (cemit ctx (backend/analyze-form ctx form)))) - (cset-prelude! ctx false) - (if (not (res 0)) - [:emit-err (string (res 1)) ""] - (let [prog (program-with-prelude prelude-path (res 1)) - # PID-unique default so concurrent processes (a foreground -e while the - # parity gate runs) never read each other's half-written program file. - path (or scheme-out (string "/tmp/jolt-chez-e-" (os/getpid) ".ss"))] - (spit path prog) - (def proc (os/spawn ["chez" "--script" path] :p {:out :pipe :err :pipe})) - (def out (drain (proc :out))) - (def err (drain (proc :err))) - (def code (os/proc-wait proc)) - [code (string/trim out) (string/trim err)]))) diff --git a/host/chez/emit.janet b/host/chez/emit.janet deleted file mode 100644 index 26a361a..0000000 --- a/host/chez/emit.janet +++ /dev/null @@ -1,552 +0,0 @@ -# Phase 1 — jolt IR -> Chez Scheme emitter (jolt-cf1q.2). -# -# The new back end: consumes the SAME host-neutral IR (jolt.ir, see -# jolt-core/jolt/ir.clj) the live analyzer produces and the Janet backend -# consumes, but emits Scheme source text instead of Janet. `host/compile` (Chez -# `eval`) turns that into a procedure. Covers the pure-functional + numeric -# subset (const/local/var/host/if/do/let/fn/invoke/def/loop/recur) — enough to -# run fib/mandelbrot-shaped code through the REAL analyzer. -# -# IR access mirrors the Janet backend: live IR fields are jolt VALUES — vectors -# are persistent (pv), and a nil-valued node densifies to a phm. `nn`/`vv` below -# normalize both into Janet structs/arrays, so the same code drives hand-built -# IR (the unit tests) and live analyzer output (the driver). - -(import ../../src/jolt/pv :as pv) -(import ../../src/jolt/phm :as phm) - -# Normalize a node (phm -> struct) and a vector field (pvec -> array view); both -# pass plain Janet values through untouched, so hand-built IR still works. -(defn- nn [n] (if (phm/phm? n) (phm/phm-to-struct n) n)) -(defn- vv [x] (if (pv/pvec? x) (pv/pv->array x) x)) - -# Hot clojure.core primitives lowered to native Scheme, mirroring the Janet -# backend's native-ops (documented numbers-only relaxation). `=` is the -# exactness-aware jolt= from values.ss; inc/dec/not are rt shims; mod/rem/quot -# map to Scheme's (correct: Scheme has all three, unlike Janet which lacked quot). -(def- native-ops - {"+" "+" "-" "-" "*" "*" "/" "/" - "<" "<" ">" ">" "<=" "<=" ">=" ">=" - "=" "jolt=" "inc" "jolt-inc" "dec" "jolt-dec" "not" "jolt-not" - "min" "min" "max" "max" - "mod" "modulo" "rem" "remainder" "quot" "quotient" - # persistent-collection leaf ops (jolt-wgbz) -> rt prims in collections.ss - "vector" "jolt-vector" "hash-map" "jolt-hash-map" "hash-set" "jolt-hash-set" - "conj" "jolt-conj" "get" "jolt-get" "nth" "jolt-nth" "count" "jolt-count" - "assoc" "jolt-assoc" "dissoc" "jolt-dissoc" "contains?" "jolt-contains?" - "empty?" "jolt-empty?" "peek" "jolt-peek" "pop" "jolt-pop" - # seq tier (jolt-5pso) -> rt prims in seq.ss - "first" "jolt-first" "rest" "jolt-rest" "next" "jolt-next" "seq" "jolt-seq" - "cons" "jolt-cons" "list" "jolt-list" "reverse" "jolt-reverse" "last" "jolt-last" - "map" "jolt-map" "filter" "jolt-filter" "remove" "jolt-remove" - "reduce" "jolt-reduce" "into" "jolt-into" "concat" "jolt-concat" "apply" "jolt-apply" - "range" "jolt-range" "take" "jolt-take" "drop" "jolt-drop" - "keys" "jolt-keys" "vals" "jolt-vals" - "even?" "jolt-even?" "odd?" "jolt-odd?" "pos?" "jolt-pos?" "neg?" "jolt-neg?" - "zero?" "jolt-zero?" "identity" "jolt-identity" - # exceptions (jolt-vcsl): ex-info builds the tagged map; ex-data/ex-message/ - # ex-cause are pure-over-get Clojure tier fns (no native-op needed). - "ex-info" "jolt-ex-info"}) - -# Value-position resolution for a clojure.core ref passed AS A VALUE (to map / -# filter / reduce / apply). Each native-op already names a usable Scheme -# procedure; arithmetic is the exception — Scheme's +/-/*// return EXACT results -# for exact/zero-arg inputs, breaking the all-double model in higher-order use, -# so value-position arithmetic routes to the flonum-coercing rt wrappers. -(def- core-value-procs - (merge native-ops {"+" "jolt-add" "-" "jolt-sub" "*" "jolt-mul" "/" "jolt-div"})) - -# Per-op arity gate: only lower when the Scheme prim and the jolt fn agree at -# this arity. Ops absent from the table are variadic (arith/compare/=, the -# collection constructors, conj/assoc/dissoc) and legal at any arity. -(def- op-arity - {"inc" |(= $ 1) "dec" |(= $ 1) "not" |(= $ 1) - "count" |(= $ 1) "empty?" |(= $ 1) "peek" |(= $ 1) "pop" |(= $ 1) - "mod" |(= $ 2) "rem" |(= $ 2) "quot" |(= $ 2) "contains?" |(= $ 2) - "get" |(or (= $ 2) (= $ 3)) "nth" |(or (= $ 2) (= $ 3)) - "assoc" |(and (>= $ 3) (odd? $)) "dissoc" |(>= $ 1) "conj" |(>= $ 1) - # seq tier arities the shims support - "first" |(= $ 1) "rest" |(= $ 1) "next" |(= $ 1) "seq" |(= $ 1) - "reverse" |(= $ 1) "last" |(= $ 1) "keys" |(= $ 1) "vals" |(= $ 1) - "even?" |(= $ 1) "odd?" |(= $ 1) "pos?" |(= $ 1) "neg?" |(= $ 1) - "zero?" |(= $ 1) "identity" |(= $ 1) - "cons" |(= $ 2) "filter" |(= $ 2) "remove" |(= $ 2) "into" |(= $ 2) - "take" |(= $ 2) "drop" |(= $ 2) "map" |(>= $ 2) "apply" |(>= $ 2) - "reduce" |(or (= $ 2) (= $ 3)) "range" |(and (>= $ 0) (<= $ 3)) - "ex-info" |(or (= $ 2) (= $ 3))}) - -# If fnode is a clojure.core (or host) ref to a native-op primitive, return the -# Scheme op string — only at an arity where the Scheme op and the jolt fn agree. -(defn- native-op [fnode nargs] - (def nm (case (get fnode :op) - :var (when (= "clojure.core" (get fnode :ns)) (get fnode :name)) - :host (get fnode :name) - nil)) - (def op (and nm (get native-ops nm))) - (def arity-ok (get op-arity nm)) - (cond - (nil? op) nil - (and arity-ok (not (arity-ok nargs))) nil - op)) - -# PRELUDE MODE (inc 3d). The default (subset) mode rejects any clojure.core ref -# that isn't a native-op — a clean "out of subset" signal for user-facing `-e`. -# When emitting clojure.core ITSELF as a Scheme prelude, core fns reference each -# other constantly; those refs must lower to `var-deref` (resolved at runtime -# from the prelude's own def-var! forms) instead of being rejected. Host interop -# (:host) and unhandled IR ops still error in both modes — those are the real -# gaps that need a hand-written RT shim. -(var- prelude-mode? false) -(defn set-prelude-mode! [on] (set prelude-mode? on)) - -(var- recur-target nil) -# Munged local names known to hold a procedure (a named fn's self-recursion name). -# Calls to these stay DIRECT; any other :local callee routes through jolt-invoke -# (dynamic IFn dispatch) — keeps the fib self-call off the invoke fallback. -(def- known-procs @{}) -(var- gensym-n 0) -(defn- fresh-label [prefix] (string prefix (++ gensym-n))) - -# Emit a call `(ctor a0 a1 ...)` with the args evaluated LEFT-TO-RIGHT. Chez's -# procedure-argument evaluation order is unspecified (and in practice right-to- -# left), but Clojure/JVM evaluates collection-literal elements left-to-right, so a -# literal like [(read r) (read r)] over side-effecting reads must bind in source -# order. Bind each arg to a fresh temp in a let* (sequential) then construct. Only -# wraps when there are >= 2 args (0/1 have no ordering to preserve), keeping the -# common small-literal output compact (jolt-avt6). -(defn- emit-ordered [ctor arg-strs] - (if (< (length arg-strs) 2) - (string "(" ctor (if (empty? arg-strs) "" (string " " (string/join arg-strs " "))) ")") - (let [tmps (map (fn [_] (fresh-label "_o$")) arg-strs) - binds (string/join (map (fn [t a] (string "(" t " " a ")")) tmps arg-strs) " ")] - (string "(let* (" binds ") (" ctor " " (string/join tmps " ") "))")))) - -# Most jolt names are already valid Scheme identifiers (inc, even?, +, ->str all -# are — Scheme allows ! $ % & * + - . / : < = > ? @ ^ _ ~). The one that isn't is -# `#`, which jolt auto-gensyms use as a suffix (e.g. p1__0000X4# from #(...) -# shorthand) — `#` starts a datum in Scheme, so replace it with `_`. -(defn- munge [name] (string/replace-all "#" "_" name)) - -(var emit nil) # forward declaration (mutual recursion with the helpers below) - -# A Chez string literal (jolt-x0os). Janet's %j renders a non-ASCII char as raw -# UTF-8 bytes (\xC3\xA9) and a control char / DEL as \xHH with NO terminating -# semicolon — both forms Chez's reader rejects ("invalid character \ in string -# hex escape"). Emit a Chez string where every byte outside printable ASCII -# becomes a codepoint hex escape \x; (UTF-8 decoded for multibyte) and the -# named escapes (\n \t \r \" \\) match what both readers accept. For pure -# printable ASCII this is byte-identical to %j. -(defn- utf8-cp [s i] - # decode the UTF-8 sequence starting at byte i -> [codepoint byte-length] - (def b (in s i)) - (cond - (< b 0x80) [b 1] - (= (band b 0xE0) 0xC0) [(bor (blshift (band b 0x1F) 6) - (band (in s (+ i 1)) 0x3F)) 2] - (= (band b 0xF0) 0xE0) [(bor (blshift (band b 0x0F) 12) - (blshift (band (in s (+ i 1)) 0x3F) 6) - (band (in s (+ i 2)) 0x3F)) 3] - (= (band b 0xF8) 0xF0) [(bor (blshift (band b 0x07) 18) - (blshift (band (in s (+ i 1)) 0x3F) 12) - (blshift (band (in s (+ i 2)) 0x3F) 6) - (band (in s (+ i 3)) 0x3F)) 4] - [b 1])) # malformed lead byte: pass through one byte -(defn- chez-str-lit [s] - (def out @"\"") - (def n (length s)) - (var i 0) - (while (< i n) - (def b (in s i)) - (cond - (= b 0x22) (do (buffer/push-string out "\\\"") (++ i)) - (= b 0x5C) (do (buffer/push-string out "\\\\") (++ i)) - (= b 0x0A) (do (buffer/push-string out "\\n") (++ i)) - (= b 0x09) (do (buffer/push-string out "\\t") (++ i)) - (= b 0x0D) (do (buffer/push-string out "\\r") (++ i)) - (and (>= b 0x20) (< b 0x7F)) (do (buffer/push-byte out b) (++ i)) - (< b 0x80) (do (buffer/push-string out (string/format "\\x%x;" b)) (++ i)) - (let [[cp len] (utf8-cp s i)] - (buffer/push-string out (string/format "\\x%x;" cp)) - (+= i len)))) - (buffer/push-string out "\"") - (string out)) - -(defn- emit-const [v] - (cond - (nil? v) "jolt-nil" - (boolean? v) (if v "#t" "#f") - # jolt models every number as a double (no ratios/bignums; see reader.janet). - # Emit flonums so arithmetic matches the Janet host and Chez doesn't fall into - # exploding exact rationals (mandelbrot). Integer-valued -> append ".0". - # ##Inf/##-Inf/##NaN: Janet stringifies these as inf/-inf/nan, which are - # unbound symbols in Chez — emit Chez's flonum literals instead. - (number? v) (cond - (= v math/inf) "+inf.0" - (= v (- math/inf)) "-inf.0" - (not= v v) "+nan.0" - (let [s (string v)] - (if (or (string/find "." s) (string/find "e" s)) s (string s ".0")))) - (string? v) (chez-str-lit v) # quoted+escaped string literal - # keyword literal -> (keyword ns name); ns is everything before the first "/" - (keyword? v) (let [s (string v) idx (string/find "/" s)] - (if (and idx (> idx 0)) - (string "(keyword " (chez-str-lit (string/slice s 0 idx)) " " - (chez-str-lit (string/slice s (inc idx))) ")") - (string "(keyword #f " (chez-str-lit s) ")"))) - # jolt char value {:ch :jolt/type :jolt/char} - (and (struct? v) (= :jolt/char (get v :jolt/type))) - (string "(integer->char " (get v :ch) ")") - (errorf "emit-const: unsupported literal %p" v))) - -# Quoted literals (jolt-u8j7). A :quote node's :form is the RAW reader form (a -# Janet value): scalars are Janet natives, a symbol is {:jolt/type :symbol …}, a -# list is an array, a vector a tuple, a map a struct/phm, a set a tagged struct. -# Reconstruct each as the matching Chez RT constructor — the runtime value of a -# quote is just that literal data (the interpreter returns the reader form -# verbatim; the Janet backend Janet-quotes it; here we rebuild it on the RT). -(var emit-quoted nil) -(defn- emit-quoted-map [m] - (def flat @[]) - (eachp [k v] m (array/push flat (emit-quoted k)) (array/push flat (emit-quoted v))) - (string "(jolt-hash-map " (string/join flat " ") ")")) -(set emit-quoted (fn emit-quoted [form] - (cond - # scalars emit-const already lowers (nil/bool/number/string/keyword/char) - (or (nil? form) (boolean? form) (number? form) (string? form) (keyword? form)) - (emit-const form) - (and (struct? form) (= :symbol (get form :jolt/type))) - (let [ns (get form :ns) - m (get form :meta)] - (if (and m (not (nil? m)) (> (length m) 0)) - # carry reader metadata (^:foo bar) onto the quoted symbol so (meta 'x) sees it - (string "(jolt-symbol/meta " (if ns (chez-str-lit ns) "#f") " " - (chez-str-lit (get form :name)) " " (emit-quoted m) ")") - (string "(jolt-symbol " (if ns (chez-str-lit ns) "#f") " " - (chez-str-lit (get form :name)) ")"))) - (and (struct? form) (= :jolt/char (get form :jolt/type))) (emit-const form) - (and (struct? form) (= :jolt/set (get form :jolt/type))) - (string "(jolt-hash-set " (string/join (map emit-quoted (get form :value)) " ") ")") - (array? form) (string "(jolt-list " (string/join (map emit-quoted form) " ") ")") - (tuple? form) (string "(jolt-vector " (string/join (map emit-quoted form) " ") ")") - (phm/phm? form) (emit-quoted-map (phm/phm-to-struct form)) - (or (struct? form) (table? form)) (emit-quoted-map form) - (errorf "emit-quoted: unsupported quoted form %p" form)))) - -# A def's :meta is a jolt map value (Janet struct/table or phm). Non-empty? -# (a plain def carries {} — keep it on the lean def-var! path). -(defn- jmeta-nonempty? [m] - (cond - (nil? m) false - (phm/phm? m) (> (length (phm/phm-to-struct m)) 0) - (or (struct? m) (table? m)) (> (length m) 0) - false)) - -(defn- emit-binding [b] - (def b (vv b)) - (string "(" (munge (get b 0)) " " (emit (get b 1)) ")")) - -# letfn lowers to a :let flagged :letrec (mutually-recursive named local fns): -# Scheme `letrec*` binds them so each sees its siblings (and itself), which a -# sequential let* can't. A plain let uses let* (Clojure let binds sequentially). -(defn- emit-let [node] - (def kw (if (get node :letrec) "letrec*" "let*")) - (string "(" kw " (" (string/join (map emit-binding (vv (get node :bindings))) " ") ") " - (emit (get node :body)) ")")) - -(defn- emit-loop [node] - (def label (fresh-label "loop")) - (def pairs (map vv (vv (get node :bindings)))) - (def names (map |(munge (get $ 0)) pairs)) - # inits are evaluated in the OUTER scope (recur-target unchanged) and, like - # Clojure loop/let, SEQUENTIALLY — a later init sees earlier bindings. Scheme's - # named `let` binds in parallel, so wrap a sequential let* around the loop. - (def inits (map |(emit (get $ 1)) pairs)) - (def seq-bs (string/join (map (fn [n i] (string "(" n " " i ")")) names inits) " ")) - (def rebinds (string/join (map (fn [n] (string "(" n " " n ")")) names) " ")) - (def prev recur-target) - (set recur-target label) - (def body (emit (get node :body))) - (set recur-target prev) - (string "(let* (" seq-bs ") (let " label " (" rebinds ") " body "))")) - -(defn- emit-recur [node] - (unless recur-target (error "emit: recur outside a loop/fn target")) - (string "(" recur-target " " (string/join (map emit (vv (get node :args))) " ") ")")) - -# One arity -> a Scheme lambda param-list + a named-let-wrapped body. The named -# let lets fn-level `recur` rebind this arity's params. A variadic arity takes a -# Scheme rest arg (proper list) and the let binding coerces it to a jolt seq -# (nil when empty — Clojure's rest semantics; list->cseq already does this); recur -# carries the rest seq directly, and the named let's init only runs on first -# entry, so the coercion isn't re-applied on a recur. -# try/catch/finally (jolt-vcsl). throw raises the jolt value RAW (jolt-throw = -# Scheme `raise`), mirroring the Janet COMPILED backend (which does `(error v)`, -# no :jolt/exception envelope) — so catch binds the value directly, no unwrap. -# catch lowers to `guard` with an `else` clause (catch-all: the IR drops the -# class), finally to `dynamic-wind`'s after-thunk (runs on success, catch, and -# escape — Clojure finally semantics). Both keys are optional on the node. -(defn- emit-try [node] - (def core - (if-let [cs (get node :catch-sym)] - (string "(guard (" (munge cs) " (else " (emit (get node :catch-body)) ")) " - (emit (get node :body)) ")") - (emit (get node :body)))) - (if-let [fin (get node :finally)] - (string "(dynamic-wind (lambda () #f) (lambda () " core ") (lambda () " (emit fin) "))") - core)) - -(defn- emit-arity-clause [a] - (def params (map munge (vv (get a :params)))) - (def restp (when-let [r (get a :rest)] (munge r))) - (def label (fresh-label "fnrec")) - (def prev recur-target) - (set recur-target label) - (def body (emit (get a :body))) - (set recur-target prev) - (def paramlist - (cond - # only a rest param: Scheme formals are the bare symbol, not `( . xs)` - (and restp (empty? params)) restp - restp (string "(" (string/join params " ") " . " restp ")") - (string "(" (string/join params " ") ")"))) - (def binds - (if restp - [;(map (fn [p] (string "(" p " " p ")")) params) - (string "(" restp " (list->cseq " restp "))")] - (map (fn [p] (string "(" p " " p ")")) params))) - [paramlist (string "(let " label " (" (string/join binds " ") ") " body ")")]) - -(defn- emit-fn [node] - (def arities (map nn (vv (get node :arities)))) - # a named fn binds its own name as a known-procedure local across ALL arities, - # so self-calls (to any arity) emit directly rather than via jolt-invoke; the - # case-lambda value dispatches on argument count. - (def self (when-let [nm (get node :name)] (munge nm))) - (def had-self (and self (get known-procs self))) - (when self (put known-procs self true)) - # Restore known-procs even when a body is uncompilable: a throw mid-emit must - # not leak this fn's name into the module global, or a LATER case binding the - # same name to a keyword/coll would emit a direct call to a non-procedure - # (runtime crash). The corpus probe shares one emit state across all cases, so - # this leak is order-dependent and otherwise invisible in single-case tests. - (def clauses - (try (map emit-arity-clause arities) - ([err fib] - (unless had-self (when self (put known-procs self nil))) - (propagate err fib)))) - (unless had-self (when self (put known-procs self nil))) - (def lambda - (if (= 1 (length clauses)) - (let [[pl body] (first clauses)] (string "(lambda " pl " " body ")")) - (string "(case-lambda " - (string/join (map (fn [c] (string "(" (get c 0) " " (get c 1) ")")) clauses) " ") - ")"))) - # A named fn (defn / (fn self [..])) references itself by name — the analyzer - # binds that name as a :local in the body. letrec makes the name visible to the - # lambda so self-calls resolve (recur stays a separate self-call to the arity). - (if-let [nm (get node :name)] - (let [m (munge nm)] (string "(letrec ((" m " " lambda ")) " m ")")) - lambda)) - -# The Clojure stdlib (clojure.core, clojure.math, clojure.string, …) and host -# interop (Math/sqrt etc.) have no implementation on Chez yet (Phase 2+). A -# reference to one — except a clojure.core call lowered to a native op — is -# genuinely uncompilable here. Reject it at emit time (a clean "out of subset" -# signal) rather than emitting a var-deref that resolves to nil and fails -# confusingly at runtime. -(defn- stdlib-var? [n] - (and (= :var (get n :op)) (string/has-prefix? "clojure." (or (get n :ns) "")))) - -# Host interop methods with a Chez RT shim (rt.ss jolt-host-call). A `.method` -# call on any other method is out of subset until shimmed — keep this in sync. -# `.write` is NOT here: StringWriter (a jhost, host-static.ss) handles .write via -# record-method-dispatch; the old jolt-host-call "write" fast-path (display to a -# port) would mis-route a writer to `(display x jhost)`. Keep the File-op methods. -(def- supported-host-methods {"isDirectory" true "listFiles" true}) - -# jolt's comparison ops are vacuously true at arity 1 and DON'T inspect the arg -# (so (< :kw) is true), but Scheme's < demands a number even there — special-case. -(def- cmp1-ops {"<" true ">" true "<=" true ">=" true}) - -# IFn dispatch for a LITERAL callee (Clojure's "value as fn"): a keyword looks -# itself up in its arg ((:k m) = (get m :k)); a map/set/vector literal looks up -# its arg ((m :k) = (get m :k)). This static lowering avoids the jolt-invoke -# dispatch overhead; the dynamic case (a local holding a keyword/coll/fn) routes -# through jolt-invoke in the emit-invoke fallback below. -(defn- ifn-kind [fnode] - (case (get fnode :op) - :const (when (keyword? (get fnode :val)) :keyword) - :map :coll :set :coll :vector :coll - nil)) - -(defn- emit-invoke [node] - (def fnode (nn (get node :fn))) - (def args (map emit (vv (get node :args)))) - (def nop (native-op fnode (length args))) - (def kind (ifn-kind fnode)) - (def default (if (> (length args) 1) (string " " (in args 1)) "")) - (cond - # zero-arg + / * : Scheme's identity is the EXACT 0 / 1, but jolt models every - # number as a double, so emit the flonum identity to keep (= 0 (+)) true. - (and nop (empty? args) (= nop "+")) "0.0" - (and nop (empty? args) (= nop "*")) "1.0" - (and nop (= 1 (length args)) (get cmp1-ops nop)) (string "(begin " (first args) " #t)") - nop (string "(" nop " " (string/join args " ") ")") - # (:k coll [default]) -> (jolt-get coll :k [default]) - (= kind :keyword) (string "(jolt-get " (first args) " " (emit fnode) default ")") - # (coll k [default]) -> (jolt-get coll k [default]) - (= kind :coll) (string "(jolt-get " (emit fnode) " " (first args) default ")") - (and (stdlib-var? fnode) (not prelude-mode?)) - (errorf "emit: unsupported stdlib fn `%s/%s` (no core on Chez yet)" (get fnode :ns) (get fnode :name)) - # static method call (Class/method arg*) -> (host-static-call "Class" - # "method" arg*). host-static.ss resolves the method from the class-statics - # registry and applies it (jolt-avt6). - (= :host-static (get fnode :op)) - (string "(host-static-call " (chez-str-lit (get fnode :class)) " " - (chez-str-lit (get fnode :member)) - (if (empty? args) "" (string " " (string/join args " "))) ")") - (= :host (get fnode :op)) - (errorf "emit: unsupported host call `%s` (no host interop on Chez yet)" (get fnode :name)) - # a :local callee that isn't a known procedure (a let/param binding holding a - # keyword/coll/fn) -> dynamic IFn dispatch. Excludes the named-fn self-call. - (and (= :local (get fnode :op)) (not (get known-procs (munge (get fnode :name))))) - (string "(jolt-invoke " (emit fnode) " " (string/join args " ") ")") - # a late-bound :var call head can hold a plain procedure OR a non-applicable - # value the RT dispatches (a multimethod record, a keyword/coll IFn) — route it - # through jolt-invoke so all of those work. Transparent for a procedure - # (jolt-invoke just applies it); the hot self-recursive call is a :local - # known-proc above, so it stays a direct call. - (= :var (get fnode :op)) - (string "(jolt-invoke " (emit fnode) " " (string/join args " ") ")") - # a computed callee (an :invoke / :if / :do expression) can yield ANY IFn — - # a procedure, but also a coll/keyword/multimethod (e.g. ((sorted-map …) k)). - # Route through jolt-invoke: transparent for a procedure, correct for the rest. - (string "(jolt-invoke " (emit fnode) " " (string/join args " ") ")"))) - -# Native-op Scheme procedures that return a genuine Scheme boolean (#t/#f), so an -# :if test built from them needs no jolt-truthy? wrapper (jolt-nkcb). Comparisons -# and `not` are #t/#f; the numeric/collection predicates bottom out in fx=?/>/etc. -(def- bool-returning-ops - {"<" true "<=" true ">" true ">=" true "jolt=" true "jolt-not" true - "jolt-even?" true "jolt-odd?" true "jolt-pos?" true "jolt-neg?" true - "jolt-zero?" true "jolt-empty?" true "jolt-contains?" true}) - -# Does this IR node emit to an expression that yields a Scheme boolean? Used to -# drop the redundant jolt-truthy? on an :if test — sound because jolt-truthy? of -# #t/#f is the identity. Conservative: only a boolean const or an :invoke that -# lowers to a bool-returning native op (any other shape keeps the wrapper). -(defn- returns-scheme-bool? [node] - (def node (nn node)) - (cond - (and (= :const (get node :op)) (boolean? (get node :val))) true - (= :invoke (get node :op)) - (let [nop (native-op (nn (get node :fn)) (length (vv (get node :args))))] - (truthy? (and nop (get bool-returning-ops nop)))) - false)) - -(set emit (fn emit [node] - (def node (nn node)) - (case (get node :op) - :const (emit-const (get node :val)) - :local (munge (get node :name)) - # late-bound var: read the cell's current root at use time. A value-position - # ref to a clojure.core fn the RT provides (e.g. passing `inc`/`even?`/`:k` to - # (map inc xs)) lowers to the RT procedure — native-ops names a real Scheme - # procedure for each. Any OTHER stdlib var (clojure.string, an unimplemented - # core fn) has no impl on Chez yet, so it's out of subset. - :var (let [core-proc (and (= "clojure.core" (get node :ns)) (get core-value-procs (get node :name)))] - (cond - core-proc core-proc - (and (stdlib-var? node) (not prelude-mode?)) - (errorf "emit: unsupported stdlib ref `%s/%s` (no core on Chez yet)" (get node :ns) (get node :name)) - (string "(var-deref " (chez-str-lit (get node :ns)) " " - (chez-str-lit (get node :name)) ")"))) - :host (errorf "emit: unsupported host ref `%s` (no host interop on Chez yet)" (get node :name)) - # value-position static ref (Class/member, e.g. Long/MAX_VALUE, System/exit - # passed as a value) -> the registered static value/procedure (host-static.ss). - :host-static (string "(host-static-ref " (chez-str-lit (get node :class)) " " - (chez-str-lit (get node :member)) ")") - # constructor (Class. args*) / (new Class args*) -> (host-new "Class" args*). - :host-new (string "(host-new " (chez-str-lit (get node :class)) - (let [args (map emit (vv (get node :args)))] - (if (empty? args) "" (string " " (string/join args " ")))) ")") - # (var x) / #'x -> the var cell itself (the rt.ss var-cell, a first-class var - # object). var?/var-get/deref/invoke/= operate on it (vars.ss). - :the-var (string "(jolt-var " (chez-str-lit (get node :ns)) " " (chez-str-lit (get node :name)) ")") - :if (let [test (get node :test) - t (if (returns-scheme-bool? test) (emit test) - (string "(jolt-truthy? " (emit test) ")"))] - (string "(if " t " " (emit (get node :then)) " " (emit (get node :else)) ")")) - :do (string "(begin " - (string/join (map emit (vv (get node :statements))) " ") - (if (empty? (vv (get node :statements))) "" " ") - (emit (get node :ret)) ")") - :invoke (emit-invoke node) - # collection literals -> rt constructors (collections.ss). Elements evaluate - # LEFT-TO-RIGHT (emit-ordered) to match Clojure for side-effecting elements. - :vector (emit-ordered "jolt-vector" (map emit (vv (get node :items)))) - :set (emit-ordered "jolt-hash-set" (map emit (vv (get node :items)))) - :map (let [flat @[]] - (each p (vv (get node :pairs)) - (def p (vv p)) - (array/push flat (emit (get p 0))) - (array/push flat (emit (get p 1)))) - (emit-ordered "jolt-hash-map" flat)) - :let (emit-let node) - :loop (emit-loop node) - :recur (emit-recur node) - :throw (string "(jolt-throw " (emit (get node :expr)) ")") - :try (emit-try node) - :quote (emit-quoted (get node :form)) - # regex literal #"…" -> a jolt-regex value (regex.ss compiles the source via - # the vendored irregex). chez-str-lit quotes+escapes the source; a backslash - # in the pattern becomes \\ in the Scheme string literal -> the 1-char - # backslash irregex expects (same escaping emit-const uses for strings). - :regex (string "(jolt-regex " (chez-str-lit (get node :source)) ")") - # #inst / #uuid literals -> a runtime inst / uuid value (inst-time.ss / - # natives-misc.ss). The source string round-trips through chez-str-lit. - :inst (string "(jolt-inst-from-string " (chez-str-lit (get node :source)) ")") - :uuid (string "(jolt-uuid-from-string " (chez-str-lit (get node :source)) ")") - # host interop (jolt-0kf5): (.method target arg*) -> (jolt-host-call "method" - # target arg*). Only the methods the RT dispatcher (rt.ss) actually shims are - # IN the subset; any other method is out of subset (a clean emit-time reject, - # like an unimplemented stdlib fn), so it doesn't masquerade as a compiled-but- - # broken divergence. The Janet back end punts ALL :host-call to the interpreter. - :host-call (let [m (get node :method) - target (emit (get node :target)) - args (map emit (vv (get node :args)))] - (if (get supported-host-methods m) - (string "(jolt-host-call " (chez-str-lit m) " " - target (if (empty? args) "" (string " " (string/join args " "))) ")") - # a non-shimmed method: dispatch at runtime by the target's type - # — a record/reify protocol method (jolt-jgoc). On a non-record - # host value this errors (was an emit-fail before, so no new - # divergence), but it lets (.protoMethod record …) compile. - (string "(record-method-dispatch " target " " (chez-str-lit m) - " (jolt-vector" (if (empty? args) "" (string " " (string/join args " "))) "))"))) - :fn (emit-fn node) - # (def name) with no init (declare): reserve the var cell (declare-var! - # doesn't clobber an existing root) so a forward reference resolves. - # A def with non-empty reader metadata (^:private / ^Type tag / docstring -> - # {:doc}) lowers to def-var-with-meta! so (meta (var x)) sees it (jolt-zikh). - :def (cond - (get node :no-init) - (string "(declare-var! " (chez-str-lit (get node :ns)) " " - (chez-str-lit (get node :name)) ")") - (jmeta-nonempty? (get node :meta)) - (string "(def-var-with-meta! " (chez-str-lit (get node :ns)) " " - (chez-str-lit (get node :name)) " " (emit (get node :init)) " " - (emit-quoted (get node :meta)) ")") - (string "(def-var! " (chez-str-lit (get node :ns)) " " - (chez-str-lit (get node :name)) " " (emit (get node :init)) ")")) - (errorf "emit: unhandled op %p" (get node :op))))) - -# Wrap emitted top-level forms into a runnable Chez program: load the RT, then -# the def forms, then print `final` (an emitted Scheme expr string) via jolt's -# number/value printing. -(defn program [forms-scheme final] - (string - "(import (chezscheme))\n" - "(load \"host/chez/rt.ss\")\n" - (string/join forms-scheme "\n") "\n" - "(printf \"~a\\n\" (jolt-final-str " final "))\n")) diff --git a/host/chez/jolt-chez.janet b/host/chez/jolt-chez.janet deleted file mode 100644 index 44a12b8..0000000 --- a/host/chez/jolt-chez.janet +++ /dev/null @@ -1,62 +0,0 @@ -# -e-capable jolt-chez (jolt-9ziu): the Option-2 back end as a runnable CLI. -# -# Analysis runs on Janet (the portable analyzer); EXECUTION runs on Chez with the -# full clojure.core assembled as a Scheme prelude (driver/emit-core-prelude). The -# prelude is assembled once and cached on disk keyed by a fingerprint of the core -# sources + the Chez RT/emitter, so repeated invocations (e.g. the run-corpus.janet -# gate, one subprocess per case) reuse it. -# -# Usage (the run-corpus.janet boundary): jolt-chez -e "EXPR" -# Run from the repo root (the prelude loads host/chez/rt.ss by relative path). -(import ../../src/jolt/api :as api) -(import ./driver :as d) - -(defn fingerprint [] - # Hash the inputs that shape the prelude: the core tiers + the emitter + the - # Chez RT shims. Any change invalidates the cached prelude. - (def parts @[]) - (each tf d/core-tier-files - (array/push parts (slurp (string "jolt-core/clojure/core/" tf ".clj")))) - (each f ["jolt-core/jolt/backend_scheme.clj" "src/jolt/host_iface.janet" - "host/chez/emit.janet" "host/chez/driver.janet" "host/chez/rt.ss" - "host/chez/values.ss" "host/chez/collections.ss" "host/chez/seq.ss" - "host/chez/atoms.ss" "host/chez/predicates.ss" "host/chez/regex.ss" - "host/chez/ns.ss" "host/chez/post-prelude.ss" "host/chez/natives-meta.ss" - "host/chez/natives-str.ss" "host/chez/records.ss" - "host/chez/host-class.ss" "host/chez/io.ss" - "host/chez/inst-time.ss" "host/chez/reader.ss" "host/chez/math.ss" - "host/chez/syntax-quote.ss" - "host/chez/host-static.ss" "host/chez/dot-forms.ss" - "src/jolt/clojure/string.clj" "src/jolt/clojure/walk.clj" - "src/jolt/clojure/template.clj" "src/jolt/clojure/edn.clj" - "src/jolt/clojure/set.clj" "src/jolt/clojure/pprint.clj"] - (array/push parts (slurp f))) - (string/slice (string (hash (string/join parts))) 0)) - -(defn ensure-prelude [ctx] - (def dir (or (os/getenv "JOLT_IMAGE_CACHE_DIR") (os/getenv "TMPDIR") "/tmp")) - (def path (string dir "/jolt-chez-prelude-" (fingerprint) ".ss")) - (unless (os/stat path) - (def [scm _ _] (d/emit-core-prelude ctx)) - (spit path scm)) - path) - -(defn main [& argv] - # argv: [script "-e" EXPR] - (def args (drop 1 argv)) - (unless (and (= (length args) 2) (= (first args) "-e")) - (eprint "usage: jolt-chez -e EXPR") - (os/exit 2)) - (def src (in args 1)) - (def ctx (api/init-cached {:compile? true})) - # late-bind unresolved symbols (no interpreter to punt to) so defmulti/defmethod - # forward references lower to a var-deref (jolt-9ls5), matching d/make-ctx. - (put (get ctx :env) :late-bind-unresolved? true) - (def prelude-path (ensure-prelude ctx)) - (def [code out err] (d/eval-e-with-prelude ctx src prelude-path)) - (when (= code :emit-err) - (eprint "jolt-chez: cannot compile: " out) - (os/exit 1)) - (unless (= "" out) (print out)) - (unless (= "" err) (eprint err)) - (os/exit code)) diff --git a/project.janet b/project.janet deleted file mode 100644 index f843185..0000000 --- a/project.janet +++ /dev/null @@ -1,17 +0,0 @@ -(declare-project - :name "jolt" - :description "Clojure interpreter on Janet") - -(declare-source - :source @["src"]) - -(declare-executable - :name "jolt" - :entry "src/jolt/main.janet") - -# Deprecated shim kept for back-compat: deps.edn resolution is built into `jolt` -# now (the CLI front-end resolves into JOLT_PATH in-process; the runtime core -# stays deps-agnostic). Forwards to `jolt`; prefer `jolt -M:…` / `jolt path`. -(declare-executable - :name "jolt-deps" - :entry "src/jolt/deps_cli.janet") diff --git a/run-tests.janet b/run-tests.janet deleted file mode 100644 index 1f460cd..0000000 --- a/run-tests.janet +++ /dev/null @@ -1,100 +0,0 @@ -#!/usr/bin/env janet -# Parallel test runner — the gate, faster. -# -# `jpm test` runs every file under test/ serially; this runs the same set across -# a pool of worker processes (each test file is an independent `janet FILE`). -# Build the executable FIRST (`jpm build`) so the binary-spawning tests don't -# skip: jpm build && janet run-tests.janet -# -# Worker count is the detected CPU count; override with JOLT_TEST_JOBS. Per-file -# stdout+stderr is captured to a temp file and only printed for failures (and, -# with -v / JOLT_TEST_VERBOSE, for everything). Exits non-zero if any file fails -# and prints the literal "All tests passed." on success (CI greps for it). - -(defn- detect-jobs [] - (or (when-let [j (os/getenv "JOLT_TEST_JOBS")] (scan-number j)) - (try - (let [p (os/spawn ["sh" "-c" "nproc 2>/dev/null || sysctl -n hw.ncpu 2>/dev/null"] - :p {:out :pipe}) - out (:read (p :out) :all)] - (os/proc-wait p) - (scan-number (string/trim (or out "")))) - ([_] nil)) - 4)) - -(defn- find-tests [dir acc] - (each name (sorted (os/dir dir)) - (def full (string dir "/" name)) - (case (os/stat full :mode) - # support/ holds shared libraries (harness, shims), not standalone tests — - # jpm doesn't run them and neither do we. - :directory (unless (= name "support") (find-tests full acc)) - :file (when (string/has-suffix? ".janet" name) (array/push acc full)))) - acc) - -(def verbose? (or (has-value? (dyn :args) "-v") (os/getenv "JOLT_TEST_VERBOSE"))) -(def janet-bin (dyn :executable)) -(def tmpdir (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-test-" (os/getpid))) -(os/mkdir tmpdir) - -(def files (find-tests "test" @[])) -(def total (length files)) -(def jobs (max 1 (min 16 (detect-jobs)))) - -(def results @[]) -(var done 0) - -(defn- run-one [file] - (def t0 (os/clock)) - (def of (string tmpdir "/" (string/replace-all "/" "_" file) ".out")) - # let the shell own redirection — avoids pipe-buffer deadlock on chatty tests. - (def cmd (string/format "exec '%s' '%s' > '%s' 2>&1" janet-bin file of)) - (def rc (os/proc-wait (os/spawn ["sh" "-c" cmd] :p))) - (def dt (- (os/clock) t0)) - (array/push results {:file file :rc rc :out of :dt dt}) - (++ done) - (printf "[%d/%d] %s %6.2fs %s%s" done total (if (zero? rc) "ok " "FAIL") - dt file (if (zero? rc) "" (string/format " (rc=%d)" rc))) - (flush)) - -# A :stop sentinel per worker signals end-of-queue — ev/chan-close discards -# buffered items (Janet 1.41), so we can't just close and drain. -(def q (ev/chan (+ total jobs))) -(each f files (ev/give q f)) -(loop [_ :range [0 jobs]] (ev/give q :stop)) - -(defn- worker [&] - (forever - (def f (ev/take q)) - (if (= f :stop) (break) (run-one f)))) - -(printf "running %d test files across %d workers...\n" total jobs) -(flush) -(def wall0 (os/clock)) -(def super (ev/chan)) -(loop [_ :range [0 jobs]] (ev/go worker nil super)) -(loop [_ :range [0 jobs]] (ev/take super)) -(def wall (- (os/clock) wall0)) - -(def failed (filter |(not (zero? ($ :rc))) results)) -(def slow (->> results (sorted-by |(- ($ :dt))) (take 5))) - -(print "\n--- slowest ---") -(each r slow (printf " %6.2fs %s" (r :dt) (r :file))) - -(when verbose? - (each r results - (printf "\n===== %s (rc=%d, %.2fs) =====" (r :file) (r :rc) (r :dt)) - (print (slurp (r :out))))) - -(unless (empty? failed) - (print "\n--- FAILURES ---") - (each r failed - (printf "\n===== %s (rc=%d) =====" (r :file) (r :rc)) - (print (slurp (r :out))))) - -(printf "\n%d files, %d failed, %.1fs wall (%d workers)" - total (length failed) wall jobs) -(if (empty? failed) - (do (print "\nAll tests passed.") (os/exit 0)) - (do (printf "\n%d test files FAILED." (length failed)) (os/exit 1))) diff --git a/spike/native/aot-demo.janet b/spike/native/aot-demo.janet deleted file mode 100644 index 231c449..0000000 --- a/spike/native/aot-demo.janet +++ /dev/null @@ -1,47 +0,0 @@ -# AOT build/deploy demo (jolt-a7ds). Two phases, run as separate processes: -# janet spike/native/aot-demo.janet build # needs cc; compiles + writes manifest -# janet spike/native/aot-demo.janet deploy # run with cc REMOVED from PATH -# Proves the deploy target needs no C toolchain: it only loads the prebuilt .so. -(import ../../src/jolt/api :as api) -(import ../../src/jolt/cgen :as cgen) - -(def cp "(defn count-point [cr ci cap] (loop [i 0 zr 0.0 zi 0.0] (if (or (>= i cap) (> (+ (* zr zr) (* zi zi)) 4.0)) i (recur (inc i) (+ (- (* zr zr) (* zi zi)) cr) (+ (* 2.0 (* zr zi)) ci)))))") -(def run "(defn run [n] (let [cap 200 nd (* 1.0 n)] (loop [y 0 acc 0] (if (< y n) (let [ci (- (/ (* 2.0 y) nd) 1.0) row (loop [x 0 a 0] (if (< x n) (let [cr (- (/ (* 2.0 x) nd) 1.5)] (recur (inc x) (+ a (count-point cr ci cap)))) a))] (recur (inc y) (+ acc row))) acc))))") -(def manifest (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-aot-demo.jdn")) -(def dir "spike/native/build/aot") - -(defn setup [ctx] - (put (ctx :env) :direct-linking? true) - (api/eval-string ctx "(ns demo)")) - -(def phase (get (dyn :args) 1)) -(cond - (= phase "build") - (do - (def ctx (api/init-cached {:compile? true})) - (put (ctx :env) :cgen-collect? true) - (setup ctx) - (api/eval-string ctx cp) - (api/eval-string ctx run) - (def build (cgen/aot-build (get (ctx :env) :cgen-collected) {:dir dir})) - (cgen/write-manifest manifest build) - (printf "BUILD: cc-available? %p -> %s (%d fn)" (cgen/toolchain-available?) - (build :sopath) (length (build :entries)))) - - (= phase "deploy") - (do - (printf "DEPLOY: cc-available? %p (should be false with cc off PATH)" - (cgen/toolchain-available?)) - (def ctx (api/init-cached {:compile? true})) - (setup ctx) - (put (ctx :env) :cgen-prebuilt (cgen/load-aot manifest)) - (api/eval-string ctx cp) - (api/eval-string ctx run) - (def native? (cfunction? (api/eval-string ctx "count-point"))) - (def t0 (os/clock)) - (def total (api/eval-string ctx "(run 200)")) - (def ms (* 1000 (- (os/clock) t0))) - (printf "DEPLOY: count-point native? %p total %d (%s) %.1f ms" - native? total (if (= total 3288753) "OK" "MISMATCH") ms)) - - (eprint "usage: aot-demo.janet build|deploy")) diff --git a/spike/native/bench-native.janet b/spike/native/bench-native.janet deleted file mode 100644 index 316cbe9..0000000 --- a/spike/native/bench-native.janet +++ /dev/null @@ -1,53 +0,0 @@ -# Benchmark the native-C mandelbrot vs the spike's other legs (jolt-5vsp lever 1). -# janet spike/native/bench-native.janet 200 -(import ./build/mandel :as mandel) - -(defn bench [label f n] - (repeat 2 (f (div n 2))) - (def times @[]) - (var last-r 0) - (repeat 3 - (def t0 (os/clock)) - (set last-r (f n)) - (array/push times (* 1000.0 (- (os/clock) t0)))) - (printf "%-28s n %d result %d mean %.2f ms" - label n last-r (/ (sum times) 3))) - -# Leg A: whole run in native C (pure native-codegen ceiling). -(defn run-pure-c [n] (mandel/run-c n)) - -# Leg B: Janet `while` loop, but count-point is a native C cfunction called n^2 -# times — measures the Janet->C boundary-crossing cost (the incremental hybrid). -(defn run-boundary [n] - (def cap 200) - (def nd (* 1.0 n)) - (var acc 0) - (var y 0) - (while (< y n) - (def ci (- (/ (* 2.0 y) nd) 1.0)) - (var x 0) - (var a 0) - (while (< x n) - (def cr (- (/ (* 2.0 x) nd) 1.5)) - (set a (+ a (mandel/count-point-c cr ci cap))) - (++ x)) - (set acc (+ acc a)) - (++ y)) - acc) - -# Leg C: C run loop calling a Janet bytecode count-point back via janet_call n^2 -# times — the reverse crossing (hot C fn -> cold bytecode helper). -(defn count-point-janet [cr ci cap] - (var i 0) (var zr 0.0) (var zi 0.0) - (while (and (< i cap) (<= (+ (* zr zr) (* zi zi)) 4.0)) - (def nzr (+ (- (* zr zr) (* zi zi)) cr)) - (def nzi (+ (* 2.0 (* zr zi)) ci)) - (set zr nzr) (set zi nzi) (++ i)) - i) -(defn run-callback [n] (mandel/run-callback n count-point-janet)) - -(defn main [& args] - (def n (if (> (length args) 1) (scan-number (get args 1)) 200)) - (bench "native-C whole run" run-pure-c n) - (bench "Janet loop -> C count-point" run-boundary n) - (bench "C loop -> janet_call back" run-callback n)) diff --git a/spike/native/dump-ir.janet b/spike/native/dump-ir.janet deleted file mode 100644 index d6a751c..0000000 --- a/spike/native/dump-ir.janet +++ /dev/null @@ -1,15 +0,0 @@ -# Dump the analyzed IR (not emitted Janet) for count-point, so the C emitter can -# be written against the real node shapes. jolt-ihdp. -(import ../../src/jolt/api :as api) -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/reader :as reader) - -(def ctx (api/init-cached {:compile? true})) -(put (ctx :env) :direct-linking? true) -(put (ctx :env) :inline? true) -(api/eval-string ctx "(ns mandelbrot)") - -(def src "(defn count-point [cr ci cap] (loop [i 0 zr 0.0 zi 0.0] (if (or (>= i cap) (> (+ (* zr zr) (* zi zi)) 4.0)) i (recur (inc i) (+ (- (* zr zr) (* zi zi)) cr) (+ (* 2.0 (* zr zi)) ci)))))") - -(def ir (backend/analyze-form ctx (reader/parse-string src))) -(printf "%P" ir) diff --git a/spike/native/mandel.c b/spike/native/mandel.c deleted file mode 100644 index f555177..0000000 --- a/spike/native/mandel.c +++ /dev/null @@ -1,91 +0,0 @@ -/* Native-C mandelbrot, exposed as a Janet module — the lever-1 ceiling probe for - * the foundational-runtime epic (jolt-5vsp). Measures: - * (1) mandel/run-c — whole run in C (count_point inlined in C). The pure - * native-codegen ceiling: no Janet in the hot loop. - * (2) mandel/count-point-c — just count_point exposed as a Janet cfunction, so a - * Janet `while` loop can call it n^2 times. Measures the - * Janet->C boundary-crossing cost — the incremental - * hybrid (hot fn in C, caller still bytecode) pays this. - * Build: jpm --local build (project.janet declares the native module). */ -#include - -/* Pure C. cr/ci/cap are doubles; cap compared as int iteration count. */ -static long count_point(double cr, double ci, long cap) { - long i = 0; - double zr = 0.0, zi = 0.0; - while (i < cap && (zr*zr + zi*zi) <= 4.0) { - double nzr = zr*zr - zi*zi + cr; - double nzi = 2.0*zr*zi + ci; - zr = nzr; zi = nzi; - i++; - } - return i; -} - -static long run_c(long n) { - long cap = 200; - double nd = (double)n; - long acc = 0; - for (long y = 0; y < n; y++) { - double ci = (2.0*y)/nd - 1.0; - long a = 0; - for (long x = 0; x < n; x++) { - double cr = (2.0*x)/nd - 1.5; - a += count_point(cr, ci, cap); - } - acc += a; - } - return acc; -} - -static Janet cfun_run_c(int32_t argc, Janet *argv) { - janet_fixarity(argc, 1); - long n = (long)janet_getinteger(argv, 0); - return janet_wrap_number((double)run_c(n)); -} - -/* count_point exposed for the Janet-loop-calls-C boundary test. */ -static Janet cfun_count_point_c(int32_t argc, Janet *argv) { - janet_fixarity(argc, 3); - double cr = janet_getnumber(argv, 0); - double ci = janet_getnumber(argv, 1); - long cap = (long)janet_getinteger(argv, 2); - return janet_wrap_number((double)count_point(cr, ci, cap)); -} - -/* run loop in C, but count_point is a Janet function called back via janet_call - * n^2 times — the reverse crossing: a C-compiled hot fn invoking a cold bytecode - * helper. Measures janet_call overhead (the cost the hybrid pays when native code - * calls back into the bytecode world). */ -static Janet cfun_run_callback(int32_t argc, Janet *argv) { - janet_fixarity(argc, 2); - long n = (long)janet_getinteger(argv, 0); - JanetFunction *cp = janet_getfunction(argv, 1); - long cap = 200; - double nd = (double)n; - long acc = 0; - for (long y = 0; y < n; y++) { - double ci = (2.0*y)/nd - 1.0; - long a = 0; - for (long x = 0; x < n; x++) { - double cr = (2.0*x)/nd - 1.5; - Janet args[3] = { janet_wrap_number(cr), janet_wrap_number(ci), - janet_wrap_number((double)cap) }; - Janet r = janet_call(cp, 3, args); - a += (long)janet_unwrap_number(r); - } - acc += a; - } - return janet_wrap_number((double)acc); -} - -static const JanetReg cfuns[] = { - {"run-c", cfun_run_c, "(mandel/run-c n) whole mandelbrot run in native C."}, - {"count-point-c", cfun_count_point_c, "(mandel/count-point-c cr ci cap) one point, native C."}, - {"run-callback", cfun_run_callback, "(mandel/run-callback n count-point-fn) C loop calling a Janet fn back via janet_call."}, - {NULL, NULL, NULL} -}; - -JANET_MODULE_ENTRY(JanetTable *env) { - janet_cfuns(env, "mandel", cfuns); -} diff --git a/spike/native/project.janet b/spike/native/project.janet deleted file mode 100644 index 327f1b6..0000000 --- a/spike/native/project.janet +++ /dev/null @@ -1,6 +0,0 @@ -(declare-project - :name "mandel-native-spike") - -(declare-native - :name "mandel" - :source ["mandel.c"]) diff --git a/src/jolt/aot.janet b/src/jolt/aot.janet deleted file mode 100644 index 0527534..0000000 --- a/src/jolt/aot.janet +++ /dev/null @@ -1,47 +0,0 @@ -# Ahead-of-time images for compiled namespaces. -# -# Compile-by-default turns each form into Janet bytecode at load time. AOT skips -# that work on subsequent runs by serializing a namespace's compiled vars to a -# bytecode image and loading them back. -# -# The trick is the marshal dictionary. A compiled jolt function closes over core -# fns (core-map, +, …) and var cells; those core fns are Janet cfunctions/closures -# that can't be marshaled by value. But the runtime env that holds them is baked -# into the binary and is byte-for-byte identical at save and load time, so we -# marshal *against* it: core fns are referenced by name, and only the user's -# bytecode plus its var cells are actually serialized. - -(import ./backend :as backend) # backend/jolt-runtime-env -(use ./types) - -# Forward dict (key -> value) for unmarshal; reverse (value -> key) for marshal. -# Built from the runtime env, which chains to the Janet boot env, so both core fns -# and Janet builtins resolve by name. -(defn- fwd-dict [] (env-lookup backend/jolt-runtime-env)) -(defn- rev-dict [] (invert (env-lookup backend/jolt-runtime-env))) - -(defn marshal-ns - "Marshal namespace `ns-name`'s var mappings to a byte buffer. The whole mappings - table is marshaled in one call so var cells shared between defs stay shared." - [ctx ns-name] - (marshal ((ctx-find-ns ctx ns-name) :mappings) (rev-dict))) - -(defn unmarshal-ns! - "Install mappings produced by marshal-ns into `ns-name` in ctx, overwriting - same-named vars. Returns ns-name." - [ctx ns-name bytes] - (let [mappings (unmarshal bytes (fwd-dict)) - ns (ctx-find-ns ctx ns-name)] - (each [sym v] (pairs mappings) (put (ns :mappings) sym v)) - ns-name)) - -(defn save-ns - "Write an AOT image of compiled namespace `ns-name` to `path`." - [ctx ns-name path] - (spit path (marshal-ns ctx ns-name))) - -(defn load-ns-image - "Read an AOT image written by save-ns back into ctx under `ns-name`. Skips - parse/analyze/emit/compile entirely — the bytecode is already built." - [ctx ns-name path] - (unmarshal-ns! ctx ns-name (slurp path))) diff --git a/src/jolt/api.janet b/src/jolt/api.janet deleted file mode 100644 index d5991f9..0000000 --- a/src/jolt/api.janet +++ /dev/null @@ -1,434 +0,0 @@ -# Jolt Public API -# High-level interface for the Clojure-on-Janet interpreter. - -(use ./types) -(use ./pv) -(use ./plist) -(use ./reader) -(use ./evaluator) -(use ./core) -(use ./loader) -(use ./async) -(import ./backend :as backend) -(import ./stdlib_embed :as stdlib-embed) -(import ./host_iface :as host) -(import ./config :as config) -# Host interop: JVM class/method shims + collection interop (.iterator/.nth/...) -# register into the evaluator at module load. See src/jolt/host_interop.janet. -(import ./host_interop) - -# A defmacro expander compiles to a native fn (built as (fn args body...) and run -# through the self-hosted pipeline) so macro expansion is COMPILED code, zero runtime -# cost — instead of an interpreted closure, mirroring Clojure (macros are ordinary -# compiled fns). Wrapped in the `fn` MACRO (not the `fn*` primitive) so a destructured -# macro arglist — `[a & [b]]`, `[& {:keys [x]}]`, nested — desugars before lowering; -# raw fn* punts on a destructuring rest param. Returns nil when the analyzer isn't -# built yet (the early macros, expanded WHILE the analyzer is being bootstrapped) or -# the body isn't compilable; in that case defmacro keeps an interpreted closure, and -# backend/recompile-macros! replaces it with a compiled expander once the analyzer -# comes alive (staged bootstrap — the interpreter is a build-time crutch, gone by -# steady state). -(set macro-compile-hook - (fn [ctx args-form body] - (backend/try-compile-fn ctx - (array/concat @[{:jolt/type :symbol :ns nil :name "fn"} args-form] body)))) - -(defn normalize-pvecs - "Deep-convert any sequential (pvec/tuple/array) to a Janet tuple. Test helper - so Janet-level `=`/deep= can compare jolt collection results against Janet - tuple literals regardless of representation — mirroring Clojure, where vectors - and lists with the same elements are equal." - [x] - (cond - # lazy-seq: realize to a tuple (map/filter/take now return lazy seqs). - (and (table? x) (= (get x :jolt/type) :jolt/lazy-seq)) - (tuple ;(map normalize-pvecs (realize-for-iteration x))) - (pvec? x) (tuple ;(map normalize-pvecs (pv->array x))) - (plist? x) (tuple ;(map normalize-pvecs (pl->array x))) - (tuple? x) (tuple ;(map normalize-pvecs x)) - (array? x) (tuple ;(map normalize-pvecs x)) - x)) - - -# Ordered clojure.core tiers (embedded jolt-core/clojure/core/NN-*.clj). Each tier -# may reference only the Janet seed + earlier tiers. A :kernel tier holds the -# structural fns the self-hosted compiler itself uses (second/peek/subvec/mapv/ -# update); in compile mode it must be bootstrap-compiled into clojure.core BEFORE -# the analyzer is built (the analyzer depends on it), so it bypasses the -# self-hosted pipeline. Non-kernel tiers route through eval-toplevel like any -# source (compiled when :compile?, interpreted otherwise — the analyzer, built -# lazily on the first such form, sees the kernel tier already in place). -(def- core-tiers - [{:ns "clojure.core.00-syntax" :kernel false} - {:ns "clojure.core.00-kernel" :kernel true} - {:ns "clojure.core.10-seq" :kernel false} - {:ns "clojure.core.20-coll" :kernel false} - {:ns "clojure.core.25-sorted" :kernel false} - {:ns "clojure.core.30-macros" :kernel false} - {:ns "clojure.core.40-lazy" :kernel false} - {:ns "clojure.core.50-io" :kernel false}]) - -(defn- eval-overlay-source [ctx src] - (var s src) - (while (> (length (string/trim s)) 0) - (def [form rest] (parse-next s)) - (set s rest) - (when (not (nil? form)) (eval-toplevel ctx form)))) - -(defn- load-core-overlay! - "Load the Clojure portion of clojure.core in dependency-ordered tiers. See - core-tiers and jolt-core/clojure/core/." - [ctx] - (def env (ctx :env)) - (def compile? (get env :compile?)) - # Core compiles with direct-linking on when :aot-core? (so core->core calls - # are direct). The flag is restored to the user-code default afterward, so - # user/REPL code stays indirect and fully redefinable. - (def user-dl (get env :direct-linking?)) - (def core-dl (get env :aot-core?)) - (def saved (ctx-current-ns ctx)) - (ctx-set-current-ns ctx "clojure.core") - # Gate the analyzer build until the kernel tier loads (see ensure-analyzer): - # present-and-false here means pre-kernel compiles fall back to the interpreter. - (put env :kernel-ready? false) - # Pre/at-kernel defns load interpreted in some mode (00-syntax always; the - # kernel tier too in interpret mode); stash their fn sources so the staged - # recompile pass (backend/recompile-defns!) can compile them once the - # analyzer is alive. Cleared after the kernel tier so later tiers and user - # code don't stash. - (put env :stash-defn-src? true) - (each tier core-tiers - (when-let [src (get stdlib-embed/sources (tier :ns))] - (put env :direct-linking? core-dl) - (if (and compile? (tier :kernel)) - (backend/bootstrap-load-source ctx "clojure.core" src) - (eval-overlay-source ctx src)) - # The self-hosted compiler depends on the kernel tier (second/peek/mapv/...). - # Mark it ready once that tier is in place so the analyzer can be built; a - # pre-kernel tier that triggers a compile (e.g. a defn in 00-syntax) instead - # falls back to the interpreter rather than building the analyzer against a - # half-loaded core (which would forward-ref the missing kernel fns to nil). - (when (tier :kernel) - (put env :kernel-ready? true) - (put env :stash-defn-src? false)))) - (put env :direct-linking? user-dl) - (ctx-set-current-ns ctx saved) - # Stage 3 interpreted bootstrap: the analyzer was loaded INTERPRETED (no - # bootstrap compiler); have it compile itself + the kernel tier before the - # macro pass, so steady-state compilation runs compiled. - (when compile? - (backend/self-compile-compiler! ctx)) - # Staged bootstrap: the early macros (00-syntax) were defined while the analyzer - # was still being built, so their expanders are interpreted closures. Now that the - # full overlay + analyzer are in place, recompile those expanders to native code — - # by steady state no macro expansion runs interpreted (no-op in interpreter mode). - (backend/ensure-macros-compiled! ctx) - # print-method's record hook: only wirable once the overlay multimethod - # exists (50-io tier), so it rides the end of overlay load. - (install-print-method-cb! ctx)) - -# clojure.math (Clojure 1.11) backed directly by Janet's math natives -# (jolt-h79). The vars hold plain Janet functions, so compiled calls -# direct-link — unlike Math/sqrt interop forms, which are in the frozen -# interpret-only punt set (~5us/call vs ~30ns here). Installed as a -# populated namespace, so (require '[clojure.math :as m]) is a no-op pass. -(defn- install-clojure-math! [ctx] - (def ns (ctx-find-ns ctx "clojure.math")) - (def fns - {"sqrt" math/sqrt "cbrt" math/cbrt "pow" math/pow - "exp" math/exp "expm1" math/expm1 - "log" math/log "log10" math/log10 "log1p" math/log1p - "sin" math/sin "cos" math/cos "tan" math/tan - "asin" math/asin "acos" math/acos "atan" math/atan "atan2" math/atan2 - "sinh" math/sinh "cosh" math/cosh "tanh" math/tanh - "floor" math/floor "ceil" math/ceil "rint" math/round - "round" (fn cm-round [x] (math/round x)) - "signum" (fn cm-signum [x] (cond (< x 0) -1.0 (> x 0) 1.0 0.0)) - "to-degrees" (fn cm-to-degrees [r] (/ (* r 180.0) math/pi)) - "to-radians" (fn cm-to-radians [d] (/ (* d math/pi) 180.0)) - "hypot" (fn cm-hypot [a b] (math/sqrt (+ (* a a) (* b b)))) - "floor-div" (fn cm-floor-div [a b] (math/floor (/ a b))) - "floor-mod" (fn cm-floor-mod [a b] (mod a b)) - "E" math/e "PI" math/pi}) - (eachp [nm f] fns (ns-intern ns nm f)) - # mark loaded so maybe-require-ns never goes looking for a source file - (def loaded (or (get (ctx :env) :loaded-namespaces) - (let [t @{}] (put (ctx :env) :loaded-namespaces t) t))) - (put loaded "clojure.math" true)) - -(defn init - "Create a new Jolt evaluation context. - opts may contain: - :namespaces — map of {ns-name → {sym → value, ...}, ...} - :mutable? — use Janet mutable data structures instead of persistent - :compile? — compile Clojure forms via the self-hosted pipeline (analyzer -> - IR -> Janet back end), falling back to the interpreter as needed - :paths — extra source roots to search for namespaces (after the stdlib)" - [&opt opts] - (default opts {}) - (let [ctx (make-ctx opts)] - # The .clj stdlib (clojure.string, jolt.http, …) baked into the image at build - # time, so it loads from any directory; the loader falls back to this when a - # namespace isn't found on disk. (See stdlib-embed.) - (put (ctx :env) :embedded-sources stdlib-embed/sources) - # Extra source roots: opts :paths, then JOLT_PATH (colon-separated). These are - # searched after the stdlib so (require ...) finds deps.edn-resolved libs. - (let [roots (get (ctx :env) :source-paths)] - (each p (get opts :paths []) (array/push roots p)) - (when-let [jp (os/getenv "JOLT_PATH")] - (each p (string/split ":" jp) (when (> (length p) 0) (array/push roots p))))) - # App source roots (jolt-87e): the project's own roots (opts :app-paths, then - # JOLT_APP_PATHS from jolt-deps). The whole-program inference fixpoint is - # scoped to namespaces loaded from these — deps load-infer per-ns instead. - # Empty => no app/dep distinction, so whole-program covers every namespace - # (a bare program run with no deps.edn keeps its old behavior). - (let [aps @[]] - (each p (get opts :app-paths []) (array/push aps p)) - (when-let [jap (os/getenv "JOLT_APP_PATHS")] - (each p (string/split ":" jap) (when (> (length p) 0) (array/push aps p)))) - (put (ctx :env) :app-source-paths aps)) - # Collection representation (persistent vs mutable) is selected at BUILD time - # via JOLT_MUTABLE (see config.janet); init-core! registers vec/vector/conj/ - # etc. that produce the mode-appropriate values, so nothing extra to load. - (init-core! ctx) - # clojure.core.async (channels + go blocks on Janet fibers); pre-populated - # so (require '[clojure.core.async ...]) finds it and applies :as/:refer. - (install-async! ctx) - # Host contract (ns jolt.host): the seam the portable jolt-core compiler calls. - (host/install! ctx) - (install-clojure-math! ctx) - # require/maybe-require-ns route loaded namespaces through the loader's - # compile-or-interpret eval-toplevel (the evaluator can't import the loader - # — that would be circular — so it reads this hook). Without it, required - # namespaces ran interpreted-only. - (put (ctx :env) :toplevel-eval eval-toplevel) - # Inter-procedural type-inference hook (jolt-767): the evaluator calls this - # after a unit finishes loading (optimization mode only). Installed here to - # avoid an evaluator->backend circular import. - (put (ctx :env) :infer-unit! backend/infer-unit!) - (put (ctx :env) :infer-program! backend/infer-program!) # jolt-t34 whole-program - # Stateful primitives as ctx-capturing clojure.core fns (protocol-dispatch, - # register-method, …) — so the protocol macros compile to plain invokes. Must - # precede the overlay (its defprotocol/extend-type expansions call these). - (install-stateful-fns! ctx) - # Clojure portion of clojure.core (jolt-core/clojure/core.clj): fns expressed - # in plain Clojure on top of the Janet primitives interned above. Loaded into - # clojure.core and compiled by the self-hosted pipeline (or interpreted when - # :compile? is off). Phase 4 kernel-shrink seam — see that file. - (load-core-overlay! ctx) - # load-string and eval as VALUES need the loader's compile-or-interpret - # routing, which lives above the evaluator — intern them here. (The eval - # special form still handles direct calls; this covers value position, - # e.g. (map eval forms).) - (let [core (ctx-find-ns ctx "clojure.core")] - (ns-intern core "load-string" - (fn [s] - (var cur s) - (var result nil) - (while (> (length (string/trim cur)) 0) - (def [form rest-src] (parse-next cur)) - (set cur rest-src) - (when (not (nil? form)) (set result (eval-toplevel ctx form)))) - result)) - (ns-intern core "eval" (fn [form] (eval-toplevel ctx form)))) - # Init is done: core + the self-hosted compiler are loaded with :inline? off - # (so they compiled exactly as before). Flip inlining on for subsequent - # user-code compilation iff user direct-linking is on (JOLT_DIRECT_LINK=1) — - # the inline pass only inlines targets that won't be redefined, the same - # safety the direct-linking flag asserts (jolt-87f). - (put (ctx :env) :inline? (if (get (ctx :env) :direct-linking?) true false)) - # jolt-t34. Two shape gates: - # :shapes? — shape-recs are active. Records use declared-shape layout + - # bare-index reads here. ON wherever the inference that proves - # reads runs = direct-linking. JOLT_NO_SHAPE force-disables. - # :map-shapes? — also shape generic const-key MAP literals. Opt-in (JOLT_SHAPE) - # because shaping maps net-loses on unproven reads; records win. - (put (ctx :env) :shapes? - (and (get (ctx :env) :direct-linking?) (not (os/getenv "JOLT_NO_SHAPE")))) - (put (ctx :env) :map-shapes? - (and (os/getenv "JOLT_SHAPE") (not (os/getenv "JOLT_NO_SHAPE")))) - # Whole-program (Stalin) mode (jolt-t34): opt-in, closed-world. Defers the - # per-ns inference and runs one fixpoint over all units at the end (main, or a - # harness calling infer-program!). Needs direct-linking (the closed-world - # assumption); slow/memory-heavy builds are the documented trade-off. - (put (ctx :env) :whole-program? - (and (os/getenv "JOLT_WHOLE_PROGRAM") (get (ctx :env) :direct-linking?))) - ctx)) - -# --- Context snapshot/fork + disk image (AOT context image) ------------------ -# -# init is expensive (~50 ms interpreted, ~900 ms compiled: tier loading, analyzer -# build, macro recompilation). For workloads that need MANY isolated contexts — -# the test harnesses build a fresh ctx per case — snapshot a fully-built ctx once -# and fork cheap deep copies (~2 ms) from it via Janet marshal/unmarshal. A fork -# shares nothing mutable with the original: defs, protocol extensions, hierarchy -# changes, atom states in one fork are invisible to the others. -# -# load-ctx-image/save-ctx-image add the disk layer (fork->validate->rewire load, -# atomic save) shared by init-cached and main's deps-image cache (jolt-q5ql) — -# the callers differ only in the validity predicate. They live here (not a -# separate module) because Janet's `use` doesn't transitively re-export, and the -# snapshot/fork they build on are already api's and consumed via (use ./api). -# -# The reverse-lookup dicts must be built from root-env (cfunctions and abstract -# values from the Janet runtime marshal by reference through them) BEFORE any ctx -# values exist in scope — module load time here, so user code can't leak into it. -(def- image-load-dict (env-lookup root-env)) -(def- image-make-dict (invert image-load-dict)) - -(defn snapshot - "Marshal a fully-built context into a buffer that fork can cheaply clone. - Build the ctx (init), customize it if needed, then snapshot once." - [ctx] - (marshal ctx image-make-dict)) - -(defn fork - "A fresh, fully-isolated deep copy of a snapshotted context (~2 ms, vs - re-running init). (fork (snapshot ctx)) behaves exactly like ctx did at - snapshot time; mutations to a fork never affect the original or other forks." - [snap] - (unmarshal snap image-load-dict)) - -(defn load-ctx-image - "Load a marshaled ctx image from `path`: fork it, verify it really is a ctx (a - corrupt image can unmarshal to a non-ctx value), run the optional `valid?` - predicate (e.g. a source-mtime check), and replay the per-PROCESS module-state - wiring an image restore skips by calling `(rewire! ctx)` (the print-method hook - lives in module state, not the marshaled ctx). Returns the ctx, or nil if the - file is absent, unreadable, not a ctx, or fails `valid?`." - [path rewire! &opt valid?] - (when (os/stat path) - (def r (protect (fork (slurp path)))) - (when (and (r 0) (ctx? (r 1)) (or (nil? valid?) (valid? (r 1)))) - (def c (r 1)) - (when rewire! (rewire! c)) - c))) - -(defn save-ctx-image - "Atomically write ctx's marshaled image to `path` (write a pid-tagged tmp file - then rename) so concurrent cold starts never observe a torn image. Best-effort: - a failed write/rename is swallowed (the next run just rebuilds)." - [ctx path] - (def tmp (string path "." (os/getpid) ".tmp")) - (when (protect (spit tmp (snapshot ctx))) - (protect (os/rename tmp path)))) - -# init in compile mode is ~2.4 s (tier loading, analyzer self-compile, macro -# recompilation) — paid by every PROCESS that builds a ctx from source, e.g. -# each `jpm test` file. init-cached pays it once: the built ctx is snapshotted -# to an image file and later processes unmarshal it (~tens of ms). Marshaling -# is against root-env (same dicts as snapshot/fork), so core cfunctions ride by -# name and everything jolt-level rides by value — a loaded image needs nothing -# from the baking process. The cache key fingerprints everything a fresh build -# would read: the embedded .clj stdlib (which includes jolt-core — the -# analyzer, IR, and core tiers), the .janet seed sources next to this module, -# the janet version, and the init opts. Any change rebuilds; a corrupt or -# unreadable image silently rebuilds. JOLT_NO_IMAGE_CACHE=1 disables. - -# Captured at module load: in source mode this is .../src/jolt/api.janet, so -# the seed sources can be fingerprinted; nil or stale in a built binary, where -# the baked-at-build-time ctx makes init-cached pointless anyway. -(def- api-module-file (dyn :current-file)) - -(defn- src-dir [] - (when api-module-file - (let [idxs (string/find-all "/" api-module-file)] - (when (not (empty? idxs)) - (string/slice api-module-file 0 (last idxs)))))) - -# Every .janet seed file under `dir`, RECURSIVELY (src/jolt/ has subdirs now — -# interop/), keyed by repo-relative path so files in different dirs don't alias. -# Sorted for a stable fingerprint. Non-recursive (os/dir) would silently miss a -# subdir edit and serve a stale image — the map-nil-style footgun, for the cache. -(defn- janet-sources-under [dir] - (def acc @[]) - (defn- walk [d prefix] - (each name (sorted (os/dir d)) - (def full (string d "/" name)) - (def rel (string prefix name)) - (case (os/stat full :mode) - :directory (walk full (string rel "/")) - :file (when (string/has-suffix? ".janet" name) (array/push acc [rel full]))))) - (walk dir "") - acc) - -(defn- source-fingerprint - "Hash + total length of every source a fresh init depends on. Two numbers, so - a 32-bit hash collision alone can't alias two different source trees." - [] - (def buf @"") - (each k (sorted (keys stdlib-embed/sources)) - (buffer/push buf k "\x00" (get stdlib-embed/sources k) "\x00")) - (def dir (src-dir)) - (when dir - (each [rel full] (janet-sources-under dir) - (buffer/push buf rel "\x00" (slurp full) "\x00"))) - [(hash (string buf)) (length buf)]) - -(defn- image-cache-path [opts] - (def dir (or (os/getenv "JOLT_IMAGE_CACHE_DIR") - (os/getenv "TMPDIR") - "/tmp")) - (def [h len] (source-fingerprint)) - # Opts land in the key via their printed form; an opt that prints unstably - # (e.g. a closure in :namespaces) just degrades to a cache miss, never to a - # wrong hit. Every ctx-shaping env var rides along via config/ctx-cache-key — - # one canonical list shared with the deps-image key (jolt-q5ql), so a new knob - # can't be added to one key and forgotten in the other. - (def key (config/ctx-cache-key [:janet (string janet/version "-" janet/build) :opts opts])) - (string dir "/jolt-ctx-" (band h 0x7FFFFFFF) "-" len "-" (band (hash key) 0x7FFFFFFF) ".jimg")) - -(defn init-cached - "init, but disk-cached: the first call builds the context and writes a - bytecode image; later calls (any process, same sources) load the image - instead of rebuilding. Same opts as init. JOLT_NO_IMAGE_CACHE=1 disables; - JOLT_IMAGE_CACHE_DIR overrides the cache directory (default TMPDIR)." - [&opt opts] - (default opts {}) - (if (or (= "1" (os/getenv "JOLT_NO_IMAGE_CACHE")) (nil? (src-dir))) - (init opts) - (let [path (image-cache-path opts)] - # The source-fingerprint is already in the path, so any cached image at - # this path is valid — no extra predicate, just the per-process rewiring. - (or (load-ctx-image path install-print-method-cb!) - (let [ctx (init opts)] - (save-ctx-image ctx path) - ctx))))) - -(defn eval-one - "Evaluate a single already-parsed form. Routing (compile when :compile? is set, - stateful forms interpret, interpreter fallback for forms the compiler can't - handle) lives in loader/eval-toplevel so load-ns and eval-one stay in sync." - [ctx form] - (eval-toplevel ctx form)) - -(defn eval-string - "Evaluate a Clojure source string in a Jolt context. - When :compile? is enabled, compiles to Janet and evaluates. - Macros are expanded at compile time. - Context-modifying forms (ns, defmacro, deftype, require, in-ns, defmulti, defmethod) - always use the interpreter." - [ctx s] - (eval-one ctx (parse-string s))) - -(defn eval-string* - "Evaluate a Clojure source string with explicit bindings." - [ctx s bindings] - (let [form (parse-string s)] - (eval-form ctx bindings form))) - -(defn load-string - "Evaluate all forms from a Clojure source string. - Uses parse-next to load every top-level form in sequence. - Returns the result of the last form evaluated." - [ctx s &opt file] - (default file "") - # record form positions so the checker can report file:line:col (jolt-fqy). - # The checker is on when JOLT_TYPE_CHECK selects it, OR by default in - # direct-link builds (where it piggybacks on inference for free). - (when (or (checker-enabled?) (get (ctx :env) :inline?)) - (track-positions! true) - (put (ctx :env) :tc-source s) - (put (ctx :env) :tc-file file)) - (eval-forms-positioned ctx (parse-all-positioned s file) file)) - diff --git a/src/jolt/async.janet b/src/jolt/async.janet deleted file mode 100644 index 8f9c385..0000000 --- a/src/jolt/async.janet +++ /dev/null @@ -1,208 +0,0 @@ -# clojure.core.async on Janet fibers. -# -# Janet fibers are stackful coroutines, so a `go` block is just "run the body in -# a fiber" — the body parks on a channel op by yielding to the event loop, and -# the whole interpreter call stack rides along on the fiber's stack. No CPS/state -# machine transform (unlike Clojure's `go` macro), so ! work anywhere -# (inside try, nested fns, loops, …). -# -# A channel is a pair of Janet ev/chans wrapped in a tagged table: a `:ch` that -# carries values and a `:done` that is closed to signal channel close. A take is -# `(ev/select :ch :done)` — ev/select checks in order, so buffered values drain -# before the close signal is seen, giving Clojure's drain-then-nil semantics. We -# use a separate `:done` channel because Janet's ev/chan-close *discards* a -# channel's buffered values. close! just closes :done (idempotent, no fiber), so -# nothing leaks. -# -# Single OS thread: go blocks run cooperatively on the event loop, so buf 0)) {:kind :fixed :n buf} - nil)) - (def vc (if spec (ev/chan (spec :n)) (ev/chan))) - (def w (wrap vc (ev/chan))) - (when spec (put w :bufkind (spec :kind))) - (when (and xform (not (nil? xform))) - (put w :xrf (xform (make-add-rf w)))) - w) - -(defn async-close! [ch] - (when (not (in (ch :closed) 0)) - (put (ch :closed) 0 true) - # flush any buffered state of a stateful transducer (completion arity) - (when (ch :xrf) (protect ((ch :xrf) (ch :ch)))) - (protect (ev/chan-close (ch :done)))) - nil) - -# ! / >!! — put, parking the fiber. Returns true if delivered, false if the -# channel is closed. nil may not be put on a channel (it is the closed value). -# With a transducer, the value is run through it (so one put may yield zero or -# more values on the channel); a `reduced` result (e.g. from `take`) closes it. -(defn async-give [ch v] - (when (nil? v) (error "Can't put nil on a channel")) - (cond - (in (ch :closed) 0) false - (ch :xrf) - (let [r ((ch :xrf) (ch :ch) v)] - (when (reduced? r) (async-close! ch)) - true) - (buf-give ch v))) - -# Run thunk (a jolt 0-arg closure, directly callable) in a fiber; return a -# buffered(1) channel that conveys its value once, then closes. A nil result -# just closes. Buffered(1) so a fire-and-forget go leaves no parked fiber. -# -# The dynamic-var bindings in effect at spawn time are conveyed into the fiber -# (Clojure binding conveyance): we snapshot them here (on the spawning fiber) -# and install a private copy inside the new fiber before running the body. -(defn async-go-spawn [thunk] - (def snap (snapshot-bindings)) - (def w (async-chan 1)) - (ev/go (fn [] - (install-bindings snap) - (def res (protect (thunk))) - (when (and (in res 0) (not (nil? (in res 1)))) - (async-give w (in res 1))) - (async-close! w))) - w) - -# (alts! [ch ...]) — take from whichever channel is ready first; returns -# [value channel] (value is nil if that channel closed). Take-only for v1. -(defn async-alts [chans] - (def cs (cond (pvec? chans) (pv->array chans) - (tuple? chans) chans - (array? chans) chans - (error "alts! expects a vector of channels"))) - (def raws @[]) - (def lookup @{}) # raw ev/chan -> [jolt-chan done?] - (each c cs - (array/push raws (c :ch)) (put lookup (c :ch) [c false]) - (array/push raws (c :done)) (put lookup (c :done) [c true])) - (def r (ev/select ;raws)) - (def info (get lookup (in r 1))) - (def jc (in info 0)) - (def val (if (or (in info 1) (not= :take (in r 0))) nil (in r 2))) - (pv-from-indexed @[val jc])) - -# (timeout ms) — a channel that closes after ms milliseconds. -(defn async-timeout [ms] - (def w (async-chan)) - (ev/go (fn [] (ev/sleep (/ ms 1000)) (async-close! w))) - w) - -# (put! ch v [cb]) — async put; (take! ch cb) — async take. Fire a fiber and -# call the optional callback with the result. -(defn async-put! [ch v &opt cb] - (ev/go (fn [] - (def ok (async-give ch v)) - (when (and cb (not (nil? cb))) (cb ok)))) - nil) -(defn async-take! [ch cb] - (ev/go (fn [] - (def val (async-take ch)) - (when (and cb (not (nil? cb))) (cb val)))) - nil) - -# --- macros (Janet macro-fns that return forms) --- - -(defn- sym [name &opt ns] {:jolt/type :symbol :ns ns :name name}) - -# (go body...) -> (go-spawn (fn* [] body...)) -(defn async-go [& body] - @[(sym "go-spawn" "clojure.core.async") (array (sym "fn*") [] ;body)]) - -# (go-loop bindings body...) -> (go (loop bindings body...)) -(defn async-go-loop [bindings & body] - @[(sym "go" "clojure.core.async") (array (sym "loop") bindings ;body)]) - -# (thread body...) — runs cooperatively in a fiber here (no OS thread); same -# shape as go (returns a result channel). -(defn async-thread [& body] - @[(sym "go-spawn" "clojure.core.async") (array (sym "fn*") [] ;body)]) - -(def- async-bindings - @{"chan" async-chan - "chan?" jolt-chan? - "close!" async-close! - "!" async-give ">!!" async-give - "alts!" async-alts "alts!!" async-alts - "timeout" async-timeout - "buffer" async-buffer - "dropping-buffer" async-dropping-buffer - "sliding-buffer" async-sliding-buffer - "put!" async-put! - "take!" async-take! - "go-spawn" async-go-spawn - "go" async-go - "go-loop" async-go-loop - "thread" async-thread}) - -(def- async-macros @{"go" true "go-loop" true "thread" true}) - -(defn install-async! - "Create/populate the clojure.core.async namespace in ctx." - [ctx] - (let [ns (ctx-find-ns ctx "clojure.core.async")] - (loop [[name f] :pairs async-bindings] - (def v (ns-intern ns name f)) - (when (get async-macros name) (put v :macro true))) - ns)) diff --git a/src/jolt/backend.janet b/src/jolt/backend.janet deleted file mode 100644 index 0b7b2fd..0000000 --- a/src/jolt/backend.janet +++ /dev/null @@ -1,1329 +0,0 @@ -# Janet back end: host-neutral IR (from jolt.analyzer) -> Janet form -> bytecode. -# -# Host-specific by definition (it targets Janet). It resolves name-based :var -# nodes to Janet var cells and reuses runtime helpers (jolt-call, make-vec, -# build-map-literal). The portable front end (jolt.analyzer) never sees any of -# this; a different runtime provides its own back end against the same IR. -# -# In src/jolt/ (not host/janet/) for the same module-resolution reason as -# host_iface — see that file's header. - -(use ./types) -(use ./core) -(use ./evaluator) -(import ./reader :as r) -(import ./cgen :as cgen) -(import ./phm :as phm) -(import ./phs :as phs) -(import ./pv :as pv) - -# The IR is portable data; reading its representation is a host-layer concern. -# Most nodes are Janet structs (raw-readable), but a node carrying a nil-valued -# field — an anonymous fn's :name, a nil const's :val, a def with no :meta, an -# arity with no :rest — is a phm, whose fields live under :buckets, not as direct -# keys. Densify such a node to a struct: phm-to-struct drops exactly those -# nil-valued fields, which is what the back end wants (it already treats an absent -# field as nil). Structs (the common case) pass through untouched. Applied at the -# few points where a node first reaches the emitter, so the rest of the back end -# keeps using plain (node :key) access and the portable front end never sees this. -# --- Runtime kernel (absorbed from the retired bootstrap compiler) ---------- - -# The Janet env compiled code evaluates in. Captured at module load: backend's -# env chains types/core/evaluator/reader/phm, so emitted symbols (let/fn/in/ -# var-get/tuple-slice/...) and jolt runtime helpers resolve by name. -(def jolt-runtime-env (curenv)) - -# Janet's `in` accessor as an embedded VALUE (jolt-fjb1). The back end uses `in` -# to index cells/shape-recs/arg tuples in code it EMITS. Emitting the bare symbol -# `in` is unhygienic: a user local named `in` (malli's explainer binds `[value in -# acc]`) shadows it in the surrounding scope, so the generated `(in cell :root)` -# would call the user's value as a function — " called with 2 arguments". -# Embedding the function value (as with jolt-call/core-get) can't be shadowed. -(def- jin in) - -(defn ctx-janet-env - "Lazily create/cache a per-context Janet environment for compiled code: a child - of the runtime env (so core fns resolve) that holds this context's user defs. - For a nil context (one-off compile/eval) returns a fresh child env." - [ctx] - (if (and ctx (table? (get ctx :env))) - (or (get (ctx :env) :janet-rt) - (let [e (make-env jolt-runtime-env)] - (put (ctx :env) :janet-rt e) - e)) - (make-env jolt-runtime-env))) - -(defn build-map-literal - "Build a map value from evaluated k v k v ... args. A phm (not a Janet struct) - when a key is a collection (value hashing) or a key/value is nil (structs drop - nil; phm preserves it, matching Clojure)." - [& kvs] - (var need-phm false) - (var ki 0) - (while (< ki (length kvs)) - (let [kk (in kvs ki) vv (in kvs (+ ki 1))] - (when (or (table? kk) (array? kk) (nil? kk) (nil? vv)) (set need-phm true))) - (+= ki 2)) - (if need-phm - (do (var m (phm/make-phm)) (var j 0) - (while (< j (length kvs)) (set m (phm/phm-assoc m (in kvs j) (in kvs (+ j 1)))) (+= j 2)) - m) - (struct ;kvs))) - -(defn- norm-node [n] - (if (phm/phm? n) (phm/phm-to-struct n) n)) - -# Inline registry (jolt-87f). When a defn of a SINGLE FIXED-ARITY fn compiles -# under :inline?, stash its body IR on the var cell so the inline pass -# (jolt.passes) can splice it into callers. Eligibility beyond single-fixed-arity -# (body grammar, size budget) is decided by the pass, which walks the body to -# alpha-rename it anyway. Skip ^:redef / ^:dynamic (those vars stay redefinable, -# so a call to them must not be inlined). The stash is {:params [..] :body }. -(defn- inline-stash! [ctx cell node] - (when (get (ctx :env) :inline?) - (def init (norm-node (node :init))) - (def meta (node :meta)) - (def redefable (and meta (or (get meta :redef) (get meta :dynamic)))) - (cond - redefable nil - (= :fn (init :op)) - (let [arities (vview (init :arities))] - (when (= 1 (length arities)) - (def ar (norm-node (in arities 0))) - (unless (ar :rest) - (put cell :inline-ir {:params (ar :params) :body (ar :body)}) - # jolt-767: stash the whole (post-pass) :def IR so the inter-procedural - # pass can re-infer its body with discovered param types and re-emit it. - (put cell :infer-ir node)))) - # a non-fn def: stash so the pass can infer its VALUE type (jolt-d6u), e.g. - # a color table used via rand-nth — its element type flows to lookups. - true (put cell :infer-ir node)))) - -# Var late-binding: reads go through `(var-get cell)` with the cell embedded as a -# constant, so compiled code sees redefinition (Janet early-binds plain symbols) -# — var-get reads the cell's root live. Writes go through a memoized setter. -(defn- var-setter [cell] - (or (get cell :jolt/setter) - (let [s (fn [v] (bind-root cell v) cell)] (put cell :jolt/setter s) s))) - -# Setter that also applies def metadata to the var (so ^:dynamic / ^:redef / -# ^:private survive compilation, matching the interpreter's def). Not memoized: -# the meta is specific to this def site. -(defn- var-setter-meta [cell meta] - (fn [v] - (bind-root cell v) - (put cell :meta (merge (or (cell :meta) {}) meta)) - (when (get meta :dynamic) (put cell :dynamic true)) - cell)) - -(defn- cell-for [ctx ns-name nm] - (ns-intern (ctx-find-ns ctx ns-name) nm)) - -# Direct-linking decision (call-site/unit property, Clojure-style). A var -# reference compiles to its embedded value (direct) iff: -# - the compiling unit has direct-linking on (env :direct-linking?), -# - the target opts in (NOT ^:redef / ^:dynamic — those force indirect), -# - the target is already defined AND its root is a Janet function. -# The function? guard is essential: embedding a non-function value (a jolt -# collection/symbol) into the emitted form would make Janet evaluate it AS code. -# So we direct-link exactly the call-optimization case; everything else stays -# indirect (live var deref → redefinable). Default user/REPL units: flag off, -# so all user calls are indirect and redefinable with no annotation. -# A var DEF'd earlier as a sibling in the current compilation unit can't be -# direct-linked/const-linked: its embedded root is the value from BEFORE this -# unit runs, but the unit's own (def …) rebinds it first — so a later reference -# in the same unit (e.g. deftype's `(def ->R R)` alias after `(def R …)`) would -# capture the stale pre-redef root (jolt-wf4). Self-reference inside a def's own -# init is unaffected: the cell is registered only AFTER its init is emitted, so a -# fn body's recursive call still direct-links (and runs after the def completes). -(defn- unit-redefined? [ctx cell] - (let [ud (get (ctx :env) :unit-defs)] (and ud (get ud cell) true))) - -(defn- direct-var? [ctx cell] - (and (get (ctx :env) :direct-linking?) - (not (cell :dynamic)) - (not (let [m (cell :meta)] (and m (get m :redef)))) - (not (unit-redefined? ctx cell)) - (let [r (cell :root)] (or (function? r) (cfunction? r))))) - -# Whole-program constant-linking (closed world): under JOLT_WHOLE_PROGRAM every -# non-dynamic var has a stable root we can embed as a CONSTANT, eliminating the -# per-reference cell deref the indirect path pays. This covers what direct-var? -# can't: ^:redef vars (no reloading under the flag, so redef is moot), data vars -# (def of a number/vector/etc.), and record-type / non-fn callable roots. The -# value is quoted at the emit site unless it's callable (a function/cfunction is -# valid in head AND value position as-is). Dynamic vars stay indirect — thread -# binding is a runtime mechanism, not redefinition. A nil root (a not-yet-run -# forward def) stays indirect so the live deref picks the value up; the -# whole-program re-emit (infer-program!, callee-first after full load) then -# const-links it once its root is in place. -(defn- const-link? [ctx cell] - (and (get (ctx :env) :whole-program?) - (get (ctx :env) :direct-linking?) - (not (cell :dynamic)) - (not (unit-redefined? ctx cell)) - (not (nil? (cell :root))))) - -# Fresh Janet symbol for back-end-introduced bindings (arity dispatch). NOT -# Janet's `gensym` — `(use ./core)` shadows it with Jolt's, which returns a jolt -# symbol struct (invalid in a Janet param position). -(var- gsym-counter 0) -(defn- gsym [] (def s (symbol "_be$" gsym-counter)) (++ gsym-counter) s) - -(var emit nil) - -(defn- emit-seq [ctx node] - (def out @['do]) - (each s (vview (node :statements)) (array/push out (emit ctx s))) - (array/push out (emit ctx (node :ret))) - (tuple/slice out)) - -(defn- emit-let [ctx node] - # letfn lowers to a :let flagged :letrec (mutually-recursive bindings). A - # compiled sequential Janet let can't forward-ref a sibling, so punt to the - # interpreter (the deliberate uncompilable channel) — its shared mutable env - # gives the letrec semantics. The Chez back end compiles it directly (letrec*). - (when (node :letrec) (error "jolt/uncompilable: letfn")) - (def binds @[]) - (each pair (vview (node :bindings)) - (def p (vview pair)) - (array/push binds (symbol (in p 0))) - (array/push binds (emit ctx (in p 1)))) - ['let (tuple/slice binds) (emit ctx (node :body))]) - -# An arity compiles to a named Janet fn whose name is its recur target, so recur -# is a self-call (Janet tail-calls it). The rest param is an ORDINARY positional -# param holding a seq (not Janet `&`), so `(recur fixed... rest-seq)` re-enters -# the way Clojure recur into a variadic arity does (rebinds the rest seq directly, -# no re-collection). The dispatch wrapper (emit-fn-body) collects the call's args. -(defn- emit-arity-fn [ctx ar] - (def ps @[]) - (each pn (vview (ar :params)) (array/push ps (symbol pn))) - (when (ar :rest) (array/push ps (symbol (ar :rest)))) - ['fn (symbol (ar :recur-name)) (tuple/slice ps) (emit ctx (ar :body))]) - -# Invoke an arity's fn with args pulled from the dispatch tuple: fixed params by -# index, rest as a slice from n-fixed on. -(defn- emit-arity-invoke [ctx ar jargs] - (def nfixed (length (vview (ar :params)))) - (def call @[(emit-arity-fn ctx ar)]) - (for i 0 nfixed (array/push call [jin jargs i])) - # empty rest binds to NIL, not () — (f) with [& r] gives r = nil in Clojure - (when (ar :rest) - (array/push call ['if ['> ['length jargs] nfixed] ['tuple/slice jargs nfixed]])) - (tuple/slice call)) - -# A tail loop lowers to a Janet `while` + state vars (jolt-v28u), NOT a -# self-recursive closure called once per iteration — that paid a fn frame + arg -# bind every iteration, which the jolt-5vsp spike localized as the ENTIRE ~1.43x -# jolt-over-hand-Janet gap on compute loops. Shape: -# (let [b0 init0] (let [b1 init1] ... ; sequential inits (later sees earlier) -# (do (var $b0 b0) (var $b1 b1) ... ; state carried across iterations -# (var flag true) (var result nil) -# (while flag -# (set flag false) -# (let [b0 $b0 b1 $b1 ...] ; FRESH immutable per-iteration binding -# (set result ))) ; a tail recur sets the $vars + flag -# result))) -# The per-iteration `let` is load-bearing, not cosmetic: a closure built in the -# body must capture THIS iteration's value (Clojure semantics), and Janet closures -# capture vars BY REFERENCE — close over a shared mutable var and every closure -# sees the final value ([3 3 3]). Rebinding into an immutable `let` each iteration -# restores per-iteration capture ([0 1 2]). recur reads the immutable bi and writes -# $bi, so the read/write sets are disjoint and cross-referencing args (swap, fib) -# need no temps. -(defn- emit-loop [ctx node] - (def recur-name (node :recur-name)) - (def syms @[]) # loop binding names (source symbols), read by the body - (def state @[]) # fresh vars carrying each binding across iterations - (def inits @[]) - (each pair (vview (node :bindings)) - (def p (vview pair)) - (array/push syms (symbol (in p 0))) - (array/push state (gsym)) - (array/push inits (emit ctx (in p 1)))) - (def flag (gsym)) - (def result (gsym)) - # Register this loop so its recurs lower to state-var sets (emit-recur looks it - # up by recur-name); restore any prior binding after the body (nil removes it). - (def frames (or (get (ctx :env) :loop-frames) - (let [t @{}] (put (ctx :env) :loop-frames t) t))) - (def prev (get frames recur-name)) - (put frames recur-name {:state state :flag flag}) - (def body (emit ctx (node :body))) - (put frames recur-name prev) - (def per-iter @[]) - (for i 0 (length syms) (array/push per-iter (syms i) (state i))) - (def block @['do]) - (for i 0 (length syms) (array/push block ['var (state i) (syms i)])) - (array/push block ['var flag true] ['var result nil]) - (array/push block ['while flag - ['set flag false] - ['let (tuple/slice per-iter) ['set result body]]]) - (array/push block result) - (var form (tuple/slice block)) - (for ri 0 (length syms) - (def i (- (length syms) 1 ri)) - (set form ['let [(syms i) (inits i)] form])) - form) - -(defn- emit-recur [ctx node] - (def recur-name (node :recur-name)) - (def frame (get (get (ctx :env) :loop-frames @{}) recur-name)) - (if frame - # while-lowered loop: write each state var from its recur arg (args read the - # immutable iteration bindings — disjoint from the $vars, so no clobber), then - # raise the continue flag. The `do` yields the flag value, discarded in tail. - (let [args (map |(emit ctx $) (vview (node :args))) - block @['do]] - (for i 0 (length (frame :state)) - (array/push block ['set ((frame :state) i) (args i)])) - (array/push block ['set (frame :flag) true]) - (tuple/slice block)) - # fn-arity recur: a self-call the Janet runtime tail-calls (unchanged path). - (tuple/slice (array/concat @[(symbol recur-name)] - (map |(emit ctx $) (vview (node :args))))))) - -# Var-cell read of a clojure.core fn, as ((in 'cell :root) args...) — the same -# live-root call the :var emit uses, for the ns get/set helpers below. -(defn- core-fn-call [ctx nm & args] - (def cell (cell-for ctx "clojure.core" nm)) - (tuple (tuple jin (tuple 'quote cell) :root) ;args)) - -(defn- emit-try [ctx node] - (def core - (if (node :catch-sym) - # Restore current-ns in the catch: a caught throw from an INTERPRETED fn - # leaves ctx-current-ns set to that fn's defining ns (it can't restore on - # unwind), which then breaks alias resolution in the catching ns. Snapshot - # the ns at try entry, reset it on catch (mirrors the interpreter's try). - (let [saved (gsym) raw (gsym)] - ['let [saved (core-fn-call ctx "__current-ns")] - ['try (emit ctx (node :body)) - [[raw] - ['do (core-fn-call ctx "__set-current-ns!" saved) - # bind the catch symbol to the UNWRAPPED value (mirrors the - # interpreter), so an interpreted throw's envelope doesn't leak here. - ['let [(symbol (node :catch-sym)) (core-fn-call ctx "__unwrap-ex" raw)] - (emit ctx (node :catch-body))]]]]]) - (emit ctx (node :body)))) - (if (node :finally) - ['defer (emit ctx (node :finally)) core] - core)) - -(defn- emit-fn-body [ctx node] - (def arities (map norm-node (vview (node :arities)))) - (def multi (> (length arities) 1)) - (cond - # Single fixed arity (the hot case): emit the arity fn directly — its name is - # the recur target, no dispatch overhead. - (and (not multi) (not ((first arities) :rest))) - (emit-arity-fn ctx (first arities)) - # Single variadic arity: a thin wrapper collects the call's args so the rest - # seq can be built, then hands off to the arity fn. Fewer args than the - # fixed params is an arity error (jolt-6xn) — without the guard the fixed - # binds fell off the end of the args tuple with a raw index error. - (not multi) - (let [jargs (gsym) - ar (first arities) - nfixed (length (vview (ar :params)))] - ['fn ['& jargs] - ['if ['< ['length jargs] nfixed] - ['error ['string "Wrong number of args (" ['length jargs] ") passed to: " - (or (node :name) "fn")]] - (emit-arity-invoke ctx ar jargs)]]) - # Multi-arity: dispatch on arg count. Fixed arities match exactly; the (one) - # variadic arity matches >= its fixed count. - (let [jargs (gsym) - nsym (gsym) - cf @['cond]] - (each ar arities - (def nfixed (length (vview (ar :params)))) - (array/push cf (if (ar :rest) [>= nsym nfixed] [= nsym nfixed])) - (array/push cf (emit-arity-invoke ctx ar jargs))) - (array/push cf ['error ['string "Wrong number of args (" nsym ") passed to: " - (or (node :name) "fn")]]) - ['fn ['& jargs] - ['do ['def nsym ['length jargs]] (tuple/slice cf)]]))) - -# A named fn (fn self [..] .. (self ..)) references itself by name. The analyzer -# binds that name as a local; bind it here to the fn value via a var (set before -# any call, so the captured closure sees it — same scheme as emit-loop). recur -# stays a separate self-call to the arity fn; this only covers by-name self-refs. -(defn- emit-fn [ctx node] - (def body (emit-fn-body ctx node)) - (if (node :name) - (let [s (symbol (node :name))] - ['do ['var s nil] ['set s body] s]) - body)) - -# A direct Janet call (f args) is only correct when the callee is definitely a -# function: Janet calling a pvec/keyword/etc. does get (or the wrong thing), not -# IFn dispatch. So only emit a direct call for :fn / :host (always functions) and -# a :var whose CURRENT root is a function (the common user/core-fn case). A :var -# holding an IFn COLLECTION (vector/keyword/set used as a fn) or a :local of -# unknown value falls through to jolt-call, which dispatches IFn correctly -# (function fast-path first). Trade-off, like direct-linking: a fn-var redefined -# to a collection after this call was compiled would still emit a direct call. -(defn- direct-call? [ctx fnode] - (case (fnode :op) - :fn true - :host true - :var (let [r (get (cell-for ctx (fnode :ns) (fnode :name)) :root)] - (or (function? r) (cfunction? r))) - false)) - -# Hot primitives emitted as native Janet ops (host-specific optimization): a -# call to clojure.core/+ etc. becomes (+ …) rather than a var deref + variadic -# core fn. Matches numeric semantics; relaxes the non-number checks (a documented -# perf-mode divergence, same as the bootstrap's core-renames). -(def- native-ops - {"+" '+ "-" '- "*" '* "/" '/ "<" '< ">" '> "<=" '<= ">=" '>= - "inc" '++ "dec" '-- - # verified semantic parity with the jolt fns (incl. negative operands): - # mod is floored, rem (janet %) truncates, / is variadic with (/ x) -> 1/x. - # quot is deliberately ABSENT: janet div floors where Clojure truncates. - "mod" 'mod "rem" '% - # jolt's bit fns are 2-arg (unlike Clojure's variadic), so these emit native - # only at exactly the arity the interpreted fn accepts; bit-not is unary. - "bit-and" 'band "bit-or" 'bor "bit-xor" 'bxor - "bit-shift-left" 'blshift "bit-shift-right" 'brshift "bit-not" 'bnot - # janet min/max are variadic with Clojure's numeric semantics; nil?/some? - # lower to janet's fastfun = / not= against nil (pure opcodes), and `not` - # to janet not — all hot in predicate-heavy loops (jolt-4vr). Same - # documented numbers-only relaxation as the arithmetic ops above. - "min" 'min "max" 'max - "nil?" 'jolt-nil? "some?" 'jolt-some? "not" 'not}) - -(def- unary-ops {'++ true '-- true 'bnot true - 'jolt-nil? true 'jolt-some? true 'not true}) -(def- binary-ops {'mod true '% true 'band true 'bor true 'bxor true - 'blshift true 'brshift true}) - -(defn- native-op - "If fnode is a clojure.core ref (or host ref) to a native-op primitive, return - the Janet op symbol, else nil — only at an arity where the janet op and the - jolt fn agree." - [fnode nargs] - (def nm (case (fnode :op) - :var (when (= "clojure.core" (fnode :ns)) (fnode :name)) - :host (fnode :name) - nil)) - (def op (and nm (get native-ops nm))) - (cond - (nil? op) nil - (and (get unary-ops op) (not= nargs 1)) nil - (and (get binary-ops op) (not= nargs 2)) nil - (and (or (= op 'min) (= op 'max)) (= nargs 0)) nil - op)) - -# Janet-level gensym for the inline fast paths: (use ./core) shadows janet's -# gensym with jolt's (which returns a jolt symbol STRUCT — useless as a janet -# binding target). _fp$ mirrors the reserved _r$ compiler prefix. -(var- fp-counter 0) -(defn- jsym [] (symbol "_fp$" (++ fp-counter))) - -# Is fnode a reference to clojure.core/get (or a host `get`)? Used to give -# (get m :kw [d]) the same inlined keyword-lookup treatment as (:kw m [d]). -(defn- get-head? [fnode] - (case (fnode :op) - :var (and (= "clojure.core" (fnode :ns)) (= "get" (fnode :name))) - :host (= "get" (fnode :name)) - false)) - -# Is fnode a reference to clojure.core/ (or host )? -(defn- core-head? [fnode name] - (case (fnode :op) - :var (and (= "clojure.core" (fnode :ns)) (= name (fnode :name))) - :host (= name (fnode :name)) - false)) - -# Is this IR node a :local the inference proved to be a vector ({:vec ...})? -(defn- vec-hinted? [n] (and (= :local (n :op)) (= :vector (n :hint)))) - -# Shared emit for a constant-keyword map lookup — both (:kw m [d]) and -# (get m :kw [d]). subj-node is the subject's IR node (carries the type hint), -# m-expr its emitted form, k the keyword, d-expr the emitted default or nil. -# - unhinted: GUARDED — (if (get m :jolt/type) (core-get …) (bare get)). The -# guard (one opcode) routes tagged reps (phm/sorted/transient/lazy-seq) to -# core-get; a plain struct/record (no :jolt/type) takes the bare get, which -# matches core-get for keyword keys. -# - ^:struct / ^Record hinted subject: skip the guard, bare get (~20 vs ~36ns). -# - hinted + JOLT_CHECK_HINTS: keep the guard but THROW on the tagged arm, so a -# lying hint surfaces a clear error (dev aid; off by default, no perf cost). -(defn- emit-kw-lookup [ctx subj-node m-expr k d-expr] - # the subject is a struct (raw-get-safe) when hinted so — by an explicit - # ^:struct/^Record hint on a local, OR by inference tagging ANY subject - # expression it proved to be a struct (jolt-d6u/RFC 0005), which is what lets - # nested access like (:r (:direction ray)) drop its guard. - (def hinted (and subj-node (= :struct (subj-node :hint)))) - (def checked (and hinted (os/getenv "JOLT_CHECK_HINTS"))) - (def m (if (symbol? m-expr) m-expr (jsym))) - (def wrap (fn [body] (if (symbol? m-expr) body ['let [m m-expr] body]))) - (def err (when checked - ['error (string "type hint violated on `" (subj-node :name) "`: (" - k " " (subj-node :name) ") — value carries :jolt/type " - "(a phm/sorted/transient/lazy-seq), not the plain " - "struct/record the ^:struct/^Record hint asserts")])) - # Subject carries a complete :shape (jolt-t34) => it is provably a shape-rec; - # the field reads by bare index. The :shape vector is ALREADY in layout order — - # declared order for records (record-shape-for), str-sorted for map literals - # (the inference's shape-order, matching emit-map) — so the field's position in - # :shape IS its slot. (:shapes? = shapes active = direct-link.) - (def sidx - (when (and (get (ctx :env) :shapes?) subj-node (subj-node :shape)) - (def raw (let [s (subj-node :shape)] (if (pv/pvec? s) (pv/pv->array s) s))) - (var pos nil) (var i 0) - (each kk raw (when (= kk k) (set pos i)) (++ i)) - (when pos (+ pos 1)))) - # sidx => proven complete shape: bare index (fastest). Otherwise a raw-get-safe - # value may still be a shape-rec (its :shape dropped by a join, or an unproven - # param). Read it INLINE from its own descriptor — a shape-rec is a tuple whose - # head is a descriptor struct; index the present field directly. A missing key - # (incl. the virtual :jolt/deftype) falls to core-get, which is nil-safe and - # shape-aware; a struct/other takes the bare get. The inline read matters: a - # core-get fn call per field read is ~2.5x slower on map-through-fn code. - # NOT gated on compile-time shapes — core is baked without the flag but still - # receives user shape-recs, so this must hold in baked core too. (jolt-t34) - (defn get-or-shape [getexpr] - (if sidx [jin m sidx] - (let [pos (jsym)] - ['if ['and ['tuple? m] ['struct? ['get m 0]]] - ['let [pos ['get [['get m 0] :idx] k]] - ['if ['nil? pos] (tuple core-get m k nil) [jin m ['+ 1 pos]]]] - getexpr]))) - (if (nil? d-expr) - (let [fast (get-or-shape ['get m k])] - (wrap (cond - checked ['if ['get m :jolt/type] err fast] - hinted fast - ['if ['get m :jolt/type] (tuple core-get m k) fast]))) - (let [d (if (symbol? d-expr) d-expr (jsym)) - v (jsym) - fast ['let [v (get-or-shape ['get m k])] ['if ['nil? v] d v]] - body (cond - checked ['if ['get m :jolt/type] err fast] - hinted fast - ['if ['get m :jolt/type] (tuple core-get m k d) fast]) - body (if (symbol? d-expr) body ['let [d d-expr] body])] - (wrap body)))) - -(defn- emit-invoke [ctx node] - (def fnode (norm-node (node :fn))) - (def args (map |(emit ctx $) (vview (node :args)))) - (def nop (native-op fnode (length args))) - (def argnodes (vview (node :args))) - # devirtualization (jolt-41m): the inference proved this is a protocol call on a - # known record type. Resolve the method impl at COMPILE time and emit a direct - # call to it, skipping the runtime protocol-dispatch registry walk. The impl is - # embedded as a constant fn value in the call head. - (def dvt (node :devirt-type)) - (def devirt-impl - (when dvt (find-protocol-method ctx dvt (node :devirt-proto) (node :devirt-method)))) - (cond - devirt-impl (tuple devirt-impl ;args) - - nop (case nop - '++ ['+ (in args 0) 1] - '-- ['- (in args 0) 1] - 'jolt-nil? ['= nil (in args 0)] - 'jolt-some? ['not= nil (in args 0)] - (tuple nop ;args)) - # (:kw m) / (:kw m default) — inline the lookup (jank-style, jolt-4vr). - # The guard is (get m :jolt/type): janet compiles `get` to an opcode - # (~17ns) where a struct?-style cfunction predicate costs ~85ns/lookup. - # :jolt/type is a reserved key — user map literals can't contain it (the - # reader treats such maps as tagged forms) — and every table-backed rep - # that must NOT be raw-indexed carries it (phm — tagged for this guard — - # sorted, transient, pvec, atoms, lazy-seqs), so a non-nil tag routes to - # core-get's full semantics. Everything else (structs = literal maps, - # records with direct field keys, nil, janet arrays, scalars) gets janet - # `get` semantics, which match core-get for keyword keys. Structs never - # store nil values (nil values force the phm rep), so present-but-nil - # can't be confused with missing on the fast arm. A ^:struct/^Record hint on - # the subject skips the guard entirely (jolt-94n; see emit-kw-lookup). - (and (= :const (fnode :op)) (keyword? (fnode :val)) - (>= 2 (length args) 1)) - (emit-kw-lookup ctx (norm-node (in argnodes 0)) (in args 0) (fnode :val) - (when (= 2 (length args)) (in args 1))) - # (get m :kw) / (get m :kw default) — same inlined keyword lookup as (:kw m), - # so an explicit get with a constant keyword gets the guard fast path and the - # ^:struct/^Record hint (jolt-94n). Only when the key is a constant keyword; - # a variable/number/string key falls through to core-get below. - (and (get-head? fnode) (>= (length args) 2) (<= (length args) 3) - (let [a1 (norm-node (in argnodes 1))] (and (= :const (a1 :op)) (keyword? (a1 :val))))) - (emit-kw-lookup ctx (norm-node (in argnodes 0)) (in args 0) - ((norm-node (in argnodes 1)) :val) - (when (= 3 (length args)) (in args 2))) - # (count v) on an inferred vector -> pv-count, skipping core-count's dispatch - # chain (jolt-d6u, Phase 2). Sound: a {:vec ...}-typed value is a pvec. - (and (core-head? fnode "count") (= 1 (length args)) (vec-hinted? (norm-node (in argnodes 0)))) - (tuple pv/pv-count (in args 0)) - # (nth v i default) on an inferred vector -> pv-nth. Only the 3-ARG form: the - # 2-arg nth ERRORS on out-of-bounds where pv-nth returns nil, so specializing - # it would change semantics; the 3-arg default matches pv-nth exactly. - (and (core-head? fnode "nth") (= 3 (length args)) (vec-hinted? (norm-node (in argnodes 0)))) - (tuple pv/pv-nth (in args 0) (in args 1) (in args 2)) - (direct-call? ctx fnode) (tuple (emit ctx fnode) ;args) - # Local callee (closure param, let-bound fn, defn self-name): inline the - # function check so the overwhelmingly-common function case is a direct - # janet call with no variadic arg-tuple packing — jolt-call only handles - # the IFn-collection leftovers (jank's dynamic_call removal, jolt-507). - # The callee is rebound to a reserved _fp$ symbol first: a raw jolt local - # name in janet CALL-HEAD position resolves against janet's macro table - # before the lexical upvalue, so a local named like a janet core macro - # (clojure.core/repeat's self-name vs janet's repeat macro) would expand - # as that macro. Argument positions (the old jolt-call shape, the rebind - # here) never consult the macro table, so the rebind is safe. - (= :local (fnode :op)) - (let [fsym (jsym)] - ['let [fsym (emit ctx fnode)] - ['if ['function? fsym] - (tuple fsym ;args) - (tuple jolt-call fsym ;args)]]) - (tuple jolt-call (emit ctx fnode) ;args))) - -(defn- emit-vector [ctx node] - (def items (map |(emit ctx $) (vview (node :items)))) - (tuple make-vec (tuple/slice (array/concat @['tuple] items)))) - -(defn- emit-map [ctx node] - (def pairs (vview (node :pairs))) - # Fast path (jolt-4vr): when every key is a scalar const (keyword/string/ - # number/bool — never a collection, so value-hashing can't be needed from - # the keys), construct the Janet struct inline with one nil-check per - # value instead of calling variadic build-map-literal and re-scanning the - # kvs at runtime. A nil value still falls back to the phm rep (Clojure - # keeps nil entries; structs drop them). - (var fast (> (length pairs) 0)) - (each pair pairs - (def k (norm-node (in (vview pair) 0))) - (def kv (get k :val)) - (unless (and (= :const (k :op)) - (or (keyword? kv) (string? kv) (number? kv) (boolean? kv))) - (set fast false))) - # Shape-record representation (jolt-t34, JOLT_SHAPE): EVERY constant-key map - # literal becomes a shape tuple (≈2x cheaper than a struct), CONSISTENTLY — - # not gated on the inference, so a value's representation always matches what - # the type system claims about it. The layout is the runtime's canonical - # shape-sort of the keys (the single source of truth all sites share). Values - # are emitted in that order; element 0 is the compile-time shape descriptor. - # gated on :inline? — shapes apply to USER code only, never to core or the - # compiler's own IR-node map literals (which the back end reads with raw - # keyword access and would break if turned into tuples) - (def shape-keys - (when (and fast (get (ctx :env) :map-shapes?) (get (ctx :env) :inline?)) - (def ks @[]) - (each pair pairs (array/push ks ((norm-node (in (vview pair) 0)) :val))) - (shape-sort ks))) - (if shape-keys - (do - (def desc (shape-for shape-keys)) - (def by-key @{}) - (each pair pairs - (def p (vview pair)) - (put by-key ((norm-node (in p 0)) :val) (emit ctx (in p 1)))) - # quote the descriptor: it is a struct constant, and its keys are a parens - # tuple — unquoted in code position Janet would try to CALL it ((:b :g)) - (def out @['tuple ['quote desc]]) - (each k shape-keys (array/push out (get by-key k))) - (tuple/slice out)) - (if fast - (do - (def binds @[]) - (def skvs @['struct]) - (def phm-args @[build-map-literal]) - (def truthy @['and]) - (each pair pairs - (def p (vview pair)) - (def kk ((norm-node (in p 0)) :val)) - (def vs (jsym)) - (array/push binds vs) - (array/push binds (emit ctx (in p 1))) - (array/push truthy vs) - (array/push skvs kk) (array/push skvs vs) - (array/push phm-args kk) (array/push phm-args vs)) - # `and` is pure branch opcodes, so the all-truthy common case pays no - # predicate calls at all. nil OR false values (rare) drop to - # build-map-literal, which re-checks nil properly (false values come - # back out on the struct arm there; nil values get the phm rep). - ['let (tuple/slice binds) - ['if (tuple/slice truthy) - (tuple/slice skvs) - (tuple/slice phm-args)]]) - (do - (def args @[build-map-literal]) - (each pair pairs - (def p (vview pair)) - (array/push args (emit ctx (in p 0))) - (array/push args (emit ctx (in p 1)))) - (tuple/slice args))))) - -# A set literal: build (make-phs e1 e2 …) so each element is evaluated at runtime -# then the persistent set is constructed — mirrors compiler.janet's emit-set-expr. -(defn- emit-set [ctx node] - (def items (map |(emit ctx $) (vview (node :items)))) - (tuple/slice (array/concat @[phs/make-phs] items))) - -# Native codegen hook (jolt-ihdp). Under :cgen?, a plain defn of a numeric-leaf -# fn is compiled to C and the resulting cfunction installed as the var root, so -# direct-linked callers embed native code. Returns the cfunction or nil (not a -# candidate / redefable / toolchain absent / cc failed -> normal bytecode path). -# Skip ^:redef / ^:dynamic: those must stay redefinable bytecode. -(defn- cgen-root [ctx node] - (def env (ctx :env)) - (def meta (node :meta)) - (def redefable (and meta (or (get meta :redef) (get meta :dynamic)))) - (when (not redefable) - (def prebuilt (get env :cgen-prebuilt)) - (def qn (string (node :ns) "/" (node :name))) - (cond - # AOT deploy: install the build-time-compiled cfunction as the root (no cc). - # Same timing as the JIT path, so callers compiled later direct-link to it. - (and prebuilt (get prebuilt qn)) (get prebuilt qn) - # JIT: compile to C now (runs cc). - (and (get env :cgen?) (cgen/numeric-leaf? (node :init))) - (let [r (protect (cgen/compile-fn (node :init) {:name (string (node :ns) "_" (node :name))}))] - (and (r 0) (r 1)))))) - -# Build-time collection (jolt-a7ds): under :cgen-collect?, record each numeric- -# leaf defn's full fn IR (with its ns/name) so an AOT driver can compile them all -# into one native module. Does NOT swap the root — the app still loads as bytecode -# during collection; the native version is wired at the later deploy run. -(defn- cgen-collect! [ctx node] - (def env (ctx :env)) - (when (get env :cgen-collect?) - (def meta (node :meta)) - (def redefable (and meta (or (get meta :redef) (get meta :dynamic)))) - (when (and (not redefable) (cgen/numeric-leaf? (node :init))) - (def coll (or (get env :cgen-collected) - (let [a @[]] (put env :cgen-collected a) a))) - (array/push coll {:ns (node :ns) :name (node :name) :ir (node :init)})))) - -(set emit - (fn emit [ctx raw] - (def node (norm-node raw)) - (case (node :op) - :const (node :val) - :local (symbol (node :name)) - :host (symbol (node :name)) - :var (let [cell (cell-for ctx (node :ns) (node :name))] - (if (direct-var? ctx cell) - (cell :root) # direct link: embed the fn value - (if (const-link? ctx cell) - # whole-program closed world: embed the stable root as a constant. - # Callable roots go in bare (valid in head/value position); any - # other value is quoted so Janet returns it rather than evaluating - # it as code (a bare tuple/struct in code position would be called). - (let [r (cell :root)] - (if (or (function? r) (cfunction? r)) r (tuple 'quote r))) - # Indirect: live deref, with the var-get FN CALL inlined away - # (jolt-8sq): a non-dynamic var's value is always its root, so - # the common case is two native table ops + a branch instead of - # a function call. Dynamic vars take the full var-get (thread- - # binding walk). The cell is quoted so it's embedded by - # reference (a bare table in arg position would be re-evaluated - # as a constructor — deep-copying it, and any atom in :root, - # each call). Redefinition stays live: :root is read per call. - # The :dynamic check must be PER CALL, not at emit: a - # (def ^:dynamic x) in the same compiled unit marks the cell - # dynamic only when the def RUNS, after this site was emitted — - # the same reason JVM Clojure's Var.deref() checks the - # thread-bound bit on every call. Non-dynamic vars (the vast - # majority) pay two native table ops + a branch instead of a - # function call. - (let [qcell (tuple 'quote cell)] - ['if [jin qcell :dynamic] - (tuple var-get qcell) - [jin qcell :root]])))) - # (var x): the var object itself (not its value) — the embedded cell, by - # reference. binding keys its thread-binding frame on this exact cell. - :the-var (tuple 'quote (cell-for ctx (node :ns) (node :name))) - :if ['if (emit ctx (node :test)) (emit ctx (node :then)) (emit ctx (node :else))] - :do (emit-seq ctx node) - :loop (emit-loop ctx node) - :recur (emit-recur ctx node) - :try (emit-try ctx node) - :throw ['error (emit ctx (node :expr))] - :def (do - # (def name) with no init (declare): no compiled value to install — - # punt to the interpreter, which interns a genuinely-unbound var - # (compiling it to nil would diverge: reading an unbound var throws). - (when (node :no-init) (error "jolt/uncompilable: def with no init")) - (let [cell (cell-for ctx (node :ns) (node :name)) - meta (node :meta) - setter (if (and meta (not (empty? meta))) (var-setter-meta cell meta) (var-setter cell)) - _ (cgen-collect! ctx node) - cfn (cgen-root ctx node)] - # cgen path: install the native cfunction as the root and DON'T - # inline-stash — callers must call the C fn, not inline the bytecode - # body (which would bypass the native version). Otherwise the normal - # bytecode path: stash for inlining, emit the init. - (if cfn - (do (when-let [ud (get (ctx :env) :unit-defs)] (put ud cell true)) - (tuple setter cfn)) - (do (inline-stash! ctx cell node) - # Emit the init BEFORE marking the cell unit-defined, so a - # recursive self-reference in the init still direct-links; a - # LATER sibling reference in this unit then sees it as - # redefined (jolt-wf4). - (let [init-form (emit ctx (node :init))] - (when-let [ud (get (ctx :env) :unit-defs)] (put ud cell true)) - (tuple setter init-form)))))) - :let (emit-let ctx node) - :fn (emit-fn ctx node) - :invoke (emit-invoke ctx node) - :vector (emit-vector ctx node) - :map (emit-map ctx node) - :set (emit-set ctx node) - :quote ['quote (node :form)] - # host interop (.method target ...): the back end doesn't model interop — - # punt to the interpreter, exactly as the analyzer used to before producing - # a :host-call node (the Chez back end lowers it instead). - :host-call (error "jolt/uncompilable: host method call") - # host class statics (Class/member) and constructors ((Class. ...)/(new - # Class ...)): the back end doesn't model class interop — punt to the - # interpreter (its class-statics / class-ctors registries), exactly as the - # analyzer used to before producing these nodes. The Chez back end lowers - # them to a runtime static/ctor dispatch (jolt-avt6). - :host-static (error "jolt/uncompilable: host static ref") - :host-new (error "jolt/uncompilable: host constructor") - # regex literal: the back end doesn't compile patterns — punt to the - # interpreter (the seed compiles #"…" to a Janet PEG). Chez emits jolt-regex. - :regex (error "jolt/uncompilable: regex literal") - # #inst / #uuid literals: the back end doesn't construct them — punt to the - # interpreter (its data-readers parse the timestamp/uuid). Chez emits a - # runtime jolt-inst-from-string / jolt-uuid-from-string value. - :inst (error "jolt/uncompilable: inst literal") - :uuid (error "jolt/uncompilable: uuid literal") - (error (string "backend: unhandled op " (node :op)))))) - -(defn emit-ir - "IR node -> Janet form (public entry for the back end)." - [ctx node] - # Fresh per-unit set of vars (re)defined in THIS top-level form, so a sibling - # reference to one can't direct-link to its pre-redef root (jolt-wf4). Scoped - # to one emit pass; each compile-and-eval / re-emit call is its own unit. - (when (table? (get ctx :env)) (put (ctx :env) :unit-defs @{})) - (emit ctx node)) - -# --- pipeline wiring (the self-hosted compile path) --- - -# Bootstrap-compile a source string into target-ns: each form is compiled via the -# bootstrap (native Janet) compiler and its defs interned in target-ns. This is -# the stage-1 builder — it runs BEFORE the self-hosted analyzer exists, so it's -# how both the compiler namespaces (jolt.ir/jolt.analyzer) and the clojure.core -# kernel tier (the structural fns the analyzer itself calls) get built. The -# analyzer uses unqualified referred names (jolt.host form-* + IR ctors), so the -# bootstrap's plain :var path compiles it; stateful forms fall back to interp. -(defn bootstrap-load-source - "Stage-1 builder: load a source string into target-ns INTERPRETED. Runs before - the self-hosted analyzer exists (it builds jolt.ir/jolt.analyzer and the kernel - tier); self-compile-compiler! then re-runs those sources through the live - analyzer so the steady-state compiler is compiled by itself — the retired - bootstrap compiler's job, done by the interpreter + one fixpoint turn." - [ctx target-ns src] - (def saved (ctx-current-ns ctx)) - (ctx-set-current-ns ctx target-ns) - (var s src) - (while (> (length (string/trim s)) 0) - (def parsed (r/parse-next s)) - (set s (in parsed 1)) - (def f (in parsed 0)) - (when (not (nil? f)) - (eval-form ctx @{} f))) - (ctx-set-current-ns ctx saved)) - -# Compile-load an embedded jolt-core namespace by name (source from the stdlib map). -(defn- compile-load [ctx ns-name] - (def src (get (get (ctx :env) :embedded-sources @{}) ns-name)) - (when src (bootstrap-load-source ctx ns-name src))) - -# Build the self-hosted compiler (IR ctors + analyzer) via the bootstrap. The -# analyzer's references to clojure.core fns it uses (second/peek/subvec/mapv/ -# update) resolve to whatever is interned in clojure.core at this point — so the -# kernel tier must already be loaded (see api/load-core-overlay!). -(defn- build-compiler! [ctx] - (compile-load ctx "jolt.ir") - (compile-load ctx "jolt.analyzer") - # jolt.passes is split into three weakly-coupled namespaces; load them in - # dependency order (fold is the base) before the façade requires them. - (compile-load ctx "jolt.passes.fold") - (compile-load ctx "jolt.passes.inline") - (compile-load ctx "jolt.passes.types") - (compile-load ctx "jolt.passes")) - -(defn- ensure-analyzer [ctx] - # Don't build until the kernel tier is loaded (see api/load-core-overlay! and - # build-compiler!). Before then a compile request — e.g. a defn in a pre-kernel - # tier — must fall back to the interpreter, not build the analyzer against a - # core missing the fns it references (which would intern them as nil cells that - # then shadow the real definitions on the self-rebuild). The flag is absent in - # bare/test contexts that never load core; treat that as ready so those keep - # building the analyzer lazily as before. - (def env (ctx :env)) - (def gated (and (has-key? env :kernel-ready?) (not (get env :kernel-ready?)))) - (when (and (not gated) - (= 0 (length ((ctx-find-ns ctx "jolt.analyzer") :mappings)))) - (build-compiler! ctx))) - -(defn rebuild-compiler! - "Recompile the self-hosted compiler (jolt.ir + jolt.analyzer) against the - CURRENT clojure.core. The fractal turn: once a core tier supplies Clojure - definitions the compiler itself uses, rebuilding makes the compiler run on - them. Idempotent; re-interns the compiler namespaces over the existing cells." - [ctx] - (build-compiler! ctx)) - -(defn- report-diags! - "Render and emit success-type diagnostics (RFC 0006) at the given strictness: - `warn` prints to stderr, `error` throws (failing this form's compilation). - file:line:col when the diagnostic carries an offset and the source is on the - env (jolt-fqy); else the ns." - [ctx diags strictness ns] - (def src (get (ctx :env) :tc-source)) - (def file (or (get (ctx :env) :tc-file) (and ns (string ns)))) - (each d diags - (def off (get d :pos)) - (def loc - (if (and off src) - (let [lc (r/line-col src off)] - (string (or file "?") ":" (in lc 0) ":" (in lc 1))) - (string "in " (if ns (string ns) "?")))) - (def msg (string "type error " loc ": " (get d :msg))) - (if (= strictness "error") - (error msg) - (eprint " " msg)))) - -(defn type-check! - "Decoupled success-type check (RFC 0006): run jolt.passes/check-form as its OWN - inference pass over `ir` and report. Used in NON-direct-link builds, where the - optimization inference doesn't run — so checking costs a separate pass. (In - direct-link builds checking piggybacks on run-passes' inference instead, near - free; see analyze-form.) Protected so a checker bug never breaks compilation. - - JOLT_TYPE_CHECK_USER (an orthogonal opt-in knob, jolt-zo1) additionally - reports calls to user functions whose concrete argument types provably make - the body throw — sound only under the closed-world assumption, hence opt-in." - [ctx ir strictness ns] - (def cf (ns-find (ctx-find-ns ctx "jolt.passes") "check-form")) - (when cf - (def uenv (os/getenv "JOLT_TYPE_CHECK_USER")) - (def strict? (and uenv (not= uenv "0") (not= uenv "off"))) - (def r (protect ((var-get cf) ir strict?))) - (when (r 0) - (def diags (if (pv/pvec? (r 1)) (pv/pv->array (r 1)) (r 1))) - (when (and diags (> (length diags) 0)) - (report-diags! ctx diags strictness ns))))) - -(defn analyze-form - "Run the portable Clojure analyzer (jolt.analyzer/analyze) on a reader form, - returning host-neutral IR." - [ctx form] - (ensure-analyzer ctx) - # Capture the real compile ns: the analyzer runs interpreted (defined in - # jolt.analyzer), and the interpreter rebinds current-ns to a fn's defining ns - # while it runs — so h/current-ns must read this instead of ctx-current-ns. - (put (ctx :env) :compile-ns (ctx-current-ns ctx)) - (def saved-ns (ctx-current-ns ctx)) - (def av (ns-find (ctx-find-ns ctx "jolt.analyzer") "analyze")) - # Pre-kernel bootstrap: ensure-analyzer is gated until the kernel tier loads - # (see api/load-core-overlay!), so a compile request from an earlier tier (e.g. - # 00-syntax's destructure defn) finds no analyzer. That fallback is DESIGNED — - # route it through the sanctioned punt channel rather than crashing on a nil var. - (unless av - (put (ctx :env) :compile-ns nil) - (error "jolt/uncompilable: analyzer not built (pre-kernel bootstrap)")) - # The analyzer runs INTERPRETED; the interpreter rebinds current-ns to a fn's - # defining ns (jolt.analyzer) while it runs and only restores on normal return. - # A punt THROWS out of those frames, leaking jolt.analyzer as current-ns (and - # :compile-ns stayed set) — the fallback interpretation then resolves user vars - # against the wrong ns. Restore both on every exit. - (def r (protect ((var-get av) ctx form))) - (put (ctx :env) :compile-ns nil) - (ctx-set-current-ns ctx saved-ns) - (unless (r 0) (error (r 1))) - # IR passes (jolt.passes/run-passes — nanopass-lite, jolt-2om): pure IR->IR - # rewrites (constant folding, ...) between the analyzer and the back end. - # Resolved lazily; absent during the pre-passes bootstrap window. - (def pv (unless (= "1" (os/getenv "JOLT_NO_IR_PASSES")) - (ns-find (ctx-find-ns ctx "jolt.passes") "run-passes"))) - # Success-type checking level (RFC 0006). JOLT_TYPE_CHECK wins when set; - # otherwise it defaults to `warn` in a direct-link build, where the inference - # already runs so checking piggybacks for nearly free — EXCEPT when direct- - # linking was auto-enabled by a casual program run (:direct-link-auto?), which - # shouldn't spam type warnings. Stays OFF for plain REPL/dev builds too; opt in - # anywhere with JOLT_TYPE_CHECK. (jolt audit) - (def tc (os/getenv "JOLT_TYPE_CHECK")) - (def tc-off (or (= tc "off") (= tc "0"))) - (def direct-link? (if (get (ctx :env) :inline?) true false)) - (def auto-dl? (if (get (ctx :env) :direct-link-auto?) true false)) - (def level (cond tc-off nil tc tc (and direct-link? (not auto-dl?)) "warn" true nil)) - (def uenv (os/getenv "JOLT_TYPE_CHECK_USER")) - (def strict? (and uenv (not= uenv "0") (not= uenv "off") true)) - # piggyback: check DURING run-passes' inference (direct-link, the cheap path) - (def piggyback? (and level direct-link? pv true)) - (def scm (and piggyback? (ns-find (ctx-find-ns ctx "jolt.passes") "set-check-mode!"))) - (when scm ((var-get scm) true strict?)) - (def result - (if pv - (let [pr (protect ((var-get pv) (r 1) ctx))] - # the pass runs interpreted; a throw inside it unwinds past the - # interpreter's ns restores — put the compile ns back either way, or - # the REST of this compilation resolves in jolt.passes - (ctx-set-current-ns ctx saved-ns) - (if (pr 0) (pr 1) (r 1))) - (r 1))) - (when scm ((var-get scm) false false)) - (cond - # direct-link: collect the diagnostics infer-top emitted and report them - piggyback? - (let [td (ns-find (ctx-find-ns ctx "jolt.passes") "take-diags!")] - (when td - (def raw ((var-get td))) - (def diags (if (pv/pvec? raw) (pv/pv->array raw) raw)) - (when (and diags (> (length diags) 0)) - (report-diags! ctx diags level saved-ns)))) - # plain build with checking explicitly requested: a separate inference pass - (and level (not direct-link?)) - (type-check! ctx (r 1) level saved-ns)) - result) - -# The analyzer's deliberate punt signal — (uncompilable why) throws the string -# "jolt/uncompilable: ". Anything else escaping the compile step is an -# unexpected compiler error, not a punt. -(defn- uncompilable-error? [err] - # The punt may arrive as a plain string (compiled analyzer) or wrapped in the - # interpreter's exception struct {:jolt/type :jolt/exception :value s} - # (interpreted analyzer — the stage-3 bootstrap path). - (def msg (if (and (struct? err) (= :jolt/exception (get err :jolt/type))) - (get err :value) - err)) - (and (or (string? msg) (buffer? msg)) - (string/has-prefix? "jolt/uncompilable" (string msg)))) - -(defn compile-and-eval - "Self-hosted compile path: analyze (portable Clojure) -> IR -> Janet -> eval. - The interpreter fallback is DELIBERATE-ONLY (Stage 2): only an analyzer punt - (jolt/uncompilable — the curated stateful/letrec set) falls back; any other - compile-step error is a compiler bug and propagates rather than being silently - hidden by interpretation. Runtime errors in compiled code propagate as before - (no double-eval, no hidden errors)." - [ctx form] - (def compiled (protect (emit-ir ctx (analyze-form ctx form)))) - (if (compiled 0) - (eval (compiled 1) (ctx-janet-env ctx)) - (if (uncompilable-error? (compiled 1)) - (eval-form ctx @{} form) - (error (compiled 1))))) - -(defn self-compile-compiler! - "Stage 3 (interpreted bootstrap): once the overlay + interpreted analyzer are - alive, run the kernel tier, jolt.ir, and jolt.analyzer back through the - SELF-HOSTED pipeline — the analyzer compiles itself (and the kernel fns it - uses), so by steady state the compiler runs compiled with no bootstrap - compiler involved. Forms a punt can't compile stay interpreted (the - deliberate channel)." - [ctx] - (def saved (ctx-current-ns ctx)) - (each [ns-name target] [["clojure.core.00-kernel" "clojure.core"] - ["jolt.ir" "jolt.ir"] - ["jolt.analyzer" "jolt.analyzer"]] - (def src (get (get (ctx :env) :embedded-sources @{}) ns-name)) - (when src - (ctx-set-current-ns ctx target) - (var s src) - (while (> (length (string/trim s)) 0) - (def parsed (r/parse-next s)) - (set s (in parsed 1)) - (def f (in parsed 0)) - (when (not (nil? f)) - (def r (protect (compile-and-eval ctx f))) - (unless (r 0) (eval-form ctx @{} f)))))) - (ctx-set-current-ns ctx saved)) - -(defn analyzer-built? [ctx] - (> (length ((ctx-find-ns ctx "jolt.analyzer") :mappings)) 0)) - -(defn try-compile-fn - "Compile a fn* form to a native Janet fn via the self-hosted pipeline, or nil if - it can't be compiled (analyzer not yet built, or the body isn't compilable). - Used to compile macro expanders for native-speed expansion." - [ctx fn-form] - (when (analyzer-built? ctx) - (def compiled (protect (emit-ir ctx (analyze-form ctx fn-form)))) - (when (compiled 0) - (def r (protect (eval (compiled 1) (ctx-janet-env ctx)))) - (when (r 0) (r 1))))) - -# Wrap expanders in the `fn` MACRO, not the `fn*` primitive: `fn` desugars a -# destructured macro arglist (`[a & [b]]`, `[& {:keys [x]}]`) before lowering, -# whereas raw fn* punts on a destructuring rest param. -(def- fn-sym {:jolt/type :symbol :ns nil :name "fn"}) - -(defn recompile-macros! - "Staged-bootstrap second pass: once the self-hosted analyzer is alive, replace - every interpreted macro expander with a COMPILED one. The early macros (00-syntax - etc.) are defined WHILE the analyzer is still being bootstrapped, so their - expanders can't compile yet (the analyzer they'd compile through doesn't exist) — - defmacro gives them an interpreted closure as a build-time crutch and stashes the - source on the var (:macro-src). This pass compiles that source through the now-live - analyzer and rebinds the var, so by steady state no macro expansion is interpreted - — mirroring how a self-hosting compiler recompiles its seed once it can. - - Idempotent: a var compiled once is marked :macro-compiled and skipped (so the - refer of a core macro into another ns, or a later rebuild, costs nothing). A macro - whose body uses &env/&form keeps its interpreted closure (the compiled fn* has no - such params). Returns the number of expanders compiled this pass." - [ctx] - (var n 0) - (each ns (all-ns ctx) - (each v (ns :mappings) - (when (and (var? v) (var-macro? v) - (v :macro-src) (not (v :macro-compiled)) - (not (v :macro-uses-env))) - (def [args-form body] (v :macro-src)) - (def compiled - (try-compile-fn ctx (array/concat @[fn-sym args-form] body))) - (when compiled - (bind-root v compiled) - (put v :macro-compiled true) - (++ n))))) - n) - -(defn recompile-defns! - "Staged-bootstrap pass for early DEFNS (jolt-4j3) — the defn analog of - recompile-macros!. Pre/at-kernel overlay defns (00-syntax's destructure, - empty?/keys/vals, and the kernel tier in interpret mode) load as interpreted - closures; the evaluator stashes their fn source on the var (:defn-src). - Once the analyzer is alive, compile that source and swap the var's ROOT — - callers go through the var, so they pick up the compiled fn. Skips vars - already done; a body the analyzer can't compile stays interpreted." - [ctx] - (def mappings ((ctx-find-ns ctx "clojure.core") :mappings)) - (var n 0) - (each nm (keys mappings) - (def v (get mappings nm)) - (when (and (table? v) (get v :defn-src) (not (get v :defn-compiled))) - (def compiled (try-compile-fn ctx (get v :defn-src))) - (when compiled - (put v :root compiled) - (put v :defn-compiled true) - (++ n)))) - n) - -# Inter-procedural collection-type inference + recompile (jolt-767, Phase 1), -# closed-world / optimization mode. After a unit loads, every single-fixed-arity -# fn stashed a post-pass :def IR (:infer-ir). We: -# 1. run a whole-unit fixpoint: a fn's param types = lub of its in-unit -# call-site arg types (computed by jolt.passes/infer-body); a fn whose var -# escapes as a VALUE keeps :any params (its callers aren't all visible). -# 2. re-infer + re-emit each fn body with its param types seeded, so -# param-dependent lookups specialize (drop the :jolt/type guard). -# Recompiled bodies are semantically identical to the guarded ones, so this is -# correct regardless of recompile order; order only affects how far a direct- -# linked call propagates the faster callee. -(defn- itype-join [a b] - (cond - (nil? a) b - (nil? b) a - (= a b) a - # compound vector types {:vec ELEM} join element-wise (jolt-d6u) - (and (struct? a) (struct? b) (in a :vec) (in b :vec)) - (struct :vec (itype-join (in a :vec) (in b :vec))) - :any)) - -(defn infer-unit! - # ns-names-arg is one ns-name (per-namespace pass, the default) or a LIST of - # ns-names (whole-program pass, jolt-t34): gathering all units into ONE fixpoint - # propagates param types across namespace boundaries, which the per-ns pass - # can't (a fn's callers in another ns aren't visible when its own ns is typed). - [ctx ns-names-arg] - (def ns-names (if (indexed? ns-names-arg) ns-names-arg [ns-names-arg])) - (def pns (ctx-find-ns ctx "jolt.passes")) - (def f-set-rtenv (and pns (ns-find pns "set-rtenv!"))) - (def f-set-vtypes (and pns (ns-find pns "set-vtypes!"))) - (def f-join (and pns (ns-find pns "join-types"))) - (def f-infer-body (and pns (ns-find pns "infer-body"))) - (def f-reinfer (and pns (ns-find pns "reinfer-def"))) - (def f-reset-esc (and pns (ns-find pns "reset-escapes!"))) - (def f-set-rshapes (and pns (ns-find pns "set-record-shapes!"))) # jolt-t34 - (def f-set-mshapes (and pns (ns-find pns "set-map-shapes!"))) # jolt-t34 - (def f-set-pmethods (and pns (ns-find pns "set-protocol-methods!"))) # jolt-41m - (def f-phint-seed (and pns (ns-find pns "phint-seed"))) # jolt-3ko - (def f-get-esc (and pns (ns-find pns "collected-escapes"))) - (def report @{}) - (when (and f-set-rtenv f-set-vtypes f-join f-infer-body f-reinfer f-reset-esc f-get-esc) - # gather single-fixed-arity fns AND non-fn defs that stashed a :def IR, across - # every ns in ns-names (one ns for the per-unit pass, all for whole-program) - (def fns @[]) - (def defs @[]) - (def by-key @{}) - (def vtypes @{}) # var VALUE types: fns -> :truthy (non-nil), defs -> inferred - (each ns-name ns-names - (def ns (ctx-find-ns ctx ns-name)) - (when ns - (each nm (keys (ns :mappings)) - (def v (get (ns :mappings) nm)) - (when (and (table? v) (get v :infer-ir)) - (def d (norm-node (get v :infer-ir))) - (def init (norm-node (d :init))) - (def key (string ns-name "/" nm)) - (if (= :fn (init :op)) - (let [ars (vview (init :arities))] - (when (= 1 (length ars)) - (def ar (norm-node (in ars 0))) - (unless (ar :rest) - (def pv (vview (ar :params))) - (def rec @{:key key :cell v :def d :params (ar :params) :body (ar :body) - :phints (ar :phints) :np (length pv) - :pt (array/new-filled (length pv)) :ret nil}) - (array/push fns rec) - (put by-key key rec) - # a fn value is non-nil -> :truthy (sealed root in opt mode) - (put vtypes key :truthy)))) - # non-fn def: its value type is inferred from its init (jolt-d6u) - (array/push defs @{:key key :init (d :init) :vt nil})))))) - (when (or (> (length fns) 0) (> (length defs) 0)) - ((var-get f-reset-esc)) - # jolt-t34: feed record-ctor shapes + the map-shaping flag to the inference - (when f-set-rshapes ((var-get f-set-rshapes) (or (get (ctx :env) :record-shapes) @{}))) - (when f-set-mshapes ((var-get f-set-mshapes) (get (ctx :env) :map-shapes?))) - # jolt-3ko: resolve each fn's declared ^Record param hints to positional - # type seeds (needs the registry above). Seeded as a param-type FLOOR in the - # fixpoint so a hinted param propagates its (field-read) types to callees - # during inference, not only at the final re-emit. - (when f-phint-seed - (each f fns - (put f :phint-types (vview ((var-get f-phint-seed) (f :params) (or (f :phints) [])))))) - # jolt-41m: feed the protocol-method registry for devirtualization - (when f-set-pmethods ((var-get f-set-pmethods) (or (get (ctx :env) :protocol-methods) @{}))) - # --- param/return/value-type fixpoint (chaotic iteration to LEAST fixpoint) --- - # Param types are RECOMPUTED FRESH each iteration, not accumulated: :any is - # the lattice top, so a join with an early-iteration :any (a caller whose own - # params weren't typed yet) would poison the result permanently. Recomputing - # from the current state lets a param refine as its callers' types improve. - (var prev-rt @{}) - (var changed true) (var iter 0) - (while (and changed (< iter 16)) - ((var-get f-set-rtenv) prev-rt) - ((var-get f-set-vtypes) vtypes) - # type every fn body once under current param types; stash ret + calls - (each f fns - (def tenv @{}) - (def pv (vview (f :params))) - (for i 0 (f :np) (when (in (f :pt) i) (put tenv (in pv i) (in (f :pt) i)))) - (def res (vview ((var-get f-infer-body) (f :body) tenv))) - (put f :tret (in res 0)) - (put f :tcalls (in res 2))) - # infer each def's VALUE type from its init - (each dv defs - (put dv :tvt (in (vview ((var-get f-infer-body) (dv :init) @{})) 0))) - # recompute param types FRESH (start at bottom) from this round's calls. - # Bottom is nil, EXCEPT a declared ^Record hint seeds its slot as a floor - # (jolt-3ko) — a fixed declared type can't poison the fixpoint the way an - # early-iteration :any would, and it lets a hinted param propagate to its - # callees even when it has no callers of its own. - (def newpt @{}) - (each f fns - (def npa (array/new-filled (f :np))) - (def phts (f :phint-types)) - (when phts (for i 0 (f :np) (when (in phts i) (put npa i (in phts i))))) - (put newpt (f :key) npa)) - (each f fns - (each c (vview (f :tcalls)) - (def cv (vview c)) - (def npa (get newpt (in cv 0))) - (when npa - (def callee (get by-key (in cv 0))) - (def ats (vview (in cv 1))) - (def lim (min (length ats) (callee :np))) - (for i 0 lim (put npa i ((var-get f-join) (in npa i) (in ats i))))))) - # commit + detect change - (set changed false) - (def nrt @{}) - (each f fns - (def np (get newpt (f :key))) - (for i 0 (f :np) (when (not= (in np i) (in (f :pt) i)) (set changed true))) - (when (not= (f :tret) (f :ret)) (set changed true)) - (put f :pt np) - (put f :ret (f :tret)) - (when (f :tret) (put nrt (f :key) (f :tret)))) - (each dv defs - (when (not= (dv :tvt) (dv :vt)) (set changed true)) - (put dv :vt (dv :tvt)) - (when (dv :tvt) (put vtypes (dv :key) (dv :tvt)))) - (set prev-rt nrt) - (++ iter)) - # --- escaped fns: var used as a value -> params untrustworthy -> skip --- - (def esc @{}) - (each k (vview ((var-get f-get-esc))) (put esc k true)) - # install the FINAL return + value types so reinfer-def sees them - (def final-rt @{}) - (each f fns (when (f :ret) (put final-rt (f :key) (f :ret)))) - ((var-get f-set-rtenv) final-rt) - ((var-get f-set-vtypes) vtypes) - # --- re-emit the WHOLE unit, callees first (jolt-d6u) ------------------- - # Re-inference alone only rebinds a fn's own var, but the hot path runs - # through callee bodies INLINED / direct-linked into callers at first - # compile. Re-emitting in callee-first (reverse-topological) order makes - # each caller re-embed its now-recompiled callees, and re-infers its body - # (typing locals via return inference) — so the specialization propagates, - # and a call site compiled AFTER this pass (the -e entry) links the whole - # recompiled chain. Every fn is re-emitted, not just those with concrete - # params, so the embedding refreshes even where a fn gained no param type. - (def order @[]) - (def seen @{}) - (defn visit [k] - (unless (get seen k) - (put seen k true) - (def f (get by-key k)) - (when f - (each c (vview (f :tcalls)) (visit (in (vview c) 0))) - (array/push order f)))) - (each f fns (visit (f :key))) - (each f order - (put report (f :key) (f :pt)) - (def ptmap @{}) - # escaped fn: its param types are untrustworthy (callers not all visible), - # so re-emit it WITHOUT seeding params (still re-embeds recompiled callees). - (unless (get esc (f :key)) - (def pv (vview (f :params))) - (for i 0 (f :np) - (def t (in (f :pt) i)) - (when (and t (not= t :any)) (put ptmap (in pv i) t)))) - (def def2 ((var-get f-reinfer) (f :def) ptmap)) - (protect (eval (emit-ir ctx def2) (ctx-janet-env ctx)))))) - report) - -(defn infer-program! - "Whole-program closed-world pass (jolt-t34, opt-in JOLT_WHOLE_PROGRAM): run ONE - inference fixpoint over every user namespace at once, so param types propagate - across namespace boundaries (the per-ns pass can't see a fn's callers in other - units). Sound only under the closed-world assumption — direct-linking, no later - eval/redefinition — which the flag asserts. The recorded ns list is in load - (topological) order; the fixpoint is order-independent but re-emit is callee- - first regardless." - [ctx] - (def nses (get (ctx :env) :inferred-nses)) - (when (and nses (> (length nses) 0)) - (infer-unit! ctx nses))) - -(defn ensure-macros-compiled! - "Called once the overlay is fully loaded (api/load-core-overlay!): ensure the - analyzer is built, then run the staged macro-recompile pass so the early - (interpreted-during-bootstrap) macro expanders become compiled. Runs in EVERY - mode — macro expansion is compiled code even when evaluation is interpreted - (in interpret mode the tiers load fast interpreted, then this one pass builds - the analyzer and compiles all stashed expanders; the analyzer itself stays - interpreted there). :compile-macros? false (JOLT_INTERPRET_MACROS=1) skips it, - keeping the fully-interpreted oracle. Cheap to call again (recompile-macros! - skips already-compiled vars)." - [ctx] - (when (get (ctx :env) :compile-macros?) - (ensure-analyzer ctx) - (when (analyzer-built? ctx) - # defns first: the expanders call them, and a recompiled expander that - # ran before the defn pass still resolves through the var either way. - (recompile-defns! ctx) - (recompile-macros! ctx)))) diff --git a/src/jolt/cgen.janet b/src/jolt/cgen.janet deleted file mode 100644 index 4cac298..0000000 --- a/src/jolt/cgen.janet +++ /dev/null @@ -1,353 +0,0 @@ -# Native code generation: jolt IR -> C, for hot numeric-leaf fns (jolt-ihdp, the -# lever-1 native-codegen tier of epic jolt-5vsp). The spike -# (docs/foundational-runtime-lever1-native-codegen.md) showed native-C compute -# beats the Janet-VM floor (~18-22x faster than bytecode, edges out JVM Clojure), -# and that compiling a hot LEAF fn to C — called from a bytecode loop — captures -# the win because the forward (bytecode -> C) crossing is nearly free. -# -# This module is the IR -> C translator + a cc/load driver. It is a standalone -# library: nothing wires it into the default compile path yet (that — detecting -# hot fns and installing the C version onto the var cell — is the next step). A -# fn is a candidate only if its whole body is numeric (params/locals/return are -# numbers, all calls are native-op arithmetic): then everything stays in C -# `double`s, unboxed at entry and reboxed at return, with no Janet in the hot loop. -(import ./core_types :as ct) -(import ./phm :as phm) - -(defn- norm-node [n] (if (phm/phm? n) (phm/phm-to-struct n) n)) - -# jolt core fn name -> {:c "" :kind :infix|:incdec}. The subset of -# backend/native-ops that maps to a C double operator with matching semantics. -# (mod/rem/bit-ops/min/max deliberately omitted for now — they need helper calls -# or differ from C operators; add them as the candidate grammar grows.) -(def- c-ops - {"+" {:c "+" :kind :infix} "-" {:c "-" :kind :infix} - "*" {:c "*" :kind :infix} "/" {:c "/" :kind :infix} - "<" {:c "<" :kind :infix} ">" {:c ">" :kind :infix} - "<=" {:c "<=" :kind :infix} ">=" {:c ">=" :kind :infix} - "=" {:c "==" :kind :infix} - "inc" {:c "+" :kind :incdec} "dec" {:c "-" :kind :incdec}}) - -(defn- args-of [node] (ct/vview (node :args))) - -# A native-op invoke -> its c-ops entry, else nil (the head must be a clojure.core -# ref to a supported primitive at the right arity). -(defn- op-for [node] - (def n (norm-node node)) - (def f (and (= :invoke (n :op)) (norm-node (n :fn)))) - (and f (= :var (f :op)) (= "clojure.core" (f :ns)) - (let [op (get c-ops (f :name)) - nargs (length (args-of n))] - (and op - (if (= (op :kind) :incdec) (= 1 nargs) (= 2 nargs)) - op)))) - -# --- candidate check: every node in the body is C-translatable --- -(var- numeric-ok? nil) -(defn- bindings-ok? [node] - (all (fn [pair] (numeric-ok? (in (ct/vview pair) 1))) (ct/vview (node :bindings)))) -(set numeric-ok? - (fn numeric-ok? [raw] - (def node (norm-node raw)) - (case (node :op) - :const (number? (node :val)) - :local true - :if (and (numeric-ok? (node :test)) (numeric-ok? (node :then)) (numeric-ok? (node :else))) - :do (and (all numeric-ok? (ct/vview (node :statements))) (numeric-ok? (node :ret))) - :let (and (bindings-ok? node) (numeric-ok? (node :body))) - :loop (and (bindings-ok? node) (numeric-ok? (node :body))) - :recur (all numeric-ok? (args-of node)) - :invoke (and (op-for node) (all numeric-ok? (args-of node))) - false))) - -(defn fn-ir-of - "Unwrap a :def-of-fn or a bare :fn IR node to the :fn node, or nil." - [ir] - (def n (norm-node ir)) - (def init (norm-node (get n :init n))) - (and (= :fn (init :op)) init)) - -(defn numeric-leaf? - "True when ir is a single-fixed-arity fn whose entire body is C-translatable - (numeric in, numeric out, only native-op arithmetic)." - [ir] - (def fnode (fn-ir-of ir)) - (and fnode - (let [ars (ct/vview (fnode :arities))] - (and (= 1 (length ars)) - (not ((first ars) :rest)) - (numeric-ok? ((first ars) :body)))))) - -# --- C generation --- -# scope: jolt-local-name (string) -> C var name. Fresh C names sidestep charset -# and keyword collisions. rctx (recur target): {:vars [c-names] :flag flag-name}. - -(defn- new-namer [] - (def counter @[0]) - (fn [] (def n (in counter 0)) (put counter 0 (+ n 1)) (string "v" n))) - -(defn- fmtnum [x] - (def s (string/format "%.17g" (* 1.0 x))) - (if (or (string/find "." s) (string/find "e" s) (string/find "n" s)) s (string s ".0"))) - -(var- c-expr nil) -(set c-expr - (fn c-expr [raw scope] - (def node (norm-node raw)) - (case (node :op) - :const (fmtnum (node :val)) - :local (or (get scope (node :name)) (error (string "cgen: unbound local " (node :name)))) - :invoke (let [op (op-for node) as (args-of node)] - (if (= (op :kind) :incdec) - (string "(" (c-expr (in as 0) scope) " " (op :c) " 1)") - (string "(" (c-expr (in as 0) scope) " " (op :c) " " (c-expr (in as 1) scope) ")"))) - (error (string "cgen: non-pure op in expr position: " (node :op)))))) - -(defn- pure? [node] - (case (node :op) :const true :local true :invoke (truthy? (op-for node)) false)) - -# emit-to: append C statements that compute node's (double) value into dest. -# Control-flow forms (if/do/let/loop/recur) lower to statements; pure nodes to a -# single assignment. A comparison yields C int 0/1, which is a fine double here. -(var- emit-to nil) -(set emit-to - (fn emit-to [raw dest scope rctx out namer] - (def node (norm-node raw)) - (case (node :op) - :if (let [t (namer)] - (buffer/push out "double " t ";\n") - (emit-to (node :test) t scope rctx out namer) - (buffer/push out "if (" t " != 0.0) {\n") - (emit-to (node :then) dest scope rctx out namer) - (buffer/push out "} else {\n") - (emit-to (node :else) dest scope rctx out namer) - (buffer/push out "}\n")) - :do (do (each s (ct/vview (node :statements)) - (def junk (namer)) (buffer/push out "double " junk ";\n") - (emit-to s junk scope rctx out namer)) - (emit-to (node :ret) dest scope rctx out namer)) - :let (let [scope2 (table/clone scope)] - (each pair (ct/vview (node :bindings)) - (def p (ct/vview pair)) - (def cv (namer)) - (buffer/push out "double " cv ";\n") - (emit-to (in p 1) cv scope2 rctx out namer) - (put scope2 (string (in p 0)) cv)) - (emit-to (node :body) dest scope2 rctx out namer)) - :loop (let [scope2 (table/clone scope) cvars @[] flag (namer)] - (each pair (ct/vview (node :bindings)) - (def p (ct/vview pair)) - (def cv (namer)) - (buffer/push out "double " cv ";\n") - (emit-to (in p 1) cv scope2 rctx out namer) - (put scope2 (string (in p 0)) cv) - (array/push cvars cv)) - (buffer/push out "int " flag " = 1;\n") - (buffer/push out "while (" flag ") {\n" flag " = 0;\n") - (emit-to (node :body) dest scope2 {:vars cvars :flag flag} out namer) - (buffer/push out "}\n")) - # recur: compute new values into temps first (avoid clobbering loop vars - # mid-update), then assign and set the continue flag. Produces no value — - # the enclosing while re-runs. - :recur (let [as (args-of node) tmps @[]] - (each a as - (def tv (namer)) - (buffer/push out "double " tv ";\n") - (emit-to a tv scope rctx out namer) - (array/push tmps tv)) - (for i 0 (length tmps) - (buffer/push out (in (rctx :vars) i) " = " (in tmps i) ";\n")) - (buffer/push out (rctx :flag) " = 1;\n")) - (if (pure? node) - (buffer/push out dest " = " (c-expr node scope) ";\n") - (error (string "cgen: unsupported op " (node :op))))))) - -(defn- sanitize [name] - (def b @"") - (each c name - (buffer/push b (if (or (and (>= c 97) (<= c 122)) (and (>= c 65) (<= c 90)) - (and (>= c 48) (<= c 57)) (= c 95)) c 95))) - (string b)) - -# Emit just the `static Janet cfun_(...) { ... }` definition for one fn -# into buf. Shared by the single-fn and multi-fn (AOT module) generators. -(defn- emit-cfun [buf ir c-name] - (def fnode (fn-ir-of ir)) - (def ar (first (ct/vview (fnode :arities)))) - (def params (map string (ct/vview (ar :params)))) - (def namer (new-namer)) - (def scope @{}) - (buffer/push buf "static Janet cfun_" c-name "(int32_t argc, Janet *argv) {\n") - (buffer/push buf "janet_fixarity(argc, " (string (length params)) ");\n") - (eachp [i pn] params - (def cv (namer)) - (buffer/push buf "double " cv " = janet_getnumber(argv, " (string i) ");\n") - (put scope pn cv)) - (def ret (namer)) - (buffer/push buf "double " ret ";\n") - (emit-to (ar :body) ret scope nil buf namer) - (buffer/push buf "return janet_wrap_number(" ret ");\n}\n")) - -(defn gen-c-module - "entries: [{:sym :ir } ...] -> C source for - ONE Janet native module exporting every entry's :sym as a cfunction. This is - the AOT/build-time shape (jolt-a7ds): all of an app's hot fns in a single .so, - compiled once at build time. Assumes each :ir is a numeric leaf." - [entries] - (def buf @"") - (buffer/push buf "#include \n") - (each e entries (emit-cfun buf (e :ir) (e :sym))) - (buffer/push buf "static const JanetReg cfuns[] = {\n") - (each e entries - (buffer/push buf " {\"" (e :sym) "\", cfun_" (e :sym) ", NULL},\n")) - (buffer/push buf " {NULL, NULL, NULL}};\n") - (buffer/push buf "JANET_MODULE_ENTRY(JanetTable *env) { janet_cfuns(env, \"cg\", cfuns); }\n") - (string buf)) - -(defn gen-c-fn - "ir (a numeric-leaf :def-of-fn or :fn node), c-name -> C source for a Janet - native module exporting `c-name` as a cfunction. Assumes (numeric-leaf? ir)." - [ir c-name] - (gen-c-module [{:sym c-name :ir ir}])) - -# --- toolchain --- -(defn header-dir - "Directory containing janet.h, probed from syspath + common prefixes, or nil." - [] - (def sp (dyn :syspath)) - (def cands @[(string sp "/../../include") "/opt/homebrew/include" - "/usr/local/include" "/usr/include"]) - (var found nil) - (each c cands (when (and (not found) (os/stat (string c "/janet.h"))) (set found c))) - found) - -(defn toolchain-available? - "True when a C compiler and janet.h are present (so compile-fn can work). Never - throws: a missing cc (not on PATH) makes os/execute raise, so guard it — a - toolchain-less deploy target must get false, not a crash." - [] - (and (header-dir) - (let [r (protect (os/execute ["cc" "--version"] :p - {:out (file/open "/dev/null" :w) - :err (file/open "/dev/null" :w)}))] - (and (r 0) (= 0 (r 1)))))) - -(defn- mkdirs [path] - (def parts (filter |(not (empty? $)) (string/split "/" path))) - (var acc (if (string/has-prefix? "/" path) "" ".")) - (each p parts (set acc (string acc "/" p)) (os/mkdir acc))) - -(defn- cache-dir [] - # Persistent across runs (like the ctx image cache, which also defaults to - # TMPDIR). Override with JOLT_CGEN_CACHE_DIR. - (string (or (os/getenv "JOLT_CGEN_CACHE_DIR") (os/getenv "TMPDIR") "/tmp") "/jolt-cgen")) - -(defn- cc-compile [cpath sopath] - # macOS needs -undefined dynamic_lookup so the module's janet_* refs resolve - # against the host at load time; ELF (Linux/BSD) resolves them then anyway. - (def cmd @["cc" "-shared" "-fPIC" "-O2" (string "-I" (header-dir))]) - (when (= :macos (os/which)) (array/push cmd "-undefined") (array/push cmd "dynamic_lookup")) - (array/push cmd cpath "-o" sopath) - (def r (os/execute cmd :p)) - (unless (= 0 r) (error (string "cgen: cc failed (" r ") for " cpath)))) - -(defn- abspath [p] (if (string/has-prefix? "/" p) p (string (os/cwd) "/" p))) - -# Build a .so from C source, content-addressed and cached. The C + Janet ABI + -# platform fully determine the .so, so a matching cache entry is always valid. -# Returns the absolute .so path. JOLT_CGEN_NO_CACHE=1 forces a rebuild. -(defn- build-so [src dir] - (def stamp (string src "|" janet/version "-" janet/build "|" (os/which))) - (def key (string (band (hash stamp) 0x7FFFFFFF) "-" (length src))) - (mkdirs dir) - (def base (string dir "/cg-" key)) - (def sopath (string base ".so")) - (def abs (abspath sopath)) - (unless (and (not (os/getenv "JOLT_CGEN_NO_CACHE")) (os/stat abs)) - (def cpath (string base ".c")) - (spit cpath src) - (cc-compile cpath sopath)) - abs) - -(defn load-module - "Load a prebuilt cgen .so (NO cc — works on a target with no toolchain) and - return a table of symbol-string -> cfunction for every cfunction it exports. - This is the runtime side of the build-time/AOT path (jolt-a7ds)." - [sopath] - (def env @{}) - (native (abspath sopath) env) - (def out @{}) - (eachp [k v] env - (when (and (symbol? k) (table? v) (or (cfunction? (v :value)) (function? (v :value)))) - (put out (string k) (v :value)))) - out) - -(defn compile-module - "AOT path: compile MANY numeric-leaf fns into ONE native module, once, at build - time. entries: [{:sym :ir } ...]. Returns - {:sopath :fns {sym -> cfunction}}, or nil if the toolchain is absent - or any entry isn't a numeric leaf. opts: :dir (cache dir)." - [entries &opt opts] - (default opts {}) - (when (and (header-dir) (all |(numeric-leaf? ($ :ir)) entries)) - (def src (gen-c-module entries)) - (def sopath (build-so src (get opts :dir (cache-dir)))) - {:sopath sopath :fns (load-module sopath)})) - -(defn compile-fn - "Compile a single numeric-leaf fn IR to a native Janet cfunction. Returns the - cfunction, or nil if ir isn't a candidate or the toolchain is unavailable. - opts: :dir (cache dir, default a persistent jolt-cgen under TMPDIR), :name (C - identifier base). Content-addressed/cached like compile-module." - [ir &opt opts] - (default opts {}) - (when (and (numeric-leaf? ir) (header-dir)) - (def c-name (sanitize (get opts :name "jolt_cfn"))) - (def src (gen-c-fn ir c-name)) - (def sopath (build-so src (get opts :dir (cache-dir)))) - (def env @{}) - (native sopath env) - ((get env (symbol c-name)) :value))) - -# --- AOT build/deploy (jolt-a7ds) --------------------------------------------- -# Build phase (needs cc): collect an app's numeric-leaf fns (the backend's -# :cgen-collect? mode fills (ctx :env) :cgen-collected with [{:ns :name :ir}]), -# compile them all into ONE native module, and write a manifest. Deploy phase -# (NO cc, target needs no toolchain): load the prebuilt module + manifest into a -# qname->cfunction map that the backend installs as var roots (:cgen-prebuilt). - -(defn aot-build - "collected: [{:ns :name :ir} ...] (numeric-leaf fns). Compile them into one - native module and return {:sopath :entries [{:ns :name :sym}]}, or - nil (toolchain absent / a non-leaf / empty). opts: :dir (cache dir). - Syms are positional (f0, f1, ...) so they're collision-free." - [collected &opt opts] - (default opts {}) - (when (and (header-dir) (not (empty? collected))) - (def entries @[]) - (def manifest @[]) - (eachp [i e] collected - (def sym (string "f" i)) - (array/push entries {:sym sym :ir (e :ir)}) - (array/push manifest {:ns (e :ns) :name (e :name) :sym sym})) - (def m (compile-module entries opts)) - (and m {:sopath (m :sopath) :entries manifest}))) - -(defn write-manifest - "Persist an aot-build result to path as jdn (the deploy side reads it)." - [path build] - (spit path (string/format "%j" build))) - -(defn load-aot - "Deploy side (NO cc): read a manifest written by write-manifest, load its - prebuilt .so, and return a qname (\"ns/name\") -> cfunction map suitable for - (ctx :env) :cgen-prebuilt. nil if the manifest/.so is missing." - [manifest-path] - (when (os/stat manifest-path) - (def build (parse (slurp manifest-path))) - (def fns (load-module (build :sopath))) - (def out @{}) - (each e (build :entries) - (when-let [f (get fns (e :sym))] - (put out (string (e :ns) "/" (e :name)) f))) - out)) diff --git a/src/jolt/cgen_build.janet b/src/jolt/cgen_build.janet deleted file mode 100644 index 76a49f0..0000000 --- a/src/jolt/cgen_build.janet +++ /dev/null @@ -1,211 +0,0 @@ -# Single-binary native build (jolt-a7ds, epic jolt-5vsp). The AOT path -# (cgen.janet) compiles an app's numeric-leaf fns into one prebuilt .so + a -# manifest, loaded at deploy with no cc. This module fuses that native code into -# the jpm-built executable so an app ships as ONE static file: no sidecar .so, no -# toolchain on the target. -# -# Shape (validated by the spike, docs/foundational-runtime-lever1-native-codegen.md): -# a staging dir with `src`/`jolt-core` symlinks into the jolt source tree, the -# generated cg.c (native module of the app's hot fns), an uberscript-style bundle -# of the app source, and an entry that bakes the jolt runtime, installs the native -# fns as var roots (:cgen-prebuilt), and runs -main. `jpm build` static-links cg.a -# (declare-native builds it) into the final exe. Build needs cc; the result does -# not. See build-app for the driver and `jolt cgen-build` (main.janet) for the CLI. -(import ./api :as api) -(import ./types :as t) -(import ./cgen :as cgen) - -# --- jolt source location ---------------------------------------------------- -# Baking the runtime into the app binary needs the jolt source tree (src/jolt + -# jolt-core). The shipped binary doesn't carry its own source, so locate a -# checkout: JOLT_HOME wins, else walk up from cwd for the marker files. -(defn- jolt-home? [d] - (and (os/stat (string d "/src/jolt/api.janet")) - (os/stat (string d "/jolt-core")))) - -(defn find-jolt-home - "Directory of a jolt source checkout (has src/jolt + jolt-core), or nil. - JOLT_HOME overrides; otherwise walk up from `start` (default cwd)." - [&opt start] - (def env-home (os/getenv "JOLT_HOME")) - (cond - (and env-home (jolt-home? env-home)) env-home - (do - (var d (or start (os/cwd))) - (var found nil) - (while (and (not found) (> (length d) 1)) - (if (jolt-home? d) - (set found d) - (set d (string/slice d 0 (max 0 (last (string/find-all "/" d))))))) - found))) - -# --- generation -------------------------------------------------------------- -(defn gen-c-and-manifest - "collected: [{:ns :name :ir} ...] (numeric-leaf fns from a :cgen-collect? load). - Emit the C source for ONE native module exporting them all, plus a positional - manifest [{:ns :name :sym} ...] mapping each app fn to its C symbol. Mirrors - cgen/aot-build but yields C source (compiled at build) rather than a .so." - [collected] - (def entries @[]) - (def manifest @[]) - (eachp [i e] collected - (def sym (string "f" i)) - (array/push entries {:sym sym :ir (e :ir)}) - (array/push manifest {:ns (e :ns) :name (e :name) :sym sym})) - {:c-src (cgen/gen-c-module entries) :manifest manifest}) - -(defn bundle-source - "Concatenate the app's loaded source files (load order: deps before dependents) - into one closed-world bundle the baked entry can eval. Verbatim — DCE is the - uberscript path's concern, not needed here for correctness." - [files] - (def buf @"") - (each f files - (buffer/push-string buf "; --- " f " ---\n" (slurp f) "\n")) - (string buf)) - -(defn collect-app - "Load main-ns through the full pipeline with :cgen-collect? on (records the - numeric-leaf fns' IR without swapping roots), returning the collected fns and - the source files loaded (for the bundle). source-roots seed :source-paths so - the app + its deps resolve. Throws on a load error." - [main-ns source-roots] - (def ctx (api/init-cached {:compile? true})) # discarded; cached for speed - (each r source-roots - (when (> (length r) 0) (array/push (get (ctx :env) :source-paths) r))) - (put (ctx :env) :direct-linking? true) - (put (ctx :env) :cgen-collect? true) - (put (ctx :env) :loaded-files @[]) - (api/load-string ctx (string "(require '[" main-ns "])") "") - (def seen @{}) - (def files @[]) - (each f (get (ctx :env) :loaded-files) - (unless (get seen f) (put seen f true) (array/push files f))) - {:collected (or (get (ctx :env) :cgen-collected) @[]) :files files}) - -(defn run-main! - "Runtime helper baked into a generated app binary: bind *command-line-args* to - args (a tuple/array of strings) and invoke main-ns/-main." - [ctx main-ns args] - (def core (t/ctx-find-ns ctx "clojure.core")) - (t/ns-intern core "*command-line-args*" (tuple/slice (tuple ;args))) - (api/eval-string ctx (string "(apply " main-ns "/-main *command-line-args*)"))) - -(defn gen-entry-source - "The generated main.janet: imports the jolt runtime + the static cg module, - builds qname->cfunction from the manifest, bakes the ctx with the app compiled - and the native fns installed as roots, and runs -main at startup. Strings are - emitted with %j so embedded source/manifest can't break the quoting." - [main-ns app-source manifest] - (string - "# Generated by `jolt cgen-build` — do not edit.\n" - "(import \"./src/jolt/api\" :as api)\n" - "(import \"./src/jolt/cgen_build\" :as cb)\n" - "(import \"./cg\" :as cg)\n\n" - "(def manifest " (string/format "%j" manifest) ")\n" - "(def app-source " (string/format "%j" app-source) ")\n" - "(def main-ns " (string/format "%j" main-ns) ")\n\n" - "(def cg-env (require \"./cg\"))\n" - "(def prebuilt\n" - " (let [tb @{}]\n" - " (each e manifest\n" - " (when-let [cell (get cg-env (symbol (e :sym)))]\n" - " (put tb (string (e :ns) \"/\" (e :name)) (get cell :value))))\n" - " tb))\n\n" - "(def ctx (api/init {:compile? true}))\n" - "(put (ctx :env) :direct-linking? true)\n" - "(put (ctx :env) :cgen-prebuilt prebuilt)\n" - "(api/load-string ctx app-source \"app.clj\")\n\n" - "(defn main [&]\n" - " (def args (or (dyn :args) @[]))\n" - " (cb/run-main! ctx main-ns (slice args 1)))\n")) - -(defn gen-project-source - "The generated project.janet. The executable's entry imports cg at build - (dofile) and static-links cg.a, so both must build first — jpm infers neither, - and cg.a isn't pulled into a non-release `build` task, so wire deps explicitly." - [exe-name] - (string - "(declare-project :name \"jolt-cgen-app\")\n\n" - "(declare-native :name \"cg\" :source @[\"cg.c\"])\n\n" - "(declare-executable :name " (string/format "%j" exe-name) " :entry \"main.janet\")\n\n" - "(add-dep \"./" exe-name "\" \"./cg.so\")\n" - "(add-dep \"./" exe-name "\" \"./cg.a\")\n")) - -# --- driver ------------------------------------------------------------------ -(defn- mkdir-p [path] - (def parts (filter |(not (empty? $)) (string/split "/" path))) - (var acc (if (string/has-prefix? "/" path) "" ".")) - (each p parts (set acc (string acc "/" p)) (os/mkdir acc))) - -(defn- rm-rf [path] - # lstat, never stat: the staging dir holds symlinks INTO the jolt tree - # (src, jolt-core); following them would delete real source. A symlink — even - # one pointing at a directory — is removed with os/rm, not recursed into. - (when-let [st (os/lstat path)] - (if (= :directory (st :mode)) - (do (each e (os/dir path) (rm-rf (string path "/" e))) (os/rmdir path)) - (os/rm path)))) - -(defn build-app - "Build main-ns into a single static executable at :out. Needs cc + jpm at build - time; the result needs neither. opts: - :main app namespace (string, required) - :out output binary path (required) - :jolt-home jolt source checkout (default: find-jolt-home) - :source-roots extra source roots for the app + deps (default from JOLT_PATH) - :stage staging dir (default: a fresh temp dir; removed unless :keep) - :keep keep the staging dir for inspection - Returns {:out :native-count :stage }." - [opts] - (def main-ns (assert (opts :main) "cgen-build: :main namespace required")) - (def out (assert (opts :out) "cgen-build: :out path required")) - (def home (or (opts :jolt-home) (find-jolt-home))) - (assert home "cgen-build: could not locate jolt source (set JOLT_HOME)") - (def source-roots - (or (opts :source-roots) - (let [jp (os/getenv "JOLT_PATH")] - (if jp (filter |(> (length $) 0) (string/split ":" jp)) @[])))) - (def exe-name "app") - - # 1. Collect the app's numeric-leaf fns + its full source bundle. - (def {:collected collected :files files} (collect-app main-ns source-roots)) - (def {:c-src c-src :manifest manifest} (gen-c-and-manifest collected)) - (def app-source (bundle-source files)) - - # 2. Stage: symlinks into the jolt tree + the generated build inputs. - (def stage - (or (opts :stage) - (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-cgen-build-" - (string/format "%x" (band (hash (string main-ns out)) 0x7fffffff))))) - (rm-rf stage) - (mkdir-p stage) - (os/symlink (string home "/src") (string stage "/src")) - (os/symlink (string home "/jolt-core") (string stage "/jolt-core")) - (spit (string stage "/cg.c") c-src) - (spit (string stage "/main.janet") (gen-entry-source main-ns app-source manifest)) - (spit (string stage "/project.janet") (gen-project-source exe-name)) - - # 3. jpm build in the staging dir (cwd + JANET_BUILDPATH=. so artifacts land - # beside the entry, where ./cg and cg.a resolve). - (def prev-cwd (os/cwd)) - (def prev-bp (os/getenv "JANET_BUILDPATH")) - (defer (do (os/cd prev-cwd) (os/setenv "JANET_BUILDPATH" prev-bp)) - (os/cd stage) - (os/setenv "JANET_BUILDPATH" ".") - # --workers=1: the build shells out to cc; one worker keeps it from saturating - # every core (it runs inside the parallel test gate, where that starves - # siblings into timeouts). Only a few small C files, so the cost is marginal. - (def code (os/execute ["jpm" "--workers=1" "build"] :p)) - (os/cd prev-cwd) - (unless (= 0 code) (error (string "cgen-build: jpm build failed (" code ")")))) - - # 4. Install the binary, then clean up staging. - (def built (string stage "/" exe-name)) - (assert (os/stat built) (string "cgen-build: expected binary at " built)) - (let [od (string/slice out 0 (max 0 (last (or (string/find-all "/" out) [0]))))] - (when (> (length od) 0) (mkdir-p od))) - (spit out (slurp built)) - (os/chmod out 8r755) - (unless (opts :keep) (rm-rf stage)) - {:out out :native-count (length manifest) :stage stage}) diff --git a/src/jolt/config.janet b/src/jolt/config.janet deleted file mode 100644 index ceef368..0000000 --- a/src/jolt/config.janet +++ /dev/null @@ -1,76 +0,0 @@ -# Build-time collection mode. -# -# Jolt can be built with either immutable (persistent) collections — proper -# Clojure value semantics — or fast Janet-native mutable collections. -# -# jpm build # immutable (default) -# JOLT_MUTABLE=1 jpm build # mutable -# -# This reads the environment at module-load time, so for a jpm-compiled -# executable the value is fixed when the binary is built (a true compile flag). -# `mutable?` is a constant, so the type-mode branches throughout core fold away. -(def mutable? (= "1" (os/getenv "JOLT_MUTABLE"))) - -# Convenience: immutable? is the default. -(def immutable? (not mutable?)) - -# --------------------------------------------------------------------------- -# Run-mode + cache-key policy (jolt-q5ql). Lifted out of main so it is unit- -# testable without the CLI and so the disk-cache keys share ONE canonical list -# of ctx-shaping env vars (a positional %q key silently misaligned if a knob was -# added in only one place — the footgun this fixes). -# --------------------------------------------------------------------------- - -# Every env var that shapes the built/optimized ctx. Both image caches key on -# this exact list, so adding a knob here updates every cache key at once. -(def ctx-shaping-env-vars - ["JOLT_PATH" "JOLT_APP_PATHS" "JOLT_MUTABLE" "JOLT_AOT_CORE" "JOLT_FEATURES" - "JOLT_INTERPRET" "JOLT_INTERPRET_MACROS" "JOLT_DIRECT_LINK" - "JOLT_NO_DIRECT_LINK" "JOLT_OPTIMIZE" "JOLT_WHOLE_PROGRAM" - "JOLT_NO_WHOLE_PROGRAM" "JOLT_SHAPE" "JOLT_NO_SHAPE" - "JOLT_NO_IR_PASSES" "JOLT_CHECK_HINTS" "JOLT_CGEN"]) - -(defn ctx-cache-key - "Build a disk-cache key from labeled prefix pairs plus the value of every - ctx-shaping env var. Each component is tagged by name (`label=value`), so a - new knob can't positionally alias two different builds. `prefix` is a flat - array of label,value,label,value,... (e.g. version + entry ns + opts)." - [prefix] - (def parts @[]) - (var i 0) - (while (< i (length prefix)) - (array/push parts (string/format "%s=%q" (in prefix i) (in prefix (+ i 1)))) - (+= i 2)) - (each ev ctx-shaping-env-vars - (array/push parts (string/format "%s=%q" ev (os/getenv ev)))) - (string/join parts "|")) - -(defn resolve-run-mode - "Resolve the compile/optimization knobs from argv-derived flags + env. - `open-mode?` = an interactive/non-program invocation (repl/-e/help/uberscript); - `main-entry?` = a -m/-M program entry. Returns the ctx env knob map that main - installs. Explicit env always wins (JOLT_NO_DIRECT_LINK / JOLT_DIRECT_LINK)." - [open-mode? main-entry?] - (def dl-forced - (cond (os/getenv "JOLT_NO_DIRECT_LINK") :off - (= "1" (os/getenv "JOLT_DIRECT_LINK")) :on - :none)) - (def dl (case dl-forced :off false :on true (not open-mode?))) - # Inference/specialization is the expensive part — default OFF, opt in with - # JOLT_OPTIMIZE (or an explicit JOLT_DIRECT_LINK, which signals a full build). - (def optimize? - (and dl (or (not (nil? (os/getenv "JOLT_OPTIMIZE"))) - (= "1" (os/getenv "JOLT_DIRECT_LINK"))))) - {:direct-linking? dl - :inline? optimize? - # auto-enabled (vs explicitly requested) — suppresses the checker default-on. - :direct-link-auto? (and dl (= dl-forced :none)) - :shapes? (and dl (not (os/getenv "JOLT_NO_SHAPE"))) - :map-shapes? (and (os/getenv "JOLT_SHAPE") (not (os/getenv "JOLT_NO_SHAPE"))) - :whole-program? (and optimize? - (not (os/getenv "JOLT_NO_WHOLE_PROGRAM")) - (or main-entry? (os/getenv "JOLT_WHOLE_PROGRAM"))) - # Native codegen (jolt-ihdp): compile numeric-leaf fns to C at def time and - # install the cfunction as the var root, so callers direct-link to native - # code. Opt-in (cc latency per fn); needs direct-linking so callers embed it. - :cgen? (and dl (= "1" (os/getenv "JOLT_CGEN")))}) diff --git a/src/jolt/core.janet b/src/jolt/core.janet deleted file mode 100644 index 3c1e0e2..0000000 --- a/src/jolt/core.janet +++ /dev/null @@ -1,336 +0,0 @@ -# Jolt Core Library -# Clojure-compatible core functions for the Jolt interpreter. -# -# This file is the AGGREGATOR (jolt-nma8, phase 2b): the implementation now lives -# in cohesive cluster modules, loaded here in dependency order and re-exported -# (:export true) so every consumer keeps a single `(use ./core)`. The bottom of -# this file owns the registration table (core-bindings) and init-core!, which -# reference fns from every cluster. - -(use ./types) -(use ./phm) -(use ./phs) -(use ./lazyseq) -(use ./regex) -(use ./config) -(use ./pv) -(use ./plist) - -# Cluster modules, in load order (each uses the ones before it). :export true -# re-exports each module's OWN defs through core, so `(use ./core)` sees them all. -(import ./core_types :prefix "" :export true) -(import ./core_coll :prefix "" :export true) -(import ./core_print :prefix "" :export true) -(import ./core_io :prefix "" :export true) -(import ./core_refs :prefix "" :export true) -(import ./core_extra :prefix "" :export true) - -(def- core-bindings - "Map of symbol name → function for all core functions." - @{"nil?" core-nil? - "string?" core-string? - "number?" core-number? - "fn?" core-fn? - "keyword?" core-keyword? - "symbol?" core-symbol? - "vector?" core-vector? - "map?" core-map? - "seq?" core-seq? - "coll?" core-coll? - "identical?" core-identical? - "integer?" core-integer? - "list?" core-list? - "+" core-+ - "-" core-sub - "*" core-* - "/" core-/ - "inc" core-inc - "dec" core-dec - "even?" core-even? - "odd?" core-odd? - "mod" core-mod - "rem" core-rem - "quot" core-quot - "rand" core-rand - "=" core-= - "<" core-< - ">" core-> - "<=" core-<= - ">=" core->= - "conj" core-conj - "assoc" core-assoc - "dissoc" core-dissoc - "get" core-get - "contains?" core-contains? - "count" core-count - "format" core-format - "first" core-first - "rest" core-rest - "next" core-next - "cons" core-cons - "seq" core-seq - "vec" core-vec - "__sq1" core-sq1 - "__sqcat" core-sqcat - "__sqvec" core-sqvec - "__sqmap" core-sqmap - "__sqset" core-sqset - "into" core-into - "with-meta" core-with-meta - "map" core-map - "filter" core-filter - "remove" core-remove - "reduce" core-reduce - "apply" core-apply - "map-entry?" core-map-entry? - "future-call" core-future-call - "future?" core-future? - "future-cancel" core-future-cancel - "tagged-literal" core-tagged-literal - "re-groups" core-re-groups - "transient" core-transient - "transient?" core-transient? - "persistent!" core-persistent! - "conj!" core-conj! - "assoc!" core-assoc! - "dissoc!" core-dissoc! - "pop!" core-pop! - "hash-combine" core-hash-combine - "hash-ordered-coll" core-hash-ordered-coll - "hash-unordered-coll" core-hash-unordered-coll - "gensym" gensym - "__write" core-write - "__eprint" core-eprint - "__eprintf" core-eprintf - "__jdbc-wrap-conn" core-jdbc-wrap-conn - "__jdbc-conn-raw" core-jdbc-conn-raw - "__jdbc-make-stmt" core-jdbc-make-stmt - "__make-file" core-make-file - "__file?" core-file? - "__pr-str1" core-pr-str1 - "__make-uuid" make-uuid - "compare" core-compare - "type" core-type - "slurp" core-slurp - "spit" core-spit - "flush" core-flush - "get-thread-bindings" core-get-thread-bindings - "__thread-bound?" core-thread-bound?* - "__dir?" core-dir? - "__list-dir" core-list-dir - "parse-long" core-parse-long - "parse-double" core-parse-double - "current-time-ms" core-current-time-ms - "mapcat" core-mapcat - "sequence" core-sequence - "keyword" core-keyword - "symbol" core-symbol - "namespace" core-namespace - "reduced" core-reduced - "reduced?" core-reduced? - "rseq" core-rseq - "ex-info" core-ex-info - "__with-out-str" core-with-out-str - "delay?" core-delay? - "make-delay" core-make-delay - "take" core-take - "drop" core-drop - "take-while" core-take-while - "drop-while" core-drop-while - "concat" core-concat - "nth" core-nth - "sort" core-sort - "partition" core-partition - "range" core-range - "vector" core-vector - "hash-map" core-hash-map - "array-map" core-array-map - "hash-set" core-hash-set - "set" core-set - "list" core-list - "set?" core-set? - "disj" core-disj - "coll->cells" coll->cells - "make-lazy-seq" make-lazy-seq - "lazy-cons" lazy-cons - "lazy-from" lazy-from - "str" core-str - "name" core-name - "subs" core-subs - "str-trim" string/trim - "str-upper" string/ascii-upper - "str-lower" string/ascii-lower - "str-find" string/find - "str-replace" core-str-replace-first - "str-replace-all" core-str-replace-all - "str-reverse-b" string/reverse - "str-join" core-str-join - "str-split" core-str-split - "re-pattern" re-pattern - "re-find" re-find - "re-matches" re-matches - "re-seq" re-seq - "regex?" regex? - "str-triml" string/triml - "str-trimr" string/trimr - # Java-style arrays (buffers for bytes, arrays otherwise) - "aclone" core-aclone - "object-array" core-object-array - "int-array" core-int-array - "long-array" core-long-array - "short-array" core-short-array - "double-array" core-double-array - "float-array" core-float-array - "char-array" core-char-array - "boolean-array" core-boolean-array - "byte-array" core-byte-array - "aset-byte" core-aset-byte - "aset-int" core-aset-int - "aset-long" core-aset-long - "aset-short" core-aset-short - "aset-double" core-aset-double - "aset-float" core-aset-float - "aset-char" core-aset-char - "aset-boolean" core-aset-boolean - "make-array" core-make-array - "into-array" core-into-array - "to-array" core-to-array - "bytes" core-bytes - "booleans" core-booleans - "ints" core-ints - "longs" core-longs - "shorts" core-shorts - "doubles" core-doubles - "floats" core-floats - "chars" core-chars - "byte" core-byte - "short" core-short - "bigint" core-bigint - "biginteger" core-biginteger - "chunk-buffer" core-chunk-buffer - "chunk-append" core-chunk-append - "chunk" core-chunk - "chunk-first" core-chunk-first - "chunk-rest" core-chunk-rest - "chunk-next" core-chunk-next - "chunk-cons" core-chunk-cons - "boolean" core-boolean - "cat" core-cat - "disj!" core-disj! - "reader-conditional" core-reader-conditional - "class" core-class - "re-matcher" core-re-matcher - # Bit operations - "__bit-and" core-bit-and - "__bit-or" core-bit-or - "__bit-xor" core-bit-xor - "bit-not" core-bit-not - "bit-shift-left" core-bit-shift-left - "bit-shift-right" core-bit-shift-right - "bit-clear" core-bit-clear - "bit-set" core-bit-set - "bit-flip" core-bit-flip - "bit-test" core-bit-test - "__bit-and-not" core-bit-and-not - "unsigned-bit-shift-right" core-unsigned-bit-shift-right - # Integer coercion / unchecked math - "int" core-int - "long" core-long - "double" core-double - "float" core-float - "char" core-char - # Hash - "hash" core-hash - "atom" core-atom - "deref" core-deref - "reset!" core-reset! - "swap!" core-swap! - "not" core-not - "Object" core-Object - "make-protocol" core-make-protocol - # satisfies?/resolve are interned by install-stateful-fns! (ctx-capturing); - # type->str was an inert SCI stub with no callers. - "implements?" core-implements? - "volatile!" core-volatile! - "Thread" core-Thread - "ThreadLocal" core-ThreadLocal - "IllegalStateException" core-IllegalStateException - "copy-core-var" core-copy-core-var - "copy-var" core-copy-var - "macrofy" core-macrofy - "new-var" core-new-var - "__local-var" core-local-var - "__close" core-close-resource - "avoid-method-too-large" core-avoid-method-too-large - "bytes?" core-bytes? - "meta" core-meta - "var-get" core-var-get - "var-set" core-var-set - "var?" core-var? - "var-dynamic?" core-var-dynamic? - "alter-var-root" core-alter-var-root - "alter-meta!" core-alter-meta! - "reset-meta!" core-reset-meta! - "push-thread-bindings" core-push-thread-bindings - "pop-thread-bindings" core-pop-thread-bindings - # Dynamic vars — stubs for SCI bootstrap - "*unchecked-math*" false - "*clojure-version*" @{:major 1 :minor 11 :incremental 0 :qualifier nil} - "*1" :jolt/nil-sentinel - "*2" :jolt/nil-sentinel - "*3" :jolt/nil-sentinel - "*e" :jolt/nil-sentinel - "*assert" true}) - -(defn core-macro-names - "Set of core binding names that are macros. Empty now that every core macro - lives in the Clojure overlay (clojure.core.*-syntax / *-macros tiers)." - [] - @{}) - -# Wire the print-method callback once the overlay (and its print-method -# multimethod) exists: the renderer's record fallthrough consults the methods -# table on the var; only a USER-registered method fires — the multimethod's -# :default would bounce straight back into the renderer. -(defn install-print-method-cb! [ctx] - (def core-ns (ctx-find-ns ctx "clojure.core")) - (def pm-var (ns-find core-ns "print-method")) - (when pm-var - (set-print-method-cb! - (fn [v emit] - (def methods (get pm-var :jolt/methods)) - (when methods - (def mt (core-meta v)) - (def t (and mt (core-get mt :type))) - (def dval (if (keyword? t) t (core-type v))) - (def m (get methods dval)) - (when m - (m v @{:jolt/type :jolt/writer :sink emit}) - true))))) - # A record/deftype's own Object/toString (jolt-rt6n): str routes records here - # so a deftype with (toString [_] ...) renders via it instead of the data repr. - (set-record-tostring-cb! - (fn [v] - (def tag (record-tag v)) - (when tag - (def m (find-method-any-protocol ctx tag "toString")) - (when m (m v)))))) - -(def init-core! - (fn [& args] - (case (length args) - 1 (let [ctx (args 0) - ns (ctx-find-ns ctx "clojure.core")] - (loop [[name fn] :pairs core-bindings] - (def v (ns-intern ns name (if (= fn :jolt/nil-sentinel) nil fn))) - (when (get (core-macro-names) name) - (put v :macro true))) - ns) - 2 (let [ctx (args 0) ns-name (args 1) - ns (ctx-find-ns ctx ns-name)] - (loop [[name fn] :pairs core-bindings] - (def v (ns-intern ns name (if (= fn :jolt/nil-sentinel) nil fn))) - (when (get (core-macro-names) name) - (put v :macro true))) - ns) - (error "Wrong number of args passed to: init-core!")))) diff --git a/src/jolt/core_coll.janet b/src/jolt/core_coll.janet deleted file mode 100644 index 53fac0f..0000000 --- a/src/jolt/core_coll.janet +++ /dev/null @@ -1,1198 +0,0 @@ -# Jolt Core — collections, transducers, seqs, HOFs, constructors -# Extracted from core.janet (jolt-nma8, phase 2b split). -# -# REP vs API: this file holds the Clojure-facing collection ops and dispatches -# on `:jolt/type` over the internal persistent structures, whose representations -# live elsewhere: persistent vector → pv.janet, list → plist.janet, hash map → -# phm.janet, set → phs.janet, lazy seq → lazyseq.janet. Grep a structure's file -# header for the primitive (pv-*/pl-*/phm-*/phs-*/ls-*) it exposes. - -(use ./types) -(use ./phm) -(use ./phs) -(use ./lazyseq) -(use ./regex) -(use ./config) -(use ./pv) -(use ./plist) -(use ./core_types) -# Collections -# ============================================================ - -# Small maps are Janet structs (native, O(1) get) but assoc copies them whole -# (O(n)); past this many entries a map promotes to the phm HAMT (O(log n) assoc) -# so incremental building isn't O(n^2). Mirrors cljs PersistentArrayMap's -# HASHMAP-THRESHOLD (jolt-684u). -(def- map-array-threshold 8) - -# Is x a map value (for conj/merge semantics: conj-ing a map merges its entries)? -(defn- map-value? [x] - (or (phm? x) (and (struct? x) (nil? (get x :jolt/type))))) - -# --- Sorted collections (sorted-map / sorted-set) ------------------------------- -# Pure Clojure now (stage 3, jolt-0lj — jolt-core/clojure/core/25-sorted.clj). -# A sorted coll is a tagged table {:jolt/type .. :entries SORTED-VECTOR :cmp -# :ops {kw fn}} whose ops travel WITH the value, so the seed's dispatch -# branches below are each a one-line call through (coll :ops) — no module-level -# hooks, correct across contexts/forks/AOT images. The tag predicates and the -# entries view live near the top of this module (canon-key/empty?/equality -# need them); only this dispatch accessor is left here. -(defn sorted-op - "The overlay-attached implementation of `op` for sorted coll `coll`." - [coll op] - (get (coll :ops) op)) - -# Merge conj items onto a map receiver. assoc1 is phm-assoc for a phm receiver, -# map-assoc1 for a struct/host-table receiver — the only thing that differs -# between the two map-conj paths. -(defn- conj-into-map [coll xs assoc1] - (var result coll) - (each x xs - (cond - # conj nil onto a map is a no-op (Clojure) - (nil? x) nil - # conj a map -> merge its entries - (map-value? x) - (each e (map-entries-of x) (set result (assoc1 result (in e 0) (in e 1)))) - # a [k v] entry: exactly a 2-element vector (Clojure throws otherwise — and - # merge inherits this strictness through conj) - (and (or (pvec? x) (tuple? x) (array? x)) (= 2 (vcount x))) - (set result (assoc1 result (vnth x 0) (vnth x 1))) - (error "Vector arg to map conj must be a pair"))) - result) - -# Dispatch is on :jolt/type via one case (the type is fetched once and the arm -# calls the concrete op directly) rather than a chain of (and (table? x) (= ..)) -# predicates — same hot-path cost as the predicate chain for the common types, -# one place per op. Host values (tuple/array/nil) and tuple-based shape-recs -# carry no :jolt/type and stay in the per-op fallback. -(defn core-conj [& args] - (if (= 0 (length args)) (make-vec @[]) # (conj) -> [] - (let [coll (first args) xs (tuple/slice args 1)] - (if (table? coll) - (case (get coll :jolt/type) - :jolt/pvec (do (var r coll) (each x xs (set r (pv-conj r x))) r) - :jolt/phm (conj-into-map coll xs phm-assoc) - # list: prepend, O(1) per element via structural sharing - :jolt/plist (do (var r coll) (each x xs (set r (pl-cons x r))) r) - # conj onto a seq prepends (Clojure: a Cons cell) - :jolt/lazy-seq (do (var r coll) (each x xs (set r (pl-cons x (realize-for-iteration r)))) r) - :jolt/set (apply phs-conj coll xs) - :jolt/sorted-map ((sorted-op coll :conj) coll xs) - :jolt/sorted-set ((sorted-op coll :conj) coll xs) - # other tables (raw host table / deftype instance) conj like a map - (conj-into-map coll xs map-assoc1)) - (cond - # conj onto nil builds a list (prepends): (conj nil 1 2) -> (2 1) - (nil? coll) (do (var r nil) (each x xs (set r (pl-cons x r))) r) - (tuple? coll) (tuple/slice (tuple ;(array/concat (array/slice coll) xs))) - (array? coll) - (if mutable? - # mutable mode: arrays are vectors — append in place - (do (each x xs (array/push coll x)) coll) - # immutable mode: arrays are lists — prepend onto a persistent cons - # node, sharing the original array as the tail (O(1) per element) - (do (var r coll) (each x xs (set r (pl-cons x r))) r)) - # struct map literal: merge entries - (conj-into-map coll xs map-assoc1)))))) - -(defn core-assoc [m & kvs] - (when (odd? (length kvs)) - (error "assoc expects an even number of key/value arguments")) - # assoc is defined on maps, vectors and nil; reject other shapes - (when (or (number? m) (string? m) (buffer? m) (keyword? m) (boolean? m) - (plist? m) (set? m) (core-transient? m) (core-sorted-set? m) - (and (struct? m) (get m :jolt/type))) - (error (string "assoc requires a map or vector, got " (type m)))) - (cond - (shape-rec? m) - (do (var result m) (var i 0) - (while (< i (length kvs)) (set result (shape-assoc result (kvs i) (kvs (+ i 1)))) (+= i 2)) - result) - (core-sorted-map? m) ((sorted-op m :assoc) m kvs) - (phm? m) - (do (var result m) (var i 0) (while (< i (length kvs)) (set result (phm-assoc result (kvs i) (kvs (+ i 1)))) (+= i 2)) result) - (pvec? m) - (do (var result m) (var i 0) - (while (< i (length kvs)) - (let [idx (kvs i)] - (when (not (and (number? idx) (= idx (math/floor idx)) (>= idx 0) (<= idx (pv-count result)))) - (error (string "Index " idx " out of bounds for assoc on a vector of length " (pv-count result)))) - (set result (pv-assoc result idx (kvs (+ i 1))))) - (+= i 2)) result) - # vector: assoc by integer index (appending at count is allowed); stays a vector - (or (tuple? m) (array? m)) - (do (var result (array/slice m)) (var i 0) - (while (< i (length kvs)) - (let [idx (kvs i) v (kvs (+ i 1))] - (when (not (and (number? idx) (= idx (math/floor idx)) (>= idx 0) (<= idx (length result)))) - (error (string "Index " idx " out of bounds for assoc on a vector of length " (length result)))) - (if (= idx (length result)) (array/push result v) (put result idx v))) - (+= i 2)) - (if (tuple? m) (tuple/slice (tuple ;result)) result)) - # map (struct/table). Promote to a phm when (a) any new key is a collection - # (a Janet struct/table would key it by identity) or any new key/value is nil - # (a struct drops nil; phm preserves it), or (b) the result would exceed the - # small-map threshold — a Janet struct copies wholesale on assoc (O(n)), so a - # growing map must ride the phm HAMT (O(log n)) past ~8 entries. Mirrors cljs - # PersistentArrayMap -> PersistentHashMap (jolt-684u). m is a struct here - # (phm handled above), so only the current size + new kvs matter. - (let [coll-key (do (var c false) (var i 0) - (while (< i (length kvs)) - (let [k (in kvs i) v (in kvs (+ i 1))] - (when (or (table? k) (array? k) (nil? k) (nil? v)) (set c true))) - (+= i 2)) c) - promote (or coll-key - (> (+ (if m (length m) 0) (/ (length kvs) 2)) map-array-threshold))] - (if promote - (do (var result (make-phm)) - (when m (each k (keys m) (set result (phm-assoc result k (get m k))))) - (var i 0) (while (< i (length kvs)) (set result (phm-assoc result (in kvs i) (in kvs (+ i 1)))) (+= i 2)) - result) - (do (var result @{}) (when m (each k (keys m) (put result k (get m k)))) - (var i 0) (while (< i (length kvs)) (let [k (kvs i) v (kvs (+ i 1))] (put result k v) (+= i 2))) - # nil assocs to a fresh immutable map ((assoc nil :a 1) => {:a 1}); a - # raw table here would not count?/seq like a Clojure map (assoc-in into - # an absent key recurses through nil — migratus's migration maps). - (if (or (struct? m) (nil? m)) (table/to-struct result) result)))))) - -(defn core-dissoc [m & ks] - (cond - (nil? m) nil - # dissoc loses a key -> the shape changes; bridge through a struct (cold op) - (shape-rec? m) (core-dissoc (shape->struct m) ;ks) - (core-sorted-map? m) ((sorted-op m :dissoc) m ks) - (phm? m) (do (var result m) (each k ks (set result (phm-dissoc result k))) result) - # reject clearly non-map values (scalars, sequences, sets, symbol/char structs) - (or (number? m) (string? m) (buffer? m) (keyword? m) (boolean? m) - (pvec? m) (plist? m) (tuple? m) (array? m) (set? m) (core-transient? m) - (and (struct? m) (get m :jolt/type))) - (error (string "dissoc requires a map, got " (type m))) - # struct map / sorted-map / record / meta-wrapped map - (do (var result @{}) (each k (keys m) (var in-ks false) (each k2 ks (if (deep= k k2) (do (set in-ks true) (break)))) (if (not in-ks) (put result k (m k)))) - (if (struct? m) (table/to-struct result) result)))) - -(defn core-get [m k &opt default] - (default default nil) - (if (nil? m) default - # inline the shape check (no fn call) so non-shape gets pay only a tuple? test - (if (and (tuple? m) (> (length m) 0) (struct? (in m 0)) (not (nil? (in (in m 0) :jolt/shape)))) - (shape-get m k default) - (if (core-sorted? m) ((sorted-op m :get) m k default) - (if (core-transient? m) - (case (m :kind) - :vector (if (and (number? k) (>= k 0) (< k (length (m :arr)))) (in (m :arr) k) default) - :map (let [p (get (m :tbl) (tbl-key k))] (if p (in p 1) default)) - :set (if (nil? (get (m :tbl) (tbl-key k))) default k)) - (if (set? m) (phs-get m k default) - (if (phm? m) (phm-get m k default) - (if (pvec? m) - (if (and (number? k) (>= k 0) (< k (pv-count m))) (pv-nth m k) default) - (if (or (struct? m) (table? m)) - (let [v (m k)] - (if (nil? v) default v)) - (if (and (or (tuple? m) (array? m)) (number? k) (>= k 0) (< k (length m))) - (in m k) - # Clojure's get indexes strings too (returns the char) — reitit's path - # parser relies on (get path i). nth already did; get did not, so - # (get "a:b" 1) was nil. - (if (and (or (string? m) (buffer? m)) (number? k) (>= k 0) (< k (length m))) - (make-char (in m k)) - default))))))))))) - -# Runtime invoke dispatch for COMPILED code (interpreter uses evaluator's -# jolt-invoke). Handles real functions plus Clojure IFn collections. -(defn jolt-call [f & args] - (cond - (or (function? f) (cfunction? f)) (apply f args) - # a var is callable as its current value (Clojure vars implement IFn) - (var? f) (apply jolt-call (var-get f) args) - (shape-rec? f) (core-get f (get args 0) (get args 1)) - (keyword? f) (core-get (get args 0) f (get args 1)) - (and (struct? f) (= :symbol (f :jolt/type))) (core-get (get args 0) f (get args 1)) - (core-sorted? f) ((sorted-op f :get) f (get args 0) (get args 1)) - (phm? f) (phm-get f (get args 0) (get args 1)) - (set? f) (if (phs-contains? f (get args 0)) (get args 0) (get args 1)) - (pvec? f) - (let [k (get args 0)] - (if (and (number? k) (= k (math/floor k)) (>= k 0) (< k (pv-count f))) - (pv-nth f k) - (error (string "Index " k " out of bounds for vector of length " (pv-count f))))) - (or (tuple? f) (array? f)) - (let [k (get args 0)] - (if (and (number? k) (= k (math/floor k)) (>= k 0) (< k (length f))) - (in f k) - (error (string "Index " k " out of bounds for vector of length " (length f))))) - # Map literal (struct with no :jolt/type marker) or a record: callable as a - # key lookup. A TAGGED struct (char/etc.) is NOT a fn — symbols are handled - # above; everything else with a :jolt/type falls through to the error. - (or (and (struct? f) (nil? (get f :jolt/type))) (and (table? f) (get f :jolt/deftype))) - (let [v (get f (get args 0) :jolt/not-found)] - (if (= v :jolt/not-found) (get args 1) v)) - (error (string "Cannot call " (type f) " as a function")))) - -(defn core-apply - "(apply f a b ... coll) — call f with the leading args plus the elements of - the final collection spliced in. Materializes pvec/lazy-seq/set tails." - [f & args] - (let [n (length args)] - (if (= n 0) - (jolt-call f) - (let [fixed (array/slice args 0 (- n 1)) - t (in args (- n 1)) - tail (cond (nil? t) [] # (apply f x nil) == (f x), as in Clojure - (set? t) (phs-seq t) (phm? t) (tuple ;(phm-entries t)) - (realize-for-iteration t))] - (jolt-call f ;fixed ;tail))))) - -# get-in now lives in the Clojure collection tier (core/20-coll.clj). - -(defn core-contains? [coll key] - (if (shape-rec? coll) (shape-contains? coll key) - (if (core-sorted? coll) (if ((sorted-op coll :contains) coll key) true false) - (if (core-transient? coll) - (case (coll :kind) - :vector (and (number? key) (>= key 0) (< key (length (coll :arr)))) - (not (nil? (get (coll :tbl) (tbl-key key))))) - (if (set? coll) (phs-contains? coll key) - (if (phm? coll) (phm-contains? coll key) - (if (pvec? coll) (and (number? key) (>= key 0) (< key (pv-count coll))) - (if (struct? coll) (not (nil? (coll key))) - (if (table? coll) (not (nil? (coll key))) - (if (or (tuple? coll) (array? coll)) - (and (number? key) (>= key 0) (< key (length coll))) - false)))))))))) - -# Coerce a Clojure IFn value to a Janet-callable fn for higher-order fns -# (map/filter/sort-by/group-by/...). Janet functions pass through; a keyword or -# symbol becomes a key lookup, a map a key lookup, a set a membership test — so -# (map :k coll), (sort-by :k coll), (filter a-set coll) work. -(defn- as-fn [f] - (cond - (or (function? f) (cfunction? f)) f - (keyword? f) (fn [x &opt d] (core-get x f d)) - (core-symbol? f) (fn [x &opt d] (core-get x f d)) - (phm? f) (fn [k &opt d] (core-get f k d)) - (set? f) (fn [x &opt d] (if (core-contains? f x) x d)) - true f)) - -# Sorted collections — minimal: backed by a struct (map) / sorted array (set), -# ordered by key/element on read. Defined early so seq/count/get can dispatch. -# sorted-map/sorted-set predicates, constructors and ops live ABOVE core-conj so -# the collection fns (conj/assoc/get/contains?/…) can branch on them. - -(defn core-count [coll] - (if (table? coll) - (case (get coll :jolt/type) - :jolt/pvec (pv-count coll) - :jolt/phm (coll :cnt) - :jolt/plist (pl-count coll) - :jolt/set (coll :cnt) - :jolt/lazy-seq (ls-count coll) - :jolt/sorted-map ((sorted-op coll :count) coll) - :jolt/sorted-set ((sorted-op coll :count) coll) - :jolt/transient (length (if (= :vector (coll :kind)) (coll :arr) (coll :tbl))) - # other tables: a deftype record instance counts its fields; a raw host - # table is unsupported (matches the original — seq handles it, count never did) - (if (get coll :jolt/deftype) (- (length (keys coll)) 1) - (error (string "count not supported on " (type coll))))) - (cond - (nil? coll) 0 - (shape-rec? coll) (shape-count coll) # shape-recs are tuples, not tables - (or (string? coll) (buffer? coll) (struct? coll) (tuple? coll) (array? coll)) (length coll) - # count is undefined on scalars (numbers/keywords/symbols/booleans/chars) - (error (string "count not supported on " (type coll)))))) - -(defn core-first [coll] - (cond - (shape-rec? coll) (core-first (shape->struct coll)) - (core-sorted? coll) ((sorted-op coll :first) coll) - (lazy-seq? coll) (ls-first coll) - (pvec? coll) (if (= 0 (pv-count coll)) nil (pv-nth coll 0)) - (plist? coll) (if (pl-empty? coll) nil (pl-first coll)) - # maps and sets: first of their seq (an entry / element) - (phm? coll) (let [e (phm-entries coll)] (if (= 0 (length e)) nil (in e 0))) - (set? coll) (let [s (phs-seq coll)] (if (= 0 (length s)) nil (in s 0))) - (and (struct? coll) (nil? (get coll :jolt/type))) - (let [ks (keys coll)] (if (= 0 (length ks)) nil (tuple (in ks 0) (get coll (in ks 0))))) - (nil? coll) nil - (string? coll) (if (= 0 (length coll)) nil (make-char (in coll 0))) - # scalars aren't seqable - (or (number? coll) (boolean? coll) (keyword? coll) (and (struct? coll) (get coll :jolt/type))) - (error (string "first not supported on " (type coll))) - (= 0 (length coll)) nil - (in coll 0))) - -(defn- seq-done? - "True when cursor c (a lazy-seq or a concrete collection) is exhausted. - Uses cell realization for lazy-seqs so nil elements don't end the seq early." - [c] - (if (lazy-seq? c) - (let [cell (realize-ls c)] - (or (nil? cell) (= :jolt/pending cell) (= 0 (length cell)))) - (or (nil? c) (= 0 (length c))))) - -(defn core-rest [coll] - (cond - # rest never returns nil — Clojure's rest yields () on an exhausted seq. - (lazy-seq? coll) (let [r (ls-rest coll)] (if (nil? r) @[] r)) - (plist? coll) (pl-rest coll) - # Indexed collections: an O(1) lazy view from index 1 (Clojure: rest of a - # vector is a seq, not a vector). Slicing per step made first/rest loops - # over concrete collections O(n^2) — a 20k rest-loop took two seconds. - # These stay ABOVE the set/map branches: rest-of-vector is every seq loop's - # hot path and must not pay the wrapper-tag checks. - (pvec? coll) (let [a (pv->array coll)] - (if (<= (length a) 1) @[] - (make-lazy-seq (fn [] (indexed-cells a 1))))) - (or (nil? coll) (= 0 (length coll))) @[] - (string? coll) (tuple ;(map make-char (string/bytes (string/slice coll 1)))) - (tuple? coll) (if (<= (length coll) 1) @[] - (make-lazy-seq (fn [] (indexed-cells coll 1)))) - # Sets, maps and sorted colls rest via their seq. Without these branches - # they fell into the indexed fall-through, which walked the wrapper table's - # INTERNAL fields — (next #{1 2}) was (nil nil) until the canonical every? - # started seq-walking sets (seed-shrink round 4). - (set? coll) (if (= 0 (coll :cnt)) @[] (core-rest (phs-seq coll))) - (phm? coll) (if (= 0 (coll :cnt)) @[] (core-rest (tuple ;(phm-entries coll)))) - (core-sorted? coll) (core-rest ((sorted-op coll :seq) coll)) - # plain struct maps (untagged literals) rest via entries too - (and (struct? coll) (nil? (get coll :jolt/type))) - (core-rest (tuple ;(map-entries-of coll))) - (if (<= (length coll) 1) @[] - (make-lazy-seq (fn [] (indexed-cells coll 1)))))) - -(defn core-next [coll] - # next is rest, but nil when the rest is empty. seq-done? realizes one lazy - # cell so a lazy rest that turns out empty (length on the table won't tell us) - # collapses to nil, matching Clojure. - (let [r (core-rest coll)] - (if (seq-done? r) nil r))) - -(defn core-cons [x coll] - "Prepend x onto coll. For concrete collections this is an O(1) persistent cons - node; for lazy-seqs it stays a lazy cell so laziness is preserved." - (cond - # Lazy tail: return a LazySeq (NOT a bare cell), so a cons-of-a-cons stays a - # proper lazy-seq and the rest-thunk never leaks as a plain array element. - (lazy-seq? coll) (make-lazy-seq (fn [] @[x (fn [] coll)])) - (or (nil? coll) (plist? coll) (array? coll) (tuple? coll)) (pl-cons x coll) - # second arg must be seqable (a collection or string); reject scalars - (not (or (core-coll? coll) (string? coll))) - (error (string "Don't know how to create ISeq from: " (type coll))) - (pl-cons x (realize-for-iteration coll)))) - -(defn core-seq [coll] - (if (table? coll) - (case (get coll :jolt/type) - :jolt/pvec (if (= 0 (pv-count coll)) nil (tuple ;(pv->array coll))) - # empty maps/sets seq to nil, as in Clojure ((seq {}) is nil, not ()) - :jolt/phm (if (= 0 (coll :cnt)) nil (tuple ;(phm-entries coll))) - :jolt/plist (if (pl-empty? coll) nil (tuple ;(pl->array coll))) - # Cell-based emptiness, NOT (nil? (ls-first)): a lazy-seq whose first - # element is legitimately nil is non-empty, so (seq (cons nil ...)) is not nil. - :jolt/lazy-seq (let [cell (realize-ls coll)] - (if (or (nil? cell) (= :jolt/pending cell) (= 0 (length cell))) nil coll)) - :jolt/set (if (= 0 (coll :cnt)) nil (phs-seq coll)) - :jolt/sorted-map ((sorted-op coll :seq) coll) - :jolt/sorted-set ((sorted-op coll :seq) coll) - # deftype instance seqs as itself; raw host table (System/getenv) as kv map - (if (get coll :jolt/deftype) coll - (if (= 0 (length coll)) nil - (tuple ;(map (fn [k] (tuple k (get coll k))) (keys coll)))))) - (cond - # shape-recs are tuples — must precede the tuple? branch - (shape-rec? coll) (tuple ;(map (fn [k] (tuple k (shape-get coll k nil))) (shape-keys coll))) - (nil? coll) nil - (buffer? coll) (if (= 0 (length coll)) nil (let [a @[]] (each x coll (array/push a x)) (tuple ;a))) - (tuple? coll) (if (= 0 (length coll)) nil (tuple/slice coll)) - (string? coll) (if (= 0 (length coll)) nil (tuple ;(map make-char (string/bytes coll)))) - (struct? coll) (if (= 0 (length coll)) nil (tuple ;(map (fn [k] (tuple k (get coll k))) (keys coll)))) - (array? coll) (if (= 0 (length coll)) nil (tuple ;coll)) - # scalars/functions aren't seqable - (error (string "seq not supported on " (type coll)))))) - -(defn core-vec [coll] - (when (not (or (nil? coll) (core-coll? coll) (string? coll))) - (error (string "Don't know how to create a vector from " (type coll)))) - (let [coll (realize-for-iteration coll)] - (cond - (array? coll) (make-vec coll) - (tuple? coll) (make-vec coll) - (struct? coll) (make-vec (map |(in (kvs coll) (+ (* $ 2) 1)) (range (/ (length (kvs coll)) 2)))) - (string? coll) (make-vec (map make-char (string/bytes coll))) - (make-vec @[])))) - -# Bulk-build a map value from a native array of [k v] pairs, mirroring -# core-assoc's struct-vs-phm choice: stay a small Janet struct (the -# PersistentArrayMap analog) when every key is a scalar, there is no nil key or -# value, and the distinct count is within the threshold; otherwise bulk-build -# the HAMT once (phm-from-pairs). Used by into-a-struct-map (jolt-5vsp). -(defn- bulk-map-from-pairs [pairs] - (var promote false) - (def t @{}) - (each p pairs - (def k (vnth p 0)) (def v (vnth p 1)) - (if (or (table? k) (array? k) (nil? k) (nil? v)) - (set promote true) - (put t k v))) # scalar keys: last-wins - (if (or promote (> (length t) map-array-threshold)) - (phm-from-pairs pairs) - (table/to-struct t))) - -(defn- into-conj [to items] - (cond - # into onto an existing phm stays a phm: accumulate its entries + the new - # [k v] items and bulk-build the HAMT ONCE (phm-from-pairs, last-value-wins), - # instead of a phm-assoc per element. jolt-5vsp collections. - (phm? to) - (let [acc (array)] - (each e (phm-entries to) (array/push acc e)) - (each item items (array/push acc [(vnth item 0) (vnth item 1)])) - (phm-from-pairs acc)) - # into onto a plain map struct (e.g. the {} literal): same one-pass build, - # but keep the small-scalar-map-stays-a-struct rule (bulk-map-from-pairs) so - # the representation matches the incremental assoc-onto-a-struct path. - (and (struct? to) (nil? (get to :jolt/type))) - (let [acc (array)] - (each e (pairs to) (array/push acc e)) - # each item is either a [k v] pair OR a map whose entries are merged - # (Clojure: (into {} [{:a 1} {:b 2}]) => {:a 1 :b 2}) - (each item items - (if (map-value? item) - (each e (map-entries-of item) (array/push acc e)) - (array/push acc [(vnth item 0) (vnth item 1)]))) - (bulk-map-from-pairs acc)) - # Other map-likes (sorted maps, deftype records): fold core-conj (handles - # both [k v] pairs and map items). - (or (struct? to) (and (table? to) (get to :jolt/deftype))) - (do (var result to) - (each item items (set result (core-conj result item))) - result) - # Accumulate into a native array and bulk-build the pvec ONCE (pv-from-indexed), - # instead of an immutable pv-conj per element (each allocating a wrapper + - # copying the tail). This is the transient-style fast path for into-a-vector. - (pvec? to) (let [arr (array/slice (pv->array to))] - (each x items (array/push arr x)) - (make-vec arr)) - (array? to) (if mutable? - (do (each x items (array/push to x)) to) # vector: append - (do (var result (array/slice to)) (each x items (array/insert result 0 x)) result)) # list: prepend - (tuple? to) (tuple/slice (tuple ;(array/concat (array/slice to) (array/slice items)))) - # hash-set target: accumulate existing members + new items and bulk-build the - # backing HAMT ONCE (phs-from-seq), instead of a phs-conj per element. - (set? to) (let [acc (array)] - (each x (phs-seq to) (array/push acc x)) - (each x items (array/push acc x)) - (phs-from-seq acc)) - # everything else conj-able (sorted colls): fold conj — previously - # this fell through to `to` unchanged, silently dropping all elements - # ((into #{} [:a :b]) was #{}, jolt-h86) - (do (var result to) (each x items (set result (core-conj result x))) result))) - -# merge now lives in the Clojure collection tier (core/20-coll.clj). - -# merge-with now lives in the Clojure collection tier (core/20-coll.clj). - -# keys / vals now live in the syntax tier (core/00-syntax.clj) — canonical -# projections of (seq m), so sorted maps come back in comparator order. - - - -# select-keys now lives in the Clojure collection tier (core/20-coll.clj). - -# zipmap now lives in the Clojure collection tier (core/20-coll.clj). - -# ============================================================ -# Transducers -# ============================================================ -# A transducer is (fn [rf] rf') where rf' is a reducing fn with arities -# []=init, [acc]=complete, [acc x]=step. map/filter/take/... return a -# transducer when called with no collection. - -(defn core-reduced [x] @{:jolt/type :jolt/reduced :val x}) -(defn core-reduced? [x] (and (table? x) (= :jolt/reduced (x :jolt/type)))) -# unreduced lives in the syntax tier (core/00-syntax.clj) over reduced?/deref. -(defn- ensure-reduced [x] (if (core-reduced? x) x (core-reduced x))) - -(defn td-map [f] - (fn [rf] (fn [& a] (case (length a) 0 (rf) 1 (rf (a 0)) (rf (a 0) (f (a 1))))))) -(defn td-filter [pred] - (fn [rf] (fn [& a] (case (length a) 0 (rf) 1 (rf (a 0)) - (if (truthy? (pred (a 1))) (rf (a 0) (a 1)) (a 0)))))) -(defn td-remove [pred] (td-filter (fn [x] (not (pred x))))) -# td-keep removed: keep (incl its transducer arity) lives in core/40-lazy.clj. -(defn td-take [n] - (fn [rf] - (var left n) - (fn [& a] (case (length a) 0 (rf) 1 (rf (a 0)) - (if (<= left 0) (core-reduced (a 0)) - (let [r (rf (a 0) (a 1))] (set left (dec left)) - (if (<= left 0) (ensure-reduced r) r))))))) -(defn td-drop [n] - (fn [rf] - (var left n) - (fn [& a] (case (length a) 0 (rf) 1 (rf (a 0)) - (if (> left 0) (do (set left (dec left)) (a 0)) (rf (a 0) (a 1))))))) -(defn td-take-while [pred] - (fn [rf] - (fn [& a] (case (length a) 0 (rf) 1 (rf (a 0)) - (if (truthy? (pred (a 1))) (rf (a 0) (a 1)) (core-reduced (a 0))))))) -(defn td-drop-while [pred] - (fn [rf] - (var dropping true) - (fn [& a] (case (length a) 0 (rf) 1 (rf (a 0)) - (do (when (and dropping (not (truthy? (pred (a 1))))) (set dropping false)) - (if dropping (a 0) (rf (a 0) (a 1)))))))) -# td-map-indexed removed: map-indexed (incl transducer arity) lives in core/40-lazy.clj. - -# Stateful windowing transducers. The 1-arg (completion) arity flushes a partial -# trailing window before delegating to rf's completion; matches Clojure. -# td-partition-all removed: partition-all (incl transducer arity) lives in core/40-lazy.clj. - -# partition-by's transducer arity lives with its (lazy) collection arity in the -# overlay (10-seq tier), written in Clojure with volatiles. - -(defn- reduce-with-reduced - "Reduce coll with reducing fn rf and seed init, honoring `reduced`. Steps lazy - seqs one cell at a time so a reducing fn that returns `reduced` (e.g. the - `take`/`take-while` transducers) can short-circuit over an INFINITE seq instead - of realizing it eagerly. Returns the final (unwrapped) accumulator." - [rf init coll] - (var acc init) - (if (lazy-seq? coll) - (do - (var cur coll) (var go true) - (while go - (let [cell (realize-ls cur)] - (if (or (nil? cell) (= :jolt/pending cell) (= 0 (length cell))) - (set go false) - (do - (set acc (rf acc (in cell 0))) - (if (core-reduced? acc) - (do (set acc (acc :val)) (set go false)) - (let [rt (in cell 1)] - (if (nil? rt) (set go false) (set cur (ls-rest-cached cur rt)))))))))) - (do - (var stop false) - (cond - # Indexed colls iterate in place — realize-for-iteration would copy a - # pvec into a fresh array (alloc + pv-nth per element) on EVERY - # reduce call, which dominates tight reduce-over-vector loops - # (jolt-4vr). Also breaks at `reduced` instead of scanning the tail. - (pvec? coll) - (do (def n (pv-count coll)) (var i 0) - (while (and (< i n) (not stop)) - (set acc (rf acc (pv-nth coll i))) - (when (core-reduced? acc) (set acc (acc :val)) (set stop true)) - (++ i))) - (or (tuple? coll) (array? coll)) - (do (def n (length coll)) (var i 0) - (while (and (< i n) (not stop)) - (set acc (rf acc (in coll i))) - (when (core-reduced? acc) (set acc (acc :val)) (set stop true)) - (++ i))) - (each x (if (set? coll) (phs-seq coll) (realize-for-iteration coll)) - (when (not stop) - (set acc (rf acc x)) - (when (core-reduced? acc) (set acc (acc :val)) (set stop true))))))) - acc) - -(defn- transduce-reduce - "Reduce coll with reducing fn rf and seed init, honoring `reduced`." - [rf init coll] - (reduce-with-reduced rf init coll)) - -# SEED-TWIN: transduce is overlay-public (jolt-core/clojure/core/20-coll.clj); -# this seed copy is NOT registered in core-bindings. It survives only as the -# helper core-into calls below — user `transduce` resolves to the overlay. The -# asymmetry with `into` (seed-public) is intentional; docs/seed-overlay-registry.md. -(defn core-transduce - "(transduce xform f coll) or (transduce xform f init coll)." - [xform f & rest] - (let [has-init (= 2 (length rest)) - init (if has-init (in rest 0) (f)) - coll (if has-init (in rest 1) (in rest 0)) - rf (xform f)] - (rf (transduce-reduce rf init coll)))) - -(defn core-into - "(into to from) or (into to xform from)." - [to & rest] - (if (= 2 (length rest)) - (let [xform (in rest 0) from (in rest 1)] - (core-transduce xform (fn [& a] (case (length a) 0 to 1 (a 0) (core-conj (a 0) (a 1)))) to from)) - (into-conj to (realize-for-iteration (in rest 0))))) - -(defn core-sequence - "(sequence coll) -> a seq of coll. (sequence xform coll) -> a LAZY seq of coll - transformed by xform: elements are pulled and pushed through the transducer one - at a time, with outputs buffered and emitted lazily — so it works over infinite - input (matching Clojure). Honors `reduced` (early stop) and runs the completion - arity to flush stateful transducers (e.g. partition-all)." - [a & rest] - (if (= 0 (length rest)) - (core-seq a) - (let [xform a - coll (in rest 0) - buf @[] - state @{:stopped false :completed false} - rf (fn [& args] - (case (length args) - 0 buf - 1 (in args 0) - (do (array/push (in args 0) (in args 1)) (in args 0)))) - xf (xform rf)] - # Pull/complete until buf holds an output or the source is fully drained. - (defn ensure-buf [src] - (var s src) - (while (and (= 0 (length buf)) (not (state :stopped)) (not (seq-done? s))) - (let [r (xf buf (core-first s))] - (set s (core-rest s)) - (when (core-reduced? r) (put state :stopped true)))) - (when (and (= 0 (length buf)) (not (state :completed)) - (or (state :stopped) (seq-done? s))) - (put state :completed true) - (xf buf)) # completion arity — flushes any buffered state - s) - (defn gen [src] - (fn [] - (let [s (ensure-buf src)] - (if (= 0 (length buf)) nil - (let [val (in buf 0)] - (array/remove buf 0 1) - @[val (gen s)]))))) - # core-seq normalizes to a tuple / lazy-seq / nil — all walkable by - # core-first/rest/seq-done?. (Walking a raw pvec/set would misfire: - # seq-done? uses length, which counts a pvec table's KEYS, not elements.) - (make-lazy-seq (gen (core-seq coll)))))) - - -(defn coll->cells [c] - "Convert a seqable to a lazy-seq cell chain: nil or [first, rest-thunk]. - A cons cell is a MUTABLE array `@[val rest-thunk]` (produced by `cons`/the lazy - transformers); user collections (tuples, pvecs, lists) are immutable. We rely - on that distinction: only a mutable 2-array whose tail is a function is treated - as an already-built cell — a user vector like `[first last]` (tail is the fn - `last`) is data and must NOT be misread as a cell. User data is recursed through - immutable tuples so its tails never reach the cell-detection branch." - (if (nil? c) nil - (if (pvec? c) (coll->cells (tuple ;(pv->array c))) - (if (plist? c) (coll->cells (tuple ;(pl->array c))) - (if (function? c) - (let [r (c)] - (if (and (array? r) (= 2 (length r)) (function? (in r 1))) - r - (coll->cells r))) - (if (lazy-seq? c) - (let [cell (realize-ls c)] - (if (= :jolt/pending cell) nil cell)) - (if (tuple? c) - # user sequential data: every element is a value, no cell-detection. - # indexed-cells walks by INDEX — the old (tuple/slice c 1) per cell - # made any walk over a concrete collection O(n^2). - (if (= 0 (length c)) nil (indexed-cells c 0)) - (if (array? c) - # mutable array: a genuine cons cell, or an eager seq result. - (if (= 0 (length c)) nil - (if (and (= 2 (length c)) (function? (in c 1))) - c # already a cell [val, rest-thunk] - (indexed-cells c 0))) - # Other concrete seqables (set/map/sorted coll/string/buffer): coerce - # to a tuple seq via core-seq, then recurse. (lazy/indexed above.) - (if (or (set? c) (phm? c) (buffer? c) (string? c) (core-sorted? c) - (and (struct? c) (nil? (get c :jolt/type))) - # raw host table (System/getenv) — a map: kv entries - (and (table? c) (nil? (get c :jolt/type)) - (nil? (get c :jolt/deftype)))) - (coll->cells (core-seq c)) - nil))))))))) - -(defn lazy-from - "Coerce any seqable to a uniform lazy view without forcing. - Returns nil if coll is nil or empty, the LazySeq unchanged if already lazy, - or a new LazySeq that walks element by element." - [coll] - (if (nil? coll) nil - (if (lazy-seq? coll) coll - (do - # Reject non-seqable scalars (number/boolean/keyword, and tagged structs - # like char/symbol) so a lazy transformer over bad input throws when - # realized — matching Clojure — instead of silently yielding empty. - (when (or (number? coll) (boolean? coll) (keyword? coll) - (and (struct? coll) (not (nil? (get coll :jolt/type))))) - (error (string "Don't know how to create ISeq from: " (type coll)))) - (let [cell (coll->cells coll)] - (if (nil? cell) nil - (make-lazy-seq (fn [] cell)))))))) - -(defn core-map [f & colls] - (def f (as-fn f)) - (if (= 0 (length colls)) - (td-map f) # transducer arity - (if (= 1 (length colls)) - (let [coll (colls 0)] - # Option A: always lazy, even over concrete collections (matches Clojure — - # map returns a seq, not a vector). - (do - (defn mstep [c] - (fn [] - (if (seq-done? c) nil - @[(f (core-first c)) (mstep (core-rest c))]))) - (make-lazy-seq (mstep (lazy-from coll))))) - # Multi-collection: lazy-seq with per-element independent state - (let [init-cs (array/new-filled (length colls) nil) - init-idxs (array/new-filled (length colls) 0) - init-reals (array/new-filled (length colls) nil) - _ (do - (var i 0) - (while (< i (length colls)) - (let [c (in colls i)] - (if (lazy-seq? c) - (put init-cs i c) - (do (put init-cs i nil) - (put init-reals i (if (set? c) (phs-seq c) (realize-for-iteration c)))))) - (++ i)) - nil)] - (defn step [cs idxs reals] - "cs: current lazy-seq cursors, idxs: indices, reals: realized colls" - (fn [] - (var args @[]) - (var next-cs (array/new-filled (length cs) nil)) - (var next-idxs (array/new-filled (length idxs) 0)) - (var next-reals (array/new-filled (length reals) nil)) - (var ok true) - (var i 0) - (while (< i (length cs)) - (let [cur (in cs i) ridx (in idxs i) real (in reals i)] - (if (not (nil? cur)) - # Detect exhaustion with seq-done?, NOT (nil? (ls-first)): a - # lazy-seq can legitimately contain nil elements, and treating the - # first nil as end-of-seq truncates (e.g. mapping over a previous - # map result that holds nils). - (if (seq-done? cur) (do (set ok false) (break)) - (do (array/push args (ls-first cur)) - (put next-cs i (ls-rest cur)) - (put next-idxs i (+ ridx 1)) - (put next-reals i nil))) - (let [c (if (nil? real) - (let [rc (realize-for-iteration (in colls i))] - (put next-reals i rc) rc) - real)] - (if (>= ridx (length c)) (do (set ok false) (break)) - (do (array/push args (in c ridx)) - (put next-cs i nil) - (put next-idxs i (+ ridx 1)) - (put next-reals i c)))))) - (++ i)) - (if (and ok (= (length args) (length cs))) - @[(apply f args) (step next-cs next-idxs next-reals)] - nil))) - (make-lazy-seq (step init-cs init-idxs init-reals)))))) - -(defn core-filter [pred & rest] - (def pred (as-fn pred)) - (if (= 0 (length rest)) (td-filter pred) - (let [coll (in rest 0)] - # Option A: always lazy (matches Clojure — filter returns a seq). - (do - (defn fstep [c] - (fn [] - (var cur c) (var hit nil) (var found false) - (while (and (not found) (not (seq-done? cur))) - (let [x (core-first cur)] - (if (pred x) (do (set hit @[x (core-rest cur)]) (set found true)) - (set cur (core-rest cur))))) - (if found @[(in hit 0) (fstep (in hit 1))] nil))) - (make-lazy-seq (fstep (lazy-from coll))))))) - -(defn core-remove [pred & rest] - (def pred (as-fn pred)) - (if (= 0 (length rest)) (td-remove pred) - (core-filter (fn [x] (not (pred x))) (in rest 0)))) - -(def core-reduce - (fn [& args] - (case (length args) - # 2-arg: seed is the first element; reduce over the rest. Lazy seqs are - # stepped incrementally (via reduce-with-reduced) so `reduced` can - # short-circuit an infinite seq rather than realizing it. - 2 (let [f (args 0) coll (args 1)] - (if (lazy-seq? coll) - (let [cell (realize-ls coll)] - (if (or (nil? cell) (= :jolt/pending cell) (= 0 (length cell))) - (f) - (let [rt (in cell 1)] - (if (nil? rt) (in cell 0) - (reduce-with-reduced f (in cell 0) (ls-rest-cached coll rt)))))) - (let [c (if (set? coll) (phs-seq coll) (realize-for-iteration coll))] - (if (= 0 (length c)) (f) - (reduce-with-reduced f (in c 0) (array/slice c 1)))))) - 3 (let [f (args 0) val (args 1) coll (args 2)] - # reify clojure.lang.IReduceInit: the reified value carries its own - # reduce — call it (ring.util.codec's tokenizer reduces this way) - (if-let [m (and (table? coll) - (get coll :jolt/protocol-methods) - (get (get coll :jolt/protocol-methods) :reduce))] - (m coll f val) - (reduce-with-reduced f val coll))) - (error "Wrong number of args passed to: reduce")))) - -(defn core-take [n & rest] - # n is a count — reject non-numbers (e.g. a char/string) like Clojure, rather - # than letting Janet's >= silently compare mixed types. - (unless (number? n) (error (string "take: n must be a number, got " (type n)))) - (if (= 0 (length rest)) (td-take n) - (let [coll (in rest 0)] - # Option A: lazy take (returns a seq, not a vector, even over a vector). - (defn tstep [c i] - (fn [] - (if (or (>= i n) (seq-done? c)) nil - @[(core-first c) (tstep (core-rest c) (+ i 1))]))) - (make-lazy-seq (tstep (lazy-from coll) 0))))) - -(defn core-drop [n & rest] - (if (= 0 (length rest)) (td-drop n) - (let [coll (in rest 0)] - # Option A: lazy drop — skip n (forcing only those), return the lazy tail. - (make-lazy-seq - (fn [] - (var cur (lazy-from coll)) - (var i 0) - (while (and (< i n) (not (seq-done? cur))) - (set cur (core-rest cur)) - (++ i)) - (coll->cells cur)))))) - -# ffirst/nfirst/fnext/nnext/last/butlast (seq tier) and second/peek/subvec/mapv/ -# update (kernel tier) now live in the Clojure clojure.core tiers under -# jolt-core/clojure/core/. The kernel tier is bootstrap-compiled before the -# self-hosted analyzer is built, so the structural fns the analyzer uses come -# from Clojure, not Janet — see api/load-core-overlay! and core/00-kernel.clj. - -(defn core-take-while [pred & rest] - (def pred (as-fn pred)) - (if (= 0 (length rest)) (td-take-while pred) - (let [coll (in rest 0)] - # Option A: lazy take-while. - (defn twstep [c] - (fn [] - (if (seq-done? c) nil - (let [x (core-first c)] - (if (pred x) @[x (twstep (core-rest c))] nil))))) - (make-lazy-seq (twstep (lazy-from coll)))))) - -(defn core-drop-while [pred & rest] - (def pred (as-fn pred)) - (if (= 0 (length rest)) (td-drop-while pred) - (let [coll (in rest 0)] - (if (lazy-seq? coll) - (do - (defn dwstep [c] - (fn [] - (var cur c) - (while (and (not (seq-done? cur)) (pred (ls-first cur))) - (set cur (ls-rest cur))) - (if (seq-done? cur) nil (realize-ls cur)))) - (make-lazy-seq (dwstep coll))) - # A string iterates as a seq of chars in Clojure; realize-for-iteration - # passes strings through, so char-seq it here (as take-while/remove do) — - # otherwise pred sees raw bytes and array/slice rejects the string. - (let [c0 (realize-for-iteration coll) - c (if (string? c0) (map make-char (string/bytes c0)) c0)] - (var start 0) - (while (and (< start (length c)) (pred (c start))) - (++ start)) - (if (tuple? c) - (tuple/slice c start) - (array/slice c start))))))) - -(defn core-concat [& colls] - "Truly lazy concatenation. `step` returns a 0-arg thunk that is only forced - when the consumer asks for the next cell, so nothing in `colls` is realized at - construction time. This is essential for self-referential lazy seqs (e.g. - (def fib (lazy-cat [0 1] (map + (rest fib) fib)))): the later colls must not be - forced until after the surrounding `def` has bound the var." - (if (= 0 (length colls)) @[] - (let [colls (if (tuple? colls) (array/slice colls) colls)] - (defn step [cs] - (fn [] - (if (= 0 (length cs)) - nil - (let [c (in cs 0) - remaining (array/slice cs 1) - cell (coll->cells c)] - (if (nil? cell) - # current coll is empty: advance to the next one - ((step remaining)) - (let [val (in cell 0) - rest-fn (in cell 1)] - @[val (step (if (nil? rest-fn) - remaining - (array/insert remaining 0 rest-fn)))])))))) - (make-lazy-seq (step colls))))) - - -(defn core-mapcat - "(mapcat f & colls) — map then concat. (mapcat f) returns a transducer." - [f & colls] - (if (= 0 (length colls)) - # transducer: map f over each input, then splice (cat) the result - (fn [rf] - (fn [& a] - (case (length a) - 0 (rf) - 1 (rf (a 0)) - (do (var acc (a 0)) - (each x (realize-for-iteration (f (a 1))) - (set acc (rf acc x))) - acc)))) - # collection arity: direct lazy implementation. Pull one element - # from each input coll, apply f, then yield elements from f's result. - # No apply-forcing — walk input colls lazily element-by-element. - (do - (var n (length colls)) - (var init-cs @[]) - (var i 0) - (while (< i n) - (array/push init-cs (lazy-from (in colls i))) - (++ i)) - (defn step [cs res] - (fn [] - (var cursors cs) (var cur-res res) (var hit nil) (var ok false) - (while (not ok) - (if (nil? cur-res) - (do - (var args @[]) (var next-cs @[]) (var exhausted false) (var j 0) - (while (and (< j n) (not exhausted)) - (let [c (in cursors j)] - (if (seq-done? c) (set exhausted true) - (do - (array/push args (ls-first c)) - (array/push next-cs (ls-rest c))))) - (++ j)) - (if exhausted (break)) - (let [r (apply f args)] - (set cursors next-cs) - (set cur-res (if (or (nil? r) (tuple? r) (array? r) - (lazy-seq? r) (pvec? r) (set? r) (plist? r)) - (lazy-from r) - (lazy-from (tuple r)))))) - (if (seq-done? cur-res) - (set cur-res nil) - (let [val (ls-first cur-res) rest (ls-rest cur-res)] - (set hit @[val (step cursors rest)]) - (set ok true))))) - (if ok hit nil))) - (make-lazy-seq (step init-cs nil))))) - -# reverse now lives in the Clojure collection tier ((reduce conj () coll)). - -(defn core-nth - "Return the nth element of a sequential collection. With a not-found arg, return - it when idx is out of bounds (even if it's nil); without one, throw — matching - Clojure, where (nth coll i nil) returns nil rather than throwing." - [coll idx & rest] - (def has-default (> (length rest) 0)) - (def default (if has-default (in rest 0) nil)) - (defn oob [n] (if has-default default (error (string "Index " idx " out of bounds, length: " n)))) - (if (nil? coll) default # (nth nil i) -> nil / default, never throws - (if (core-transient? coll) - (let [a (coll :arr)] (if (and (>= idx 0) (< idx (length a))) (in a idx) (oob (length a)))) - (if (plist? coll) - (let [a (pl->array coll)] - (if (and (>= idx 0) (< idx (length a))) (in a idx) (oob (length a)))) - (if (pvec? coll) - (if (and (>= idx 0) (< idx (pv-count coll))) - (pv-nth coll idx) - (oob (pv-count coll))) - (if (lazy-seq? coll) - # Walk with seq-done?, NOT (ls-first cur): a lazy element may legitimately be - # false or nil, which truthiness would mistake for end-of-seq. - (if (< idx 0) (oob 0) - (do - (var cur coll) - (var i 0) - (while (and (< i idx) (not (seq-done? cur))) - (set cur (core-rest cur)) - (++ i)) - (if (seq-done? cur) (oob i) (core-first cur)))) - (do - (var c (realize-for-iteration coll)) - (if (and (>= idx 0) (< idx (length c))) - (if (string? c) (make-char (in c idx)) (in c idx)) - (oob (length c)))))))))) - -(defn core-sort - "(sort coll) or (sort comparator coll). Comparator may return a boolean or a - Clojure-style negative/zero/positive number." - [a & rest] - (let [has-cmp (> (length rest) 0) - cmp (if has-cmp a nil) - coll (if has-cmp (first rest) a)] - (if (nil? coll) @[] - (let [arr (array/slice (realize-for-iteration coll))] - (if has-cmp - (sort arr (fn [x y] (let [r (cmp x y)] (if (number? r) (< r 0) (truthy? r))))) - (sort arr)) - (tuple/slice (tuple ;arr)))))) - -# (sort-by keyfn coll) or (sort-by keyfn comparator coll). The comparator (when -# given) compares the KEYS and may return a boolean or a Clojure-style number. -# sort-by now lives in the Clojure collection tier — canonical: compare- -# defaulted (nil sorts first), comparator over KEYS, via the host sort seam. - -# distinct now lives in the Clojure lazy tier (core/40-lazy.clj). -# group-by / frequencies now live in the Clojure collection tier -# (core/20-coll.clj). - -(defn core-partition - "(partition n coll), (partition n step coll), or (partition n step pad coll). - Only complete partitions of size n are kept; with pad, the final partial - partition is padded from pad (possibly to fewer than n if pad runs out)." - [n & rest] - (let [argc (length rest) - step (if (>= argc 2) (first rest) n) - pad (if (>= argc 3) (in rest 1) nil) - has-pad (>= argc 3) - coll (case argc 1 (first rest) 2 (in rest 1) 3 (in rest 2))] - # Option A: always lazy. - (defn pstep [c] - (fn [] - (if (seq-done? c) nil - (do - (var part @[]) (var cur c) (var i 0) - (while (and (< i n) (not (seq-done? cur))) - (array/push part (core-first cur)) - (set cur (core-rest cur)) - (++ i)) - (cond - (= i n) - (let [next-cur (if (= step n) cur (lazy-from (core-drop (- step n) cur)))] - @[(tuple/slice (tuple ;part)) (pstep next-cur)]) - # partial final partition: pad it (last partition, then stop) - (and has-pad (> i 0)) - (do - (each x (realize-for-iteration pad) - (when (< (length part) n) (array/push part x))) - @[(tuple/slice (tuple ;part)) (fn [] nil)]) - nil))))) - (make-lazy-seq (pstep (lazy-from coll))))) - -# partition-by now lives in the Clojure seq tier (core/10-seq.clj). - -# partition-all now lives in the Clojure lazy tier (core/40-lazy.clj). - - -# keep-indexed / map-indexed / cycle now live in the Clojure lazy tier -# (core/40-lazy.clj). - -# reduce-kv now lives in the Clojure collection tier (core/20-coll.clj). - -# pop is defined only on stacks (vectors -> last end, lists -> front); Clojure -# throws on sets/maps/seqs/strings/scalars. (peek lives in the Clojure kernel -# tier — core/00-kernel.clj.) -# subvec lives in the Clojure kernel tier — core/00-kernel.clj. - -# trampoline now lives in the Clojure collection tier (core/20-coll.clj). - -(def core-format (fn [fmt & args] (string/format fmt ;args))) - -# ============================================================ -# Sequence generators -# ============================================================ - -(def core-range - (fn [& args] - (if (= 0 (length args)) - # (range) — infinite lazy sequence 0, 1, 2, ... - (do - (defn rstep [i] (fn [] @[i (rstep (+ i 1))])) - (make-lazy-seq (rstep 0))) - (let [start (if (> (length args) 1) (args 0) 0) - end (if (> (length args) 1) (args 1) (args 0)) - step (if (> (length args) 2) (args 2) 1)] - (var result @[]) - (var i start) - (while (if (pos? step) (< i end) (> i end)) - (array/push result i) - (+= i step)) - (tuple/slice (tuple ;result)))))) - -# repeat / iterate now live in the Clojure lazy tier (core/40-lazy.clj). - -# repeatedly now lives in the Clojure lazy tier (core/40-lazy.clj). - -# ============================================================ -# Higher-order functions -# ============================================================ - -# identity / constantly live in the Clojure collection tier (core/20-coll.clj). - -# complement now lives in the Clojure collection tier (core/20-coll.clj). - -# inst?/inst-ms live in the Clojure collection tier (core/20-coll.clj). -# Jolt has no uri host type, so uri? is always false. -# uri? lives in the Clojure collection tier (no uri host type: always false). -# uuid? now lives in the Clojure collection tier (tagged-value predicate). -(defn core-bytes? [x] (buffer? x)) -# tagged-literal? now lives in the Clojure collection tier (tagged-value predicate). - -(defn core-meta [x] - "Returns the metadata of x, or nil." - (cond - (var? x) (var-meta x) - # symbols carry reader metadata (type hints etc.) in a :meta field - (and (struct? x) (= :symbol (get x :jolt/type))) (get x :meta) - (table? x) (or (get x :jolt/meta) (get x :meta)) - nil)) - -# every-pred now lives in the Clojure collection tier (core/20-coll.clj). - -# Public comp lives in the overlay now (20-coll) — its stages can be any jolt -# IFn (keyword/map/set/vector), which raw Janet calls mishandle ((comp seq -# :content) returned nil: janet keyword-apply is not jolt invoke). This -# private composer remains ONLY for the transducer machinery below, where the -# stages are always real fns. -# (td-comp is gone: eduction — its last caller — lives in the overlay now.) - -# partial now lives in the Clojure collection tier (canonical arities). - -# juxt now lives in the Clojure collection tier (core/20-coll.clj). - -# memoize now lives in the Clojure collection tier — find-based, so it -# caches nil results too (this kernel fn re-computed them). - -# ============================================================ -# Collection constructors -# ============================================================ - -(defn core-vector [& xs] (make-vec xs)) -(defn core-hash-map [& kvs] (make-phm kvs)) - -(defn core-array-map [& kvs] - (var result @{}) - (var i 0) - (while (< i (length kvs)) - (put result (kvs i) (kvs (+ i 1))) - (+= i 2)) - (table/to-struct result)) - -(defn core-hash-set [& xs] - (apply make-phs xs)) - -# sorted sets are tagged tables the host set? predicate misses (jolt-dpn) -(defn core-set? [x] (or (set? x) (core-sorted-set? x))) -(defn core-disj [s & ks] - (cond - (core-sorted-set? s) ((sorted-op s :disj) s ks) - (set? s) (apply phs-disj s ks) - (error "disj expects a set"))) - -(defn core-set [coll] - (apply core-hash-set (realize-for-iteration coll))) - -(defn core-list [& xs] - (array ;xs)) - -# ============================================================ diff --git a/src/jolt/core_extra.janet b/src/jolt/core_extra.janet deleted file mode 100644 index 982c6a5..0000000 --- a/src/jolt/core_extra.janet +++ /dev/null @@ -1,469 +0,0 @@ -# Jolt Core — additional clojure.core fns, transients, hashing -# Extracted from core.janet (jolt-nma8, phase 2b split). - -(use ./types) -(use ./phm) -(use ./phs) -(use ./lazyseq) -(use ./regex) -(use ./config) -(use ./pv) -(use ./plist) -(use ./core_types) -(use ./core_coll) -(use ./core_print) -(use ./core_io) -(use ./core_refs) -# Threading macros (as regular functions? No, as macros in Clojure) -# These need to be defined as macros in the Jolt namespace system. -# For now, skip — they need proper macro definition via the evaluator. -# ============================================================ - -# ============================================================ -# Initialization — intern everything into a context's namespace -# ============================================================ - -(def gensym_counter @{:val 0}) - -(defn gensym - "Returns a new symbol with a unique name." - [&opt prefix-string] - (default prefix-string "G__") - (def n (get gensym_counter :val)) - (put gensym_counter :val (+ n 1)) - {:jolt/type :symbol :ns nil :name (string prefix-string n)}) - - -# if-let/when-let/if-some/when-some now live in the Clojure overlay -# (core/30-macros.clj) as defmacros. - -(defn core-push-thread-bindings [b] (push-thread-bindings b)) -(defn core-pop-thread-bindings [] (pop-thread-bindings)) - -(defn core-var-get [v] (var-get v)) -(defn core-var-set [v val] (var-set v val)) -(defn core-var? [x] (var? x)) -(defn core-alter-var-root [v f & args] (apply alter-var-root v f args)) -(defn core-alter-meta! [v f & args] (apply alter-meta! v f args)) -(defn core-reset-meta! [v meta] (reset-meta! v meta)) - -# intern is a ctx-capturing clojure.core fn now (install-stateful-fns!). - -# get-method/methods/remove-method/remove-all-methods/prefer-method are -# overlay macros (core/30-macros.clj) over the evaluator's *-setup fns. - -(defn core-with-meta [obj meta] - # Functions and scalars can't carry metadata in Jolt's model — return as-is - # rather than crashing (Clojure attaches meta only to IObj values). - (cond - (or (function? obj) (cfunction? obj) (number? obj) (boolean? obj) - (nil? obj) (string? obj) (keyword? obj) (buffer? obj)) - obj - # Symbols carry metadata IN-PLACE in their struct's :meta field (this is how - # the reader attaches ^hint and keeps symbol? true — see reader/read-meta). - # The table-proto path below would make (symbol? (with-meta sym ..)) false and - # break destructuring/hint reading, so keep a symbol a symbol. - (and (struct? obj) (= :symbol (obj :jolt/type))) - (struct ;(kvs obj) :meta meta) - true - (do - (var new-obj @{}) - (each k (keys obj) - (put new-obj k (get obj k))) - # table/setproto requires a table, convert struct meta to table. meta may - # be nil (Clojure allows (with-meta obj nil) to clear metadata). - (var meta-tab @{}) - (when meta (each k (keys meta) (put meta-tab k (get meta k)))) - (table/setproto new-obj meta-tab) - (put new-obj :jolt/meta meta) - new-obj))) - -(defn core-var-dynamic? [v] - (var-dynamic? v)) - -# Java interop stubs -(def core-Object (fn [] (struct ;[:jolt/type :jolt/java-object]))) - -# Volatiles — typed box so deref/volatile? can recognize them. -(defn core-volatile! [v] @{:jolt/type :jolt/volatile :val v}) -# volatile? / vreset! / vswap! now live in the Clojure collection tier — vreset! -# over jolt.host/ref-put!, vswap! over vreset! + get. The constructor stays native. - -# Delays — created lazily by the `delay` macro; forced once via force/deref. -(defn core-make-delay [thunk] @{:jolt/type :jolt/delay :fn thunk :realized false :val nil}) -(defn core-delay? [x] (and (table? x) (= :jolt/delay (x :jolt/type)))) -# Proxy stub — returns nil form (macro, args not evaluated) -# Thread stubs -(def core-Thread (fn [& args] (struct ;[:jolt/type :jolt/thread]))) -(def core-ThreadLocal (fn [& args] (struct ;[:jolt/type :jolt/thread-local]))) -(def core-IllegalStateException (fn [& args] (struct ;[:jolt/type :jolt/exception]))) - - - -# letfn — mutually-recursive local fns. Expands to let* of fn* bindings; jolt -# closures capture the (shared, mutable) bindings table, so forward references -# between the fns resolve at call time. - -# doseq — like `for` but eager and returns nil. Reuse `for`, force realization -# with `count`, discard the result. -# assert — (assert x) / (assert x message). Throws when x is falsy. - -# ns-name now lives in the Clojure collection tier (pure over get + symbol). - -# update lives in the Clojure kernel tier — core/00-kernel.clj. update-in stays -# (it's recursive and has internal callers). -(defn- ks-rest [ks] - (if (tuple? ks) (tuple/slice ks 1) (array/slice ks 1))) - -# assoc-in / update-in now live in the Clojure collection tier (canonical -# recursive ports). - - - -# fnil now lives in the Clojure collection tier (core/20-coll.clj), with -# Clojure's canonical 2/3/4-arity (patch the first 1-3 args only). - -# copy-var stubs for sci.impl.copy-vars (used by sci.impl.namespaces) -(defn core-copy-core-var [sym] nil) -(defn core-copy-var [sym & args] nil) -(defn core-macrofy [sym fn & more] fn) -(defn core-new-var [sym & args] nil) -# A free-standing var cell (not interned anywhere): with-local-vars binds -# these as locals; var-get/var-set work on any cell. -(defn core-local-var [&opt val] - @{:jolt/type :jolt/var :name "local" :ns nil :root val :gen 0}) -# with-open's close seam: a map-like value closes via its :close fn, a host -# file via file/close. No .close interop on the Janet host. -(defn core-close-resource [x] - (cond - (and (or (table? x) (struct? x)) (function? (get x :close))) ((get x :close)) - (= :core/file (type x)) (file/close x) - (error (string "with-open: don't know how to close " (type x))))) -# sci stub: pass the registry map through (it was @{} — a raw host table that -# strict map-conj rightly rejects; identity also keeps sci's registry intact). -(defn core-avoid-method-too-large [& args] (if (> (length args) 0) (in args 0) {})) - -# declare macro — accepts symbols, does nothing (forward declaration) - -# Build a protocol value (a self-evaluating tagged table). Exposed so the overlay -# `defprotocol` can construct one via a fn call rather than embedding a tagged -# struct literal (which the interpreter would try to re-evaluate). `methods` is a -# {kw {:name str}} map; only :name is consulted (by satisfies?). -(defn core-make-protocol [name-str methods] - @{:jolt/type :jolt/protocol - :name {:jolt/type :symbol :ns nil :name name-str} - :methods methods}) - -# extends? is a real overlay fn now (30-macros, over extenders). -(def core-implements? (fn [& args] false)) - -# ============================================================ -# Additional clojure.core functions (conformance batch) -# ============================================================ - -(defn core-keyword - "(keyword name) or (keyword ns name). Namespaced keywords are `:ns/name`. - (keyword nil) is nil; the 2-arg form requires string args (nil ns allowed)." - [& args] - (case (length args) - 1 (let [a (in args 0)] - (cond - (nil? a) nil - (keyword? a) a - (or (string? a) (core-symbol? a)) (keyword (core-name a)) - (error (string "keyword requires a string, symbol or keyword, got " (type a))))) - 2 (let [ns (in args 0) nm (in args 1)] - (when (not (and (or (nil? ns) (string? ns)) (string? nm))) - (error "keyword ns and name must be strings")) - (keyword (if ns (string ns "/" nm) nm))) - (keyword ;args))) - -(defn core-symbol - "(symbol name) or (symbol ns name) -> a jolt symbol struct. name/ns must be - strings (a single symbol arg is returned as-is)." - [& args] - (case (length args) - 1 (let [a (in args 0)] - (cond - (core-symbol? a) a - (or (string? a) (keyword? a)) {:jolt/type :symbol :ns nil :name (core-name a)} - (error (string "symbol requires a string or symbol, got " (type a))))) - 2 (let [ns (in args 0) nm (in args 1)] - (when (not (and (or (nil? ns) (string? ns)) (string? nm))) - (error "symbol ns and name must be strings")) - {:jolt/type :symbol :ns ns :name nm}) - (error "symbol expects 1 or 2 args"))) - -# (take-nth's transducer arity lives in the overlay now.) - - -# filterv now lives in the Clojure collection tier (core/20-coll.clj). - -# mapv lives in the Clojure kernel tier — core/00-kernel.clj. - -# (interpose's transducer arity lives in the overlay now.) -# interpose / take-nth now live in the Clojure lazy tier (core/40-lazy.clj), -# with the canonical transducer arities. - -# keep now lives in the Clojure lazy tier (core/40-lazy.clj). - -# empty now lives in the Clojure collection tier (core/20-coll.clj); a lazy -# seq empties to () there (this fn returned a host table for it). - -# not-empty now lives in the Clojure collection tier (core/20-coll.clj). - -# rseq is defined only on vectors and sorted collections (Reversible). -(defn core-rseq [coll] - (cond - (pvec? coll) (tuple/slice (tuple ;(reverse (pv->array coll)))) - (core-sorted? coll) ((sorted-op coll :rseq) coll) - (error (string "rseq requires a vector or sorted collection, got " (type coll))))) - - - -# some-fn now lives in the Clojure collection tier (core/20-coll.clj). - -# Associative = maps and (real) vectors only. pvec is a literal/built vector; -# tuples and lists are seq results, not associative. -# ifn? now lives in the Clojure collection tier — canonical IFn set (fns, -# keywords, symbols, maps, sets, vectors, vars); lists are NOT IFn. -# With a single item, Clojure returns it WITHOUT calling f. On ties, the last -# extremal item wins (>=/<= update), matching Clojure. -# Clojure's min-key/max-key: the 2-arg base compares with strict < / > (so the -# second wins on ties/NaN), and each further item switches on <= / >=. This -# asymmetry reproduces the JVM's NaN-ordering behavior. Janet's < / > are used -# directly (NaN comparisons are false, never throwing). -# keys must be numbers (NaN allowed) — like Clojure, which compares them with . -# min-key / max-key now live in the Clojure collection tier (core/20-coll.clj). - -# vary-meta / namespace-munge now live in the Clojure collection tier -# (core/20-coll.clj) — pure compositions of meta/with-meta and str/map. - -# Exceptions (ex-info / ex-data / ex-message) -(defn core-ex-info [msg data & more] - @{:jolt/type :jolt/ex-info :message msg :data data - :cause (if (> (length more) 0) (in more 0) nil)}) -# ex-data / ex-message / ex-cause now live in the Clojure collection tier -# (core/20-coll.clj) — pure over get on the tagged value the constructor builds. - -# String split/replace that accept either a literal string or a regex value. -(defn core-str-split [pat s &opt limit] - (if (regex? pat) - (re-split pat s limit) - (let [parts (string/split pat s)] - # literal separator: a positive limit caps the part count; rejoin the tail - # with the (constant) separator to recover the unsplit remainder. - (if (and limit (> limit 0) (> (length parts) limit)) - (array/push (array/slice parts 0 (- limit 1)) - (string/join (array/slice parts (- limit 1)) pat)) - parts)))) -(defn core-str-replace-all [pat repl s] - (if (regex? pat) - (re-replace-all pat s repl) - (string/replace-all pat repl s))) -(defn core-str-replace-first [pat repl s] - (if (regex? pat) - (re-replace-first pat s repl) - (string/replace pat repl s))) - -# Iterator/enumeration seqs — Jolt has no Java iterators, so adapt to plain seq. -# enumeration-seq / iterator-seq live in the Clojure collection tier. -# xml-seq now lives in the Clojure collection tier (core/20-coll.clj). -# line-seq now lives in the Clojure IO tier (core/50-io.clj), over the reader -# protocol of the *in* family. -(defn core-re-matcher [re s] @{:jolt/type :jolt/matcher :re re :s s :pos 0}) - -# bean / print-method / print-dup / the proxy surface live in the Clojure -# collection tier (JVM-shape stubs; print hooks inert until jolt-g1r). -# == lives in the Clojure collection tier (core/20-coll.clj); memfn is an -# overlay macro (core/30-macros.clj) over the .method call sugar. -# eduction / ->Eduction live in the Clojure collection tier (core/20-coll.clj). - -(def- char-escapes - {10 "\\n" 9 "\\t" 13 "\\r" 12 "\\f" 8 "\\b" 34 "\\\"" 92 "\\\\"}) -(def- char-names - {10 "newline" 9 "tab" 13 "return" 12 "formfeed" 8 "backspace" 32 "space"}) -# char-escape-string / char-name-string now live in the Clojure collection -# tier as char-keyed maps. The CODE-keyed tables below stay: pr-render uses them. - - -# subseq / rsubseq over sorted collections -# subseq / rsubseq now live in the Clojure sorted tier (core/25-sorted.clj), -# along with the constructors and all sorted-coll semantics. - -# ============================================================ -# Additional clojure.core functions -# ============================================================ - -# Integer-valued: a finite number equal to its floor. Infinity floors to itself -# but is NOT integer-valued (so float?/double? are true for ##Inf, and int?/ -# pos-int?/… are false), and NaN is excluded by the equality check. -(defn- intval? [x] (and (number? x) (< (math/abs x) math/inf) (= x (math/floor x)))) - -# Forcing lazy seqs -# Map entries (represented as 2-element vectors) -# key/val require a map entry (a 2-element vector/tuple in Jolt); Clojure throws -# otherwise. (Jolt can't distinguish a 2-vector from a real MapEntry.) -# A map entry is a 2-element tuple — Jolt produces tuples only from map -# iteration (first/seq/map over a map), while vector literals are pvecs and -# lists are arrays. So key/val/map-entry? accept a 2-tuple and reject a plain -# vector, matching Clojure (where a MapEntry is distinct from a vector). -(defn- entry-like? [x] (and (tuple? x) (= 2 (length x)))) -# key / val now live in the Clojure collection tier (core/20-coll.clj), -# along with find (previously missing from jolt entirely). -(defn core-map-entry? [x] (entry-like? x)) - -# Reversible (supports rseq) = vectors and sorted collections. -# Numeric predicates (Jolt has no ratios/bigdec). nat-int?/pos-int?/neg-int?/ -# ratio?/decimal?/rational? live in the Clojure collection tier (core/20-coll.clj). -# Jolt has no ratio type, so numerator/denominator have no valid input (Clojure -# requires a Ratio and throws otherwise). -# numerator / denominator now live in the Clojure collection tier (Jolt has -# no ratios; they throw, as on a non-ratio in Clojure). - -# special-symbol? lives in the Clojure collection tier (a quoted symbol set). - -# record? now lives in the Clojure collection tier (tagged-value predicate). - -# Promise: single-threaded box backed by an atom (deref returns nil until set). -# promise / deliver live in the Clojure collection tier (an atom; deref of an -# undelivered promise is nil — single-threaded host, no blocking). - -(defn core-tagged-literal [tag form] @{:jolt/type :jolt/tagged-literal :tag tag :form form}) -# ensure-reduced / halt-when live in the Clojure collection tier -# (core/20-coll.clj) — halt-when is the canonical ::halt-map version there. -(defn core-re-groups [m] (error "re-groups: stateful matchers are not supported in Jolt")) - -# Transients — real mutable scratch collections backed by Janet's native arrays -# and tables (host interop): O(1) conj!/assoc!/dissoc!/disj!/pop!, frozen back to -# a persistent value by persistent!. A transient is a tagged table holding either -# a Janet array (vectors) or a Janet table keyed by canonical key (maps/sets, so -# collection keys still compare by value). The mutating ops return the transient. -(defn core-transient [coll] - (cond - (pvec? coll) - @{:jolt/type :jolt/transient :kind :vector :arr (pv->array coll)} - (set? coll) - (let [t @{}] (each e (phs-seq coll) (put t (tbl-key e) (tbl-box e))) - @{:jolt/type :jolt/transient :kind :set :tbl t}) - (or (phm? coll) (and (struct? coll) (nil? (get coll :jolt/type)))) - (let [t @{}] - (each pair (realize-for-iteration coll) - (put t (tbl-key (in pair 0)) @[(in pair 0) (in pair 1)])) - @{:jolt/type :jolt/transient :kind :map :tbl t}) - # mutable-build arrays (vectors/lists) — copy into a transient vector - (array? coll) @{:jolt/type :jolt/transient :kind :vector :arr (array/slice coll)} - # tuples (reader vectors / map entries) are vectors too - (tuple? coll) @{:jolt/type :jolt/transient :kind :vector :arr (array ;coll)} - (error (string "Don't know how to create a transient from " (type coll))))) - -# A transient is invalidated by persistent!; using it afterwards is a bug. -(defn- tr-check-active! [t] - (when (get t :jolt/persistent) - (error "Transient used after persistent! call"))) - -(defn- tr-conj! [t x] - (tr-check-active! t) - (case (t :kind) - :vector (array/push (t :arr) x) - :set (put (t :tbl) (tbl-key x) (tbl-box x)) - :map (cond - # a [k v] pair (map-entry / 2-vector) - (and (or (pvec? x) (tuple? x) (array? x)) - (= 2 (if (pvec? x) (pv-count x) (length x)))) - (put (t :tbl) (tbl-key (vnth x 0)) @[(vnth x 0) (vnth x 1)]) - # a map: merge all its entries - (or (phm? x) (and (struct? x) (nil? (get x :jolt/type)))) - (each e (map-entries-of x) - (put (t :tbl) (tbl-key (in e 0)) @[(in e 0) (in e 1)])) - (error "conj! on a transient map requires a [key value] pair or a map"))) - t) - -(defn- tr-assoc! [t k v] - (tr-check-active! t) - (case (t :kind) - :vector (let [a (t :arr)] - (when (not (and (number? k) (= k (math/floor k)) (>= k 0) (<= k (length a)))) - (error (string "Index " k " out of bounds for assoc! on a transient vector of length " (length a)))) - (if (= k (length a)) (array/push a v) (put a k v))) - :map (put (t :tbl) (tbl-key k) @[k v]) - (error "assoc! expects a transient vector or map")) - t) - -# The bang ops require a transient (Clojure throws otherwise); no lenient -# fallback to the persistent op. -(defn core-conj! [& args] - (cond - (= 0 (length args)) (core-transient (make-vec @[])) # (conj!) -> (transient []) - (= 1 (length args)) (first args) # (conj! coll) -> coll, as-is - (let [t (first args) xs (tuple/slice args 1)] - (if (core-transient? t) - (do (each x xs (tr-conj! t x)) t) - (error "conj! requires a transient"))))) - -(defn core-assoc! [t & kvs] - # assoc! requires an even key/val count, like assoc and Clojure's assoc! — a - # dangling key with no value throws (jolt-ea9k: the former lenient nil-fill - # was non-Clojure and inconsistent with jolt's own plain assoc). - (when (odd? (length kvs)) - (error "assoc! expects an even number of key/value arguments")) - (if (core-transient? t) - (do (var i 0) (while (< i (length kvs)) (tr-assoc! t (in kvs i) (in kvs (+ i 1))) (+= i 2)) t) - (error "assoc! requires a transient"))) - -(defn core-dissoc! [t & ks] - (if (and (core-transient? t) (= :map (t :kind))) - (do (tr-check-active! t) (each k ks (put (t :tbl) (tbl-key k) nil)) t) - (error "dissoc! requires a transient map"))) - -(defn core-disj! [t & xs] - (if (and (core-transient? t) (= :set (t :kind))) - (do (tr-check-active! t) (each x xs (put (t :tbl) (tbl-key x) nil)) t) - (error "disj! requires a transient set"))) - -(defn core-pop! [t] - (if (and (core-transient? t) (= :vector (t :kind))) - (do (tr-check-active! t) - (when (= 0 (length (t :arr))) (error "Can't pop empty vector")) - (array/pop (t :arr)) t) - (error "pop! requires a transient vector"))) - -(defn core-persistent! [t] - (if (core-transient? t) - (do - (tr-check-active! t) - (def result - (case (t :kind) - :vector (make-vec (t :arr)) - # The transient already deduped into a native table; bulk-build the - # persistent value ONCE (bottom-up HAMT) instead of folding a phm-assoc - # per entry. This is the lever behind every transient-based builder - # (frequencies/group-by/set/into) — jolt-5vsp collections. - :set (phs-from-seq (map tbl-unbox (values (t :tbl)))) - :map (phm-from-pairs (values (t :tbl))))) - # Invalidate: any further bang op (or a second persistent!) now throws. - (put t :jolt/persistent true) - result) - (error "persistent! requires a transient"))) - -# Unchecked arithmetic — Jolt numbers don't overflow, so these are plain ops. -# unchecked-* arithmetic lives in the Clojure collection tier -# (core/20-coll.clj); only the masking byte/short/char coercions remain above. - -# Hashing helpers -# Hashes are masked to 24 bits at each step so intermediate products stay within -# Janet's integer range (a float here would make band error). -(defn- h24 [x] (band (hash x) 0xffffff)) -(defn core-hash-combine [a b] (band (bxor (h24 a) (+ (h24 b) 0x9e3779)) 0xffffff)) -(defn core-hash-ordered-coll [coll] - (var h 1) (each x (realize-for-iteration coll) (set h (band (+ (* 31 h) (h24 x)) 0xffffff))) h) -(defn core-hash-unordered-coll [coll] - (var h 0) (each x (realize-for-iteration coll) (set h (band (+ h (h24 x)) 0xffffff))) h) - -# prefers is a macro over prefers-setup now (the store lives on the VAR). - - - -# parse-uuid lives in the Clojure collection tier (core/20-coll.clj) over -# re-matches + the __make-uuid host constructor (types.janet). - diff --git a/src/jolt/core_io.janet b/src/jolt/core_io.janet deleted file mode 100644 index 4e824ec..0000000 --- a/src/jolt/core_io.janet +++ /dev/null @@ -1,235 +0,0 @@ -# Jolt Core — I/O, files, JDBC, compare, type -# Extracted from core.janet (jolt-nma8, phase 2b split). - -(use ./types) -(use ./phm) -(use ./phs) -(use ./lazyseq) -(use ./regex) -(use ./config) -(use ./pv) -(use ./plist) -(use ./core_types) -(use ./core_coll) -(use ./core_print) -# I/O — minimal wrappers -# ============================================================ - -# print/println use str semantics (bare strings); pr/prn use readable (quoted). -# All space-separate their args, like Clojure. -# print/println live in the Clojure collection tier (core/20-coll.clj) over -# the __write / __pr-str1 host seams; str-render-one stays for core-str. -(defn core-write [s] (prin s) nil) - -(defn core-eprint [s] (eprint s) nil) -(defn core-eprintf [fmt & args] (eprintf fmt ;args) nil) - -# next.jdbc host shims (the db library's next.jdbc compat layer builds on these). -# A connection is a tagged table wrapping a jdbc.core conn (:raw) plus clj -# callbacks: :exec runs one SQL string in the transaction (so the janet-side -# Statement.executeBatch can run SQL without a janet->clj call), :close closes -# the underlying conn, :product is the JDBC database product name. instance? -# Connection (evaluator) and the :jolt/jdbc-conn tagged methods (host_interop) key -# off this shape. -(defn core-jdbc-wrap-conn [raw exec closef product] - @{:jolt/type :jolt/jdbc-conn :raw raw :exec exec :close closef - :product product :closed @[false]}) -# Robust unwrap: a wrapped conn -> its :raw; anything else passes through (so the -# next.jdbc fns accept either a wrapped conn or a bare jdbc.core conn/spec). -(defn core-jdbc-conn-raw [x] - (if (and (table? x) (= :jolt/jdbc-conn (get x :jolt/type))) (get x :raw) x)) -(defn core-jdbc-make-stmt [w] - # :close lets with-open close the statement (core-close-resource calls :close); - # nothing to release — executeBatch already ran the commands. - @{:jolt/type :jolt/jdbc-stmt :exec (get w :exec) :cmds @[] :close (fn [] nil)}) - -# java.io.File model (jolt-hjw). io/file and (File. …) build a tagged :jolt/file -# value so (instance? File x) works and migratus's File-vs-jar branching takes -# the filesystem path. The File method surface + nio glob live in host_interop; here -# are the constructor/predicate builtins and the path coercion str/slurp use. -(defn core-file-path - "The path string of a :jolt/file, or (string x) for anything else." - [x] - (if (and (table? x) (= :jolt/file (get x :jolt/type))) (get x :path) (string x))) -(defn core-make-file [path &opt child] - (def base (core-file-path path)) - @{:jolt/type :jolt/file :path (if child (string base "/" (core-file-path child)) base)}) -(defn core-file? [x] (and (table? x) (= :jolt/file (get x :jolt/type)))) - -# newline lives in the Clojure collection tier (core/20-coll.clj). - -# Clojure 1.11 string->scalar parsers: nil on malformed input, throw on a -# non-string. Validation is strict (scan-number alone accepts 0x10 etc.). -(defn- parse-arg-str [s who] - (if (or (string? s) (buffer? s)) (string s) - (error (string who " requires a string, got " (type s))))) - -(defn core-parse-long [s] - (def str* (parse-arg-str s "parse-long")) - (def n (length str*)) - (def start (if (and (> n 0) (or (= 43 (in str* 0)) (= 45 (in str* 0)))) 1 0)) - (if (and (> n start) - (do (var ok true) - (for i start n (when (or (< (in str* i) 48) (> (in str* i) 57)) (set ok false))) - ok)) - (scan-number str*) - nil)) - -(defn core-parse-double [s] - (def str* (parse-arg-str s "parse-double")) - # strict float shape: [+-] digits [. digits] [eE [+-] digits] — at least one - # digit overall; "Infinity"/"-Infinity"/"NaN" accepted like the reference. - (cond - (= str* "Infinity") math/inf - (= str* "-Infinity") (- math/inf) - (= str* "NaN") math/nan - (do - (def pat (peg/compile ~(sequence (opt (set "+-")) (choice (sequence (some :d) (opt (sequence "." (any :d)))) (sequence "." (some :d))) (opt (sequence (set "eE") (opt (set "+-")) (some :d))) -1))) - (if (peg/match pat str*) (scan-number str*) nil)))) - -# parse-boolean lives in the Clojure collection tier (core/20-coll.clj). - -# Host time source for the `time` macro (monotonic, milliseconds). -(defn core-current-time-ms [] (* 1000 (os/clock :monotonic))) - -# Host IO (host-classified in the spec): path-based slurp/spit, *out* flush. -# Opts (:encoding ...) are accepted and ignored — everything is UTF-8 here. -# Reader shims (java.io.StringReader / PushbackReader / anything carrying -# :s + :pos) DRAIN instead of opening a file: Ring middleware slurps request -# bodies, and the jolt Ring adapter hands those over as StringReaders. -(defn core-slurp [src & opts] - (cond - (core-file? src) (string (slurp (core-file-path src))) - (and (table? src) (string? (get src :s)) (number? (get src :pos))) - (let [s (src :s) p (src :pos)] - (put src :pos (length s)) - (string/slice s p)) - # a byte-array / buffer body: bytes already in hand, just stringify - (buffer? src) (string src) - (string (slurp src)))) - -(defn core-spit [path content & opts] - (def append? (do (var a false) (var i 0) - (while (< i (length opts)) - (when (and (= :append (in opts i)) (in opts (+ i 1))) (set a true)) - (+= i 2)) - a)) - (def f (file/open (core-file-path path) (if append? :a :w))) - (file/write f (str-render-one content)) - (file/close f) - nil) - -(defn core-flush [] - (def out (dyn :out)) - (when out (file/flush out)) - nil) - -# Thread-binding introspection over the frame stack (types/cur-binding-stack). -(defn core-get-thread-bindings [] - # Innermost frame wins: merge frames oldest-first. The result is a Janet - # STRUCT keyed by the var tables themselves — the exact frame representation - # var-get reads (identity-keyed get) — so the map can be re-pushed by - # with-bindings*/bound-fn* and remains lookup-able with (get m the-var). - (def acc @{}) - (each frame (snapshot-bindings) - (each entry (realize-for-iteration frame) - (put acc (in entry 0) (in entry 1)))) - (table/to-struct acc)) - -(defn core-thread-bound?* [v] - (var found false) - (each frame (snapshot-bindings) - (each entry (realize-for-iteration frame) - (when (= (in entry 0) v) (set found true)))) - found) - -# Directory primitives for file-seq (paths, not File objects — host-classified). -(defn core-dir? [path] - (def st (os/stat path)) - (and st (= :directory (st :mode)))) - -(defn core-list-dir [path] - (def entries (os/dir path)) - (map (fn [e] (string path "/" e)) (sort entries))) - -# Clojure compare: a total order over comparable values. nil sorts first; -# numbers numerically; strings/keywords lexically; symbols by ns then name; -# booleans false x y) 1 0)) - (cond - (and (nil? a) (nil? b)) 0 - (nil? a) -1 - (nil? b) 1 - (and (number? a) (number? b)) (cmp3 a b) - (and (or (string? a) (buffer? a)) (or (string? b) (buffer? b))) - (cmp3 (string a) (string b)) - (and (keyword? a) (keyword? b)) (cmp3 (string a) (string b)) - (and (core-symbol? a) (core-symbol? b)) - (let [r (cmp3 (string (or (a :ns) "")) (string (or (b :ns) "")))] - (if (= 0 r) (cmp3 (a :name) (b :name)) r)) - (and (boolean? a) (boolean? b)) - (cond (= a b) 0 (= a false) -1 1) - (and (core-char? a) (core-char? b)) (cmp3 (a :ch) (b :ch)) - (and (struct? a) (= :jolt/uuid (get a :jolt/type)) - (struct? b) (= :jolt/uuid (get b :jolt/type))) - (cmp3 (a :str) (b :str)) - (and (struct? a) (= :jolt/inst (get a :jolt/type)) - (struct? b) (= :jolt/inst (get b :jolt/type))) - (cmp3 (a :ms) (b :ms)) - (and (jvec? a) (jvec? b)) - (let [la (vcount a) lb (vcount b)] - (if (not= la lb) - (cmp3 la lb) - (do - (var r 0) (var i 0) - (while (and (= r 0) (< i la)) - (set r (ccompare (vnth a i) (vnth b i))) - (++ i)) - r))) - (error (string "Cannot compare " (type a) " with " (type b)))))) - -# Clojure type: the :type metadata when present, else the value's type. With no -# class objects on this host, the "class" is a symbol: a deftype/record value -# yields its type tag symbol; everything else a taxonomy keyword -# (host-classified — see spec coverage). -(defn core-type [x] - (def m (core-meta x)) - (def override (and m (core-get m :type))) - (if (not (nil? override)) - override - (cond - (and (table? x) (get x :jolt/deftype)) - {:jolt/type :symbol :ns nil :name (get x :jolt/deftype)} - (nil? x) nil - (boolean? x) :boolean - (number? x) :number - (or (string? x) (buffer? x)) :string - (keyword? x) :keyword - (core-symbol? x) :symbol - (core-char? x) :char - (and (struct? x) (get x :jolt/type)) (get x :jolt/type) - (jvec? x) :vector - (core-map? x) :map - (set? x) :set - (core-seq? x) :seq - (or (function? x) (cfunction? x)) :fn - (table? x) (or (get x :jolt/type) :table) - :else (keyword (type x))))) - -# Capture *out*: run thunk with Janet's :out dynamic bound to a buffer, so all -# print/println/pr/prn output (which go through `prin` -> (dyn :out)) is collected -# and returned as a string. The with-out-str macro (overlay) wraps a body thunk. -(defn core-with-out-str [thunk] - (def buf @"") - (with-dyns [:out buf] (thunk)) - (string buf)) - -# pr/prn/pr-str live in the Clojure collection tier (core/20-coll.clj); the -# renderer itself stays host (representation-coupled, shared with hot str). -(defn core-pr-str1 [x] (let [b @""] (pr-render b x) (string b))) - -# ============================================================ diff --git a/src/jolt/core_print.janet b/src/jolt/core_print.janet deleted file mode 100644 index 388c28c..0000000 --- a/src/jolt/core_print.janet +++ /dev/null @@ -1,250 +0,0 @@ -# Jolt Core — string + print rendering (pr-str/str) -# Extracted from core.janet (jolt-nma8, phase 2b split). - -(use ./types) -(use ./phm) -(use ./phs) -(use ./lazyseq) -(use ./regex) -(use ./config) -(use ./pv) -(use ./plist) -(use ./core_types) -(use ./core_coll) -# String functions -# ============================================================ - -# Readable rendering of a value (Clojure pr semantics): strings quoted, -# keywords with leading ':', symbols by name, collections with their reader -# syntax. Used by both pr-str (readable) and str (collection elements). -# A namespace's :name may be a string or a symbol struct depending on the -# creation path — normalize for display. -(defn- ns-display-name [ns] - (def n (ns :name)) - (if (and (struct? n) (= :symbol (get n :jolt/type))) (n :name) (string n))) - -# print-method callback (jolt-g1r): set by api/init AFTER the overlay loads, -# to a (fn [v emit] handled?) that looks for a USER-registered print-method -# multimethod entry for v's dispatch value and renders through it (emit takes -# string pieces). The renderer consults it only on the record/tagged -# fallthrough, so built-in rendering pays nothing. -(var print-method-cb nil) -(defn set-print-method-cb! [f] (set print-method-cb f)) - -# Late-bound hook to a record's custom Object/toString (jolt-rt6n). Returns the -# string a deftype's (toString [_] ...) produces, or nil when the type defines -# none. core can't reach the ctx type-registry directly, so install-print-method-cb! -# wires this per-ctx. str routes records through it; the data repr is the fallback. -(var record-tostring-cb nil) -(defn set-record-tostring-cb! [f] (set record-tostring-cb f)) - -(def- pr-char-escapes - {34 "\\\"" 92 "\\\\" 10 "\\n" 9 "\\t" 13 "\\r" 12 "\\f" 8 "\\b"}) -(var pr-render nil) - -# Format a number the way Clojure prints it: infinity and NaN have named forms -# (Janet renders them "inf"/"-inf"/"nan"). -(defn- fmt-number [v] - (cond - (not (number? v)) (string v) - (= v math/inf) "Infinity" - (= v (- math/inf)) "-Infinity" - (not= v v) "NaN" - (string v))) - -(defn- pr-render-seq [buf items open close] - (buffer/push-string buf open) - (var first true) - (each x items - (if first (set first false) (buffer/push-string buf " ")) - (pr-render buf x)) - (buffer/push-string buf close)) - -(defn- pr-render-pairs [buf pairs] - (buffer/push-string buf "{") - (var first true) - (each pair pairs - (if first (set first false) (buffer/push-string buf ", ")) - (pr-render buf (in pair 0)) - (buffer/push-string buf " ") - (pr-render buf (in pair 1))) - (buffer/push-string buf "}")) - -(defn- name-of - "Extract a plain name string from a string, symbol struct, or a namespace/var - table (reading its :name) — never recurses into the cyclic ns structure." - [x] - (cond - (nil? x) nil - (string? x) x - (and (struct? x) (= :symbol (get x :jolt/type))) (x :name) - (or (struct? x) (table? x)) (name-of (get x :name)) - (string x))) - -(defn- var-display - "Render a Jolt var as #'ns/name. A var's :meta/:ns refs are cyclic, so this - reads only its :name and :ns name — printing the var's pairs would loop." - [v] - (let [nm (name-of (v :name)) - ns (name-of (v :ns))] - (if ns (string "#'" ns "/" nm) (string "#'" nm)))) - -(defn- pr-push-escaped - "Readable string body: escape per char-escapes (quote, backslash, \\n & co), - so pr-str round-trips through the reader (this was unescaped, jolt pre-r6)." - [buf s] - (each c (string/bytes s) - (if-let [esc (get pr-char-escapes c)] - (buffer/push-string buf esc) - (buffer/push-byte buf c)))) - -(set pr-render - (fn [buf v] - (cond - (nil? v) (buffer/push-string buf "nil") - (= true v) (buffer/push-string buf "true") - (= false v) (buffer/push-string buf "false") - (string? v) (do (buffer/push-string buf "\"") (pr-push-escaped buf v) (buffer/push-string buf "\"")) - (buffer? v) (do (buffer/push-string buf "\"") (pr-push-escaped buf (string v)) (buffer/push-string buf "\"")) - (keyword? v) (do (buffer/push-string buf ":") (buffer/push-string buf (string v))) - (core-char? v) (do (buffer/push-string buf "\\") - (buffer/push-string buf - (case (v :ch) - 10 "newline" 32 "space" 9 "tab" 13 "return" - 12 "formfeed" 8 "backspace" 0 "nul" - (char->string v)))) - (number? v) (buffer/push-string buf (fmt-number v)) - (and (struct? v) (= :symbol (v :jolt/type))) - (buffer/push-string buf (if (v :ns) (string (v :ns) "/" (v :name)) (v :name))) - (and (struct? v) (= :jolt/inst (v :jolt/type))) - (do (buffer/push-string buf "#inst \"") (buffer/push-string buf (inst->rfc3339 v)) - (buffer/push-string buf "\"")) - (= :jolt/namespace (get v :jolt/type)) - (do (buffer/push-string buf "#namespace[") - (buffer/push-string buf (ns-display-name v)) - (buffer/push-string buf "]")) - (and (table? v) (= :jolt/var (get v :jolt/type))) (buffer/push-string buf (var-display v)) - (shape-rec? v) - (let [rtag (record-tag v) - pairs (map (fn [k] [k (shape-get v k nil)]) (shape-keys v))] - (cond - # a record shape-rec prints Clojure-style: #ns.Type{:k v, ...} - (and rtag print-method-cb (print-method-cb v (fn [piece] (buffer/push-string buf piece)))) nil - rtag (do (buffer/push-string buf (string "#" rtag)) - (pr-render-pairs buf pairs)) - (pr-render-pairs buf pairs))) - (core-sorted-map? v) (pr-render-pairs buf - (map (fn [e] [(vnth e 0) (vnth e 1)]) (sorted-entries-arr v))) - (core-sorted-set? v) (pr-render-seq buf (sorted-entries-arr v) "#{" "}") - (lazy-seq? v) (pr-render-seq buf (realize-for-iteration v) "(" ")") - (set? v) (pr-render-seq buf (phs-seq v) "#{" "}") - (phm? v) (pr-render-pairs buf (phm-entries v)) - (pvec? v) (pr-render-seq buf (pv->array v) "[" "]") - (plist? v) (pr-render-seq buf (pl->array v) "(" ")") - (and (table? v) (get v :jolt/deftype)) - (if (and print-method-cb (print-method-cb v (fn [piece] (buffer/push-string buf piece)))) - nil - # Clojure's record syntax: #ns.Type{:k v, ...} (fields only, the - # deftype tag elided). This used to print the raw janet table. - (do - (buffer/push-string buf (string "#" (get v :jolt/deftype))) - (pr-render-pairs buf - (filter (fn [pair] (not= :jolt/deftype (in pair 0))) (pairs v))))) - (tuple? v) (pr-render-seq buf v "[" "]") - # mutable mode: arrays are vectors -> print with [] (else lists -> ()) - (array? v) (if mutable? (pr-render-seq buf v "[" "]") (pr-render-seq buf v "(" ")")) - # Any remaining TAGGED value dispatches through print-method when the - # hook is wired: the io tier owns the cold renderings (uuid, regex, - # transient, channel — branches that used to live here), and user - # defmethods on any :jolt/* tag fire from inside nested values. Before - # the overlay loads (init-time error messages) these fall through to - # the raw pairs view below. - (and print-method-cb (get v :jolt/type) - (print-method-cb v (fn [piece] (buffer/push-string buf piece)))) - nil - (struct? v) (pr-render-pairs buf (pairs v)) - (table? v) (pr-render-pairs buf (pairs v)) - true (buffer/push-string buf (string v))))) - -(defn str-render-one - "Render one value with Clojure's `str`/.toString semantics (bare strings, - nil -> empty, keywords/symbols by name, collections via pr-render)." - [v] - (cond - (nil? v) "" - (string? v) v - (buffer? v) (string v) - (core-char? v) (char->string v) - (keyword? v) (string ":" (string v)) - (and (struct? v) (= :symbol (v :jolt/type))) - (if (v :ns) (string (v :ns) "/" (v :name)) (v :name)) - (and (struct? v) (= :jolt/uuid (v :jolt/type))) (v :str) - (and (struct? v) (= :jolt/inst (v :jolt/type))) (inst->rfc3339 v) - # a java.io.File renders as its path (Clojure's File.toString) - (and (table? v) (= :jolt/file (get v :jolt/type))) (get v :path) - # (str pattern) -> raw regex source (no #"" delimiters), so libraries that - # compose patterns via (re-pattern (str p1 ...)) work (Pattern.toString). - (and (table? v) (= :jolt/regex (get v :jolt/type))) (get v :source) - (= :jolt/namespace (get v :jolt/type)) (ns-display-name v) - (and (table? v) (= :jolt/var (get v :jolt/type))) (var-display v) - (number? v) (fmt-number v) - (= true v) "true" - (= false v) "false" - # a record/deftype with a custom Object/toString renders via it (Clojure's - # str/.toString semantics); plain records fall through to the data repr. - (if-let [s (and record-tostring-cb (record-tag v) (record-tostring-cb v))] - s - (let [buf @""] (pr-render buf v) (string buf))))) - -(defn core-str [& xs] - (if (= 0 (length xs)) "" - (do - (var result @[]) - (each x xs (array/push result (str-render-one x))) - (string/join result "")))) - -(defn core-str-join - "clojure.string/join: stringify each element (Clojure semantics), then join." - [coll &opt sep] - (default sep "") - (let [items (realize-for-iteration coll) - parts @[]] - (each x items (array/push parts (str-render-one x))) - (string/join parts (str-render-one sep)))) - -(defn core-name - "Returns the name string of a keyword, symbol, or string (without namespace)." - [x] - (cond - (keyword? x) (let [s (string x) i (string/find "/" s)] (if i (string/slice s (+ i 1)) s)) - (and (struct? x) (= :symbol (x :jolt/type))) (x :name) - (string? x) x - "")) - -(defn core-namespace - "Returns the namespace string of a keyword/symbol, or nil if none." - [x] - (cond - (keyword? x) (let [s (string x) i (string/find "/" s)] (if i (string/slice s 0 i) nil)) - (and (struct? x) (= :symbol (x :jolt/type))) - (if (x :ns) (if (struct? (x :ns)) ((x :ns) :name) (string (x :ns))) nil) - nil)) - -(def core-subs - (fn [& args] - (when (not (or (= 2 (length args)) (= 3 (length args)))) - (error "Wrong number of args passed to: subs")) - (let [s (args 0) - start (get args 1)] - (when (not (string? s)) (error (string "subs requires a string, got " (type s)))) - (let [len (length s) - end (if (= 3 (length args)) (args 2) len)] - # Clojure validates bounds (no negative/from-end/clamping like Janet): - # 0 <= start <= end <= (count s). - (when (not (and (number? start) (number? end) - (= start (math/floor start)) (= end (math/floor end)) - (>= start 0) (<= start end) (<= end len))) - (error "String index out of range")) - (string/slice s start end))))) - -# ============================================================ diff --git a/src/jolt/core_refs.janet b/src/jolt/core_refs.janet deleted file mode 100644 index 9c218d7..0000000 --- a/src/jolt/core_refs.janet +++ /dev/null @@ -1,313 +0,0 @@ -# Jolt Core — arrays, bit ops, coercions, hash, atoms/refs -# Extracted from core.janet (jolt-nma8, phase 2b split). - -(use ./types) -(use ./phm) -(use ./phs) -(use ./lazyseq) -(use ./regex) -(use ./config) -(use ./pv) -(use ./plist) -(use ./core_types) -(use ./core_coll) -(use ./core_print) -(use ./core_io) -# Java-style arrays — backed by Janet's C primitives. Byte arrays use Janet -# buffers (contiguous, O(1) indexed get/put — genuinely fast); object and -# numeric arrays use Janet arrays. aget/aset/alength/aclone work over both. -# ============================================================ - -# alength / aget / aset now live in the Clojure collection tier — count/nth reads -# and an aset write through jolt.host/ref-put!. The typed/object array constructors -# below stay native (they build the mutable backing). - -(defn core-aclone [arr] - (cond - (buffer? arr) (buffer/slice arr) - (pvec? arr) (array ;(pv->array arr)) - (array/slice arr))) - -# Numeric / object arrays: (T-array size) | (T-array size init) | (T-array seq) -(defn- make-num-array [a rest init] - (if (number? a) - (array/new-filled a (if (> (length rest) 0) (in rest 0) init)) - (array ;(realize-for-iteration a)))) -(defn core-object-array [a & rest] (make-num-array a rest nil)) -(defn core-int-array [a & rest] (make-num-array a rest 0)) -(defn core-long-array [a & rest] (make-num-array a rest 0)) -(defn core-short-array [a & rest] (make-num-array a rest 0)) -(defn core-double-array [a & rest] (make-num-array a rest 0)) -(defn core-float-array [a & rest] (make-num-array a rest 0)) -(defn core-char-array [a & rest] - # JVM char-array also accepts a STRING/char-seq (char[] of its characters) — - # selmer's parse-str does (char-array template). - (cond - (string? a) (map make-char (string/bytes a)) - (buffer? a) (map make-char (string/bytes (string a))) - (make-num-array a rest (make-char 0)))) -(defn core-boolean-array [a & rest] (make-num-array a rest false)) - -# Byte arrays — Janet buffers (each element a 0..255 byte). -(defn core-byte-array [a & rest] - (if (number? a) - (buffer/new-filled a (band (if (> (length rest) 0) (in rest 0) 0) 0xff)) - (let [b (buffer/new 0)] - (each x (realize-for-iteration a) (buffer/push-byte b (band x 0xff))) - b))) - -(defn core-aset-byte [arr i v] (put arr i (band v 0xff)) v) -(defn core-aset-int [arr i v] (put arr i v) v) -(defn core-aset-long [arr i v] (put arr i v) v) -(defn core-aset-short [arr i v] (put arr i v) v) -(defn core-aset-double [arr i v] (put arr i v) v) -(defn core-aset-float [arr i v] (put arr i v) v) -(defn core-aset-char [arr i v] (put arr i v) v) -(defn core-aset-boolean [arr i v] (put arr i v) v) - -(defn core-make-array [a & rest] - # (make-array len) or (make-array type len ...); ignore the type tag - (let [len (if (number? a) a (in rest 0))] (array/new-filled len nil))) - -(defn core-into-array [a & rest] - (let [s (if (> (length rest) 0) (in rest 0) a)] - (array ;(realize-for-iteration s)))) - -(defn core-to-array [coll] - (def arr @[]) (each x (realize-for-iteration coll) (array/push arr x)) arr) -# to-array-2d lives in the Clojure collection tier (core/20-coll.clj). - -# Array-element casts — identity on arrays; `bytes` coerces to a byte buffer. -(defn core-bytes [x] (if (buffer? x) x (core-byte-array x))) -(defn core-booleans [x] x) -(defn core-ints [x] x) -(defn core-longs [x] x) -(defn core-shorts [x] x) -(defn core-doubles [x] x) -(defn core-floats [x] x) -(defn core-chars [x] x) - -# Scalar numeric coercions -(defn core-byte [x] (let [b (band (math/trunc x) 0xff)] (if (>= b 128) (- b 256) b))) -(defn core-short [x] (let [s (band (math/trunc x) 0xffff)] (if (>= s 0x8000) (- s 0x10000) s))) -# The masking unchecked-byte/short/char and float/double coercions live in -# the Clojure collection tier (core/20-coll.clj). - -# 64-bit integers (Janet int/s64 — C-backed) -(defn core-bigint [x] (int/s64 x)) -(defn core-biginteger [x] (int/s64 x)) -# bigdec now lives in the Clojure collection tier (no BigDecimal: a double). - -# Chunked seqs — Jolt does not chunk, so these are simple eager equivalents. -(defn core-chunk-buffer [capacity] @[]) -(defn core-chunk-append [b x] (array/push b x) b) -(defn core-chunk [b] b) -# chunked-seq? now lives in the Clojure collection tier (always false on Jolt). -(defn core-chunk-first [s] (core-first s)) -(defn core-chunk-rest [s] (core-rest s)) -(defn core-chunk-next [s] (core-next s)) -(defn core-chunk-cons [chunk rest] (core-concat (realize-for-iteration chunk) rest)) - -# More clojure.core: real implementations backed by existing Jolt machinery. -(defn core-boolean [x] (if x true false)) -(defn core-cat [rf] - (fn [& a] - (case (length a) - 0 (rf) 1 (rf (a 0)) - (do (var acc (a 0)) (each x (realize-for-iteration (a 1)) (set acc (rf acc x))) acc)))) -(defn core-reader-conditional [form splicing?] - @{:jolt/type :jolt/reader-conditional :form form :splicing? splicing?}) -# reader-conditional? now lives in the Clojure collection tier (tagged-value predicate). -# sorted-map-by / sorted-set-by (and all other sorted-coll constructors and -# semantics) now live in the Clojure sorted tier (core/25-sorted.clj). -# array-seq / seque live in the Clojure collection tier (core/20-coll.clj). -# supers now lives in the Clojure collection tier (no class hierarchy: #{}). -(defn core-class [x] - (cond - # typed throwables carry their JVM class name (host_net's HTTP/SSL shims): - # (class e) -> "java.net.SocketTimeoutException" so (= ClassSym (class e)) holds - (and (table? x) (get x :class)) (get x :class) - (nil? x) nil (number? x) "java.lang.Number" (string? x) "java.lang.String" - (boolean? x) "java.lang.Boolean" (keyword? x) "clojure.lang.Keyword" - (function? x) "clojure.lang.IFn" (buffer? x) "[B" - (string (type x)))) -# clojure-version / munge / test now live in the Clojure collection tier -# (core/20-coll.clj). - - -# ============================================================ -# Bit operations (needed for persistent data structures) -# ============================================================ - -(def core-bit-and (fn [a b] (band a b))) -(def core-bit-or (fn [a b] (bor a b))) -(def core-bit-xor (fn [a b] (bxor a b))) -(def core-bit-not (fn [a] (bnot a))) -(def core-bit-shift-left (fn [x n] (blshift x n))) -(def core-bit-shift-right (fn [x n] (brshift x n))) -(def core-bit-clear (fn [x n] (band x (bnot (blshift 1 n))))) -(def core-bit-set (fn [x n] (bor x (blshift 1 n)))) -(def core-bit-flip (fn [x n] (bxor x (blshift 1 n)))) -(def core-bit-test (fn [x n] (not= 0 (band x (blshift 1 n))))) -(def core-bit-and-not (fn [a b] (band a (bnot b)))) -(def core-unsigned-bit-shift-right (fn [x n] (brushift x n))) - -# ============================================================ -# Integer coercion -# ============================================================ - -(def core-int (fn [x] (if (core-char? x) (x :ch) (math/trunc x)))) -(def core-long (fn [x] (if (core-char? x) (x :ch) (math/trunc x)))) -(def core-double (fn [x] (* 1.0 (if (core-char? x) (x :ch) x)))) -(def core-float core-double) -# num and the unchecked-*/promoting-' arithmetic live in the Clojure -# collection tier (core/20-coll.clj) — jolt numbers don't overflow. -(defn core-char [x] - "(char code-or-char) -> a character value." - (cond - (core-char? x) x - (number? x) (make-char (math/trunc x)) - (string? x) (make-char (in x 0)) - (error "char expects a number or character"))) - -# ============================================================ -# Hash -# ============================================================ - -(def core-hash (fn [x] (hash x))) - - -# ============================================================ -# Atom -# ============================================================ - -(defn core-atom - "Create an atom. Accepts optional :validator fn and :meta map." - [val & opts] - (var atm @{:jolt/type :jolt/atom :value val :watches @{} :validator nil}) - (var i 0) - (while (< i (length opts)) - (case (opts i) - :validator (put atm :validator (opts (+ i 1))) - :meta (let [m (opts (+ i 1))] - (var meta-tab @{}) - (each k (keys m) (put meta-tab k (get m k))) - (table/setproto atm meta-tab) - (put atm :jolt/meta m))) - (+= i 2)) - atm) - -# atom? now lives in the Clojure collection tier (tagged-value predicate). - -# Futures — run the body on a real OS thread (ev/thread) for true parallelism. -# Janet threads have separate heaps, so the thunk and the state it closes over are -# MARSHALLED (copied) to the worker thread and the result is marshalled back. A -# future therefore sees a *snapshot* of captured state and communicates only via -# its return value — mutating a captured atom does not propagate to the parent. -# Coordination uses two channels: a thread-chan carries the single [:ok v] / -# [:error e] result back, and a parent-local chan acts as a broadcast latch that -# is closed when the result lands so any number of deref-ers can unpark. -(defn core-future? [x] (and (table? x) (= :jolt/future (x :jolt/type)))) - -(defn core-future-call [thunk] - (def tc (ev/thread-chan 1)) # worker thread -> collector (shared, thread-safe) - (def latch (ev/chan)) # parent-local: closed when the result is in - (def fut @{:jolt/type :jolt/future :latch latch :cached false :res nil :cancelled false}) - # Worker: compute on a fresh OS thread, send back a marshalled result. The give - # is guarded so a non-marshallable value can't strand deref-ers forever. - (ev/spawn-thread - (def res (try [:ok (thunk)] ([e] [:error e]))) - (try (ev/give tc res) - ([_] (ev/give tc [:error "future result is not marshallable across threads"])))) - # Collector: a parent-side fiber bridges the single result into the box and - # closes the latch to wake every waiter. If the future was already cancelled, - # the box is finalized — drop the late result and don't re-close the latch. - (ev/spawn - (def res (ev/take tc)) - (when (not (fut :cancelled)) - (put fut :res res) - (put fut :cached true) - (try (ev/chan-close latch) ([_] nil)))) - fut) - -(defn- future-result [fut] - (def res (fut :res)) - (if (= :error (in res 0)) (error (in res 1)) (in res 1))) - -# future-done? / future-cancelled? now live in the Clojure collection tier (pure -# reads of :cached/:cancelled). core-future? stays — deref/future-cancel call it. -# Janet OS threads can't be interrupted, so the worker still runs to completion -# in the background; we can only mark the *future* cancelled (done) so deref -# raises and realized?/future-done?/future-cancelled? reflect it. Returns false -# if the future has already completed (matching Clojure). -(defn core-future-cancel [x] - (if (and (core-future? x) (not (x :cached)) (not (x :cancelled))) - (do - (put x :cancelled true) - (put x :res [:error "future cancelled"]) - (put x :cached true) - (try (ev/chan-close (x :latch)) ([_] nil)) - true) - false)) - -# future macro: (future body...) -> (future-call (fn* [] body...)) -(defn core-deref [ref & opts] - (cond - (and (table? ref) (= :jolt/reduced (ref :jolt/type))) - (ref :val) - (and (table? ref) (= :jolt/atom (ref :jolt/type))) - (ref :value) - (and (table? ref) (= :jolt/volatile (ref :jolt/type))) - (ref :val) - (and (table? ref) (= :jolt/delay (ref :jolt/type))) - (if (ref :realized) (ref :val) - (let [v ((ref :fn))] (put ref :val v) (put ref :realized true) v)) - (and (table? ref) (= :jolt/future (ref :jolt/type))) - (if (empty? opts) - (do (when (not (ref :cached)) (ev/take (ref :latch))) (future-result ref)) - # (deref future timeout-ms timeout-val): wait at most timeout-ms. The - # deadline cancels the parked take; if the result still hasn't landed we - # return the supplied timeout value (the future keeps running). - (let [timeout-val (in opts 1)] - (when (not (ref :cached)) - (try (ev/with-deadline (/ (in opts 0) 1000) (ev/take (ref :latch))) ([_] nil))) - (if (ref :cached) (future-result ref) timeout-val))) - (and (table? ref) (= :jolt/var (ref :jolt/type))) - (ref :root) - ref)) - -(defn- atom-validate - "Call validator on atm. Returns the value if valid, errors otherwise." - [atm val] - (let [v (atm :validator)] - (if v - (if (v val) val - (error "Validator rejected value")) - val))) - -(defn- atom-notify-watches - [atm old-val new-val] - (loop [[k w] :pairs (atm :watches)] - (w k atm old-val new-val))) - -(defn core-reset! [atm val] - (let [old-val (atm :value)] - (atom-validate atm val) - (put atm :value val) - (atom-notify-watches atm old-val val) - val)) - -(defn core-swap! [atm f & args] - (var old-val (atm :value)) - (var new-val (apply f old-val args)) - (atom-validate atm new-val) - (put atm :value new-val) - (atom-notify-watches atm old-val new-val) - new-val) - -# Atom peripheral ops (swap-vals!/reset-vals!/compare-and-set!/get-validator/ -# add-watch/remove-watch/set-validator!) now live in the Clojure collection tier — -# composed over the native atom ops + jolt.host/ref-put!. atom/swap!/reset!/deref -# and the atom-validate/atom-notify-watches helpers stay native (compiler-critical). - -# ============================================================ diff --git a/src/jolt/core_types.janet b/src/jolt/core_types.janet deleted file mode 100644 index ca35f03..0000000 --- a/src/jolt/core_types.janet +++ /dev/null @@ -1,470 +0,0 @@ -# Jolt Core — vector helpers, predicates, math, comparison, equality -# Extracted from core.janet (jolt-nma8, phase 2b split). - -(use ./types) -(use ./phm) -(use ./phs) -(use ./lazyseq) -(use ./regex) -(use ./config) -(use ./pv) -(use ./plist) - -# ------------------------------------------------------------ -# Vector representation helpers -# -# In immutable mode a vector value is a structural-sharing persistent vector -# (pvec); in mutable mode it is a plain Janet array. Janet tuples may also still -# appear (e.g. literals that have not been routed through make-vec), so the read -# helpers below accept tuple, pvec and (mutable mode) array uniformly. -# ------------------------------------------------------------ - -(defn jvec? - "True when x is a vector VALUE. In immutable mode that is a persistent vector - or tuple; in mutable mode vectors are plain arrays (so vectors and lists share - one fast representation — `vector?` is true for both)." - [x] - (if mutable? - (or (array? x) (tuple? x)) - (or (tuple? x) (pvec? x)))) - -(defn vcount [x] (if (pvec? x) (pv-count x) (length x))) -(defn vnth [x i] (if (pvec? x) (pv-nth x i) (in x i))) - -(defn vview - "An indexed (tuple/array) view of a vector value, for iteration/slicing." - [x] - (if (pvec? x) (pv->array x) x)) - -(defn make-vec - "Build a vector value from a Janet array/tuple of elements, honoring the - build-time collection mode." - [xs] - (if mutable? (array ;xs) (pv-from-indexed xs))) - -(defn core-transient? - "True when x is a transient (a mutable scratch collection). See `transient`." - [x] - (and (table? x) (= :jolt/transient (get x :jolt/type)))) - -# Sorted-coll tag checks + entries view, defined this early because canon-key, -# empty?, and jolt-equal? (all below) need them. The sorted-coll SEMANTICS are -# pure Clojure (core/25-sorted.clj); see the dispatch section further down. -# SEED-TWIN: sorted-map?/sorted-set?/sorted? also live in the overlay -# (jolt-core/clojure/core/25-sorted.clj); the overlay copies are the public ones -# (NOT in core-bindings). These seed copies exist only for earlier-tier seed -# dispatch. Change both copies together — docs/seed-overlay-registry.md. -(defn core-sorted-map? [x] (and (table? x) (= :jolt/sorted-map (x :jolt/type)))) -(defn core-sorted-set? [x] (and (table? x) (= :jolt/sorted-set (x :jolt/type)))) -(defn core-sorted? [x] (or (core-sorted-map? x) (core-sorted-set? x))) -# The comparator-ordered entries as a Janet array (entries are jolt vectors: -# pvecs in immutable mode, arrays in mutable mode) — for the seed's printers/ -# equality. Materialized from the red-black tree via the coll's own :entries op -# (jolt-0hbr); the old sorted-VECTOR rep is read directly as a fallback. -(defn sorted-entries-arr [coll] - (def ef (let [ops (coll :ops)] (and ops (ops :entries)))) - (def e (if ef (ef coll) (coll :entries))) - (if (pvec? e) (pv->array e) e)) - -# Lazy cell chain over an indexed (tuple/array) collection, walking by INDEX — -# O(1) per step. Slicing the remainder per step (the old shape) made every -# full walk over a concrete collection O(n^2). -(defn indexed-cells [t i] - (if (>= i (length t)) nil - @[(in t i) (fn [] (indexed-cells t (+ i 1)))])) - -# A nil element/key/value nested in a collection used AS a map key would be -# dropped when canon-key re-keys a native Janet table (a Janet struct can't hold a -# nil key or value), so #{nil 1} would canonicalize like #{1} and collide as a key -# (jolt-zcm9). Box a nested nil to a marker. It must be VALUE-hashable: the -# canonical struct becomes a long-lived phm key whose hash has to survive the -# marshal/snapshot/fork that init-cached uses, so an identity-hashed mutable table -# (like the transient sentinel below) won't do — its hash isn't preserved across -# unmarshal. An interned keyword hashes by content. Collision risk is only a real -# element equal to this exact keyword — the same negligible class as canon-key's -# existing set/map struct aliasing. -(def canon-nil (keyword "jolt.lang/canonical-nil")) -(defn- canon-box [c] (if (nil? c) canon-nil c)) - -# Canonicalize a collection key/element to a value-hashable Janet struct/tuple so -# the PHM/PHS treat value-equal maps/vectors as the same key (Janet hashes tables -# by identity otherwise). Installed into phm via set-canonicalize-key!. -(var canon-key nil) -(set canon-key - (fn [k] - (cond - (pvec? k) (tuple ;(map canon-key (pv->array k))) - (plist? k) (tuple ;(map canon-key (pl->array k))) - (set? k) (do (def t @{}) (each e (phs-seq k) (put t (canon-box (canon-key e)) true)) (table/to-struct t)) - (phm? k) (do (def t @{}) (each pair (phm-entries k) (put t (canon-box (canon-key (in pair 0))) (canon-box (canon-key (in pair 1))))) (table/to-struct t)) - # sorted colls canonicalize like their unsorted counterparts, so - # (get {(sorted-map :a 1) :hit} {:a 1}) finds the key - (core-sorted-map? k) (do (def t @{}) (each e (sorted-entries-arr k) (put t (canon-box (canon-key (vnth e 0))) (canon-box (canon-key (vnth e 1))))) (table/to-struct t)) - (core-sorted-set? k) (do (def t @{}) (each x (sorted-entries-arr k) (put t (canon-box (canon-key x)) true)) (table/to-struct t)) - (and (table? k) (get k :jolt/deftype)) - (do (def t @{}) (each kk (keys k) (when (not= kk :jolt/deftype) (put t kk (canon-box (canon-key (get k kk)))))) (table/to-struct t)) - (struct? k) (do (def t @{}) (each kk (keys k) (put t (canon-box (canon-key kk)) (canon-box (canon-key (get k kk))))) (table/to-struct t)) - (array? k) (tuple ;(map canon-key k)) - (tuple? k) (tuple ;(map canon-key k)) - k))) -(set-canonicalize-key! canon-key) - -# Janet tables silently drop a nil key (put/get with nil is a no-op), but Clojure -# maps allow a nil key. The transient map/set keys its native table by canon-key, -# which returns nil only for nil input — so route nil to a unique sentinel. This -# one is a fresh mutable table (canon-key never produces one, so no collision); it -# is fine here because a transient's native table is built and consumed within one -# operation and never crosses a marshal boundary, so identity hashing is stable. -(def tbl-nil-key @{}) -(defn tbl-key [k] (if (nil? k) tbl-nil-key (canon-key k))) - -# A transient SET stores `(tbl-key x) -> x`, i.e. the member IS the table value. A -# nil member can't be a Janet table value either (put with a nil value drops the -# entry), so box nil as the same sentinel and unbox on read-back. -(defn tbl-box [x] (if (nil? x) tbl-nil-key x)) -(defn tbl-unbox [v] (if (= v tbl-nil-key) nil v)) - -# All [k v] entries of a map (struct or phm), nil-valued keys included. Use this -# instead of (keys (phm-to-struct m)) — phm-to-struct drops keys whose value is -# nil, which is exactly what Clojure maps must keep. -(defn map-entries-of [m] - (if (phm? m) (phm-entries m) (map (fn [k] [k (in m k)]) (keys m)))) - -# assoc one entry onto a map value (struct or phm), preserving a nil key/value and -# value-comparing collection keys (promotes a struct to a phm when needed). A -# single-entry core-assoc usable by fns defined before core-assoc itself. -(defn map-assoc1 [m k v] - (cond - (phm? m) (phm-assoc m k v) - (or (nil? k) (nil? v) (table? k) (array? k)) - (do (var p (make-phm)) (each ek (keys m) (set p (phm-assoc p ek (in m ek)))) (phm-assoc p k v)) - (do (def t (merge @{} m)) (put t k v) (table/to-struct t)))) - -# Build a map from a flat [k v k v ...] array: a phm when any key/value is nil or -# a key is a collection (value hashing); a struct otherwise. One O(n) pass. -(defn- kvs->map [kvs] - (var need-phm false) (var i 0) - (while (< i (length kvs)) - (let [k (in kvs i) v (in kvs (+ i 1))] - (when (or (nil? k) (nil? v) (table? k) (array? k)) (set need-phm true))) - (+= i 2)) - (if need-phm - (do (var m (make-phm)) (var j 0) - (while (< j (length kvs)) (set m (phm-assoc m (in kvs j) (in kvs (+ j 1)))) (+= j 2)) m) - (struct ;kvs))) - -(defn realize-for-iteration [c] - "Normalize a seqable to a Janet array/tuple for iteration: pvec -> array, - set -> seq, lazy-seq -> realized array; others pass through. Warning: will - loop on infinite lazy-seqs. Terminates on the empty cell, not on nil." - (cond - # nil is an empty seq in Clojure — iterating it yields nothing. - (nil? c) @[] - (shape-rec? c) (map (fn [k] (tuple k (shape-get c k nil))) (shape-keys c)) - (pvec? c) (pv->array c) - (plist? c) (pl->array c) - (set? c) (phs-seq c) - (phm? c) (phm-entries c) - # sorted colls iterate their comparator-ordered entries/elements - (core-sorted? c) (sorted-entries-arr c) - # a string is a seqable of CHARS in Clojure (not bytes/1-char strings) — mirror - # core-seq so vec/set/into over a string agree with seq (jolt-dl4s) - (string? c) (tuple ;(map make-char (string/bytes c))) - # byte array (Janet buffer) -> array of byte values - (buffer? c) (let [a @[]] (each x c (array/push a x)) a) - # struct map literal (no :jolt/type marker — not a symbol/char) -> entries - (and (struct? c) (nil? (get c :jolt/type))) (map (fn [k] (tuple k (get c k))) (keys c)) - # raw host table (System/getenv, os/environ) — also a map: entries - (and (table? c) (nil? (get c :jolt/type)) (nil? (get c :jolt/deftype))) - (map (fn [k] (tuple k (get c k))) (keys c)) - (lazy-seq? c) - (do - (var items @[]) - (var cur c) - (var go true) - (while go - (let [cell (realize-ls cur)] - (if (or (nil? cell) (= :jolt/pending cell) (= 0 (length cell))) - (set go false) - (do - (array/push items (in cell 0)) - (let [rt (in cell 1)] - (if (nil? rt) (set go false) (set cur (ls-rest-cached cur rt)))))))) - items) - c)) - -# Syntax-quote form builders. The syntax-quote lowering (evaluator) emits calls to -# these so a `(...)/`[...] body is plain compilable code instead of an interpreted -# special form. A list FORM is a Janet array, a vector FORM a tuple (the reader's -# representation), so these build those types. Each concat part is either a 1-elem -# wrap (__sq1, a non-spliced item) or a spliced seq (~@), flattened in order. -(defn core-sq1 [x] @[x]) - -(defn core-sqcat [& parts] - (def r @[]) - (each p parts (each x (realize-for-iteration p) (array/push r x))) - r) - -(defn core-sqvec [& parts] - (def r @[]) - (each p parts (each x (realize-for-iteration p) (array/push r x))) - (tuple/slice r)) - -# Map builder: parts are alternating k v (no splicing in map syntax-quote). -(defn core-sqmap [& parts] - # A syntax-quoted map template is Clojure's array-map case: construction - # order is source order and must survive into the built map, which usually - # becomes a FORM whose entries the evaluator walks (jolt-p3c). Same - # carriers as the reader: struct prototype / phm field. - (def kvs (array ;parts)) - (def m (kvs->map kvs)) - (cond - (struct? m) (struct/with-proto (struct :jolt/kv-order (tuple/slice kvs)) ;kvs) - (table? m) (do (put m :jolt/kv-order (tuple/slice kvs)) m) - m)) - -# Set builder: like core-sqvec but yields a set, so `#{~@a} splices into a set. -(defn core-sqset [& parts] - (def r @[]) - (each p parts (each x (realize-for-iteration p) (array/push r x))) - (apply make-phs r)) - -# ============================================================ -# Predicates -# ============================================================ - -# SEED-TWIN: char? is also defined in the overlay (jolt-core/clojure/core/ -# 20-coll.clj) and the overlay copy is the public one (NOT in core-bindings). -# This seed copy is internal type dispatch only. docs/seed-overlay-registry.md. -(defn core-char? [x] (and (struct? x) (= :jolt/char (x :jolt/type)))) -(defn char-code [c] (c :ch)) -(defn char->string [c] (string/from-bytes (c :ch))) - -(defn core-nil? [x] (nil? x)) -(defn core-not [x] (if x false true)) -# some? / true? / false? now live in the Clojure collection tier. -(defn core-string? [x] (string? x)) -(defn core-number? [x] (number? x)) -(defn core-fn? [x] (or (function? x) (cfunction? x))) -(defn core-keyword? [x] (keyword? x)) -(defn core-symbol? [x] (and (struct? x) (= :symbol (x :jolt/type)))) -# A record shape-rec is a Janet tuple (jvec? true), but a record is NOT a vector -# in Clojure — `(vector? record)` is false, and so is `(sequential? record)`. -# Excluding it here keeps map-destructuring of a record off the `& {:keys}` kwargs -# coerce path (which does `(apply hash-map x)` for a sequential x). jvec? itself -# stays as-is for internal representation dispatch. -(defn core-vector? [x] (and (jvec? x) (not (shape-rec? x)))) -# map? is STRICT: a plain struct map literal, a phm, a sorted map, or a record. -# Tagged structs (symbols/chars/uuids — anything with :jolt/type) are VALUES, -# not maps. (sorted-map? is defined later, so the table check is inlined.) -(defn core-map? [x] - (or (shape-rec? x) - (phm? x) - (and (struct? x) (nil? (get x :jolt/type))) - (and (table? x) - (or (not (nil? (get x :jolt/deftype))) - (= :jolt/sorted-map (get x :jolt/type)))))) -# seq? is true only for actual sequences (lists, lazy-seqs) — NOT vectors, which -# are not ISeq in Clojure. (A Janet array represents a Clojure list/seq result.) -(defn core-seq? [x] (or (array? x) (plist? x) (lazy-seq? x))) -# coll? mirrors map?'s strictness for structs/tables, and includes the sorted -# collections and records (IPersistentCollection in Clojure). -(defn core-coll? [x] - (or (array? x) (tuple? x) (pvec? x) (plist? x) (phm? x) (set? x) (lazy-seq? x) - (and (struct? x) (nil? (get x :jolt/type))) - (and (table? x) - (or (not (nil? (get x :jolt/deftype))) - (= :jolt/sorted-map (get x :jolt/type)) - (= :jolt/sorted-set (get x :jolt/type)))))) - - - -(defn core-identical? [a b] (= a b)) - -# Strictness helpers: like Clojure, numeric ops reject non-numbers, and the -# integer ops (odd?/even?) reject non-integers (incl. infinities, NaN, fractions). -(defn- finite-num? [x] (and (number? x) (= x x) (< (if (< x 0) (- x) x) math/inf))) -(defn- need-num [x op] - (if (number? x) x (error (string op " requires a number, got " (type x))))) -(defn- need-int [x op] - (if (and (number? x) (= x x) (< (if (< x 0) (- x) x) math/inf) (= x (math/floor x))) x - (error (string op " requires an integer")))) - -# zero? / pos? live in the syntax tier (core/00-syntax.clj) — empty? and the -# analyzer use them; neg? lives in the collection tier (20-coll.clj). -# even?/odd? are PERF-WALL residents: (filter even? ...) is idiomatic and the -# overlay versions cost an extra call layer per element (seq-pipe bench 4x). -(defn core-even? [n] (= 0 (% (need-int n "even?") 2))) -(defn core-odd? [n] (not= 0 (% (need-int n "odd?") 2))) - -# Finite integral number: NaN and the infinities are NOT integers (floor of -# inf is inf, so the naive floor check wrongly accepted them). -(defn core-integer? [x] - (and (number? x) (= x x) - (< x math/inf) (> x (- math/inf)) - (= x (math/floor x)))) -(defn core-list? [x] (or (plist? x) (and (array? x) (not (get x :jolt/type))))) - -# empty? now lives in the syntax tier (core/00-syntax.clj): the expanders -# call it, so it must exist before the kernel tier compiles. - -# every? lives in the syntax tier (core/00-syntax.clj) — the analyzer uses it; -# the canonical seq/first/next walk short-circuits lazy seqs the same way. - -# ============================================================ -# Math — Clojure semantics (variadic, / with one arg = reciprocal) -# ============================================================ - -(def core-+ (fn [& args] (if (= 0 (length args)) 0 (+ ;args)))) - -(def core-sub - (fn [& args] - (if (= 0 (length args)) - (error "Wrong number of args (0) passed to: -") - (apply - args)))) - -(def core-* (fn [& args] (if (= 0 (length args)) 1 (* ;args)))) - -(def core-/ - (fn [& args] - (case (length args) - 0 (error "Wrong number of args (0) passed to: /") - 1 (/ 1 (args 0)) - (apply / args)))) - -(def core-inc inc) -(def core-dec dec) -# Clojure integer division: quot truncates toward zero; rem matches the sign of -# the dividend; mod matches the sign of the divisor (floored). -(def core-quot (fn [n d] - (when (or (not (finite-num? n)) (not (finite-num? d))) (error "quot requires finite numbers")) - (when (= d 0) (error "Divide by zero")) - (let [q (/ n d)] (if (< q 0) (math/ceil q) (math/floor q))))) -(def core-rem (fn [n d] (- n (* (core-quot n d) d)))) -(def core-mod (fn [n d] - (let [m (core-rem n d)] - (if (or (= m 0) (= (> n 0) (> d 0))) m (+ m d))))) - -# max / min now live in the Clojure collection tier (canonical pairwise -# >/<, so non-numbers throw and NaN behaves as on the JVM). - - -(defn core-rand [& n] (let [r (math/random)] (if (empty? n) r (* r (in n 0))))) -# rand-int / shuffle / random-uuid now live in the Clojure collection tier -# over the rand host seam (canonical: rand-int truncates toward zero). - -# ============================================================ -# Comparison -# ============================================================ - -(defn- eq-seqable - "If x is a Clojure sequential (vector/list/lazy-seq), return its elements as - an array; otherwise nil. Lets = compare across tuple/array/lazy-seq." - [x] - (cond - # a shape-rec is a MAP, not a sequence, even though it is a tuple - (shape-rec? x) nil - (lazy-seq? x) (realize-for-iteration x) - (pvec? x) (pv->array x) - (plist? x) (pl->array x) - (tuple? x) x - (array? x) x - nil)) - -(defn- eq-map-pairs - "Return [k v] pairs for a map-like value (phm/sorted-map/struct/table), else nil." - [x] - (cond - # a record shape-rec returns nil so equality falls to deep=, which is - # type-aware (the descriptor is interned per type): a record equals only a - # same-type record, never a plain map — mirroring the :jolt/deftype table - # form below. A plain-map shape-rec compares by pairs. - (shape-rec? x) (if (record-tag x) nil (map (fn [k] @[k (shape-get x k nil)]) (shape-keys x))) - (phm? x) (phm-entries x) - # sorted-map equals any map with the same pairs (representation-agnostic, as - # in Clojure); sorted-set is handled by the set branch of jolt-equal? - (core-sorted-map? x) (map (fn [e] @[(vnth e 0) (vnth e 1)]) (sorted-entries-arr x)) - (core-sorted-set? x) nil - (and (table? x) (get x :jolt/deftype)) nil - (struct? x) (pairs x) - (table? x) (pairs x) - nil)) - -# Elements of a set-like value (phs or sorted-set) as an array, else nil. -(defn- eq-set-elems [x] - (cond - (set? x) (phs-seq x) - (core-sorted-set? x) (sorted-entries-arr x) - nil)) - -(var jolt-equal? nil) -(set jolt-equal? - (fn [a b] - (let [sa (eq-seqable a) sb (eq-seqable b)] - (cond - # both sequential: compare element-wise (vectors/lists/lazy-seqs equal) - (and sa sb) - (if (= (length sa) (length sb)) - (do (var ok true) (var i 0) - (while (and ok (< i (length sa))) - (unless (jolt-equal? (in sa i) (in sb i)) (set ok false)) - (++ i)) - ok) - false) - (or sa sb) false - # sets (phs or sorted-set, in any combination) - (or (set? a) (set? b) (core-sorted-set? a) (core-sorted-set? b)) - # value-based: same size and every element of a is value-equal to some - # element of b (so #{ {:a 1} } equals #{ (hash-map :a 1) } regardless of - # the elements' underlying representations) - (let [ea (eq-set-elems a) eb (eq-set-elems b)] - (if (and ea eb (= (length ea) (length eb))) - (do - (var ok true) - (each x ea - (unless (some (fn [y] (jolt-equal? x y)) eb) (set ok false))) - ok) - false)) - # maps: compare key/value pairs recursively, order-independent - true - (let [pa (eq-map-pairs a) pb (eq-map-pairs b)] - (if (or pa pb) - (if (and pa pb (= (length pa) (length pb))) - (do (var ok true) - (each pair pa - (let [k (in pair 0) v (in pair 1) - found (do (var fv :jolt/none) - (each p2 pb (when (jolt-equal? k (in p2 0)) (set fv (in p2 1)))) - fv)] - (unless (and (not= found :jolt/none) (jolt-equal? v found)) (set ok false)))) - ok) - false) - (deep= a b))))))) - -(defn core-= [& args] - (if (< (length args) 2) true - (do - (var ok true) - (var i 0) - (while (and ok (< i (dec (length args)))) - (unless (jolt-equal? (args i) (args (+ i 1))) (set ok false)) - (++ i)) - ok))) - -# not= lives in the syntax tier (core/00-syntax.clj) — the kernel uses it. - -# Comparisons are variadic: (< a b c) means a < b < c. -(defn- chain-cmp [op opname xs] - # 1-arity (e.g. (< x)) is true regardless of x and does no type check. - (when (>= (length xs) 2) (each x xs (need-num x opname))) - (var ok true) (var i 0) - (while (and ok (< i (dec (length xs)))) - (unless (op (in xs i) (in xs (+ i 1))) (set ok false)) - (++ i)) - ok) -(defn core-< [& xs] (chain-cmp < "<" xs)) -(defn core-> [& xs] (chain-cmp > ">" xs)) -(defn core-<= [& xs] (chain-cmp <= "<=" xs)) -(defn core->= [& xs] (chain-cmp >= ">=" xs)) - -# ============================================================ diff --git a/src/jolt/deps.janet b/src/jolt/deps.janet deleted file mode 100644 index c84a1b9..0000000 --- a/src/jolt/deps.janet +++ /dev/null @@ -1,300 +0,0 @@ -# deps.edn resolution for Jolt. -# -# Resolve git and :local/root dependencies from a deps.edn into a list of source -# directories, which the loader then searches (see evaluator/find-ns-file). We -# reuse jpm's git fetch + cache (jpm/pm) rather than shipping a package manager. -# Maven (:mvn/version) deps are ignored — git only, pure clj/cljc only. -# -# jpm is loaded lazily (require, not import) so it's needed only at resolve time -# (dev/build), never embedded in the shipped binary. - -(import ./reader :as reader) - -# Read deps.edn with Jolt's reader (not Janet's parse) so EDN `;` line comments -# are handled. It returns plain Janet data — structs with keyword keys, tuples — -# which we walk directly. (#{} sets and tagged literals aren't expected in the -# :deps/:paths we read.) -(defn read-edn [path] - (when (os/stat path) - (try (reader/parse-string (slurp path)) ([_] nil)))) - -(defn- jpm-fn [mod sym] - (get-in (require mod) [sym :value])) - -(defn- ensure-jpm-config [tree] - ((jpm-fn "jpm/config" 'load-default)) - (setdyn :modpath tree) - (setdyn :gitpath (dyn :gitpath "git"))) - -(defn- clone-git [spec] - # spec is a deps.edn dep value: {:git/url ... :git/sha/:git/tag ...} - (def resolve-bundle (jpm-fn "jpm/pm" 'resolve-bundle)) - (def download-bundle (jpm-fn "jpm/pm" 'download-bundle)) - # Run git silenced (jpm's shell honors :silent): its checkout chatter - # ("HEAD is now at …") otherwise lands on STDOUT and corrupts the - # documented `JOLT_PATH=$(jolt-deps path)` capture. Progress goes to stderr. - (eprintf "jolt-deps: fetching %s @ %s" - (get spec :git/url) (or (get spec :git/sha) (get spec :git/tag) "HEAD")) - (with-dyns [:silent true] - (def b (resolve-bundle {:url (get spec :git/url) - :sha (get spec :git/sha) - :tag (get spec :git/tag) - :shallow false})) - (download-bundle (b :url) (b :type) (b :tag) (b :shallow)))) - -(defn- src-roots - "Source dirs of a project/dep at `dir`: its deps.edn :paths joined to dir - (default [\"src\"])." - [dir edn] - (map |(string dir "/" $) (or (and edn (get edn :paths)) ["src"]))) - -# --- user config + aliases (tools.deps-shaped, scoped to git/:local) ----------- - -(defn config-dir - "User-level config dir: $JOLT_CONFIG, else $XDG_CONFIG_HOME/jolt, else - ~/.jolt — the same fallback chain the Clojure CLI uses for ~/.clojure." - [] - (or (os/getenv "JOLT_CONFIG") - (when-let [x (os/getenv "XDG_CONFIG_HOME")] - (when (> (length x) 0) (string x "/jolt"))) - (string (os/getenv "HOME") "/.jolt"))) - -(defn- merge-per-key [a b] # dictionary union, b's entries win - (def out @{}) - (each m [a b] (when (dictionary? m) (eachp [k v] m (put out k v)))) - out) - -# Reader symbols carry position metadata, so any map keyed by SYMBOLS (deps -# libs, task names) must be re-keyed by name before merging or deduping. -(defn- sym-name [x] - (if (and (dictionary? x) (get x :name)) - (if-let [ns (get x :ns)] - (string ns "/" (get x :name)) - (get x :name)) - (string x))) - - -(defn- ensure-jpm-dep - "A :jpm/module dep declares a janet module installed through jpm (e.g. - spork/http). jolt-deps doesn't manage janet packages — jpm does — so this - just verifies the module is importable, optionally running `jpm install - <:jpm/install>` once when it isn't, and fails with the install hint - otherwise. Contributes no source roots; the janet.* bridge autoloads the - module at first use." - [lib spec] - (def mod (get spec :jpm/module)) - (defn importable? [] ((protect (require mod)) 0)) - (unless (importable?) - (when-let [pkg (get spec :jpm/install)] - (eprintf "jolt-deps: %s: jpm module %s missing — running `jpm install %s`" - (sym-name lib) mod pkg) - (os/execute ["jpm" "install" pkg] :p)) - (unless (importable?) - (errorf "%s: janet module %s is not importable. Install it with `jpm install %s` (jolt-deps leaves janet packages to jpm)." - (sym-name lib) mod (or (get spec :jpm/install) mod))))) - -(defn- merge-by-name [a b] # union of symbol-keyed dictionaries, b wins - (def out @{}) - (each m [a b] (when (dictionary? m) (eachp [k v] m (put out (sym-name k) v)))) - out) - -(defn- mkdirs [p] - (def abs (string/has-prefix? "/" p)) - (var acc nil) - (each seg (filter |(not= "" $) (string/split "/" p)) - (set acc (cond (nil? acc) (if abs (string "/" seg) seg) (string acc "/" seg))) - (unless (os/stat acc) (os/mkdir acc)))) - -(defn- default-tree - "Where git clones land when no tree is given: $JOLT_GITLIBS, else - (config-dir)/gitlibs — a global, sha-immutable cache shared across projects - (the tools.gitlibs ~/.gitlibs model), not a per-project ./jpm_tree." - [] - (def g (os/getenv "JOLT_GITLIBS")) - (if (and g (> (length g) 0)) g (string (config-dir) "/gitlibs"))) - -(defn load-config - "The project deps.edn merged over the user-level one (config-dir)/deps.edn. - tools.deps merge semantics: scalar keys and :paths replace (project wins), - :deps and :aliases merge per key with the project winning. Relative - :local/root in the USER file is resolved against the cwd — prefer absolute - paths there." - [deps-edn-path] - (def proj (read-edn deps-edn-path)) - (def user (read-edn (string (config-dir) "/deps.edn"))) - (if (and (nil? user) (nil? proj)) - nil - # normalize even when only one file exists: :deps/:tasks come back keyed - # by NAME (reader symbols carry position metadata and never compare equal) - (let [u (when (dictionary? user) user) - p (when (dictionary? proj) proj) - out (merge-per-key u p)] - (put out :deps (merge-by-name (and u (get u :deps)) (and p (get p :deps)))) - (put out :aliases (merge-per-key (and u (get u :aliases)) (and p (get p :aliases)))) - (put out :tasks (merge-by-name (and u (get u :tasks)) (and p (get p :tasks)))) - out))) - -(defn combine-aliases - "Combine the selected alias keywords against `edn`'s :aliases: - :extra-paths and :extra-deps accumulate in order, :main-opts is last-wins - (the tools.deps CLI rules). Unknown alias -> error." - [edn aliases] - (def als (or (and (dictionary? edn) (get edn :aliases)) {})) - (def extra-paths @[]) - (def extra-deps @{}) - (var main-opts nil) - (each a (or aliases []) - (def spec (get als a)) - (when (nil? spec) (error (string "unknown alias: " a))) - (each p (or (get spec :extra-paths) []) (array/push extra-paths p)) - (when (dictionary? (get spec :extra-deps)) - (eachp [lib coord] (get spec :extra-deps) (put extra-deps lib coord))) - (when-let [mo (get spec :main-opts)] - (set main-opts (tuple ;(map string mo))))) - {:extra-paths extra-paths :extra-deps extra-deps :main-opts main-opts}) - -(defn alias-main-opts - "The :main-opts the selected aliases produce (last alias with the key wins), - or nil. Reads the merged user+project config." - [deps-edn-path aliases] - (get (combine-aliases (load-config deps-edn-path) aliases) :main-opts)) - -(defn resolve-deps - "Resolve the git/:local deps of `deps-edn-path` into an ordered, de-duplicated - array of source dirs (the project's own :paths first, then each dependency's, - transitively). `tree` is where jpm's clone cache lives (default ./jpm_tree). - `aliases` (keywords) pull :extra-paths/:extra-deps from the merged config's - :aliases. The user-level deps.edn (see load-config) merges under the project." - [deps-edn-path &opt tree aliases] - (default tree (default-tree)) - (mkdirs tree) - (ensure-jpm-config tree) - (def edn (load-config deps-edn-path)) - (def extra (combine-aliases edn aliases)) - (def roots @[]) - (def seen @{}) # lib name -> chosen coordinate (for conflict reporting) - (defn add-root [r] (unless (index-of r roots) (array/push roots r))) - (defn coord-str [spec] - (cond - (and (dictionary? spec) (get spec :local/root)) - (string ":local/root " (get spec :local/root)) - (and (dictionary? spec) (get spec :git/url)) - (string (get spec :git/url) " @ " (or (get spec :git/sha) (get spec :git/tag))) - (string/format "%j" spec))) - (defn coord= [a b] - (and (deep= (get a :local/root) (get b :local/root)) - (deep= (get a :git/url) (get b :git/url)) - (deep= (get a :git/sha) (get b :git/sha)) - (deep= (get a :git/tag) (get b :git/tag)) - (deep= (get a :jpm/module) (get b :jpm/module)))) - (def queue @[]) - (defn discover [lib spec base-dir] - (def k (sym-name lib)) - (if-let [prev (get seen k)] - (unless (coord= prev spec) - (eprintf "WARNING: %s: conflicting coordinates — using %s, ignoring %s" - k (coord-str prev) (coord-str spec))) - (do - (put seen k spec) - (when (and (dictionary? spec) (get spec :jpm/module)) - (ensure-jpm-dep lib spec)) - (def dir - (cond - (and (dictionary? spec) (get spec :git/url)) - # :deps/root (tools.deps): the project lives in a subdirectory - # of the repo — monorepos like ring-clojure/ring. - (let [cloned (clone-git spec) - root (get spec :deps/root)] - (if root (string cloned "/" root) cloned)) - (and (dictionary? spec) (get spec :local/root)) - (let [lr (get spec :local/root)] - (if (string/has-prefix? "/" lr) lr (string base-dir "/" lr))) - nil)) # :mvn/* and anything else: skip - (when dir - (def dep-edn (read-edn (string dir "/deps.edn"))) - (each r (src-roots dir dep-edn) (add-root r)) - (array/push queue [dep-edn dir]))))) - # the project's own paths (+ alias extra paths) lead the roots - (each r (src-roots (os/cwd) edn) (add-root r)) - (each pp (extra :extra-paths) (add-root (string (os/cwd) "/" pp))) - # breadth-first: every top-level dep registers before any transitive dep — - # so a top-level coordinate always wins, matching tools.deps. Alias - # :extra-deps go first: a selected alias's pin beats the project's. - (eachp [lib spec] (extra :extra-deps) - (discover lib spec (os/cwd))) - (eachp [lib spec] (or (and (dictionary? edn) (get edn :deps)) {}) - (discover lib spec (os/cwd))) - (while (> (length queue) 0) - (def [dep-edn dir] (get queue 0)) - (array/remove queue 0) - (when (dictionary? dep-edn) - (eachp [lib spec] (or (get dep-edn :deps) {}) - (discover lib spec dir)))) - roots) - -(defn resolve-deps-cached - "Like resolve-deps, but caches the resolved roots in the tree keyed on a hash - of the project deps.edn + the user deps.edn + the selected aliases, so an - unchanged config resolves without re-fetching." - [deps-edn-path &opt tree aliases] - (default tree (default-tree)) - (when (os/stat deps-edn-path) - # the roots depend on the PROJECT (config + aliases), so their cache is - # project-local like tools.deps' .cpcache; the clone tree stays global - (os/mkdir ".cpcache") - (def cache-file ".cpcache/jolt-deps.jdn") - (def user-path (string (config-dir) "/deps.edn")) - # The raw key material, not (hash …): janet's hash is seeded per process, - # so a hashed key never matches across invocations and the cache never hit. - (def key [(slurp deps-edn-path) - (or (when (os/stat user-path) (slurp user-path)) "") - (string/format "%j" (map string (or aliases [])))]) - (def cached (when (os/stat cache-file) (try (parse (slurp cache-file)) ([_] nil)))) - (if (and cached (deep= key (get cached :key))) - (get cached :roots) - (let [roots (resolve-deps deps-edn-path tree aliases)] - (spit cache-file (string/format "%j" {:key key :roots roots})) - roots)))) - -(defn project-source-roots - "The project's OWN source roots — its deps.edn :paths plus any alias - :extra-paths, joined to cwd — as opposed to dependency roots. These are the - 'app' namespaces: the runtime scopes the whole-program inference fixpoint to - them (JOLT_APP_PATHS) so a dep-heavy app's startup doesn't re-infer every - transitive dependency namespace (jolt-87e)." - [deps-edn-path &opt aliases] - (def out @[]) - (when (os/stat deps-edn-path) - (def edn (load-config deps-edn-path)) - (def extra (combine-aliases edn aliases)) - (each r (src-roots (os/cwd) edn) (array/push out r)) - (each pp (extra :extra-paths) (array/push out (string (os/cwd) "/" pp)))) - out) - -# --- :tasks (the honest subset of babashka's) ---------------------------------- -# A STRING task is a shell command. A MAP task carries :main-opts (jolt args — -# `-e "(...)"` covers expression tasks) and an optional :doc. Babashka-style -# bare-expression tasks aren't supported: the reader hands us parsed data, and -# round-tripping it back to source isn't worth the fragility. - -(defn tasks - "Sorted [name doc] pairs from the merged user+project :tasks." - [deps-edn-path] - (def m (get (load-config deps-edn-path) :tasks)) - (def names (sort (keys (or m @{})))) - (map (fn [n] - (def v (get m n)) - [n (when (dictionary? v) (get v :doc))]) - names)) - -(defn task-spec - "What running task `name` means: {:type :shell :cmd s} or - {:type :jolt :argv [...]}; nil when undefined." - [deps-edn-path name] - (def v (get (or (get (load-config deps-edn-path) :tasks) @{}) name)) - (cond - (nil? v) nil - (or (string? v) (buffer? v)) {:type :shell :cmd (string v)} - (and (dictionary? v) (get v :main-opts)) - {:type :jolt :argv (tuple ;(map string (get v :main-opts)))} - (error (string "task " name ": use a shell string or {:main-opts [...]}")))) diff --git a/src/jolt/deps_cli.janet b/src/jolt/deps_cli.janet deleted file mode 100644 index 3d0de25..0000000 --- a/src/jolt/deps_cli.janet +++ /dev/null @@ -1,27 +0,0 @@ -# jolt-deps — deprecated shim. Dependency resolution is now built into `jolt` -# itself (the runtime stays deps-agnostic; the CLI front-end resolves deps.edn -# into JOLT_PATH in-process). This binary forwards everything to `jolt` so -# existing scripts keep working — prefer calling `jolt` directly: -# -# jolt-deps -M:nrepl -> jolt -M:nrepl -# jolt-deps path -> jolt path -# jolt-deps run FILE -> jolt run FILE -# -# The jolt binary is found via $JOLT_BIN, else the `jolt` sitting next to this -# shim (built as a pair), else `jolt` on PATH. - -(defn- jolt-bin [] - (or (os/getenv "JOLT_BIN") - (let [self (or (first (dyn :args)) (dyn :executable)) - slashes (when self (string/find-all "/" self)) - dir (when (and slashes (> (length slashes) 0)) - (string/slice self 0 (last slashes))) - sibling (when dir (string dir "/jolt"))] - (when (and sibling (os/stat sibling)) sibling)) - "jolt")) - -(defn main [&] - (def argv (tuple/slice (or (dyn :args) @[]) 1)) - (eprint "jolt-deps is deprecated — dependency resolution is built into `jolt` now " - "(e.g. `jolt -M:nrepl`, `jolt path`, `jolt run FILE`).") - (os/exit (os/execute [(jolt-bin) ;argv] :p))) diff --git a/src/jolt/eval_base.janet b/src/jolt/eval_base.janet deleted file mode 100644 index 8587a3b..0000000 --- a/src/jolt/eval_base.janet +++ /dev/null @@ -1,609 +0,0 @@ -# Jolt Evaluator — base: forward vars, syntax-quote, ns-loading, registries -# Extracted from evaluator.janet (jolt-oudv, phase 2a split). - -(use ./types) -(use ./phm) -(use ./phs) -(use ./lazyseq) -(use ./pv) -(use ./plist) -(use ./config) -(use ./reader) -(use ./regex) - -# Host PNG encoder, exposed to the overlay as `janet.png/encode` / `janet.png/write` -# (resolved through module-load-env below). Pure Janet, no jolt deps. -(import ./png :prefix "png/") - - -# The env this module was loaded under — proto-chains to the Janet root env; -# the janet/* interop bridge falls back to it inside env-less fibers. -(def module-load-env (fiber/getenv (fiber/current))) - -# jpm-module autoload: a janet./ reference whose module isn't -# in the env is satisfied by requiring it from the jpm module path on first -# use — (janet.spork.http/server ...) just works when spork is installed, -# and the same goes for any jpm module. Loaded bindings are cached here -# (and failures negatively cached, so a missing module errors fast). -(def janet-bridge-extras @{}) -(def janet-bridge-failed @{}) -(defn bridge-autoload - "jname is spork.http/server-shaped: require spork/http, cache its public - bindings under the dotted prefix, return the one asked for (nil when the - module is missing or has no such binding)." - [jname] - (def slash (string/find "/" jname)) - (when slash - (def mod-ns (string/slice jname 0 slash)) - (unless (get janet-bridge-failed mod-ns) - (def mod-path (string/replace-all "." "/" mod-ns)) - (def r (protect (require mod-path))) - (if (r 0) - (eachp [sym entry] (r 1) - (when (and (symbol? sym) (table? entry) (not (get entry :private))) - (put janet-bridge-extras (string mod-ns "/" sym) (get entry :value)))) - (put janet-bridge-failed mod-ns true)))) - (in janet-bridge-extras jname)) - -(defn sym-name? - [sym-s name-str] - (and (struct? sym-s) (= :symbol (sym-s :jolt/type)) (= name-str (sym-s :name)))) - -(defn- special-symbol? - [name] - (or (= name "quote") (= name "syntax-quote") (= name "unquote") - (= name "unquote-splicing") (= name "do") (= name "if") - (= name "def") (= name "defmacro") (= name "fn*") (= name "let*") (= name "loop*") - (= name "recur") (= name "throw") (= name "try") - (= name "set!") (= name "var") - (= name "eval") - (= name "new") (= name ".") - # var-get/var-set/var?/alter-var-root/alter-meta!/reset-meta! are plain - # clojure.core fns (core-bindings); find-var/intern are ctx-capturing fns - # (install-stateful-fns!) — no longer special forms (Stage 2 tier 6). - # locking/instance?/satisfies?/defonce/read-string/macroexpand-1 and the - # multimethod table ops are overlay macros / clojure.core fns now - # (Stage 2 tier 6c) — not special forms. - )) - -(var eval-form nil) - -# Macro expansion cache (interpreter): a macro CALL form expands ONCE and the -# result is reused — macroexpansion is a compile-time step with zero runtime cost, -# the proper Lisp model. Keyed by the call form's identity (a fn body re-evaluates -# the same form arrays each call). Also gives compile-once gensym semantics (a -# foo# auto-gensym is fixed across calls, unlike per-call re-expansion). Cleared -# when a macro is (re)defined so stale expansions don't linger. -(def macro-cache @{}) - -# Compile hook for macro expanders: set by the api to (fn [ctx args-form body] -> -# compiled-janet-fn | nil). When set and the body is compilable (no &env/&form, -# analyzer available), defmacro uses the compiled expander instead of the -# interpreted closure — macro expansion at native speed, zero runtime cost. -(var macro-compile-hook nil) - -(defn form-uses-sym? [form nm] - (cond - (and (struct? form) (= :symbol (form :jolt/type))) (= nm (form :name)) - (or (array? form) (tuple? form)) - (do (var found false) (each x form (when (form-uses-sym? x nm) (set found true) (break))) found) - (and (struct? form) (nil? (form :jolt/type))) - (do (var found false) (each k (keys form) - (when (or (form-uses-sym? k nm) (form-uses-sym? (get form k) nm)) (set found true) (break))) found) - false)) - -# A transient is a tagged mutable table @{:jolt/type :jolt/transient :kind ...}. -(defn- jolt-transient? [x] - (and (table? x) (= :jolt/transient (get x :jolt/type)))) - -# Read-only lookup over a transient (vector index / map key / set membership), -# mirroring core-get. Map/set backing tables are keyed by the same canon used -# by phm, so canonicalize collection keys here too. -(defn- transient-lookup [t k default] - (case (t :kind) - :vector (let [a (t :arr)] - (if (and (number? k) (= k (math/floor k)) (>= k 0) (< k (length a))) - (in a k) default)) - :map (let [e (get (t :tbl) (canon k))] (if (nil? e) default (in e 1))) - :set (if (nil? (get (t :tbl) (canon k))) default k) - default)) - -(defn coll-lookup - "Clojure `get` semantics over a jolt collection, used for collection-as-IFn." - [coll k default] - (cond - (jolt-transient? coll) (transient-lookup coll k default) - (shape-rec? coll) (shape-get coll k default) - # sorted colls are tables — without this arm they fell into the raw - # table-get branch and (:k (sorted-map ...)) was always nil (jolt-4vr spec) - (and (table? coll) (or (= :jolt/sorted-map (coll :jolt/type)) - (= :jolt/sorted-set (coll :jolt/type)))) - ((get (coll :ops) :get) coll k default) - (phm? coll) (phm-get coll k default) - (set? coll) (if (phs-contains? coll k) k default) - (pvec? coll) - (if (and (number? k) (= k (math/floor k)) (>= k 0) (< k (pv-count coll))) - (pv-nth coll k) default) - (or (tuple? coll) (array? coll)) - (if (and (number? k) (= k (math/floor k)) (>= k 0) (< k (length coll))) - (in coll k) default) - (or (struct? coll) (table? coll)) - (let [v (get coll k :jolt/not-found)] - (if (= v :jolt/not-found) default v)) - (nil? coll) default - default)) - -(defn jolt-invoke - "Apply f to already-evaluated args. Handles real functions and Clojure's - IFn collections: vectors (index lookup), maps/sets/keywords/symbols (get), - and deftype/record values implementing IFn. `args` is an array." - [ctx f args] - (cond - (or (function? f) (cfunction? f)) (apply f args) - # a var is callable as its current value (Clojure vars implement IFn) — - # e.g. (wrap-request #'core/request) threads the var as the base client - (var? f) (jolt-invoke ctx (var-get f) args) - (jolt-transient? f) (transient-lookup f (get args 0) (get args 1)) - # a record shape-rec is callable: IFn impl if it has one, else map-like - # field access. A plain (non-record) shape-rec is just field access. - (shape-rec? f) - (let [tag (record-tag f) - ifn (when tag (find-protocol-method ctx tag "IFn" "-invoke"))] - (if ifn (apply ifn f args) (shape-get f (get args 0) (get args 1)))) - (keyword? f) (coll-lookup (get args 0) f (get args 1)) - (and (struct? f) (= :symbol (f :jolt/type))) - (coll-lookup (get args 0) f (get args 1)) - (and (table? f) (or (= :jolt/sorted-map (f :jolt/type)) - (= :jolt/sorted-set (f :jolt/type)))) - # the overlay-attached :get op (comparator-based lookup, like Clojure) - ((get (f :ops) :get) f (get args 0) (get args 1)) - (phm? f) (phm-get f (get args 0) (get args 1)) - (set? f) (if (phs-contains? f (get args 0)) (get args 0) (get args 1)) - (pvec? f) - (let [k (get args 0)] - (if (and (number? k) (= k (math/floor k)) (>= k 0) (< k (pv-count f))) - (pv-nth f k) - (error (string "Index " k " out of bounds for vector of length " (pv-count f))))) - (or (tuple? f) (array? f)) - (let [k (get args 0)] - (if (and (number? k) (= k (math/floor k)) (>= k 0) (< k (length f))) - (in f k) - (error (string "Index " k " out of bounds for vector of length " (length f))))) - # Map literal only (struct with no :jolt/type). A tagged struct (char/etc.) - # is not callable — symbols are handled above; chars fall through to the error. - (and (struct? f) (nil? (get f :jolt/type))) - (let [v (get f (get args 0) :jolt/not-found)] - (if (= v :jolt/not-found) (get args 1) v)) - (and (table? f) (get f :jolt/deftype)) - (let [ifn-fn (find-protocol-method ctx (get f :jolt/deftype) "IFn" "-invoke")] - (if ifn-fn (apply ifn-fn f args) - (if (and (get f :jolt/protocol-methods) (get (f :jolt/protocol-methods) :-invoke)) - (apply (get (f :jolt/protocol-methods) :-invoke) f args) - # No IFn impl: fall back to map-like field access, e.g. (point :x) - (let [v (get f (get args 0) :jolt/not-found)] - (if (= v :jolt/not-found) (get args 1) v))))) - (and (table? f) (get f :jolt/protocol-methods)) - (let [invoke-fn (get (f :jolt/protocol-methods) :-invoke)] - (if invoke-fn (apply invoke-fn f args) - (error (string "Cannot call " (type f) " as a function")))) - (error (string "Cannot call " (type f) " as a function")))) - -(defn- sq-symbol - "Resolve a symbol inside syntax-quote. `foo#` becomes a stable auto-gensym - (per-expansion, via gsmap); special forms are left unqualified; a clojure.core - name is fully qualified to clojure.core/ (matching Clojure, for hygiene); other - symbols are qualified to the current namespace so they resolve when the macro is - used elsewhere." - [ctx form gsmap] - (if (nil? (form :ns)) - (let [nm (form :name)] - (cond - (string/has-suffix? "#" nm) - (or (get gsmap nm) - (let [g {:jolt/type :symbol :ns nil - :name (string (string/slice nm 0 -2) "__" (string (gensym)) "__auto")}] - (put gsmap nm g) g)) - (special-symbol? nm) form - (ns-find (ctx-find-ns ctx "clojure.core") nm) - {:jolt/type :symbol :ns "clojure.core" :name nm} - # Unresolved -> qualify to the namespace being COMPILED when set (the - # analyzer runs interpreted in jolt.analyzer, so ctx-current-ns is wrong - # mid-compile — the same seam resolve-var/h-current-ns use). Matters when - # a macro expander's template is lowered while a symbol it references is - # not yet defined (deftype's extend-type, defined later in the same tier): - # it must qualify to the macro's home ns, not jolt.analyzer. - {:jolt/type :symbol - :ns (or (get (ctx :env) :compile-ns) (ctx-current-ns ctx)) - :name nm})) - # Alias-qualified (impl/foo): resolve the alias to its target namespace so the - # emitted symbol resolves at the macro's USE site, which has no such alias - # (jolt-9av). Matches Clojure's syntax-quote. A real ns name (not an alias) - # has no entry and is left as written. - (let [cur (ctx-find-ns ctx (or (get (ctx :env) :compile-ns) (ctx-current-ns ctx))) - target (and cur (or (ns-alias-lookup cur (form :ns)) - (ns-import-lookup cur (form :ns))))] - (if target - {:jolt/type :symbol :ns target :name (form :name)} - form)))) - -(defn d-realize - "Realize a lazy-seq to an array for positional destructuring / splicing; pass - others (pvec/plist coerced to array, everything else unchanged). nil is an - empty seq, as everywhere in Clojure — ~@nil splices nothing (an interpreted - macro's empty & rest binds nil, which used to blow up `each`)." - [val] - (if (nil? val) @[] - (if (pvec? val) (pv->array val) - (if (plist? val) (pl->array val) - (if (lazy-seq? val) - (do - (var items @[]) (var cur val) (var go true) - (while go - (let [cell (realize-ls cur)] - (if (or (nil? cell) (= :jolt/pending cell) (= 0 (length cell))) - (set go false) - (do (array/push items (in cell 0)) - (let [rt (in cell 1)] - (if (nil? rt) (set go false) (set cur (ls-rest-cached cur rt)))))))) - items) - val))))) - -(defn syntax-quote* - [ctx bindings form &opt gsmap] - (default gsmap @{}) - (cond - (and (array? form) (> (length form) 0) (sym-name? (first form) "unquote")) - (eval-form ctx bindings (in form 1)) - (and (array? form) (> (length form) 0) (sym-name? (first form) "unquote-splicing")) - (error "~@ used outside of a list or vector in syntax-quote") - (or (number? form) (string? form) (keyword? form) (nil? form) (= true form) (= false form)) - form - (and (struct? form) (= :symbol (form :jolt/type))) - (sq-symbol ctx form gsmap) - (tuple? form) - (do (var result @[]) (var i 0) (while (< i (length form)) - (let [item (in form i)] - (if (and (array? item) (> (length item) 0) (sym-name? (first item) "unquote-splicing")) - (let [sv (eval-form ctx bindings (in item 1))] - (each v (d-realize sv) (array/push result v))) - (array/push result (syntax-quote* ctx bindings item gsmap)))) - (++ i)) (tuple ;result)) - (array? form) - (do (var result @[]) (var i 0) (while (< i (length form)) - (let [item (in form i)] - (if (and (array? item) (> (length item) 0) (sym-name? (first item) "unquote-splicing")) - (let [sv (eval-form ctx bindings (in item 1))] - (each v (d-realize sv) (array/push result v))) - (array/push result (syntax-quote* ctx bindings item gsmap)))) - (++ i)) result) - # set literal: lower each element (processing ~/~@) and rebuild a set. - (and (struct? form) (= :jolt/set (form :jolt/type))) - (do (var result @[]) - (each item (form :value) - (if (and (array? item) (> (length item) 0) (sym-name? (first item) "unquote-splicing")) - (let [sv (eval-form ctx bindings (in item 1))] - (each v (d-realize sv) (array/push result v))) - (array/push result (syntax-quote* ctx bindings item gsmap)))) - (make-phs ;result)) - (and (struct? form) (get form :jolt/type)) form - (struct? form) - (do (var kvs @[]) - (def order (form-kv-order form)) - (if order - (each x order (array/push kvs (syntax-quote* ctx bindings x gsmap))) - (each k (keys form) - (array/push kvs (syntax-quote* ctx bindings k gsmap)) - (array/push kvs (syntax-quote* ctx bindings (get form k) gsmap)))) - # keep carrying source order through nested syntax-quote (jolt-p3c) - (struct/with-proto (struct :jolt/kv-order (tuple/slice kvs)) ;kvs)) - form)) - -# Syntax-quote LOWERING: instead of evaluating a `(...) form to a value (what -# syntax-quote* does), produce equivalent CONSTRUCTION CODE so a backtick body is -# plain compilable code (read -> macroexpand -> compile, zero runtime cost). -# Mirrors syntax-quote*/sq-symbol exactly; the canonical algorithm is -# tools.reader's syntax-quote*/expand-list. List forms build via __sqcat (-> array), -# vectors via __sqvec (-> tuple), maps via __sqmap; symbols become (quote resolved); -# ~ leaves the expr in place, ~@ passes the seq straight to __sqcat for splicing. -(defn- sqsym* [nm] {:jolt/type :symbol :ns nil :name nm}) - -(var syntax-quote-lower nil) - -(defn- sq-lower-part [ctx item gsmap] - (if (and (array? item) (> (length item) 0) (sym-name? (first item) "unquote-splicing")) - (in item 1) - @[(sqsym* "__sq1") (syntax-quote-lower ctx item gsmap)])) - -(set syntax-quote-lower - (fn syntax-quote-lower [ctx form &opt gsmap] - (default gsmap @{}) - (cond - (and (array? form) (> (length form) 0) (sym-name? (first form) "unquote")) - (in form 1) - (and (array? form) (> (length form) 0) (sym-name? (first form) "unquote-splicing")) - (error "~@ used outside of a list or vector in syntax-quote") - (or (number? form) (string? form) (keyword? form) (nil? form) (= true form) (= false form)) - form - (and (struct? form) (= :symbol (form :jolt/type))) - @[(sqsym* "quote") (sq-symbol ctx form gsmap)] - (array? form) - (array/concat @[(sqsym* "__sqcat")] (map (fn [it] (sq-lower-part ctx it gsmap)) form)) - (tuple? form) - (array/concat @[(sqsym* "__sqvec")] (map (fn [it] (sq-lower-part ctx it gsmap)) form)) - # set literal: lower each element (so ~/~@ are processed) and rebuild a set. - (and (struct? form) (= :jolt/set (form :jolt/type))) - (array/concat @[(sqsym* "__sqset")] (map (fn [it] (sq-lower-part ctx it gsmap)) (form :value))) - # other tagged structs (chars): returned as-is (no recursion) - (and (struct? form) (get form :jolt/type)) - @[(sqsym* "quote") form] - (struct? form) - (do (var parts @[(sqsym* "__sqmap")]) - (def order (form-kv-order form)) - (if order - (each x order (array/push parts (syntax-quote-lower ctx x gsmap))) - (each k (keys form) - (array/push parts (syntax-quote-lower ctx k gsmap)) - (array/push parts (syntax-quote-lower ctx (get form k) gsmap)))) - parts) - @[(sqsym* "quote") form]))) - -(defn resolve-var - [ctx bindings sym-s] - (let [name (sym-s :name) ns (sym-s :ns)] - (if (not (nil? ns)) - # Resolve ns aliases (e.g. `p/thrown?` where `p` is a require :as alias) so - # aliased refs/macros resolve. During compilation the analyzer (interpreted, - # in jolt.analyzer) rebinds ctx-current-ns to its own ns, so look up the alias - # against the COMPILE ns (:compile-ns, the user's ns) when set — otherwise an - # aliased ref like g/foo wouldn't resolve mid-compile. Same ns h-current-ns uses. - (let [cur-name (or (get (ctx :env) :compile-ns) (ctx-current-ns ctx)) - current-ns (ctx-find-ns ctx cur-name) - aliased-ns (or (ns-alias-lookup current-ns ns) (ns-import-lookup current-ns ns)) - target-ns (ctx-find-ns ctx (or aliased-ns ns))] - (ns-find target-ns name)) - (if (get bindings name) nil - (let [current-ns (ctx-current-ns ctx) - ns (ctx-find-ns ctx current-ns) - v (ns-find ns name)] - (if v v - (let [core-ns (ctx-find-ns ctx "clojure.core")] - (ns-find core-ns name)))))))) - -(defn sym-name-str - [sym-s] - (if (sym-s :ns) (string (sym-s :ns) "/" (sym-s :name)) (sym-s :name))) - -(defn- ns->relpath - "Namespace name to its file-relative path (dots->dirs, dashes->_), no extension." - [ns-name] - (string/replace-all "." "/" (string/replace-all "-" "_" ns-name))) - -(defn- find-ns-file - "Search the context's source roots (stdlib first, then deps.edn dirs) for the - namespace's source, trying .clj then .cljc. Returns the path or nil." - [ctx ns-name] - (let [rel (ns->relpath ns-name) - roots (or (get (ctx :env) :source-paths) @["src/jolt"])] - (var found nil) - (each root roots - (each ext [".clj" ".cljc"] - (when (nil? found) - (let [p (string root "/" rel ext)] - (when (os/stat p) (set found p)))))) - found)) - -(defn- load-ns-source - "Parse and evaluate every form of a namespace's source in the given context. - Routes through the loader's eval-toplevel when the api has installed it - (the :toplevel-eval hook) so REQUIRED namespaces compile like everything - else — without it they ran interpreted-only: slower, and their fns were - anonymous closures in stack traces (jolt-2o7.1)." - [ctx src &opt file] - (default file "") - (def toplevel (get (ctx :env) :toplevel-eval)) - # a require runs nested inside an outer file's eval; save/restore the outer - # checker source so its later forms still convert offsets correctly (jolt-fqy) - (def checking (or (checker-enabled?) (get (ctx :env) :inline?))) - (def saved-src (and checking (get (ctx :env) :tc-source))) - (def saved-file (and checking (get (ctx :env) :tc-file))) - (when checking - (track-positions! true) - (put (ctx :env) :tc-source src) - (put (ctx :env) :tc-file file)) - (defer (when checking - (put (ctx :env) :tc-source saved-src) - (put (ctx :env) :tc-file saved-file)) - (each [f line] (parse-all-positioned src file) - (try - (if toplevel (toplevel ctx f) (eval-form ctx @{} f)) - ([err fib] - # innermost failing form wins; files unwound through form the - # 'while loading …' chain (mirrors loader/eval-forms-positioned, - # which this can't import — circularity) (jolt-2o7.4) - (def env (ctx :env)) - (when (nil? (get env :error-pos)) - (put env :error-pos {:file file :line line})) - (when (nil? (get env :error-loading)) (put env :error-loading @[])) - (def chain (get env :error-loading)) - (when (not= (last chain) file) (array/push chain file)) - (propagate err fib)))))) - -# jolt-87e: is a namespace loaded from `path` part of the APP (vs a dependency)? -# True when its file sits under one of the declared app source roots -# (:app-source-paths, from JOLT_APP_PATHS / jolt-deps). When NO app roots are -# declared (a bare program run, or jolt invoked without jolt-deps), everything -# counts as app so whole-program covers the whole program exactly as before. -# Only app namespaces defer into the one whole-program fixpoint; dependency -# namespaces infer per-ns at load, so a dep-heavy app's startup doesn't re-infer -# hundreds of transitive dependency namespaces in a single closed-world pass. -(defn- app-source-ns? - [ctx path] - (def roots (get (ctx :env) :app-source-paths)) - (if (or (nil? roots) (empty? roots)) - true - (and path (truthy? (some |(string/has-prefix? $ path) roots))))) - -(defn maybe-require-ns - "If namespace ns-name isn't populated yet, load its source — from a file on the - context's source roots, else from the stdlib baked into the image. Restores the - current namespace afterwards (a library's own `ns` form, or our manual switch - for ns-form-less stdlib files, changes it). No-op for already-loaded namespaces." - [ctx ns-name] - (let [ns (ctx-find-ns ctx ns-name)] - (when (and (= 0 (length (ns :mappings))) - (not (get (get (ctx :env) :loaded-namespaces @{}) ns-name)) - (not= ns-name "clojure.core")) - (let [path (find-ns-file ctx ns-name) - embedded (get (get (ctx :env) :embedded-sources @{}) ns-name) - stdlib? (not (nil? embedded))] - # Clojure throws FileNotFoundException here; succeeding silently leaves - # an empty namespace behind and defers the failure to the first - # unresolved symbol, far from the actual cause (a typo, a missing - # JOLT_PATH root). Best-effort loaders (the SCI bootstrap, which loads - # clj-targeted sources whose requires can't all exist on this host) - # opt out via :lenient-require? on the env. - (when (and (nil? path) (nil? embedded) - (not (get (ctx :env) :lenient-require?))) - (error (string "Could not locate " ns-name - " on the context's source paths (JOLT_PATH / :paths)"))) - (when (or path embedded) - (let [saved (ctx-current-ns ctx) - # jolt-87e: is this an app namespace, or a dependency/library? Only - # the app is the closed world the whole-program optimizer reasons - # over; dependencies are open-world libraries. - app? (app-source-ns? ctx path) - # Whole-program optimize is active for this load. - wp-active? (and (get (ctx :env) :inline?) - (get (ctx :env) :whole-program?) - (not (get (ctx :env) :infer-program-done?))) - # A dependency under whole-program optimize compiles at DEFAULT - # cost: :inline? off for its load, so the per-form inline + - # inference passes — the bulk of optimize-mode startup — don't run - # over hundreds of library forms. (Direct-linking + shape-recs stay - # on, exactly like a non-optimized direct-link build.) This is what - # makes JOLT_OPTIMIZE viable on dep-heavy apps; the app's own nses - # below keep full optimization. (jolt-87e) - dep-cheap? (and wp-active? (not app?)) - saved-inline (get (ctx :env) :inline?)] - # Stdlib files have no `ns` form, so switch into the target ns first - # (their defs intern there); a library's own `ns` form overrides this. - (ctx-set-current-ns ctx ns-name) - (when dep-cheap? (put (ctx :env) :inline? false)) - (if path - (load-ns-source ctx (slurp path) path) - (load-ns-source ctx embedded (string ns-name " (stdlib)"))) - (when dep-cheap? (put (ctx :env) :inline? saved-inline)) - # Inter-procedural collection-type inference (jolt-767): once the whole - # unit is loaded, run the closed-world fixpoint + recompile so param- - # dependent lookups specialize. Only in optimization mode; best-effort - # (a failure here must not break loading). Hook installed by the api to - # avoid an evaluator->backend circular import. - (when (get (ctx :env) :inline?) - (cond - # whole-program (jolt-t34), APP namespace: defer — record the ns and - # run ONE fixpoint over all app units later (the closed-world pass - # sees every caller, so cross-ns param types propagate). - (and wp-active? app?) - (let [lst (or (get (ctx :env) :inferred-nses) - (let [a @[]] (put (ctx :env) :inferred-nses a) a))] - (array/push lst ns-name)) - # whole-program, DEPENDENCY namespace (jolt-87e): nothing to do — - # it compiled cheaply above (no inference to run or defer). - wp-active? - nil - # per-ns mode (whole-program off), or a lazy require AFTER the batch - # ran: infer this unit on its own. - (when-let [iu (get (ctx :env) :infer-unit!)] - (protect (iu ctx ns-name))))) - # Record load order for tooling (uberscript): a dependency finishes - # loading before its requirer, so this is topological. Skip the - # baked-in stdlib — it's part of the runtime, not something to bundle. - (when (and path (not stdlib?)) - (when-let [lf (get (ctx :env) :loaded-files)] (array/push lf path))) - (ctx-set-current-ns ctx saved))))))) - -(defn eval-require - [ctx spec] - (let [ns-sym (in spec 0) - ns-name (sym-name-str ns-sym)] - (var alias nil) - (var refer-syms nil) - (var i 1) - (let [slen (length spec)] - # Scan ALL options — a spec may carry both :as and :refer, e.g. - # [clojure.string :as str :refer [blank?]]; don't stop at the first. - (while (< i slen) - (let [item (in spec i)] - (cond - (or (= item :as) (and (struct? item) (= :symbol (item :jolt/type)) (= "as" (item :name)))) - (do (set alias ((in spec (+ i 1)) :name)) (+= i 2)) - (or (= item :refer) (and (struct? item) (= :symbol (item :jolt/type)) (= "refer" (item :name)))) - (do (set refer-syms (in spec (+ i 1))) (+= i 2)) - (++ i))))) - (maybe-require-ns ctx ns-name) - (when alias - (let [current-ns (ctx-find-ns ctx (ctx-current-ns ctx))] - (ns-add-alias current-ns alias ns-name))) - (when refer-syms - (let [source-ns (ctx-find-ns ctx ns-name) - target-ns (ctx-find-ns ctx (ctx-current-ns ctx))] - (if (or (= refer-syms :all) - (and (struct? refer-syms) (= :symbol (refer-syms :jolt/type)) - (= "all" (refer-syms :name)))) - # :refer :all — share EVERY var (this used to each over the :all - # keyword itself and silently refer nothing; selmer's - # [selmer.util :refer :all] left *tag-open* & co unresolved) - (eachp [nm v] (source-ns :mappings) - (put (target-ns :mappings) nm v)) - (each refer-sym refer-syms - (let [name (if (struct? refer-sym) (refer-sym :name) refer-sym) - v (ns-find source-ns name)] - (when v - # Share the SOURCE var (the Clojure model): macro-ness travels with - # it and source-ns redefinitions propagate to the referer. - (put (target-ns :mappings) name v))))))) - nil)) - -(defn bind-put - "Put a value into bindings. Uses :jolt/nil sentinel for nil values - because Janet's (put table key nil) silently drops the key." - [bindings key value] - (put bindings key (if (nil? value) :jolt/nil value))) - -(defn binding-get - "Get a value from bindings, walking the prototype chain." - [bindings name] - (var result :jolt/not-found) - (var t bindings) - (while (not (nil? t)) - (when (in t name) - (set result (in t name)) - (break)) - (set t (table/getproto t))) - result) - -# Pluggable host-class shims (java.time etc. register here at module load): -# class-statics: "ClassName" -> {"member" value-or-fn} (Foo/bar resolution) -# tagged-methods: :jolt/tag -> {"method" (fn [self args...])} ((.m obj) dispatch) -(def class-statics @{}) -(def tagged-methods @{}) -(defn register-class-statics! [class-name tbl] (put class-statics class-name tbl)) -(defn register-tagged-methods! [tag tbl] (put tagged-methods tag tbl)) -# Constructor shims: (ClassName. args) resolves ClassName as a value, so the -# ctor fns are interned as clojure.core vars at init (install-stateful-fns!). -(def class-ctors @{}) -(defn register-class-ctor! [nm f] (put class-ctors nm f)) - -# java.util.Iterator shim: (.iterator coll) gives a jolt iterator over any -# seqable, with (.hasNext it) / (.next it). Some Clojure libs (e.g. hiccup's -# iterate!) loop with the Java Iterator protocol; this makes that work over jolt -# collections. The realizer (core/realize-for-iteration, which handles every -# collection type) is late-bound because core loads after this file. -(var coll-realizer nil) -(defn set-coll-realizer! [f] (set coll-realizer f)) -# Late-bound (wired in api): routes a Java collection-interop method call -# (.nth/.count/.valAt/.seq …) on a jolt persistent collection to the clojure.core -# equivalent. Returns :jolt/ci-none when it doesn't apply. Lets clj-targeted libs -# (malli) that use .nth/.count on vectors/maps in their :clj branches work. -(var coll-interop nil) -(defn set-coll-interop! [f] (set coll-interop f)) diff --git a/src/jolt/eval_resolve.janet b/src/jolt/eval_resolve.janet deleted file mode 100644 index d391bc7..0000000 --- a/src/jolt/eval_resolve.janet +++ /dev/null @@ -1,443 +0,0 @@ -# Jolt Evaluator — symbol/var resolution, params, destructuring, class lookup -# Extracted from evaluator.janet (jolt-oudv, phase 2a split). - -(use ./types) -(use ./phm) -(use ./phs) -(use ./lazyseq) -(use ./pv) -(use ./plist) -(use ./config) -(use ./reader) -(use ./regex) -(use ./eval_base) -(register-tagged-methods! :jolt/iterator - @{"hasNext" (fn [self] (< (self :pos) (length (self :items)))) - "next" (fn [self] - (def x (in (self :items) (self :pos))) - (put self :pos (+ 1 (self :pos))) - x)}) -# Class names evaluate to their CANONICAL NAME STRING — the same value -# core-class returns — so (defmethod m String ...) keys match a -# (defmulti m (comp class :body)) dispatch (ring.util.request does this). -# `new` resolves the actual constructor from class-ctors by short name. -(def class-canonical-names - @{"String" "java.lang.String" "Number" "java.lang.Number" - "Boolean" "java.lang.Boolean" "Long" "java.lang.Long" - "Integer" "java.lang.Integer" "Double" "java.lang.Double" - "InputStream" "java.io.InputStream" "OutputStream" "java.io.OutputStream" - "File" "java.io.File" "Reader" "java.io.Reader" "Writer" "java.io.Writer" - "ISeq" "clojure.lang.ISeq" "Keyword" "clojure.lang.Keyword" - "Symbol" "clojure.lang.Symbol" "MapEntry" "clojure.lang.MapEntry" - "StringReader" "java.io.StringReader" "StringWriter" "java.io.StringWriter" - "StringBuilder" "java.lang.StringBuilder" - "StringTokenizer" "java.util.StringTokenizer" - "Charset" "java.nio.charset.Charset" "Base64" "java.util.Base64" - "Exception" "java.lang.Exception" - "IllegalArgumentException" "java.lang.IllegalArgumentException" - "InterruptedException" "java.lang.InterruptedException" - "Throwable" "java.lang.Throwable"}) -# A class used as a VALUE should evaluate to what (clojure.core/type instance) -# returns for its instances, so a registry keyed by class (e.g. malli's -# class-schemas) matches a value's (type ...). For jolt's native tagged types the -# class maps to its :jolt/type keyword — Pattern <-> a compiled regex. -(def- class-value-overrides - @{"Pattern" :jolt/regex "java.util.regex.Pattern" :jolt/regex}) -(defn class-value-for - "The value a class-name symbol evaluates to: a type override, else its canonical - name string." - [nm] - (or (get class-value-overrides nm) - (get class-canonical-names nm) - # qualified already, or unknown: the name itself is the token - nm)) -(defn ctor-for-class-token - "Constructor fn for a class token (a canonical-name string): try the full - name, then the short name after the last dot." - [tok] - (or (in class-ctors tok) - (let [parts (string/split "." tok)] - (in class-ctors (last parts))))) - -# java.lang.String method surface for clj-compat interop: (.toLowerCase s), -# (.indexOf s x), ... — the methods portable cljc libraries actually call. -# Case mapping is ASCII (the whole engine is byte-based); indexOf returns -1 -# on miss, as on the JVM. -(defn- str-needle [x] - (cond - (and (struct? x) (= :jolt/char (get x :jolt/type))) (string/from-bytes (x :ch)) - # (.indexOf s 61): an int needle is a char CODE on the JVM, not its decimal - # text (ring-codec splits k=v pairs this way) - (number? x) (string/from-bytes (math/trunc x)) - (string x))) -# java.lang.Number surface (ring-codec: (.byteValue (Integer/valueOf s 16))). -(def number-methods - {"byteValue" (fn [n] (let [b (band (math/trunc n) 0xff)] (if (> b 127) (- b 256) b))) - "shortValue" (fn [n] (let [v (band (math/trunc n) 0xffff)] (if (> v 32767) (- v 65536) v))) - "intValue" (fn [n] (math/trunc n)) - "longValue" (fn [n] (math/trunc n)) - "floatValue" (fn [n] (* 1.0 n)) - "doubleValue" (fn [n] (* 1.0 n)) - "toString" (fn [n &opt radix] (if (= radix 16) (string/format "%x" (math/trunc n)) (string n)))}) - -# Universal java.lang.Object / exception / persistent-collection methods that -# reitit's :clj branches call on non-string targets: (.getMessage e), -# (.assoc m k v), (.get m k). Consulted in the method-dispatch fallthrough. -(def object-methods - {"getMessage" (fn [e] (cond (and (table? e) (= :jolt/ex-info (get e :jolt/type))) (get e :message) - (string? e) e - (string e))) - "getCause" (fn [e] (and (table? e) (get e :cause))) - "toString" (fn [x] (string x)) - "equals" (fn [a b] (deep= a b)) - "hashCode" (fn [x] (hash x)) - # (.iterator coll) -> a jolt iterator (see :jolt/iterator above). Materializes - # the collection to an indexable array via the late-bound core realizer. - "iterator" (fn [coll] @{:jolt/type :jolt/iterator :pos 0 - :items (if coll-realizer (coll-realizer coll) @[])})}) - -(def string-methods - {"getBytes" (fn [s &opt charset] (buffer s)) - "toString" (fn [s] s) - "toLowerCase" (fn [s] (string/ascii-lower s)) - "toUpperCase" (fn [s] (string/ascii-upper s)) - "trim" (fn [s] (string/trim s)) - "intern" (fn [s] s) - # file-path surface: io/file returns plain path strings, so the java.io.File - # / java.net.URL methods selmer's template cache calls land here - "toURI" (fn [s] s) - "toURL" (fn [s] s) - "getPath" (fn [s] s) - "getName" (fn [s] (if-let [i (string/find "/" (string/reverse s))] - (string/slice s (- (length s) i)) s)) - "exists" (fn [s] (not (nil? (os/stat s)))) - "lastModified" (fn [s] (if-let [st (os/stat s)] (math/floor (* 1000 (st :modified))) 0)) - # JVM String.split takes a REGEX string; trailing empties dropped like the JVM - "split" (fn [s re &opt limit] - (def parts (re-split (re-pattern re) s)) - (while (and (> (length parts) 0) (= "" (last parts))) - (array/pop parts)) - parts) - "length" (fn [s] (length s)) - "isEmpty" (fn [s] (= 0 (length s))) - "charAt" (fn [s i] {:jolt/type :jolt/char :ch (s i)}) - "codePointAt" (fn [s i] (s i)) - "indexOf" (fn [s x &opt from] (or (string/find (str-needle x) s (or from 0)) -1)) - "lastIndexOf" (fn [s x] - (let [n (str-needle x)] - (var found -1) (var i 0) - (while (< i (length s)) - (let [f (string/find n s i)] - (if f (do (set found f) (set i (+ f 1))) (set i (length s))))) - found)) - "substring" (fn [s start &opt end] (string/slice s start end)) - "startsWith" (fn [s p] (string/has-prefix? p s)) - "endsWith" (fn [s p] (string/has-suffix? p s)) - "contains" (fn [s sub] (not (nil? (string/find (str-needle sub) s)))) - "concat" (fn [s o] (string s o)) - "replace" (fn [s a b] (string/replace-all (str-needle a) (str-needle b) s)) - "replaceAll" (fn [s regex replacement] (re-replace-all (re-pattern regex) s replacement)) - "replaceFirst" (fn [s regex replacement] (re-replace-first (re-pattern regex) s replacement)) - "matches" (fn [s regex] (not (nil? (re-matches (re-pattern regex) s)))) - "compareTo" (fn [s o] (cond (< s o) -1 (> s o) 1 0)) - "equalsIgnoreCase" (fn [s o] (= (string/ascii-lower s) (string/ascii-lower (string o))))}) - -(defn resolve-sym - [ctx bindings sym-s] - (let [name (sym-s :name) ns (sym-s :ns)] - # Math/Thread/System/Long and every other class resolve through the generic - # class-statics registry (host_interop registers them at load); no special-case. - (if (get class-statics ns) - (let [v (get (get class-statics ns) name)] - (if (nil? v) (error (string "Unsupported member: " ns "/" name)) v)) - (if (not (nil? ns)) - (let [current-ns (ctx-find-ns ctx (ctx-current-ns ctx)) - aliased-ns (or (ns-alias-lookup current-ns ns) (ns-import-lookup current-ns ns)) - target-ns (ctx-find-ns ctx (or aliased-ns ns)) - v (and target-ns (ns-find target-ns name))] - (if v (var-get v) - # Explicit Janet interop. The `janet` namespace segment marks every - # crossing into host code, where Clojure semantics no longer hold: - # janet/ -> Janet root binding (janet/slurp, janet/type) - # janet./ -> Janet module binding (janet.net/server, - # janet.os/clock) - # This makes the whole Janet stdlib reachable from Clojure while keeping - # the interop boundary visible at the call site. - (if (or (= ns "janet") (string/has-prefix? "janet." ns)) - (let [jname (if (= ns "janet") name (string (string/slice ns 6) "/" name)) - # worker fibers may carry no env (fiber/new without :e inherit) - # — fall back to the env captured at module load - # four-step resolution: the runtime fiber's env (when it - # has one), the evaluator's module env (worker/connection - # fibers carry a foreign or empty env — net/server handler - # fibers resolve janet/struct through here), the autoload - # cache, then a jpm-module require on first miss - entry (or (when-let [fe (fiber/getenv (fiber/current))] - (in fe (symbol jname))) - (in module-load-env (symbol jname)) - (in janet-bridge-extras jname) - (bridge-autoload jname))] - (if (not (nil? entry)) - (if (table? entry) (entry :value) entry) - (error (string "Unable to resolve Janet symbol: " jname)))) - # syntax-quote ns-qualifies bare class names inside macros - # (selmer.util/StringBuilder); class names never belong to an ns — - # fall back to the constructor / statics shims before giving up. - (if (or (in class-ctors name) (get class-canonical-names name) (get class-value-overrides name)) - (class-value-for name) - (error (string "Unable to resolve symbol: " ns "/" name)))))) - # Use :jolt/not-found sentinel to distinguish nil binding from absent binding - (let [local (get bindings name :jolt/not-found-1) - local (if (= local :jolt/not-found-1) (binding-get bindings name) local)] - (if (not= local :jolt/not-found) - (if (= local :jolt/nil) nil local) - (let [current-ns (ctx-current-ns ctx) ns (ctx-find-ns ctx current-ns) v (ns-find ns name)] - (if v (var-get v) - # Check clojure.core as auto-referred fallback - (let [core-ns (ctx-find-ns ctx "clojure.core") - core-v (ns-find core-ns name)] - (if core-v - (var-get core-v) - # Try class-name resolution: Foo.Bar.Baz -> ns "Foo.Bar", name "Baz" - (let [dot-idx (string/find "." name)] - (if dot-idx - (let [last-dot (do - (var idx dot-idx) - (var next-dot (string/find "." name (+ idx 1))) - (while (not (nil? next-dot)) - (set idx next-dot) - (set next-dot (string/find "." name (+ idx 1)))) - idx) - class-ns (string/slice name 0 last-dot) - class-name (string/slice name (+ last-dot 1))] - (let [target-ns (ctx-find-ns ctx class-ns) tv (ns-find target-ns class-name)] - (if tv (var-get tv) tv))) - # No implicit Janet fallback (Stage 3): an unresolved - # Clojure symbol is an error. Host access is the explicit - # janet/ prefix above. - (if (or (in class-ctors name) (get class-canonical-names name) (get class-value-overrides name)) - (class-value-for name) - (error (string "Unable to resolve symbol: " name " in this context"))))))))))))))) -(defn- parse-arg-names - "Parse a parameter vector, handling & rest args. - Returns {:fixed [names...] :rest name-or-nil :all [names...]}" - [args-form] - (var fixed @[]) - (var rest-name nil) - (var i 0) - (while (< i (length args-form)) - (let [a (in args-form i)] - (if (and (struct? a) (= :symbol (a :jolt/type)) (= "&" (a :name))) - (do - (+= i 1) - (if (< i (length args-form)) - (do - (set rest-name ((in args-form i) :name)) - (+= i 1)) - (error "& without argument in parameter list"))) - (do - (if (and (struct? a) (= :symbol (a :jolt/type))) - (array/push fixed (a :name)) - # destructuring form: recurse into it - (when (indexed? a) - (var di 0) - (while (< di (length a)) - (def inner (in a di)) - (if (and (struct? inner) (= :symbol (inner :jolt/type)) (= "&" (inner :name))) - (do - (+= di 1) - (if (< di (length a)) - (do - (set rest-name ((in a di) :name)) - (+= di 1)) - (error "& without argument in parameter list"))) - (do - (if (and (struct? inner) (= :symbol (inner :jolt/type))) - (array/push fixed (inner :name)) - # nested destructuring - extract names - (when (indexed? inner) - (each sym inner - (when (and (struct? sym) (= :symbol (sym :jolt/type))) - (array/push fixed (sym :name)))))) - (+= di 1)))))) - (+= i 1))))) - (var all @[]) - (each n fixed (array/push all n)) - (if rest-name (array/push all rest-name)) - {:fixed (tuple/slice (tuple ;fixed)) :rest rest-name :all (tuple/slice (tuple ;all))}) - -# ============================================================ -# Destructuring (Clojure-compatible, recursive) -# ============================================================ - -(defn parse-params - "Parse a parameter vector into raw patterns: {:fixed [pat...] :rest pat-or-nil}. - Unlike parse-arg-names, patterns are kept intact (not flattened) so they can - be destructured against the corresponding argument." - [args-form] - (var fixed @[]) - (var rest-pat nil) - (var i 0) - (while (< i (length args-form)) - (let [a (in args-form i)] - (if (and (struct? a) (= :symbol (a :jolt/type)) (= "&" (a :name))) - (do (+= i 1) - (when (< i (length args-form)) (set rest-pat (in args-form i))) - (+= i 1)) - (do (array/push fixed a) (+= i 1))))) - {:fixed (tuple/slice (tuple ;fixed)) :rest rest-pat}) - -(defn rest-args-val - "What a rest param binds to: nil when no args remain (Clojure semantics — - (fn [& r]) called with nothing gives r = nil, never an empty seq)." - [args i] - (when (> (length args) i) (tuple/slice args i))) - -(defn plain-sym? [p] (and (struct? p) (= :symbol (p :jolt/type)))) - -(defn require-symbol-params - "fn* is a primitive: its params must be plain symbols. The fn/defn MACROS desugar - destructuring into plain params + a body let before emitting fn*, so fn* never - legitimately sees a pattern — matching Clojure, where (fn* [[a b]] ...) is the - compile error 'fn params must be Symbols'. Enforcing it here keeps the interpreter - consistent with the self-hosted analyzer (which also requires plain fn* params) - and with Clojure, instead of leniently destructuring a form Clojure rejects." - [param-info] - (each p (param-info :fixed) - (unless (plain-sym? p) (error "fn params must be Symbols"))) - (let [r (param-info :rest)] - (when (and r (not (plain-sym? r))) (error "fn params must be Symbols")))) - -(defn- d-get - "Look up key k in a map-like value (phm/struct/table/nil)." - [m k] - (cond - (phm? m) (phm-get m k) - (or (struct? m) (table? m)) (get m k) - true nil)) - -(defn- find-or-default - "Find the :or default expression for binding name nm, or :jolt/none." - [or-map nm] - (var result :jolt/none) - (when or-map - (each k (keys or-map) - (when (and (struct? k) (= :symbol (k :jolt/type)) (= nm (k :name))) - (set result (get or-map k))))) - result) - -(var destructure-bind nil) -(set destructure-bind - (fn dbind [ctx bindings pat val] - (cond - # plain symbol - (and (struct? pat) (= :symbol (pat :jolt/type))) - (bind-put bindings (pat :name) val) - # sequential pattern (vector of sub-patterns) - (indexed? pat) - (let [rv (d-realize val) - seqable? (indexed? rv)] - (var di 0) (var vi 0) - (def n (length pat)) - (while (< di n) - (let [elem (in pat di)] - (cond - # & rest - (and (struct? elem) (= :symbol (elem :jolt/type)) (= "&" (elem :name))) - (do - # rest binds a seq (jolt list = array), per Clojure semantics. - # For lazy-seqs, preserve laziness: walk vi steps via ls-rest - # instead of slicing the eagerly-realized array. - (destructure-bind ctx bindings (in pat (+ di 1)) - (if (lazy-seq? val) - (do - (var c val) (var i 0) - (while (< i vi) - (let [nxt (ls-rest c)] - (if (nil? nxt) (break) - (do (set c nxt) (++ i))))) - c) - (if (and seqable? (< vi (length rv))) - (array/slice (if (tuple? rv) (array/slice rv) rv) vi) - @[]))) - (set di (+ di 2))) - # :as whole - (= elem :as) - (do - (destructure-bind ctx bindings (in pat (+ di 1)) val) - (set di (+ di 2))) - # positional element - true - (do - (destructure-bind ctx bindings elem - (if (and seqable? (< vi (length rv))) (in rv vi) nil)) - (+= di 1) (+= vi 1)))))) - # map pattern (struct/table that isn't a symbol) - (or (struct? pat) (table? pat)) - (let [rv (d-realize val) - # Destructuring a sequential value as a map treats it as kwargs: - # alternating k/v pairs, or a single trailing map (Clojure's - # `[& {:keys ...}]`). A real map value is used as-is. - mval (if (and (indexed? rv) (not (or (struct? rv) (table? rv)))) - (if (and (= 1 (length rv)) - (let [e (in rv 0)] (or (struct? e) (table? e) (phm? e)))) - (in rv 0) - (let [m @{}] - (var i 0) - (while (< (+ i 1) (length rv)) - (put m (in rv i) (in rv (+ i 1))) - (+= i 2)) - m)) - val)] - (def or-map (get pat :or)) - (def as-sym (get pat :as)) - (when as-sym (destructure-bind ctx bindings as-sym mval)) - # :keys (keyword), :strs (string), :syms (symbol). A namespaced symbol - # in :keys/:syms (x/y) looks up the namespaced key but binds local y. - (each spec [[:keys :kw] [:strs :str] [:syms :sym]] - (let [kw (in spec 0) kind (in spec 1) names (get pat kw)] - (when (and names (indexed? names)) - (each s names - (let [sym? (and (struct? s) (= :symbol (s :jolt/type))) - local (if sym? (s :name) (string s)) - nsp (and sym? (s :ns)) - key (case kind - :kw (keyword (if nsp (string nsp "/" local) local)) - :str local - :sym {:jolt/type :symbol :ns nsp :name local}) - v (d-get mval key) - v (if (nil? v) - (let [d (find-or-default or-map local)] - (if (= d :jolt/none) nil (eval-form ctx bindings d))) - v)] - (bind-put bindings local v)))))) - # direct {local-pattern key-expr} entries (local may itself be a - # nested vector/map pattern). Special keys are keywords; skip them. - (each k (keys pat) - (when (not (keyword? k)) - (let [key-val (eval-form ctx bindings (get pat k)) - v (d-get mval key-val)] - (if (and (struct? k) (= :symbol (k :jolt/type))) - # symbol target: apply :or default if missing - (let [nm (k :name) - v (if (nil? v) - (let [d (find-or-default or-map nm)] - (if (= d :jolt/none) nil (eval-form ctx bindings d))) - v)] - (bind-put bindings nm v)) - # nested pattern target - (destructure-bind ctx bindings k v)))))) - true (error (string "Unsupported destructuring pattern: " (string/format "%q" pat)))))) - -# ---- host-type protocol extension (extend-protocol String/Number/... ) ---- -(def host-type-names - {"Long" true "Integer" true "Short" true "Byte" true "BigInteger" true "BigInt" true - "Double" true "Float" true "Number" true "BigDecimal" true "Ratio" true - "String" true "CharSequence" true "Boolean" true "Character" true - "Keyword" true "Symbol" true "Object" true "IFn" true "Fn" true - "PersistentVector" true "PersistentList" true "PersistentHashMap" true - "PersistentHashSet" true "IPersistentMap" true "IPersistentVector" true - "IPersistentSet" true "IPersistentCollection" true "ISeq" true "Atom" true "nil" true - # java.util interfaces + seq types ring & friends extend on - "Map" true "Set" true "List" true "Collection" true "LazySeq" true - "APersistentMap" true}) diff --git a/src/jolt/eval_runtime.janet b/src/jolt/eval_runtime.janet deleted file mode 100644 index d5980a6..0000000 --- a/src/jolt/eval_runtime.janet +++ /dev/null @@ -1,874 +0,0 @@ -# Jolt Evaluator — protocols, multimethods, deftype/reify, stateful fn install -# Extracted from evaluator.janet (jolt-oudv, phase 2a split). - -(use ./types) -(use ./phm) -(use ./phs) -(use ./lazyseq) -(use ./pv) -(use ./plist) -(use ./config) -(use ./reader) -(use ./regex) -(use ./eval_base) -(use ./eval_resolve) -(defn- canonical-host-tag - "If type-name names a host type (optionally java.*/clojure.lang.* qualified), - return its bare canonical name; else nil (it's a deftype/record name)." - [type-name] - (let [base (cond - (string/has-prefix? "java.lang." type-name) (string/slice type-name 10) - (string/has-prefix? "java.util." type-name) (string/slice type-name 10) - (string/has-prefix? "clojure.lang." type-name) (string/slice type-name 13) - type-name)] - (if (get host-type-names base) base nil))) - -(defn- value-host-tags - "Candidate host type-tags for a runtime value, most-specific first." - [obj] - (cond - (number? obj) ["Long" "Integer" "Number" "Double" "Object"] - (string? obj) ["String" "CharSequence" "Object"] - (or (= true obj) (= false obj)) ["Boolean" "Object"] - (keyword? obj) ["Keyword" "Object"] - (and (struct? obj) (= :jolt/char (get obj :jolt/type))) ["Character" "Object"] - (and (struct? obj) (= :symbol (get obj :jolt/type))) ["Symbol" "Object"] - (plist? obj) ["PersistentList" "IPersistentList" "IPersistentCollection" "ISeq" "List" "Collection" "Object"] - (lazy-seq? obj) ["LazySeq" "ISeq" "IPersistentCollection" "Collection" "Object"] - # maps: phm / plain struct / sorted / records — java.util.Map covers them - # all in ring-style extend-protocol clauses - (or (phm? obj) - (shape-rec? obj) # plain shape maps AND records — both map-like - (and (struct? obj) (nil? (get obj :jolt/type))) - (and (table? obj) (or (get obj :jolt/deftype) - (= :jolt/sorted-map (get obj :jolt/type))))) - ["PersistentHashMap" "APersistentMap" "IPersistentMap" "Map" "IPersistentCollection" "Object"] - (or (set? obj) (and (table? obj) (= :jolt/sorted-set (get obj :jolt/type)))) - ["PersistentHashSet" "IPersistentSet" "Set" "IPersistentCollection" "Object"] - (or (tuple? obj) (array? obj) (pvec? obj)) ["PersistentVector" "IPersistentVector" "IPersistentCollection" "ISeq" "Object"] - (or (function? obj) (cfunction? obj)) ["IFn" "Fn" "Object"] - (nil? obj) ["nil" "Object"] - ["Object"])) - -# --------------------------------------------------------------------------- -# Stateful primitives as ordinary fns (Stage 2 jolt-eaa). These mutate/read the -# per-ctx protocol registry, so they need ctx. They're interned into clojure.core -# as closures over ctx (install-stateful-fns!), which makes them resolve + COMPILE -# as plain :var invokes — the back end embeds the per-ctx var cell, and the closure -# captures ctx so a compiled protocol dispatcher works even when called later. -# Both the interpreter and compiled code call these same closures; there is no -# longer a special-form handler for them. proto/method/type names arrive as -# STRINGS (the defprotocol/extend-type macros pass (name sym), not the symbol). -(defn protocol-dispatch-impl [ctx proto-name method-name obj rest-args] - # an empty jolt rest arg is NIL (Clojure semantics); janet apply needs a tuple - (default rest-args []) - (def type-tag (or (record-tag obj) - (if (and (table? obj) (get obj :jolt/protocol-methods)) (get obj :jolt/deftype)))) - (if (and (table? obj) (get obj :jolt/protocol-methods)) - (let [reified-fns (get obj :jolt/protocol-methods) - f (get reified-fns (keyword method-name))] - (if f (apply f obj rest-args) - (error (string "No reified method " method-name " for " type-tag)))) - (if type-tag - (let [f (find-protocol-method ctx type-tag proto-name method-name)] - (if f (apply f obj rest-args) - (error (string "No method " method-name " in " proto-name " for " type-tag)))) - # host value: try candidate host type-tags (Long/String/Object/...), with a - # generation-guarded inline cache (same walk for every value of a host class). - (let [env (ctx :env) - reg-gen (or (get env :type-registry-gen) 0) - pc (let [c (get env :proto-dispatch-cache)] - (if (and c (= (c :gen) reg-gen)) c - (let [n @{:gen reg-gen :map @{}}] - (put env :proto-dispatch-cache n) n))) - cands (value-host-tags obj) - ckey [(first cands) proto-name method-name] - cached (get (pc :map) ckey) - found (if (nil? cached) - (let [f (do (var r nil) - (each tag cands - (when (nil? r) - (set r (find-protocol-method ctx tag proto-name method-name)))) - r)] - (put (pc :map) ckey (if f f :jolt/none)) - f) - (if (= cached :jolt/none) nil cached))] - (if found (apply found obj rest-args) - (error (string "No dispatch for " method-name " on " (type obj)))))))) - -(defn register-method-impl [ctx type-name proto-name method-name f] - # host types register under a bare canonical tag; deftype/record names stay - # namespace-qualified to the ns the (extend-)type form runs in. - (def host (canonical-host-tag type-name)) - (def type-tag (if host host (string (ctx-current-ns ctx) "." type-name))) - (register-protocol-method ctx type-tag proto-name method-name f)) - -(defn make-reified-impl [ctx methods-map & rest-args] - # methods-map is the EVALUATED {keyword fn} map (a phm when compiled, a struct/ - # table when interpreted) — the fn* literals are already fns, just store them. - # proto-names are the (short) names of every protocol the reify implements. - (def proto-names (if (and (= 1 (length rest-args)) (indexed? (in rest-args 0))) - (in rest-args 0) # wiring passed the rest tuple as one arg - rest-args)) - (def obj @{:jolt/deftype (string "reified-" (if (> (length proto-names) 0) (in proto-names 0) "")) - :jolt/protocols (tuple ;proto-names) - :jolt/protocol-methods @{}}) - (def pairs (if (phm? methods-map) - (phm-entries methods-map) - (map (fn [k] [k (get methods-map k)]) (keys methods-map)))) - (each p pairs (put (obj :jolt/protocol-methods) (in p 0) (in p 1))) - obj) - -(defn require-impl - "(require '[ns :as a :refer [...]] ...) — load + alias/refer each spec. A fn, so - the args (quoted specs) arrive evaluated. Varargs (Clojure-compatible); each spec - is a vector [ns & opts] or a bare ns symbol (treated as [ns])." - [ctx & specs] - (each spec specs - (let [s (if (pvec? spec) (pv->array spec) spec)] - (cond - (and (indexed? s) (> (length s) 0)) (eval-require ctx s) - (and (struct? s) (= :symbol (s :jolt/type))) (eval-require ctx @[s]) - (error "require expects a vector spec or a namespace symbol")))) - nil) - -(defn in-ns-impl - "(in-ns 'foo) — switch the current namespace (creating it if needed). A fn; the - quoted symbol arrives evaluated." - [ctx sym] - (def ns-name (if (and (struct? sym) (= :symbol (sym :jolt/type))) (sym :name) (string sym))) - (def the-ns-obj (ctx-find-ns ctx ns-name)) - # An ns entered in-session counts as loaded (Clojure's ns macro commutes the - # name into *loaded-libs*), so a later require/use of it must not try to load - # a file — see maybe-require-ns. Namespace objects are immutable structs, so - # the set lives on the env. - (def loaded (or (get (ctx :env) :loaded-namespaces) - (let [t @{}] (put (ctx :env) :loaded-namespaces t) t))) - (put loaded ns-name true) - (ctx-set-current-ns ctx ns-name) - the-ns-obj) - -(defn use-impl - "(use '[ns ...] ...) — refer ALL public vars of each used ns into the CURRENT ns. - A fn; quoted specs arrive evaluated. Each spec is a ns symbol or a [ns & opts] - vector (a pvec/tuple, not a Janet array — coerce, then take the head as the ns)." - [ctx & specs] - (def target-ns (ctx-find-ns ctx (ctx-current-ns ctx))) - (each s specs - (let [spec (if (pvec? s) (pv->array s) s) - ns-sym (if (indexed? spec) (in spec 0) spec) - src-name (sym-name-str ns-sym)] - (maybe-require-ns ctx src-name) - (let [source-ns (ctx-find-ns ctx src-name)] - # Refer maps the SOURCE VAR itself (the Clojure model): redefinitions in - # the source ns propagate, the :macro flag travels for free, and - # ns-refers can identify refers by the var's home :ns. - (loop [[sym v] :pairs (source-ns :mappings)] - (put (target-ns :mappings) sym v))))) - nil) - -(defn import-impl - "(import 'pkg.Class ...) — register the short class name as an alias of the fully - qualified name in the current ns. A fn; quoted class symbols arrive evaluated." - [ctx & class-specs] - (def ns (ctx-find-ns ctx (ctx-current-ns ctx))) - (defn sym-name [x] (if (and (struct? x) (= :symbol (x :jolt/type))) (x :name) (string x))) - (defn import-one [class-name &opt pkg] - (def last-dot (do (var idx -1) (var pos 0) - (while (< pos (length class-name)) - (when (= (class-name pos) 46) (set idx pos)) (++ pos)) - idx)) - (def short-name (if (>= last-dot 0) (string/slice class-name (+ last-dot 1)) class-name)) - (def pkg-name (cond pkg pkg (>= last-dot 0) (string/slice class-name 0 last-dot) nil)) - (ns-import ns short-name class-name) - # a deftype "class" lives as a ctor var in its defining jolt ns — share it - # (the JVM import makes (TextNode. ...) resolvable; this is our analog) - (when pkg-name - (when-let [src-ns (get ((ctx :env) :namespaces) pkg-name) - v (ns-find src-ns short-name)] - (put (ns :mappings) short-name v)))) - (each class-spec class-specs - (if (or (array? class-spec) (tuple? class-spec) - (and (table? class-spec) (= :jolt/pvec (class-spec :jolt/type)))) - # vector spec: [pkg Class1 Class2 ...] - (let [items (if (table? class-spec) (pv->array class-spec) class-spec) - pkg (sym-name (in items 0))] - (for i 1 (length items) - (import-one (string pkg "." (sym-name (in items i))) pkg))) - (import-one (sym-name class-spec)))) - nil) - -(defn refer-clojure-impl - "(refer-clojure :exclude [a b]) — currently only :exclude is honored: unmap the - excluded names from the current ns. A fn; quoted args arrive evaluated." - [ctx & args] - (when (and (>= (length args) 2) (= (in args 0) :exclude)) - (let [ns (ctx-find-ns ctx (ctx-current-ns ctx)) - excl (in args 1)] - (each sym excl - (ns-unmap ns (if (and (struct? sym) (= :symbol (sym :jolt/type))) (sym :name) (string sym)))))) - nil) - -# Multimethod value -> its var. methods/get-method take the multimethod VALUE -# (Clojure semantics) and recover the var (hence :jolt/methods) through this, -# which works from a compiled fn in any namespace — resolving the symbol at call -# time in the current ns did not (a bare multifn ref in its defining ns saw an -# empty table once defmethods lived in other namespaces; migratus hit this). -(def multi-registry @{}) - -(defn defmulti-setup - "(defmulti name dispatch & opts) — intern a multimethod var. A fn; name arrives - quoted, dispatch + opts (:default key, :hierarchy h) arrive evaluated. The - defmulti macro is the thin wrapper. Builds the dispatch closure over the method - table (shared with the var's :jolt/methods so defmethod adds to it)." - [ctx name-sym dispatch-raw & opts] - (def dispatch-fn (if (keyword? dispatch-raw) (fn [x] (get x dispatch-raw)) dispatch-raw)) - (def default-key - (do (var dv :default) (var i 0) - (while (< i (length opts)) - (if (= :default (in opts i)) (do (set dv (in opts (+ i 1))) (set i (length opts))) (+= i 2))) - dv)) - (def hierarchy - (do (var h nil) (var i 0) - (while (< i (length opts)) - (if (= :hierarchy (in opts i)) (do (set h (in opts (+ i 1))) (set i (length opts))) (+= i 2))) - h)) - (def ns (ctx-find-ns ctx (ctx-current-ns ctx))) - (def methods @{}) - (def isa-cache @[nil]) - (def dispatch-cache @{}) - # the prefers table, shared with the var (prefer-method-setup mutates it) - (def v-box @[nil]) - (def mm-fn - (fn [& args] - (let [dv* (apply dispatch-fn args) - dv (if (nil? dv*) :jolt/nil-sentinel dv*) - method (get methods dv)] - (if method - (apply method args) - (let [cached (get dispatch-cache dv)] - (if cached - (apply cached args) - # isa? is the OVERLAY's (the hierarchy system is pure Clojure now, - # stage 3); resolve its var lazily, once. A :hierarchy option is an - # atom (deref per dispatch, like Clojure's var) or a plain map. - (let [isa-fn (do - (when (nil? (isa-cache 0)) - (put isa-cache 0 - (var-get (ns-find (ctx-find-ns ctx "clojure.core") "isa?")))) - (isa-cache 0)) - h (if hierarchy - (if (and (table? hierarchy) (= :jolt/atom (get hierarchy :jolt/type))) - (hierarchy :value) - hierarchy) - nil) - # Collect EVERY isa-matching method key, then pick the - # dominant one: x dominates y when x is prefer-method'd - # over y (direct preference) or (isa? x y). Two matches - # with no dominant is an ambiguity ERROR, as in Clojure — - # this used to silently take whichever key the table - # yielded first, ignoring prefer-method (jolt-heo). - found (do - (def matches @[]) - (each k (keys methods) - (when (if h (isa-fn h dv k) (isa-fn dv k)) - (array/push matches k))) - (defn pref? [x y] - (def px (get (or (get v-box 0) @{}) x)) - (and px (not (nil? (get px y))))) - (defn dom? [x y] - (or (pref? x y) (if h (isa-fn h x y) (isa-fn x y)))) - (case (length matches) - 0 nil - 1 (get methods (in matches 0)) - (do - (var best (in matches 0)) - (var i 1) - (while (< i (length matches)) - (when (dom? (in matches i) best) (set best (in matches i))) - (++ i)) - (var amb nil) - (each k matches - (when (and (nil? amb) (not (deep= k best)) (not (dom? best k))) - (set amb k))) - (when amb - (error (string "Multiple methods in multimethod '" (name-sym :name) - "' match dispatch value — neither is preferred"))) - (get methods best))))] - (if found - (do (put dispatch-cache dv found) (apply found args)) - (let [dm (get methods default-key)] - (if dm (apply dm args) - (error (string "No method in multimethod " (name-sym :name) - " for dispatch value: " dv)))))))))))) - (def v (ns-intern ns (name-sym :name) mm-fn)) - # pre-create the prefers store so the dispatch closure and - # prefer-method-setup share one table - (def prefs-tbl (or (get v :jolt/prefers) - (do (put v :jolt/prefers @{}) (get v :jolt/prefers)))) - (put v-box 0 prefs-tbl) - (put v :jolt/methods methods) - (put v :jolt/dispatch-cache dispatch-cache) - (put v :jolt/default default-key) - (when hierarchy (put v :jolt/hierarchy hierarchy)) - (put multi-registry mm-fn v) - (var-get v)) - -(defn defmethod-setup - "(defmethod mm dispatch-val impl) — add a method to a multimethod. A fn; mm - arrives quoted, dispatch-val evaluated, impl is the COMPILED method fn (the - defmethod macro builds (fn …)). Auto-creates the multimethod if it's missing." - [ctx mm-sym dispatch-val impl] - (def mm-var - (or (resolve-var ctx @{} mm-sym) - (let [ns (ctx-find-ns ctx (ctx-current-ns ctx)) - stub (fn [& args] nil)] - (def v (ns-intern ns (mm-sym :name) stub)) - (put v :jolt/methods @{}) - (put multi-registry stub v) - v))) - (def methods (or (get mm-var :jolt/methods) (let [m @{}] (put mm-var :jolt/methods m) m))) - # nil is a legal dispatch value (ring's body-string keys a method on it); - # janet tables can't hold nil keys, so it rides the sentinel - (put methods (if (nil? dispatch-val) :jolt/nil-sentinel dispatch-val) impl) - (let [dc (get mm-var :jolt/dispatch-cache)] - (when dc (each k (keys dc) (put dc k nil)))) - mm-var) - -(defn- hint-cross-ns-key - "Resolve a record-typed field hint (\"Vec3\", \"v/Vec3\", \"rt.vec/Vec3\") to the - home namespace's ctor key (\"rt.vec/->Vec3\") when the type is defined in a - DIFFERENT namespace and referred/aliased into the one being defined. The local - current-ns/->Type lookup misses those; this resolves the hint name through the - ns's :refer/:as bindings to the type var, then maps its root ctor value back to - the home key via the ctor-value index. Using the ctor VALUE, not the var's :ns, - is what makes :refer work — a :refer re-interns a fresh var whose :ns is the - referring ns, but its root is the same shared ctor closure. nil if unresolved." - [ctx t cix] - # Resolve against the COMPILE ns (the user ns being analyzed), not ctx-current-ns - # — during compilation the analyzer rebinds ctx-current-ns to jolt.analyzer, so a - # bare referred name would otherwise miss. Qualified alias/Name resolves the alias - # against the compile ns; a bare name looks up the compile ns's own mappings - # (which include :refer-interned vars). - (def cur-name (or (get (ctx :env) :compile-ns) (ctx-current-ns ctx))) - (def cur-ns (ctx-find-ns ctx cur-name)) - (def slash (string/find "/" t)) - (def v (when cur-ns - (if slash - (let [a (string/slice t 0 slash) nm (string/slice t (inc slash)) - home (or (ns-alias-lookup cur-ns a) (ns-import-lookup cur-ns a))] - (when home (ns-find (ctx-find-ns ctx home) nm))) - (ns-find cur-ns t)))) - (when (and v (table? v)) (get cix (v :root)))) - -(defn record-hint-ctor-key - "Resolve a record-type hint NAME (as written on a ^Type field/param — bare, - aliased, or fully qualified) to its home ctor key in the record-shapes registry - (\"rt.vec/->Vec3\"), or nil if it is not a known record type. Local - current-ns/->Name wins; otherwise cross-ns via the ctor-value index. Public so - the analyzer (through jolt.host) can type a ^Type PARAM hint exactly as a field - hint resolves, which is what carries a record param's type across a namespace - boundary without whole-program inference." - [ctx name] - (def rs (get (ctx :env) :record-shapes)) - (when rs - (def cur (or (get (ctx :env) :compile-ns) (ctx-current-ns ctx))) - (def local (string cur "/->" name)) - (if (get rs local) - local - (let [cix (get (ctx :env) :record-ctor-index)] - (when cix (hint-cross-ns-key ctx name cix)))))) - -(defn make-deftype-ctor-impl - "Build a deftype constructor closure. The ns-qualified type tag is baked at - definition time (this runs during the deftype's (def …), in the type's ns), so - instances carry a stable tag matching what extend-type registers methods under. - field-kws is the [:f1 :f2 …] keyword vector; the ctor maps positional args to - those keys. A ctx-capturing closure (make-deftype-ctor) is the public handle." - [ctx type-name-sym field-kws &opt field-tags field-muts] - (def type-tag (string (ctx-current-ns ctx) "." (type-name-sym :name))) - (def kws (d-realize field-kws)) - # per-field type hints (jolt-3ko): a tuple parallel to kws — "Vec3" (a record - # type name), "num", or nil. The inference resolves these to the field's exact - # type so reading a field back carries it (a nested record stays typed). - (def tags (if field-tags (d-realize field-tags) (array/new-filled (length kws)))) - # jolt-c3q: a type with any ^:unsynchronized-mutable / ^:volatile-mutable field - # is set!-able, so it CAN'T be an immutable shape-rec tuple. Such a type uses - # the mutable :jolt/deftype table form regardless of :shapes? (set! mutates it, - # field reads route through the tagged-table path), and is NOT registered as a - # shape so the inference never emits a bare-index read against the table. - (def mutable? (and field-muts (some |(identity $) (d-realize field-muts)))) - # The ctor closure itself. Built FIRST so it can be indexed by value below. - # Records are shape-recs when shapes are active (:shapes? = direct-link, where - # the inference proves the reads) — the whole field-access pipeline handles - # them; otherwise (or when mutable) the original :jolt/deftype tables. Read at - # ctor-BUILD time so a type is consistently one representation or the other. - (def the-ctor - (if (and (get (ctx :env) :shapes?) (not mutable?)) - (fn [& args] (make-record type-tag kws args)) - (fn [& args] - (var inst @{:jolt/deftype type-tag}) - (var i 0) (each kw kws (put inst kw (in args i)) (++ i)) - inst))) - # jolt-t34: register this record's ctor return shape (DECLARED field order) so - # the inference types (->Name ...) as a struct of these fields and field reads - # on the result bare-index. Keyed by the ctor var-key "ns/->Name" to match how - # the IR names the call head. Harmless when records aren't shaped (sidx gated). - # Skipped for mutable types — they're tables, not shape-recs (jolt-c3q). - (unless mutable? - (let [rs (or (get (ctx :env) :record-shapes) - (let [t @{}] (put (ctx :env) :record-shapes t) t)) - # ctor-value index: maps each ctor closure to its rs key, so a ^Type hint - # in another namespace can resolve home through the type var's root value - # (jolt-3ko cross-ns hints; see hint-cross-ns-key). - cix (or (get (ctx :env) :record-ctor-index) - (let [t @{}] (put (ctx :env) :record-ctor-index t) t)) - # resolve a record-typed hint ("Vec3") to its ctor-key ("ns/->Vec3") so - # the inference resolves it with a direct lookup. "num" stays as-is; a - # local def wins; else try cross-ns resolution; an unresolved name (not a - # known record type) stays bare -> :any. - resolved (map (fn [t] - (cond (nil? t) nil - (= t "num") "num" - (let [ck (string (ctx-current-ns ctx) "/->" t)] - (if (get rs ck) ck - (or (hint-cross-ns-key ctx t cix) t))))) - tags)] - (put rs (string (ctx-current-ns ctx) "/->" (type-name-sym :name)) - {:fields (tuple ;kws) :type type-tag :tags (tuple ;resolved)}) - (put cix the-ctor (string (ctx-current-ns ctx) "/->" (type-name-sym :name))))) - the-ctor) - -(defn install-stateful-fns! - "Intern ctx-capturing closures for the stateful primitives into clojure.core, so - both the interpreter and the compiler reach them as ordinary fns. Called by - api/init after init-core! and before the overlay loads (the protocol macros - expand to calls of these)." - [ctx] - (def core (ctx-find-ns ctx "clojure.core")) - # current-ns get/set for compiled code (emit-try restores the ns on a caught - # throw — an interpreted fn that throws leaves ctx-current-ns set to its - # defining ns, since it can't restore on unwind; the interpreted try already - # repairs this, the compiled try did not, leaking the ns past a catch). - (ns-intern core "__current-ns" (fn [] (ctx-current-ns ctx))) - (ns-intern core "__set-current-ns!" (fn [ns-sym] (ctx-set-current-ns ctx ns-sym) nil)) - (ns-intern core "protocol-dispatch" - (fn [proto-name method-name obj rest-args] - (protocol-dispatch-impl ctx proto-name method-name obj rest-args))) - # Devirtualization registry (jolt-41m): defprotocol calls this at load so the - # inference can recognize a protocol-method call site. Maps the method's - # var-key "ns/method" -> [proto-name method-name]. - (ns-intern core "register-protocol-methods!" - (fn [proto-name method-names] - (def reg (or (get (ctx :env) :protocol-methods) - (let [t @{}] (put (ctx :env) :protocol-methods t) t))) - (def ns (ctx-current-ns ctx)) - (each m (d-realize method-names) (put reg (string ns "/" m) (tuple proto-name m))) - nil)) - (ns-intern core "extenders" - (fn [proto] - # All type-tags whose registry entry implements this protocol, as symbols - # (closest analog to Clojure's class list); nil when none. - (let [pname (get (get proto :name) :name) - registry (get (ctx :env) :type-registry) - out @[]] - (each tag (keys registry) - (when (get (get registry tag) pname) - (array/push out {:jolt/type :symbol :ns nil :name tag}))) - (if (empty? out) nil (tuple ;out))))) - (ns-intern core "register-method" - (fn [type-name proto-name method-name f] - (register-method-impl ctx type-name proto-name method-name f))) - (ns-intern core "make-reified" - (fn [methods-map & proto-names] (make-reified-impl ctx methods-map proto-names))) - # Host-class shim registration, exposed to Clojure so a library can mirror a - # Java class jolt doesn't ship (e.g. reitit.Trie). __register-class-statics! - # makes (Class/method ...) resolve; __register-class-methods! makes (.method - # tagged-value ...) dispatch; __register-class-ctor! makes (Class. ...) build. - # Reader-conditional feature toggle, exposed to Clojure so a namespace can - # load a clj-targeted library (e.g. reitit, under :clj) WITHOUT forcing the - # whole process to :clj — set features, require the lib, restore. Returns the - # previous feature set (a list of name strings) for restoration. - (ns-intern core "__reader-features" - (fn [] (tuple ;(map (fn [k] (string k)) (keys reader-features))))) - (ns-intern core "__reader-features-set!" - (fn [names] - # names arrives as a jolt vector (pvec) or list — coerce to a janet array - (def arr (cond (pvec? names) (pv->array names) - (or (tuple? names) (array? names)) names - @[names])) - (reader-features-set! (map (fn [n] (if (keyword? n) n (string n))) arr)) - nil)) - (ns-intern core "__register-class-statics!" - (fn [nm tbl] (register-class-statics! nm tbl) nil)) - (ns-intern core "__register-class-methods!" - (fn [tag tbl] (register-tagged-methods! tag tbl) nil)) - (ns-intern core "__register-class-ctor!" - (fn [nm f] (register-class-ctor! nm f) (ns-intern core nm (class-value-for nm)) nil)) - (ns-intern core "require" (fn [& specs] (require-impl ctx ;specs))) - (ns-intern core "in-ns" (fn [sym] (in-ns-impl ctx sym))) - (ns-intern core "use" (fn [& specs] (use-impl ctx ;specs))) - (ns-intern core "import" (fn [& specs] (import-impl ctx ;specs))) - (ns-intern core "refer-clojure" (fn [& args] (refer-clojure-impl ctx ;args))) - (ns-intern core "defmulti-setup" (fn [name-sym dispatch & opts] (defmulti-setup ctx name-sym dispatch ;opts))) - (ns-intern core "defmethod-setup" (fn [mm-sym dval impl] (defmethod-setup ctx mm-sym dval impl))) - (ns-intern core "make-deftype-ctor" (fn [name-sym field-kws &opt field-tags field-muts] (make-deftype-ctor-impl ctx name-sym field-kws field-tags field-muts))) - # Var/namespace lookups that need the ctx (the rest of the var fns — var-get/ - # var-set/var?/alter-var-root/alter-meta!/reset-meta! — are plain core-bindings). - (ns-intern core "find-var" (fn [sym] (find-var ctx sym))) - # *ns*: the current-namespace dynamic var. Its root is kept in sync by - # ctx-set-current-ns via the cached var table (env :ns-var); a thread - # binding (binding [*ns* ...]) shadows the root through var-get as usual. - (def ns-var (ns-intern core "*ns*" (ctx-find-ns ctx (ctx-current-ns ctx)))) - (put ns-var :dynamic true) - (put (ctx :env) :ns-var ns-var) - (ns-intern core "intern" - (fn [ns-name sym-name &opt val] - (def ns (ctx-find-ns ctx (if (struct? ns-name) (ns-name :name) ns-name))) - (ns-intern ns (if (struct? sym-name) (sym-name :name) sym-name) val))) - # --- ns introspection (Stage 2 tier 6b) — evaluated-arg Clojure semantics. - # A namespace designator is an ns object (passes through) or a symbol/string - # naming one. find-ns is a pure lookup (nil when absent); create-ns creates - # (ctx-find-ns is create-on-demand). The optional-arg forms default to the - # current ns, preserving the prior 0-arg interpreter behavior. - (def ns-name-of (fn [x] - (cond - (and (struct? x) (= :symbol (x :jolt/type))) (x :name) - (string? x) x - (keyword? x) (string x) - nil))) - (def ns-of (fn [x] - (if (= :jolt/namespace (get x :jolt/type)) - x - (let [nm (ns-name-of x)] - (if nm (get (get (ctx :env) :namespaces) nm) nil))))) - (def ns-or-current (fn [x] - (if (nil? x) - (ctx-find-ns ctx (ctx-current-ns ctx)) - (or (ns-of x) (error (string "No namespace: " (ns-name-of x))))))) - (ns-intern core "find-ns" (fn [x] (ns-of x))) - (ns-intern core "create-ns" (fn [x] (ctx-find-ns ctx (ns-name-of x)))) - (ns-intern core "remove-ns" (fn [x] (remove-ns ctx (ns-name-of x)))) - (ns-intern core "all-ns" (fn [] (all-ns ctx))) - (ns-intern core "the-ns" (fn [&opt x] (ns-or-current x))) - # interns/imports return a jolt MAP (struct), not the live host table — so - # count/seq/keys work on them, and callers can't mutate the ns through them. - (ns-intern core "ns-interns" (fn [&opt x] (table/to-struct ((ns-or-current x) :mappings)))) - # {alias-symbol -> namespace object}, Clojure's shape, from the string store. - (ns-intern core "ns-aliases" - (fn [&opt x] - (def ns (ns-or-current x)) - (def out @{}) - (eachp [a target] (ns :aliases) - (put out {:jolt/type :symbol :ns nil :name a} (ctx-find-ns ctx target))) - (table/to-struct out))) - (ns-intern core "ns-imports" (fn [&opt x] (table/to-struct ((ns-or-current x) :imports)))) - # (ns-resolve ns sym) -> the var or nil. Unqualified syms look in ns's own - # mappings; ns-qualified syms resolve through ns's aliases. (types/ns-resolve - # keys ns-find with the symbol struct instead of its name string, so it never - # finds anything — do the lookup here.) - (ns-intern core "ns-resolve" - (fn [ns-d sym] - (def ns (ns-or-current ns-d)) - (def nm (if (struct? sym) (sym :name) (string sym))) - (def nsp (if (struct? sym) (sym :ns) nil)) - (if nsp - (let [target (or (ns-alias-lookup ns nsp) nsp) - target-ns (ctx-find-ns ctx target)] - (when target-ns (ns-find target-ns nm))) - (ns-find ns nm)))) - (ns-intern core "resolve" - (fn [sym] - (when (and (struct? sym) (= :symbol (sym :jolt/type))) - (def r (protect (resolve-var ctx @{} sym))) - (if (r 0) (r 1) nil)))) - # refer: bring another ns's public vars into the current ns. Reuses use-impl's - # refer-all behavior; the :only/:exclude/:rename filters are not yet honored. - (ns-intern core "refer" (fn [ns-sym & filters] (use-impl ctx ns-sym))) - # --- dispatch-table / type fns (Stage 2 tier 6c) ------------------------ - # A multimethod's method table lives on its VAR (the value is the dispatch - # closure), so the overlay macros pass the NAME quoted — the defmulti/ - # defmethod pattern — and these resolve the var. prefer-method auto-creates - # a missing multimethod (matching the prior interpreter arm). - (def mm-var-of (fn [mm-sym auto-create?] - (def r (protect (resolve-var ctx @{} mm-sym))) - (def found (if (r 0) (r 1) nil)) - (if found - found - (when auto-create? - (def ns (ctx-find-ns ctx (ctx-current-ns ctx))) - (def stub (fn [& args] nil)) - (def nv (ns-intern ns (mm-sym :name) stub)) - (put nv :jolt/methods @{}) - (put multi-registry stub nv) - nv)))) - (def clear-dispatch-cache! (fn [mm-var] - (let [dc (get mm-var :jolt/dispatch-cache)] - (when dc (each k (keys dc) (put dc k nil)))))) - (ns-intern core "prefer-method-setup" - (fn [mm-sym dval-a dval-b] - (def mm-var (mm-var-of mm-sym true)) - (def prefs (or (get mm-var :jolt/prefers) - (do (put mm-var :jolt/prefers @{}) (mm-var :jolt/prefers)))) - # {x -> {y true ...}}: x is preferred over each y (Clojure's {x #{y}}) - (def sub (or (get prefs dval-a) - (do (put prefs dval-a @{}) (get prefs dval-a)))) - (put sub dval-b true) - (clear-dispatch-cache! mm-var) - mm-var)) - (ns-intern core "remove-method-setup" - (fn [mm-sym dval] - (def dval (if (nil? dval) :jolt/nil-sentinel dval)) - (def mm-var (mm-var-of mm-sym false)) - (when mm-var - (let [methods (get mm-var :jolt/methods)] - (when methods (put methods dval nil))) - (clear-dispatch-cache! mm-var)) - mm-var)) - (ns-intern core "remove-all-methods-setup" - (fn [mm-sym] - (def mm-var (mm-var-of mm-sym false)) - (when mm-var - # clear IN PLACE: the dispatch closure captured this table at defmulti - # time, so swapping in a fresh one leaves dispatch seeing stale methods - (let [methods (get mm-var :jolt/methods)] - (when methods (each k (keys methods) (put methods k nil)))) - (clear-dispatch-cache! mm-var)) - mm-var)) - (ns-intern core "prefers-setup" - (fn [mm-sym] - (def mm-var (mm-var-of mm-sym false)) - (or (and mm-var (get mm-var :jolt/prefers)) {}))) - # methods/get-method receive the multimethod VALUE (Clojure semantics): map it - # back to its var via multi-registry. A symbol arg still works (mm-var-of), for - # any caller that passes one. - (def mm-var-of-val (fn [mm] - (if (function? mm) (get multi-registry mm) (mm-var-of mm false)))) - (ns-intern core "get-method-setup" - (fn [mm dval] - (def dval (if (nil? dval) :jolt/nil-sentinel dval)) - (def mm-var (mm-var-of-val mm)) - (when mm-var - (let [methods (get mm-var :jolt/methods)] - (or (get methods dval) (get methods :default)))))) - (ns-intern core "methods-setup" - (fn [mm] - (def mm-var (mm-var-of-val mm)) - (when mm-var - # a jolt map, not the live host table (and phm so vector dispatch - # values look up by value, same reason build-eval-map promotes) - (var m (make-phm)) - (let [tbl (get mm-var :jolt/methods)] - (when tbl (each k (keys tbl) (set m (phm-assoc m k (get tbl k)))))) - m))) - # satisfies?: evaluated protocol value + instance. Recognizes a reify the same - # way instance? does — by the protocols it records on itself (a reify's methods - # are instance-local, so they aren't in the global type registry that - # type-satisfies? consults). - (ns-intern core "satisfies?" - (fn [proto obj] - (def pn (proto :name)) - (def pn-str (if (struct? pn) (pn :name) pn)) - (def protos (if (table? obj) (get obj :jolt/protocols))) - (def type-tag (or (record-tag obj) - (if (and (table? obj) (get obj :jolt/protocol-methods)) - (get obj :jolt/deftype)))) - (cond - (and protos (string? pn-str) - (truthy? (some (fn [p] (= (last (string/split "." p)) - (last (string/split "." pn-str)))) - protos))) true - type-tag (type-satisfies? ctx type-tag pn-str) - false))) - # instance?: the overlay macro passes the TYPE NAME quoted (class names don't - # evaluate to values on jolt); the value arg arrives evaluated. - # Generic hook so an external host-shim library (e.g. jolt-lang/http-client) - # can teach instance? about its own shim types without editing core. Each hook - # is (fn [class-name val] -> truthy|nil); consulted when no built-in matches. - (var instance-check-hooks @[]) - (ns-intern core "__register-instance-check!" - (fn [f] (array/push instance-check-hooks f) nil)) - (ns-intern core "instance-check" - (fn [type-sym val] - (if (record-tag val) - (let [type-tag (record-tag val) - type-name (type-sym :name)] - (or (= type-tag type-name) - (and (> (length type-tag) (length type-name)) - (= (string/slice type-tag (- (length type-tag) (length type-name))) - type-name)) - # instance? of a PROTOCOL works like satisfies?: a reify implementing - # it is an instance. The reify records every protocol it implements - # (short names); (instance? a.b.Proto x) passes a qualified name, so - # match by short name against any of them. (malli relies on this.) - (let [protos (if (table? val) (get val :jolt/protocols)) - tn-short (last (string/split "." type-name))] - (and protos (truthy? (some (fn [p] (= (last (string/split "." p)) tn-short)) protos)))))) - (match (type-sym :name) - "Number" (number? val) - "java.lang.Number" (number? val) - "Long" (number? val) - "java.lang.Long" (number? val) - "Integer" (number? val) - "Double" (number? val) - "String" (string? val) - "java.lang.String" (string? val) - # String implements CharSequence — malli's :re validator gates on - # (instance? CharSequence x) before matching (jolt-ltwk). - "CharSequence" (string? val) - "java.lang.CharSequence" (string? val) - "Boolean" (or (= true val) (= false val)) - "Keyword" (keyword? val) - # regex patterns (cuerdas-style (instance? Pattern x) checks) - "Pattern" (and (table? val) (= :jolt/regex (val :jolt/type))) - "java.util.regex.Pattern" (and (table? val) (= :jolt/regex (val :jolt/type))) - "Character" (and (struct? val) (= :jolt/char (get val :jolt/type))) - "java.lang.Character" (and (struct? val) (= :jolt/char (get val :jolt/type))) - # java.time shims (host_interop.janet); #inst IS java.util.Date in Clojure - "java.util.Date" (and (struct? val) (= :jolt/inst (get val :jolt/type))) - "Date" (and (struct? val) (= :jolt/inst (get val :jolt/type))) - "Instant" (and (table? val) (= :jolt/instant (get val :jolt/type))) - "java.time.Instant" (and (table? val) (= :jolt/instant (get val :jolt/type))) - "LocalDateTime" (and (table? val) (= :jolt/local-dt (get val :jolt/type))) - "java.time.LocalDateTime" (and (table? val) (= :jolt/local-dt (get val :jolt/type))) - "ZonedDateTime" (and (table? val) (= :jolt/zoned-dt (get val :jolt/type))) - "java.time.ZonedDateTime" (and (table? val) (= :jolt/zoned-dt (get val :jolt/type))) - "LocalTime" false - "LocalDate" false - "java.sql.Time" false - "java.sql.Timestamp" false - "java.sql.Date" false - "DateTimeFormatter" (and (table? val) (= :jolt/dt-formatter (get val :jolt/type))) - "URL" (and (table? val) (= :jolt/url (get val :jolt/type))) - "java.net.URL" (and (table? val) (= :jolt/url (get val :jolt/type))) - # next.jdbc host shim: a wrapped jdbc.core connection (core.janet). - # migratus's do-commands only runs SQL through its (instance? Connection) - # branch, so the wrapped conn must answer true here. - "Connection" (and (table? val) (= :jolt/jdbc-conn (get val :jolt/type))) - "java.sql.Connection" (and (table? val) (= :jolt/jdbc-conn (get val :jolt/type))) - # java.io.File model (jolt-hjw): io/file and (File. …) build :jolt/file, - # so migratus's (instance? File migration-dir) takes the filesystem path. - "File" (and (table? val) (= :jolt/file (get val :jolt/type))) - "java.io.File" (and (table? val) (= :jolt/file (get val :jolt/type))) - # JVM char[] class — (Class/forName "[C"); jolt char arrays are Janet - # arrays of char structs - "[C" (and (array? val) - (or (= 0 (length val)) - (and (struct? (val 0)) (= :jolt/char ((val 0) :jolt/type))))) - "clojure.lang.Atom" (and (table? val) (= :jolt/atom (val :jolt/type))) - "clojure.lang.Volatile" (and (table? val) (= :jolt/volatile (val :jolt/type))) - "clojure.lang.Delay" (and (table? val) (= :jolt/delay (val :jolt/type))) - "clojure.lang.IPersistentMap" (or (phm? val) (struct? val)) - "clojure.lang.IPersistentVector" (or (tuple? val) (pvec? val)) - "clojure.lang.IPersistentSet" (set? val) - "Object" true - # no built-in match — consult library-registered instance? hooks - (do (var r false) - (each h instance-check-hooks - (when (h (type-sym :name) val) (set r true) (break))) - r))))) - # Reader / expansion as plain fns: read-string parses one form; macroexpand-1 - # expands a (quoted, already-evaluated) call form once via its macro var. - (ns-intern core "read-string" (fn [s] (parse-string s))) - # Strip the interpreter's {:jolt/type :jolt/exception :value v} throw envelope. - # Compiled catch uses this so a caught value matches what the interpreter binds - # (interpreted throw wraps; compiled throw raises raw) — keeps (class e) / - # ex-message / catch consistent across the compiled⇄interpreted boundary. - (ns-intern core "__unwrap-ex" - (fn [e] (if (and (or (table? e) (struct? e)) (= :jolt/exception (get e :jolt/type))) - (get e :value) e))) - # The *in* reader family's host seams. __stdin-read-line: one line from real - # stdin, newline stripped, nil at EOF. __parse-next: one form off a string -> - # [form rest-of-string], nil when only whitespace remains. *in*, read-line, - # read, with-in-str, and line-seq are Clojure over these (core/50-io.clj). - # The loader's registered source roots (the closest thing to a classpath) — - # io/resource searches these for relative resource paths. - # registered constructor shims: the NAME evaluates to the canonical class - # string (so class-dispatch defmultis match); `new` finds the ctor fn. - (eachp [nm f] class-ctors (ns-intern core nm (class-value-for nm))) - # dispatch-only type names (no ctor): InputStream, File, ISeq, ... - (eachp [nm canon] class-canonical-names - (unless (or (in class-ctors nm) (ns-find core nm)) - (ns-intern core nm canon))) - (ns-intern core "__source-roots" - (fn [] (tuple ;(get (ctx :env) :source-paths)))) - (ns-intern core "__stdin-read-line" - (fn [] - (let [l (file/read stdin :line)] - (if (nil? l) nil - (let [s (string l)] - (if (string/has-suffix? "\n" s) (string/slice s 0 -2) s)))))) - (ns-intern core "__parse-next" - (fn [s] - (if (= 0 (length (string/trim s))) nil - (let [r (parse-next s)] (tuple (r 0) (r 1)))))) - (def expand-1 (fn [the-form] - (if (and (array? the-form) (> (length the-form) 0) - (struct? (first the-form)) (= :symbol ((first the-form) :jolt/type))) - (let [v (resolve-var ctx @{} (first the-form))] - (if (and v (var-macro? v)) - (apply (var-get v) (tuple/slice the-form 1)) - the-form)) - the-form))) - (ns-intern core "macroexpand-1" expand-1) - # Apply a registered data reader to an already-read form (EDN built-in tags - # #uuid/#inst and any registered reader). Throws on an unknown tag. - (ns-intern core "__read-tagged" - (fn [tag form] - (def data-readers (get (ctx :env) :data-readers)) - (def reader-fn (if data-readers (get data-readers tag))) - (if reader-fn - (reader-fn form) - (error (string "No reader function for tag " tag))))) - # macroexpand: expand repeatedly until the head is no longer a macro (the - # form's SUBFORMS are not expanded, matching Clojure). - (ns-intern core "macroexpand" - (fn [the-form] - (var cur the-form) - (var nxt (expand-1 cur)) - (while (not= cur nxt) (set cur nxt) (set nxt (expand-1 cur))) - cur)) - # alias bookkeeping is UNIFIED (jolt-ark): :aliases (alias-name string -> - # ns-name string) is the one store, read by resolution and ns-aliases; - # :imports holds class imports only. - (ns-intern core "alias" - (fn [alias-sym ns-sym] - (def cur (ctx-find-ns ctx (ctx-current-ns ctx))) - (ns-add-alias cur (alias-sym :name) (ns-sym :name)) - nil)) - (ns-intern core "ns-unalias" - (fn [ns-d alias-sym] - (def ns (ns-or-current ns-d)) - (put (ns :aliases) (alias-sym :name) nil) - nil)) - # ns-publics: {symbol -> var} (jolt has no private vars, so publics = interns). - # Keys are symbol structs (value-hashed), matching Clojure's symbol keys. - (def mappings->symbol-map (fn [ns pred] - (var m (make-phm)) - (loop [[nm v] :pairs (ns :mappings)] - (when (pred nm v) - (set m (phm-assoc m {:jolt/type :symbol :ns nil :name nm} v)))) - m)) - (ns-intern core "ns-publics" - (fn [&opt ns-d] - (mappings->symbol-map (ns-or-current ns-d) (fn [nm v] true)))) - # ns-map: all mappings (interns + refers; jolt has no class imports in maps). - (ns-intern core "ns-map" - (fn [&opt ns-d] - (mappings->symbol-map (ns-or-current ns-d) (fn [nm v] true)))) - # ns-refers: mappings whose var's HOME ns differs from this ns (copied in by - # refer/use/require :refer). - (ns-intern core "ns-refers" - (fn [&opt ns-d] - (def ns (ns-or-current ns-d)) - (def my-name (ns :name)) - (mappings->symbol-map ns (fn [nm v] - (and (table? v) (not= (get v :ns) my-name)))))) - (ns-intern core "ns-unmap" - (fn [ns-d sym] - (def ns (ns-or-current ns-d)) - (put (ns :mappings) (if (struct? sym) (sym :name) (string sym)) nil) - nil)) - core) - -# Dispatch a special form by its string name. diff --git a/src/jolt/eval_special.janet b/src/jolt/eval_special.janet deleted file mode 100644 index 2ce291c..0000000 --- a/src/jolt/eval_special.janet +++ /dev/null @@ -1,780 +0,0 @@ -# Jolt Evaluator — special forms (eval-list dispatch) -# Extracted from evaluator.janet (jolt-oudv, phase 2a split). - -(use ./types) -(use ./phm) -(use ./phs) -(use ./lazyseq) -(use ./pv) -(use ./plist) -(use ./config) -(use ./reader) -(use ./regex) -(use ./eval_base) -(use ./eval_resolve) -(use ./eval_runtime) -(defn- unwrap-meta-name - "Recursively unwrap (with-meta sym meta) forms to extract the underlying symbol. - Returns the symbol struct, or the original form if it's not a with-meta wrapper." - [form] - (if (and (array? form) (> (length form) 0) - (struct? (in form 0)) - (= :symbol ((in form 0) :jolt/type)) - (= "with-meta" ((in form 0) :name))) - (unwrap-meta-name (in form 1)) - form)) - - -# --- special-form handlers (exploded from eval-list, jolt-oudv) --- -(defn eval-do [ctx bindings form] - (do - (var result nil) - (var i 1) - (let [len (length form)] - (while (< i len) - (set result (eval-form ctx bindings (in form i))) - (++ i))) - result)) - -(defn eval-if [ctx bindings form] - (do - # 2 or 3 argument forms only (spec 03-special-forms X1) - (when (or (< (length form) 3) (> (length form) 4)) - (error (string "Wrong number of args (" (dec (length form)) ") passed to: if"))) - (let [test-val (eval-form ctx bindings (in form 1))] - (if (and (not (nil? test-val)) (not (= false test-val))) - (eval-form ctx bindings (in form 2)) - (if (> (length form) 3) (eval-form ctx bindings (in form 3)) nil))))) - -(defn eval-def [ctx bindings form] - (let [raw-name (in form 1) - name-sym (unwrap-meta-name raw-name) - # Metadata on the name: keyword/type-hint metadata rides on the - # symbol (:meta); a ^{:map} reads as a with-meta form we evaluate. - sym-meta (or (and (struct? name-sym) (get name-sym :meta)) {}) - wm-meta (if (and (array? raw-name) (> (length raw-name) 0) - (sym-name? (first raw-name) "with-meta")) - (let [mv (protect (eval-form ctx bindings (last raw-name)))] - (if (and (mv 0) (or (table? (mv 1)) (struct? (mv 1)))) (mv 1) {})) - {}) - name-meta (merge wm-meta sym-meta) - dynamic? (truthy? (get name-meta :dynamic)) - ns-name (ctx-current-ns ctx) - ns (ctx-find-ns ctx ns-name) - # Create var first (unbound) so self-referencing defs resolve - v (ns-intern ns (name-sym :name))] - # (def name) with no init interns the var and leaves any existing - # root binding alone (Clojure semantics — this is what declare - # expands to, so compiled forward refs bind to the var instead of - # falling through to a like-named host builtin). - (if (= 2 (length form)) - (do - (when (not (empty? name-meta)) - (put v :meta (merge (or (get v :meta) {}) name-meta))) - (when dynamic? (put v :dynamic true)) - v) - (let [# (def name docstring value): docstring form 2, value form 3 - has-doc (and (> (length form) 3) (string? (in form 2))) - val-form (in form (if has-doc 3 2)) - val (eval-form ctx bindings val-form)] - (bind-root v val) - # Staged bootstrap (jolt-4j3): pre/at-kernel overlay defns load - # interpreted; stash the fn source so backend/recompile-defns! can - # compile them once the analyzer is alive — the defn analog of - # :macro-src. Only set while api/load-core-overlay! loads the early - # tiers (the flag scopes it away from user code). - (when (and (get (ctx :env) :stash-defn-src?) - (function? val) - (array? val-form) (> (length val-form) 0) - (or (sym-name? (first val-form) "fn") - (sym-name? (first val-form) "fn*"))) - (put v :defn-src val-form)) - (let [extra (if has-doc (merge name-meta {:doc (in form 2)}) name-meta)] - (when (not (empty? extra)) - (put v :meta (merge (or (get v :meta) {}) extra)))) - (when dynamic? - (put v :dynamic true)) - # def returns the var (Clojure semantics); REPL prints #'ns/name - v)))) - -(defn eval-defmacro [ctx bindings form] - (let [# ^{:map} metadata on the name reads as a (with-meta sym …) - # form (jolt-8w2); unwrap to the bare symbol like def does. - name-sym (unwrap-meta-name (in form 1)) - after-name (tuple/slice form 2) - # Skip an optional leading docstring (string) then an optional - # attr-map (a struct that is not a symbol — a map literal reads - # as a struct), matching defn. Real macros use both, e.g. - # (defmacro info "doc" {:arglists '(...)} [& args] …). - a1 (if (and (> (length after-name) 0) (string? (first after-name))) - (tuple/slice after-name 1) after-name) - after-meta (if (and (> (length a1) 0) - (struct? (first a1)) - (not= :symbol (get (first a1) :jolt/type))) - (tuple/slice a1 1) a1) - # What remains is either a params VECTOR (tuple) + body, or one - # or more arity CLAUSES (each a list, i.e. a janet array). Build - # a uniform arity list [{:params … :body …} …]. - multi? (and (> (length after-meta) 0) (array? (first after-meta))) - arities (if multi? - (map (fn [cl] {:params (first cl) :body (tuple/slice cl 1)}) - after-meta) - @[{:params (first after-meta) :body (tuple/slice after-meta 1)}]) - defining-ns (ctx-current-ns ctx)] - (def interp-fn (fn [& macro-args] - (def n (length macro-args)) - # Pick the arity: an exact fixed-count match wins; otherwise the - # first variadic arity that accepts n args (Clojure fn dispatch). - (var chosen nil) - (each ar arities - (def pi (parse-params (ar :params))) - (when (and (nil? chosen) (not (pi :rest)) (= n (length (pi :fixed)))) - (set chosen [pi (ar :body)]))) - (when (nil? chosen) - (each ar arities - (def pi (parse-params (ar :params))) - (when (and (nil? chosen) (pi :rest) (>= n (length (pi :fixed)))) - (set chosen [pi (ar :body)])))) - (when (nil? chosen) - (error (string "no matching arity for macro " (name-sym :name) - " (" n " args)"))) - (def pi (chosen 0)) - (def body (chosen 1)) - (var new-bindings @{}) - (table/setproto new-bindings bindings) - (put new-bindings "&env" @{}) # implicit &env for macro bodies (table — nil-safe) - (var i 0) - # Destructure macro params (like fn), so [& [a & more :as all]] - # and {:keys …} rest forms work in macro arglists. - (each pat (pi :fixed) - (destructure-bind ctx new-bindings pat (macro-args i)) - (++ i)) - (when (pi :rest) - (destructure-bind ctx new-bindings (pi :rest) (rest-args-val macro-args i))) - # Use defining namespace for symbol resolution - (def saved-ns (ctx-current-ns ctx)) - (ctx-set-current-ns ctx defining-ns) - # Plain trailing restore (NOT defer/try — those build a fiber per - # call and blow the C stack on deep interpreted recursion). An - # unwinding throw is repaired once at the TOP-LEVEL boundary - # (loader/eval-toplevel restores the ns on error). - (var result nil) - (each bf body - (set result (eval-form ctx new-bindings bf))) - (ctx-set-current-ns ctx saved-ns) - result)) - # A COMPILED expander (native-speed) is only built for the - # single-arity case (the compile hook + recompile path take one - # [args body]); multi-arity macros use the interpreted expander. - (def single? (= 1 (length arities))) - (def args-form (and single? ((first arities) :params))) - (def body (and single? ((first arities) :body))) - (def uses-env (do (var u false) - (each ar arities - (when (or (form-uses-sym? (ar :body) "&env") - (form-uses-sym? (ar :body) "&form")) - (set u true))) - u)) - (def compiled-fn - (when (and macro-compile-hook single? (not uses-env)) - (macro-compile-hook ctx args-form body))) - (def macro-fn (or compiled-fn interp-fn)) - (let [ns-name (ctx-current-ns ctx) - ns (ctx-find-ns ctx ns-name)] - (def v (ns-intern ns (name-sym :name) macro-fn)) - (put v :macro true) - # Stash the expander source so backend/recompile-macros! can - # compile it once the analyzer is alive (staged bootstrap): a - # macro defined WHILE the analyzer is still being built gets an - # interpreted closure now, a compiled expander later. uses-env - # macros stay interpreted (the compiled fn* has no &env/&form); - # multi-arity macros keep the interpreted dispatch (no single - # [args body] to recompile). - (when single? (put v :macro-src @[args-form body])) - (put v :macro-uses-env uses-env) - (when compiled-fn (put v :macro-compiled true)) - # A (re)defined macro invalidates any cached expansions. - (table/clear macro-cache) - (var-get v)))) - -(defn eval-fn* [ctx bindings form] - (let [# optional name: (fn* name [args] ...) / (fn* name ([args] ...)...) - named? (and (struct? (in form 1)) (= :symbol ((in form 1) :jolt/type))) - fn-name (if named? ((in form 1) :name) nil) - form (if named? (array/concat @[(in form 0)] (tuple/slice form 2)) form)] - (if (array? (in form 1)) - # Multi-arity: (fn* ([args] body...) ([args] body...)...) - (let [pairs (tuple/slice form 1) - arities @{} - defining-ns (ctx-current-ns ctx)] - (var self nil) - # The (single) variadic clause is dispatched separately: it handles - # any arg count >= its fixed count. Storing it in `arities` by - # fixed-count would collide with a same-fixed-count fixed clause and - # only match that exact count. - (var variadic-fn nil) - (var variadic-min 0) - (each pair pairs - (let [args-form (in pair 0) - body (tuple/slice pair 1) - param-info (parse-params args-form) - _ (require-symbol-params param-info) - fixed-pats (param-info :fixed) - rest-pat (param-info :rest) - n-fixed (length fixed-pats) - # recur-entry: where (recur ...) re-enters THIS arity. For - # a fixed arity it's the dispatcher (exact count re-selects - # it). For the VARIADIC arity, recur takes n-fixed + 1 args - # with the LAST bound DIRECTLY as the rest seq (Clojure) — - # re-entering through the varargs collector would wrap it - # in a fresh 1-element rest list and the seq never empties - # (the jolt-4df hang). - recur-entry-box @[nil] - run-clause (fn [fn-bindings] - (put fn-bindings :jolt/loop-fn (in recur-entry-box 0)) - (when fn-name (bind-put fn-bindings fn-name self)) - # Use defining namespace for symbol resolution - (def saved-ns (ctx-current-ns ctx)) - (ctx-set-current-ns ctx defining-ns) - # Plain trailing restore (NOT defer/try — those build a fiber per - # call and blow the C stack on deep interpreted recursion). An - # unwinding throw is repaired once at the TOP-LEVEL boundary - # (loader/eval-toplevel restores the ns on error). - (var result nil) - (each body-form body - (set result (eval-form ctx fn-bindings body-form))) - (ctx-set-current-ns ctx saved-ns) - result) - f (fn [& fn-args] - (var fn-bindings @{}) - (table/setproto fn-bindings bindings) - (var i 0) - (each pat fixed-pats - (destructure-bind ctx fn-bindings pat (fn-args i)) - (++ i)) - (when rest-pat - (destructure-bind ctx fn-bindings rest-pat (rest-args-val fn-args i))) - (run-clause fn-bindings))] - (if rest-pat - (do - (put recur-entry-box 0 - (fn [& recur-args] - (var fn-bindings @{}) - (table/setproto fn-bindings bindings) - (var i 0) - (each pat fixed-pats - (destructure-bind ctx fn-bindings pat (recur-args i)) - (++ i)) - (destructure-bind ctx fn-bindings rest-pat (get recur-args i)) - (run-clause fn-bindings))) - (set variadic-fn f) (set variadic-min n-fixed)) - (do - (put recur-entry-box 0 (fn [& recur-args] (apply self recur-args))) - (put arities n-fixed f))))) - (set self (fn [& fn-args] - (let [n (length fn-args) - f (get arities n)] - (cond - f (apply f fn-args) - (and variadic-fn (>= n variadic-min)) (apply variadic-fn fn-args) - (error (string "Wrong number of args (" n ") passed to: " - (or fn-name "fn"))))))) - self) - # Single-arity: (fn* [args] body...) - (let [args-form (in form 1) - body (tuple/slice form 2) - param-info (parse-params args-form) - _ (require-symbol-params param-info) - fixed-pats (param-info :fixed) - rest-pat (param-info :rest) - defining-ns (ctx-current-ns ctx)] - (var self nil) - (var recur-entry nil) - (def run-body (fn [fn-bindings] - (put fn-bindings :jolt/loop-fn recur-entry) - (when fn-name (bind-put fn-bindings fn-name self)) - # Use defining namespace for symbol resolution - (def saved-ns (ctx-current-ns ctx)) - (ctx-set-current-ns ctx defining-ns) - # Plain trailing restore (NOT defer/try — those build a fiber per - # call and blow the C stack on deep interpreted recursion). An - # unwinding throw is repaired once at the TOP-LEVEL boundary - # (loader/eval-toplevel restores the ns on error). - (var result nil) - (each body-form body - (set result (eval-form ctx fn-bindings body-form))) - (ctx-set-current-ns ctx saved-ns) - result)) - (def n-fixed (length fixed-pats)) - (set self (fn [& fn-args] - # ArityException semantics (jolt-6xn): a fixed arity takes - # exactly its params, a variadic one at least its fixed params. - # The compiled path enforces this natively (janet fn arity); - # this keeps the interpreter oracle in agreement. - (def n (length fn-args)) - (when (if rest-pat (< n n-fixed) (not= n n-fixed)) - (error (string "Wrong number of args (" n ") passed to: " - (or fn-name "fn")))) - (var fn-bindings @{}) - (table/setproto fn-bindings bindings) - (var i 0) - (each pat fixed-pats - (destructure-bind ctx fn-bindings pat (fn-args i)) - (++ i)) - (when rest-pat - (destructure-bind ctx fn-bindings rest-pat (rest-args-val fn-args i))) - (run-body fn-bindings))) - # recur re-enters here: for a variadic fn it takes n-fixed + 1 - # args, the LAST bound DIRECTLY as the rest seq (Clojure) — going - # back through the varargs collector wrapped the seq in a fresh - # 1-element rest list, so it never emptied (the jolt-4df hang). - (set recur-entry - (if rest-pat - (fn [& recur-args] - (var fn-bindings @{}) - (table/setproto fn-bindings bindings) - (var i 0) - (each pat fixed-pats - (destructure-bind ctx fn-bindings pat (recur-args i)) - (++ i)) - (destructure-bind ctx fn-bindings rest-pat (get recur-args i)) - (run-body fn-bindings)) - self)) - self)))) - -(defn eval-let* [ctx bindings form] - (let [bind-vec (in form 1) - body (tuple/slice form 2)] - (var new-bindings @{}) - (table/setproto new-bindings bindings) - (var i 0) - (let [len (length bind-vec)] - (while (< i len) - (let [pat (bind-vec i)] - # let* is a primitive (the let macro desugars destructuring); - # its binding names must be plain symbols, as in Clojure. - (unless (plain-sym? pat) (error "Bad binding form, expected symbol")) - (def val (eval-form ctx new-bindings (bind-vec (+ i 1)))) - (destructure-bind ctx new-bindings pat val) - (+= i 2)))) - (var result nil) - (each body-form body - (set result (eval-form ctx new-bindings body-form))) - result)) - -(defn eval-loop* [ctx bindings form] - (let [bind-vec (in form 1) - body (tuple/slice form 2) - init-vals @[] - patterns @[] - # Inits are evaluated sequentially in an accumulating scope (like - # let*), so a later init can reference an earlier binding — - # matching Clojure's loop. - seq-bindings @{}] - (table/setproto seq-bindings bindings) - (var i 0) - (while (< i (length bind-vec)) - # loop* is a primitive (the loop macro desugars destructuring); - # its binding names must be plain symbols, as in Clojure. - (unless (plain-sym? (bind-vec i)) (error "Bad binding form, expected symbol")) - (def v (eval-form ctx seq-bindings (bind-vec (+ i 1)))) - (bind-put seq-bindings ((bind-vec i) :name) v) - (array/push init-vals v) - (array/push patterns (bind-vec i)) - (+= i 2)) - (var loop-fn nil) - (set loop-fn (fn [& args] - (var loop-bindings @{}) - (table/setproto loop-bindings bindings) - (var j 0) - (each pat patterns - (destructure-bind ctx loop-bindings pat (in args j)) - (++ j)) - (put loop-bindings :jolt/loop-fn loop-fn) - (var result nil) - (each body-form body - (set result (eval-form ctx loop-bindings body-form))) - result)) - (apply loop-fn init-vals))) - -(defn eval-recur [ctx bindings form] - (let [loop-fn (get bindings :jolt/loop-fn)] - (if (nil? loop-fn) - (error "recur used outside of loop* or fn*") - (let [args (map |(eval-form ctx bindings $) (tuple/slice form 1))] - (apply loop-fn args))))) - -(defn eval-try [ctx bindings form] - (let [# The body is EVERY form between `try` and the first catch/finally - # clause (not just form 1 — a multi-form body before the clauses, - # e.g. (try (foo) (bar) (catch …)), dropped all but the first). - forms (tuple/slice form 1) - clause? (fn [c] - (and (array? c) (> (length c) 0) - (struct? (first c)) (= :symbol ((first c) :jolt/type)) - (or (= "catch" ((first c) :name)) - (= "finally" ((first c) :name))))) - split (do (var k 0) - (while (and (< k (length forms)) (not (clause? (in forms k)))) (++ k)) - k) - body-forms (tuple/slice forms 0 split) - clauses (tuple/slice forms split) - # current-ns is dynamic state. The interpreter rebinds it to a - # fn's defining ns while that fn runs and restores it on normal - # return, but a fn that THROWS unwinds past its own restore — so - # the ns can leak. try is the unwind boundary: restore the ns that - # was current at try entry before running catch/finally, so caught - # code (and the harness's is/thrown?) sees the right namespace. - try-ns (ctx-current-ns ctx)] - (var catch-sym nil) - (var catch-body nil) - (var finally-body nil) - (each clause clauses - (when (and (array? clause) (> (length clause) 0)) - (let [head (first clause)] - (when (and (struct? head) (= :symbol (head :jolt/type))) - (match (head :name) - "catch" (do - # (catch class binding body*) — binding (3rd elem) must - # be a symbol. Validate up front (even when the body - # never throws) so a malformed clause is a clean error, - # not a silent nil or an internal crash when caught. - (let [b (when (>= (length clause) 3) (in clause 2))] - (unless (and b (struct? b) (= :symbol (b :jolt/type))) - (error "Unable to parse catch clause; expected (catch class binding body*)"))) - (set catch-sym (in clause 2)) - (set catch-body (tuple/slice clause 3))) - "finally" (set finally-body (tuple/slice clause 1))))))) - (defn eval-body [] - (var result nil) - (each bf body-forms (set result (eval-form ctx bindings bf))) - result) - (defn run-finally [] - (when finally-body - (each fb finally-body (eval-form ctx bindings fb)))) - (defn run-protected [] - (if catch-sym - (try - (eval-body) - ([err] - (ctx-set-current-ns ctx try-ns) - (var new-bindings @{}) - (table/setproto new-bindings bindings) - # bind the originally-thrown value (unwrap the :jolt/exception - # envelope) so (catch … e (throw e)) rethrows the same value - # rather than nesting another envelope - (def caught - (if (and (or (table? err) (struct? err)) (= :jolt/exception (get err :jolt/type))) - (get err :value) - err)) - (put new-bindings (catch-sym :name) caught) - (var result nil) - (each cb catch-body - (set result (eval-form ctx new-bindings cb))) - result)) - # no catch: restore the ns on an unwinding error, then re-raise - (try (eval-body) ([err] (ctx-set-current-ns ctx try-ns) (error err))))) - # finally ALWAYS runs (success, caught error, or rethrow) — defer so it - # fires even if a catch body throws. Without a finally, just run. - (if finally-body - (defer (run-finally) (run-protected)) - (run-protected)))) - -(defn eval-set! [ctx bindings form] - (let [target (in form 1) - val (eval-form ctx bindings (in form 2))] - # Handle (set! (.-field obj) val) — .-field shorthand as a list - (if (and (array? target) (> (length target) 1) - (struct? (first target)) (= :symbol ((first target) :jolt/type)) - (> (length ((first target) :name)) 1) - (= (string/slice ((first target) :name) 0 2) ".-")) - (let [obj (eval-form ctx bindings (in target 1)) - field-name (string/slice ((first target) :name) 2) - field-key (keyword field-name)] - (if (get obj :jolt/deftype) - (do (put obj field-key val) val) - (error (string "Can't set! field on non-deftype: " (type obj))))) - # (set! (. obj -field) val) — instance field mutation - (if (and (array? target) (> (length target) 0) - (struct? (first target)) - (= :symbol ((first target) :jolt/type)) - (= "." ((first target) :name))) - (let [obj (eval-form ctx bindings (in target 1)) - field-sym (in target 2) - field-name (field-sym :name) - field-key (keyword (if (and (> (length field-name) 0) (= "-" (string/slice field-name 0 1))) - (string/slice field-name 1) - field-name))] - (if (get obj :jolt/deftype) - (do (put obj field-key val) val) - (error (string "Can't set! field on non-deftype: " (type obj))))) - # (set! var val) — normal var mutation - (let [target-sym target - v (resolve-var ctx bindings target-sym)] - (if v - (do (var-set v val) val) - # Auto-create var if it doesn't exist - (let [ns-name (ctx-current-ns ctx) - ns (ctx-find-ns ctx ns-name)] - (def new-v (ns-intern ns (target-sym :name) val)) - val))))))) - -(defn eval-new [ctx bindings form] - (let [type-sym (in form 1) - args (map |(eval-form ctx bindings $) (tuple/slice form 2)) - ctor (eval-form ctx bindings type-sym) - ctor (if (string? ctor) (or (ctor-for-class-token ctor) ctor) ctor)] - (apply ctor args))) - -# Member dispatch shared by the two `.` forms (jolt-eos3). `args` is the -# (possibly empty) tuple of already-evaluated arguments; `has-args` is true for -# the call form `(. obj method arg...)` and false for the bare form -# `(. obj member)`. The two forms agree on the string/number/object/tagged-shim -# dispatch chain (single-sourced here, so an interop change touches one place) -# but diverge in the tail: the call form tries record → native-field → -# coll-interop(args); the bare form tries zero-arg coll-interop → field / -# zero-arg method. The guards that differed between the old copy-pasted arms are -# keyed off `has-args` so behavior is identical (note: the object-methods guard -# checks `table?` only, while tagged dispatch checks table-or-struct — both kept -# verbatim from the original arms). -# A record's own implementation of `field-name` (its instance fn, a reified fn, -# or a protocol method from the type registry), or nil. A deftype/defrecord -# method must win over the generic object-methods table — e.g. a custom -# (Object (toString [_] ...)) over the default toString (jolt-rt6n). -(defn- record-member [ctx target field-name] - (when (record-tag target) - (let [mk (keyword field-name) - own (get target mk) - reified (get (get target :jolt/protocol-methods) mk)] - (cond - (or (function? own) (cfunction? own)) own - (or (function? reified) (cfunction? reified)) reified - (find-method-any-protocol ctx (record-tag target) field-name))))) - -(defn dispatch-member [ctx bindings target member-raw member-name field-name args has-args] - (cond - # java.lang.String surface for string/buffer targets - (or (string? target) (buffer? target)) - (let [m (get string-methods field-name)] - (if m - (m (string target) ;args) - (if-let [om (get object-methods field-name)] - (om (string target) ;args) - (error (string "Unsupported String method ." field-name))))) - # numeric methods - (and (number? target) (get number-methods field-name)) - ((get number-methods field-name) target ;args) - # universal object methods — skipped when a shim tag-table owns the member, - # OR when the target is a record that implements the member itself (so a - # deftype's own toString/equals/hashCode wins over the generic one, jolt-rt6n). - # Call form defers to tagged dispatch whenever a tag-table exists; bare form - # only when the tag-table actually carries this member, so zero-arg - # toString/hashCode still reach object-methods on shim objects. - (and (get object-methods field-name) - (not (and (table? target) (get tagged-methods (get target :jolt/type)) - (or has-args (get (get tagged-methods (get target :jolt/type)) field-name)))) - (not (record-member ctx target field-name))) - ((get object-methods field-name) target ;args) - # registered shim objects (java.time etc.): tag-keyed method tables - (and (or (table? target) (struct? target)) - (get tagged-methods (get target :jolt/type)) - (or has-args (get (get tagged-methods (get target :jolt/type)) field-name))) - (let [m (get (get tagged-methods (get target :jolt/type)) field-name)] - (if m - (m target ;args) - (error (string "Unsupported method ." field-name " on " (string (get target :jolt/type)))))) - # --- divergent tail --- - has-args - # (. obj method args...): record protocol dispatch, else native field/method - (if (record-tag target) - # deftype/reify methods live in the protocol registry (or the instance's - # reified-fns table), not on the instance. get is safe on a shape-rec - # tuple (returns nil for the method/protocol keys). - (let [method-key (keyword field-name) - own (get target method-key) - reified (get (get target :jolt/protocol-methods) method-key) - m (cond - (or (function? own) (cfunction? own)) own - (or (function? reified) (cfunction? reified)) reified - (find-method-any-protocol ctx (record-tag target) field-name))] - (if m - (apply m target args) - (error (string "No method ." field-name " on " (record-tag target))))) - # Janet-native interop: try field lookup + call - (if (or (table? target) (struct? target)) - (let [method (get target (keyword field-name))] - (if (or (function? method) (cfunction? method)) - (method target ;args) - # If stored as fn* form (array), compile to function then call - (if (array? method) - (let [method-fn (eval-form ctx bindings method)] - (if (or (function? method-fn) (cfunction? method-fn)) - (method-fn target ;args) - (error (string "Cannot call non-function " field-name " on " (type target))))) - (let [r (if coll-interop (coll-interop target field-name args) :jolt/ci-none)] - (if (= r :jolt/ci-none) - (error (string "Cannot call non-function " field-name " on " (type target))) - r))))) - (error (string "Cannot call method " field-name " on " (type target))))) - # (. obj member) with no extra args: a symbol member naming a function is a - # zero-arg method call (receiver passed as self); a keyword or `-field` - # member is plain field access. - true - # zero-arg Java collection interop (.count/.seq/… on a jolt collection) - # before field lookup — coll-interop returns :jolt/ci-none if not its kind - (let [ci (if coll-interop (coll-interop target field-name @[]) :jolt/ci-none)] - (if (not= ci :jolt/ci-none) ci - (let [v (if (record-tag target) - (coll-lookup target (keyword field-name) nil) - (get target (keyword field-name)))] - (if (and (struct? member-raw) (= :symbol (member-raw :jolt/type)) - (not (string/has-prefix? "-" member-name))) - (cond - (or (function? v) (cfunction? v)) (v target) - # zero-arg deftype/reify method via the protocol registry - (record-tag target) - (let [reified (get (get target :jolt/protocol-methods) (keyword field-name)) - m (if (or (function? reified) (cfunction? reified)) reified - (find-method-any-protocol ctx (record-tag target) field-name))] - (if m (m target) v)) - # value stored as an unevaluated fn* form: compile then call - (array? v) (let [f (eval-form ctx bindings v)] - (if (or (function? f) (cfunction? f)) (f target) f)) - v) - v)))))) - -(defn eval-dot [ctx bindings form] - (let [target (eval-form ctx bindings (in form 1)) - member-raw (in form 2) - # Resolve member name: symbols have :name, keywords use string, strings as-is - member-name (if (and (struct? member-raw) (= :symbol (member-raw :jolt/type))) - (member-raw :name) - (if (keyword? member-raw) - (string member-raw) - member-raw)) - field-name (if (and (string? member-name) (> (length member-name) 0) (= "-" (string/slice member-name 0 1))) - (string/slice member-name 1) - member-name) - has-args (> (length form) 3) - args (if has-args (map |(eval-form ctx bindings $) (tuple/slice form 3)) @[])] - (dispatch-member ctx bindings target member-raw member-name field-name args has-args))) - -(defn eval-list - [ctx bindings form] - (def first-form (first form)) - # Safe name extraction: non-symbol heads (e.g. keywords) fall through to default. - # A head qualified to a NON-core namespace (e.g. clojure.edn/read-string) must - # resolve to that var, not the like-named clojure.core special form — so only - # unqualified or clojure.core-qualified heads dispatch as special forms. - (def name (if (and (struct? first-form) (= :symbol (first-form :jolt/type))) - (let [ns (first-form :ns)] - (if (or (nil? ns) (= ns "clojure.core")) (first-form :name) nil)) - nil)) - (match name - "quote" (in form 1) - # Interpreter builds the form directly (self-contained, no core dependency). - # The COMPILE path instead lowers syntax-quote to construction code (via - # syntax-quote-lower) so a backtick body is compilable; the two are kept in - # sync and cross-checked by conformance (interpret vs compile modes). - "syntax-quote" (syntax-quote* ctx bindings (in form 1)) - "unquote" (error "Unquote not valid outside of syntax-quote") - "unquote-splicing" (error "Unquote-splicing not valid outside of syntax-quote") - "eval" (eval-form ctx bindings (eval-form ctx bindings (in form 1))) - # read-string/macroexpand-1 are ctx-capturing clojure.core fns and defonce - # an overlay macro now (Stage 2 tier 6c) — no special-form arms. - "do" (eval-do ctx bindings form) - "if" (eval-if ctx bindings form) - "def" (eval-def ctx bindings form) - "defmacro" (eval-defmacro ctx bindings form) - # ns is now a macro (clojure.core, 30-macros) expanding to in-ns + require/use/ - # import/refer-clojure calls — all ctx-capturing fns — so it compiles. No - # special-form arm; an (ns ...) head falls through to the macro-expansion path. - # require / in-ns are now ordinary clojure.core fns (install-stateful-fns!) — - # no special-form arm; they compile + interpret as plain invokes. - # all-ns/the-ns/create-ns/remove-ns/ns-interns/ns-aliases/ns-imports/ - # ns-resolve/resolve/find-ns/refer are ctx-capturing clojure.core fns now - # (install-stateful-fns!) with evaluated-arg Clojure semantics — they fall - # through to the function-call default and compile as plain invokes - # (Stage 2 tier 6b). - "fn*" (eval-fn* ctx bindings form) - "let*" (eval-let* ctx bindings form) - "loop*" (eval-loop* ctx bindings form) - "recur" (eval-recur ctx bindings form) - "throw" (let [val (eval-form ctx bindings (in form 1))] - (error {:jolt/type :jolt/exception :value val})) - "try" (eval-try ctx bindings form) - "set!" (eval-set! ctx bindings form) - "var" (let [target-sym (in form 1) - v (resolve-var ctx bindings target-sym)] - (if v v (error (string "Unable to resolve var: " (sym-name-str target-sym) " in var")))) - # var-get/var-set/var?/alter-var-root/alter-meta!/reset-meta! are plain - # clojure.core fns; find-var/intern are ctx-capturing clojure.core fns - # (install-stateful-fns!) — they fall through to the function-call default - # and compile as ordinary invokes (Stage 2 tier 6). - # set?/disj are plain clojure.core fns now (core-set?/core-disj) — no longer - # special-cased here, the analyzer, or compiler.janet (jolt-g3h). - # protocol-dispatch / register-method / make-reified are now ordinary - # clojure.core fns (install-stateful-fns!) — the defprotocol/extend-type/reify - # macros call them with name STRINGS, so they compile + interpret as plain - # invokes (no special-form arms). - # satisfies?/instance?/locking and the multimethod table ops - # (prefer-method/remove-method/remove-all-methods/get-method/methods) are - # clojure.core fns / overlay macros now (Stage 2 tier 6c) — no special arms. - # deftype is now a macro (30-macros) over make-deftype-ctor + extend-type — - # compiles as a plain (do …); no special-form arm. - "new" (eval-new ctx bindings form) - "." (eval-dot ctx bindings form) - # default: function application — check for macros - (if (and (struct? first-form) (= :symbol (first-form :jolt/type))) - (let [sym-name (first-form :name)] - # Handle .-fieldName accessor: (.-cnt obj) → (. obj -cnt) - (if (and (> (length sym-name) 1) (= (string/slice sym-name 0 2) ".-") - (> (length form) 1)) - (let [field-name (string/slice sym-name 2) - target (eval-form ctx bindings (in form 1))] - (get target (keyword field-name))) - # (.method obj args...) sugar -> (. obj method args...): desugar and - # re-enter the dot special form (which holds the String surface, the - # deftype method path, and the map-fn fallback). - (if (and (> (length sym-name) 1) - (= (string/slice sym-name 0 1) ".") - (not= sym-name "..") - (> (length form) 1)) - (eval-form ctx bindings - (array/concat @[{:jolt/type :symbol :ns nil :name "."} - (in form 1) - {:jolt/type :symbol :ns nil :name (string/slice sym-name 1)}] - (tuple/slice form 2))) - # Handle ClassName. constructor syntax (".." is the member-threading - # macro, not a constructor named ".") - (if (and (> (length sym-name) 1) (not= sym-name "..") - (= (sym-name (- (length sym-name) 1)) 46)) - (let [type-name (string/slice sym-name 0 (- (length sym-name) 1)) - type-sym {:jolt/type :symbol :ns (first-form :ns) :name type-name} - ctor (eval-form ctx bindings type-sym) - # class names evaluate to canonical-name STRINGS now; the - # constructor itself comes from the ctor registry - ctor (if (string? ctor) (or (ctor-for-class-token ctor) ctor) ctor) - args (map |(eval-form ctx bindings $) (tuple/slice form 1))] - (apply ctor args)) - (let [v (resolve-var ctx bindings first-form)] - (if (and v (var-macro? v)) - # Expand once (cached by call-form identity), then evaluate the - # macro-free expansion with the current bindings each call. - (let [cached (in macro-cache form)] - (if (not (nil? cached)) - (eval-form ctx bindings cached) - (let [expanded (apply (var-get v) (tuple/slice form 1))] - (put macro-cache form expanded) - (eval-form ctx bindings expanded)))) - (let [f (eval-form ctx bindings first-form) - args (map |(eval-form ctx bindings $) (tuple/slice form 1))] - (jolt-invoke ctx f args)))))))) - (let [f (eval-form ctx bindings first-form) - args (map |(eval-form ctx bindings $) (tuple/slice form 1))] - (jolt-invoke ctx f args))))) - -# Build a map value from an array of evaluated [k v k v ...]. A phm (not a Janet -# struct) is used when a key is a collection (value-based hashing) OR a key/value -# is nil (Janet structs drop nil; phm preserves it, matching Clojure). The common -# scalar/nil-free case stays a struct. diff --git a/src/jolt/evaluator.janet b/src/jolt/evaluator.janet deleted file mode 100644 index 6ebf868..0000000 --- a/src/jolt/evaluator.janet +++ /dev/null @@ -1,109 +0,0 @@ -# Jolt Evaluator -# Direct interpreter for Clojure forms on Janet. -# -# This file is the AGGREGATOR (jolt-oudv, phase 2a): the interpreter is now split -# into cluster modules, loaded here in dependency order and re-exported -# (:export true) so every consumer keeps a single `(use ./evaluator)`. The -# eval-form entry (set at the bottom) ties resolution, special forms and the -# collection/map literal evaluation together. - -(use ./types) -(use ./phm) -(use ./phs) -(use ./lazyseq) -(use ./pv) -(use ./plist) -(use ./config) -(use ./reader) -(use ./regex) - -(import ./eval_base :prefix "" :export true) -(import ./eval_resolve :prefix "" :export true) -(import ./eval_runtime :prefix "" :export true) -(import ./eval_special :prefix "" :export true) - -(defn- map-needs-phm? [kvs] - (var need false) (var i 0) - (while (< i (length kvs)) - (let [k (in kvs i) v (in kvs (+ i 1))] - (when (or (table? k) (array? k) (nil? k) (nil? v)) (set need true) (break))) - (+= i 2)) - need) - -(defn- build-eval-map [kvs] - (if (map-needs-phm? kvs) - (do (var m (make-phm)) (var j 0) - (while (< j (length kvs)) (set m (phm-assoc m (in kvs j) (in kvs (+ j 1)))) (+= j 2)) m) - (struct ;kvs))) - -(set eval-form (fn [ctx bindings form] - (cond - (nil? form) nil - (number? form) form - (string? form) form - (keyword? form) form - (bytes? form) form - (buffer? form) form - (tuple? form) - (let [els (map |(eval-form ctx bindings $) form)] - (if mutable? (array ;els) (pv-from-indexed els))) - (struct? form) - (if (= :symbol (form :jolt/type)) - (resolve-sym ctx bindings form) - (if (= :jolt/char (form :jolt/type)) - form - # a UUID/inst value flowing back through eval (macro expansion, eval of a - # read form) is a self-evaluating literal, like chars. A namespace object - # does too: `~*ns*` in a syntax-quote (clojure.tools.logging) splices the - # live ns into the expansion. - (if (or (= :jolt/uuid (form :jolt/type)) (= :jolt/inst (form :jolt/type)) - (= :jolt/namespace (form :jolt/type))) - form - (if (= :jolt/set (form :jolt/type)) - # evaluate each element (set literals like #{(inc 1)} must compute) - (apply make-phs (map |(eval-form ctx bindings $) (form :value))) - (if (= :jolt/tagged (form :jolt/type)) - (let [tag (form :tag) - data-readers (get (ctx :env) :data-readers) - reader-fn (if data-readers (get data-readers tag))] - (cond - # #"..." regex literal -> a regex value (Janet PEG-backed) - (= tag :regex) (compile-regex (form :form)) - reader-fn (reader-fn (form :form)) - (error (string "No reader function for tag " tag)))) - (if (get form :jolt/type) - (error (string "Unexpected tagged form: " (form :jolt/type))) - # plain map literal: evaluate keys and values in SOURCE order when - # the reader order rides along (jolt-p3c), hash order otherwise - (let [kvs @[] - order (form-kv-order form)] - (if order - (each x order (array/push kvs (eval-form ctx bindings x))) - (each k (keys form) - (array/push kvs (eval-form ctx bindings k)) - (array/push kvs (eval-form ctx bindings (get form k))))) - (build-eval-map kvs)))))))) - # A phm map-literal FORM (reader emits one for {:a nil} etc., which a struct - # would have dropped): evaluate its key/value forms and rebuild, preserving nil. - (phm? form) - (let [kvs @[] - order (form-kv-order form)] - (if order - (each x order (array/push kvs (eval-form ctx bindings x))) - (each e (phm-entries form) - (array/push kvs (eval-form ctx bindings (in e 0))) - (array/push kvs (eval-form ctx bindings (in e 1))))) - (build-eval-map kvs)) - (array? form) - (if (= 0 (length form)) - @[] - (eval-list ctx bindings form)) - # A non-array ISeq used as a form is a CALL too (jolt-2rx): cons/concat/list - # and ~@ build a plist or lazy-seq (list?/seq? true, array? false) — without - # this they fell through to self-eval, so (eval (cons '+ '(1 2))) returned the - # list as data instead of 3, and macro output containing such subforms never - # evaluated. d-realize coerces to the element array; an empty list self-evals. - (or (plist? form) (lazy-seq? form)) - (let [arr (d-realize form)] - (if (= 0 (length arr)) form (eval-list ctx bindings arr))) - form))) diff --git a/src/jolt/host_iface.janet b/src/jolt/host_iface.janet deleted file mode 100644 index 89dfcbb..0000000 --- a/src/jolt/host_iface.janet +++ /dev/null @@ -1,356 +0,0 @@ -# Janet implementation of the Jolt host contract (ns `jolt.host`). -# -# This is the seam between the portable jolt-core (analyzer/IR/core, pure Clojure -# under jolt-core/) and the Janet runtime. jolt-core calls ONLY these functions — -# never Janet directly. Re-hosting Jolt to another runtime means reimplementing -# this contract (+ the back end and RT) for that runtime. -# -# Lives in src/jolt/ (with the rest of the Janet host) rather than a separate -# host/janet/ dir: Janet resolves relative imports per-file, so a host/janet -# module importing ../../src/jolt/* loads SECOND instances of compiler/types/core -# (inconsistent state). The portability boundary is the `jolt.host` namespace -# contract + jolt-core/, not the directory. -# -# Two groups: -# 1. Form introspection — reader forms are host-specific (the reader is the -# host's), so shape predicates/accessors live here. Returns jolt values the -# analyzer walks with ordinary Clojure. -# 2. Compile-time environment — resolve symbols to vars/macros, expand macros, -# the current namespace. These take ctx (an opaque host handle). - -(use ./types) -(use ./evaluator) -(use ./core) -(import ./phm :as phm) -(import ./pv :as pv) -(import ./reader :as rdr) - -# --------------------------------------------------------------------------- -# Form introspection -# --------------------------------------------------------------------------- - -(defn h-sym? [form] (and (struct? form) (= :symbol (form :jolt/type)))) -(defn h-sym-name [form] (form :name)) -(defn h-sym-ns [form] (form :ns)) -# Reader metadata on a symbol (e.g. ^:dynamic / ^:redef / ^:private on a def -# name). Returns the meta map (a portable jolt map) or nil. Lets the analyzer -# carry def metadata that the back end applies to the var — without it, compiled -# defs drop all var meta. -# -# The reader builds meta as a Janet TABLE (mutable). Return it as an immutable -# STRUCT so it is a portable jolt value: the Janet back end's merge/get work on a -# struct, AND jolt's own count/map?/keys (used by the portable Clojure emitter, -# jolt.backend-scheme, to emit def metadata) work on a struct but NOT on a raw -# table. A table embedded in the IR is a host value (counter to jolt.ir's "no host -# values embedded") — struct keeps :meta host-neutral. (jolt-me6m) -(defn h-sym-meta [form] - (def m (form :meta)) - (if (table? m) (table/to-struct m) m)) - -(defn h-list? [form] (array? form)) # a call / list (reader: array) -(defn h-vector? [form] (tuple? form)) # a vector literal (reader: tuple) -# A map-literal form is a plain struct, or a phm when the reader preserved a nil -# key/value (Janet structs drop nil). Sets/chars/symbols are tagged structs (have -# :jolt/type); phm carries :jolt/deftype, distinct from those. -(defn h-map? [form] - (or (and (struct? form) (nil? (form :jolt/type))) - (phm/phm? form))) -(defn h-set? [form] (and (struct? form) (= :jolt/set (form :jolt/type)))) -(defn h-char? [form] (and (struct? form) (= :jolt/char (form :jolt/type)))) -# Codepoint of a char form. Janet rep is a {:ch :jolt/type :jolt/char} struct; -# the emitter uses this (not a raw :ch read) so the Chez host can answer for its -# native char rep too (form-char-code). -(defn h-char-code [form] (get form :ch)) -# A regex literal #"…" reads as a tagged form {:jolt/type :jolt/tagged :tag :regex -# :form "source"}. The analyzer lowers it to a :regex IR node (Chez emits a -# jolt-regex value; the Janet back end punts to the interpreter, which compiles it -# via the seed PEG engine). -(defn h-regex? [form] - (and (struct? form) (= :jolt/tagged (form :jolt/type)) (= :regex (form :tag)))) -(defn h-regex-source [form] (form :form)) - -# #inst / #uuid literals read as tagged forms whose :tag keyword keeps the leading -# # (the data-readers convention; (keyword "#inst") = :#inst). The analyzer lowers -# them to :inst / :uuid IR leaves: the Chez back end emits a runtime inst/uuid -# value; the Janet back end punts to the interpreter (its data-readers parse them). -(defn h-inst? [form] - (and (struct? form) (= :jolt/tagged (form :jolt/type)) (= (keyword "#inst") (form :tag)))) -(defn h-inst-source [form] (form :form)) -(defn h-uuid? [form] - (and (struct? form) (= :jolt/tagged (form :jolt/type)) (= (keyword "#uuid") (form :tag)))) -(defn h-uuid-source [form] (form :form)) - -(defn h-literal? [form] - (or (nil? form) (boolean? form) (number? form) (string? form) - (keyword? form) (h-char? form))) - -# Items of a list/vector as a jolt vector, so the analyzer walks them with Clojure. -(defn h-elements [form] (make-vec form)) -(defn h-vector-items [form] (make-vec form)) -(defn h-map-pairs [form] - # reader forms carry source order (jolt-p3c) — Clojure evaluates literal - # entries left to right; hash order only for constructed maps - (def order (rdr/form-kv-order form)) - (cond - order - (do (def out @[]) - (var i 0) - (while (< i (length order)) - (array/push out (make-vec [(in order i) (in order (+ i 1))])) - (+= i 2)) - (make-vec out)) - (phm/phm? form) - (make-vec (map (fn [e] (make-vec [(in e 0) (in e 1)])) (phm/phm-entries form))) - (make-vec (map (fn [k] (make-vec [k (get form k)])) (keys form))))) -(defn h-set-items [form] (make-vec (form :value))) - -# --------------------------------------------------------------------------- -# Compile-time environment -# --------------------------------------------------------------------------- - -# Names the analyzer must NOT treat as a function call: interpreter special forms -# plus definitional/host macros the compiler doesn't lower. The analyzer handles -# a subset (quote/if/do/def/fn*/let*/loop*/recur/throw/try) and falls back to the -# interpreter for the rest. Kept in sync with evaluator/special-symbol? and -# compiler/uncompilable-heads. -(def- special-names - (let [t @{}] - (each n ["quote" "syntax-quote" "unquote" "unquote-splicing" "do" "if" "def" - "defmacro" "fn*" "let*" "loop*" "recur" "throw" "try" "set!" - # defmulti/defmethod/deftype now compile (macros over *-setup fns). - "eval" "new" - # var-get/var-set/var?/alter-var-root/alter-meta!/reset-meta! are - # plain core fns; find-var/intern are ctx-capturing core fns — all - # compile as ordinary invokes now (Stage 2 tier 6). - "." - # satisfies?/instance?/locking/defonce/read-string/macroexpand-1 and - # the multimethod table ops (prefer-method/remove-method/ - # remove-all-methods/get-method/methods) are clojure.core fns / - # overlay macros now (Stage 2 tier 6c) — ordinary invokes. - # create-ns/remove-ns/find-ns/all-ns/the-ns/resolve/ns-resolve/ - # ns-aliases/ns-imports/ns-interns/refer are ctx-capturing - # clojure.core fns now (compile as plain invokes — tier 6b), like - # ns/require/in-ns/use/import/refer-clojure before them. - # defprotocol/extend-type/extend-protocol/reify/defrecord now expand to - # plain def + protocol-dispatch/register-method/make-reified/deftype. - "gen-class" - # letfn stays: its let* expansion needs letrec semantics (mutual - # recursion between the fns), which compiled sequential let* lacks. - "monitor-enter" "monitor-exit" "letfn"] - (put t n true)) - t)) - -# Interop-shaped heads the interpreter lowers but the back end doesn't model: -# (.method obj …) / (.-field obj) — member access (name starts with ".") -# (Foo. …) — constructor (name ends with "." ) -# Treated as special so the analyzer marks them uncompilable and falls back. -(defn- interop-head? [name] - (def n (length name)) - (and (> n 1) - (or (= (string/slice name 0 1) ".") - (= (string/slice name (- n 1)) ".")))) - -(defn h-special? [name] - (if (or (get special-names name) (interop-head? name)) true false)) - -# The namespace being compiled. NOT ctx-current-ns directly: the interpreter -# rebinds current-ns to a fn's defining ns while that fn runs, so an interpreted -# analyzer (defined in jolt.analyzer) would otherwise see jolt.analyzer. The back -# end stashes the real compile ns in :compile-ns before invoking the analyzer. -(defn h-current-ns [ctx] (or (get (ctx :env) :compile-ns) (ctx-current-ns ctx))) - -(defn h-macro? [ctx sym] - (let [v (resolve-var ctx @{} sym)] - (if (and v (var-macro? v)) true false))) - -(defn h-expand-1 [ctx form] - (let [head (in form 0) - v (resolve-var ctx @{} head) - macro-fn (var-get v)] - (apply macro-fn (tuple/slice form 1)))) - -# Classify a global (non-local) symbol reference: -# {:kind :var :ns NS :name NAME} — a Jolt var (current ns / clojure.core) -# {:kind :host :name NAME} — resolves only via the host env (+, int?, …), -# same fallback the interpreter's resolve-sym uses -# {:kind :unresolved :name NAME} — not yet defined (forward reference) -(defn h-resolve-global [ctx sym] - # Unqualified syms must resolve against the COMPILE ns (h-current-ns), not - # ctx-current-ns: the analyzer runs interpreted in jolt.analyzer, so during - # analysis resolve-var's unqualified branch looks in the wrong namespace. - # Before jolt-2o7.3 the analyzer's lenient fallthrough masked this (it - # emitted a var-ref against compile-ns for everything 'unresolved'). - (def v (if (sym :ns) - (resolve-var ctx @{} sym) - (let [cns (ctx-find-ns ctx (h-current-ns ctx))] - (or (and cns (ns-find cns (sym :name))) - (ns-find (ctx-find-ns ctx "clojure.core") (sym :name)))))) - (if v - {:kind :var :ns (var-ns v) :name (var-name v)} - (let [nm (sym :name) - entry (in (fiber/getenv (fiber/current)) (symbol nm))] - (if (not (nil? entry)) - {:kind :host :name nm} - {:kind :unresolved :name nm})))) - -(defn h-intern! [ctx ns-name nm] - (ns-intern (ctx-find-ns ctx ns-name) nm) - nil) - -# Open-world (late-binding) analysis: when set on the ctx env, an unresolved -# symbol emits a var-ref against the compile ns (resolved at runtime) instead of -# punting to the interpreter. The Chez back end (host/chez/driver) sets it: it has -# no interpreter to punt to, and a forward reference to a runtime-interned var -# (e.g. defmulti's setup call) must lower to a var-deref. Off everywhere else, so -# the normal compiler keeps its strict 'Unable to resolve symbol' behavior. -(defn h-late-bind? [ctx] (truthy? (get (ctx :env) :late-bind-unresolved?))) - -# --------------------------------------------------------------------------- -# Installation: bind these fns as vars in the `jolt.host` namespace so jolt-core -# can call them. Idempotent per context. -# --------------------------------------------------------------------------- - -# Form predicates use `form-*` names (not list?/vector?/map?/set?/char?) so the -# analyzer can refer them unqualified without the bootstrap's core-renames -# intercepting them as the value-level predicates. -# Lower a syntax-quote's inner form to construction code (so the analyzer can -# compile it). The portable analyzer calls this and analyzes the result. -(defn h-syntax-quote-lower [ctx inner] - (syntax-quote-lower ctx inner)) - -# Runtime host primitive: set a key on a mutable reference cell (an atom, the -# watches sub-table, ...). The minimal mutation kernel the overlay can't express -# over core fns — putting nil removes the key (Janet table semantics). Returns the -# table so callers can thread; overlay wrappers return the Clojure-meaningful value. -(defn h-ref-put! [tab key val] (put tab key val) tab) - -# Runtime host primitive: mint a fresh tagged host table — the value-layer -# constructor the overlay uses to define host-dispatched values (sorted colls). -# Fields are attached with ref-put!. -(defn h-tagged-table [kw] @{:jolt/type kw}) - -# Raw field read on a host table, BYPASSING collection semantics. The overlay -# needs this to read its own wrappers' fields: plain (get sorted-coll k) is the -# comparator lookup (it dispatches back into the overlay), so reading :entries -# with it would recurse forever. -(defn h-ref-get [tab key] (get tab key)) - -# Absolute source offset of a list FORM (jolt-fqy), or nil. The analyzer stamps -# it onto :invoke nodes so the success checker can report file:line:col. -(defn h-form-position [form] (rdr/form-pos form)) - -# --------------------------------------------------------------------------- -# Inline registry (jolt-87f, Route 1 AOT escape analysis). The inline pass -# (jolt.passes) is portable Clojure and can't read Janet var cells, so it asks -# the host whether a given global is inline-eligible and, if so, for its body IR. -# --------------------------------------------------------------------------- - -# Is inlining enabled for the unit currently being compiled? :inline? is OFF for -# all of init (core tiers + self-hosted compiler recompile) and flipped on at the -# end of init to the user direct-linking setting, so core compiles exactly as -# before (const-fold only) and only opted-in user code inlines. -(defn h-inline-enabled? [ctx] (if (get (ctx :env) :inline?) true false)) - -# The stashed inline body for global ns/name, or nil. Returns it only when the -# target is inline-SAFE: a defined var that won't be redefined (not ^:redef / -# ^:dynamic) and that carries a stashed :inline-ir (set by the back end when the -# var's defn compiled as a small, side-effect-bounded fn). The stash is -# {:params [name ...] :body } — a single fixed arity. -(defn h-inline-ir [ctx ns-name nm] - (when (get (ctx :env) :inline?) - (def cell (let [n (ctx-find-ns ctx ns-name)] (and n (ns-find n nm)))) - (when (and cell (table? cell) - (not (cell :dynamic)) - (not (let [m (cell :meta)] (and m (get m :redef))))) - (cell :inline-ir)))) - -# Is `name` (a bare type-name string, e.g. "Vec3") a defrecord/deftype? Both -# expand to define a ->Name positional constructor var (30-macros.clj), so its -# presence is the marker. Lets the analyzer resolve a ^Record type hint to the -# struct fast path: record instances are tables tagged :jolt/deftype (NOT -# :jolt/type), so a raw keyword get is correct for them (jolt-94n). -(defn h-record-ctor-key [ctx name] - # The home ctor key ("ns/->Name") for a ^Type hint, resolving cross-ns - # (referred/aliased) records too — nil if `name` is not a known record type. - (record-hint-ctor-key ctx name)) - -(defn h-record-type? [ctx name] - # A ^Type hint names a record iff it resolves to a ctor key (local OR cross-ns, - # via record-hint-ctor-key — so a referred/aliased foreign record is recognized, - # not just one whose ->Name happens to be interned in the current ns). - (if (record-hint-ctor-key ctx name) true false)) - -# The record-ctor shape registry ("ns/->Name" -> {:fields (:k ..) :type tag ..}), -# or an empty table. Lets scalar-replace (jolt-15jq) recognize a (->Rec ..) call -# and map its positional args to the declared field order — the record analogue -# of the inline map-literal keys the map fold already sees in the IR. -(defn h-record-shapes [ctx] - (or (get (ctx :env) :record-shapes) @{})) - -# Reader form CONSTRUCTORS (Chez Phase 3, jolt-cf1q.4). The portable Clojure -# reader (jolt.reader) holds all the LEXING/PARSING logic but must DELEGATE form -# construction to the host — a Clojure source file cannot write a {:jolt/type -# :symbol} literal (it parses as a tagged reader form, CLAUDE.md), and the -# concrete representation (Janet struct/array/tuple here; something else on Chez) -# is the host's to own. Same split the analyzer already uses for form-* readers. -(defn h-make-symbol [name] (rdr/make-symbol name)) -(defn h-make-char [code] (make-char code)) -(defn h-char-from-name [name] (char-from-name name)) -# Parse a numeric literal substring to a number. The reader keeps the radix/ratio/ -# sign/exponent LOGIC portable; only the final string->number bottoms out here -# (Janet scan-number; Chez string->number). Returns nil on a non-number. -(defn h-scan-number [str] (scan-number str)) - -# Collection form constructors. The portable reader accumulates items in a jolt -# vector and hands it here; the host builds its native form representation. -(defn- jvec->array [v] - (cond - (pv/pvec? v) (pv/pv->array v) - (indexed? v) (array ;v) - (array))) -(defn h-make-list [items] (jvec->array items)) # list form = Janet array -(defn h-make-vector [items] (tuple/slice (jvec->array items))) # vector form = Janet tuple -(defn h-make-map [kvs] (rdr/reader-map (jvec->array kvs))) # map form (+ kv-order) -# Attach/merge reader metadata onto a symbol FORM (^hint sym): keeps it a bare -# symbol carrying :meta, so type hints are transparent in every position. -(defn h-sym-merge-meta [sym m] - (struct ;(kvs sym) :meta (merge (or (sym :meta) {}) m))) -(defn h-make-set [items] # set form - {:jolt/type :jolt/set :value (tuple/slice (jvec->array items))}) -(defn h-make-tagged [tag form] # tagged form (#inst/#uuid/#regex/#foo) - {:jolt/type :jolt/tagged :tag tag :form form}) -# A fresh unique name string for #() auto-gensym params (the reader appends '#'). -(defn h-gensym-name [] (string (gensym))) - -(def- exports - {"form-sym?" h-sym? "form-sym-name" h-sym-name "form-sym-ns" h-sym-ns - "form-make-symbol" h-make-symbol "form-make-char" h-make-char - "form-char-from-name" h-char-from-name "form-scan-number" h-scan-number - "form-make-list" h-make-list "form-make-vector" h-make-vector - "form-make-map" h-make-map "form-sym-merge-meta" h-sym-merge-meta - "form-make-set" h-make-set "form-make-tagged" h-make-tagged - "form-gensym-name" h-gensym-name - "ref-put!" h-ref-put! - "ref-get" h-ref-get - "tagged-table" h-tagged-table - "form-sym-meta" h-sym-meta - "form-list?" h-list? "form-vec?" h-vector? "form-map?" h-map? - "form-set?" h-set? "form-char?" h-char? "form-char-code" h-char-code "form-literal?" h-literal? - "form-regex?" h-regex? "form-regex-source" h-regex-source - "form-inst?" h-inst? "form-inst-source" h-inst-source - "form-uuid?" h-uuid? "form-uuid-source" h-uuid-source - "form-elements" h-elements "form-vec-items" h-vector-items - "form-map-pairs" h-map-pairs "form-set-items" h-set-items - "form-special?" h-special? "compile-ns" h-current-ns "form-macro?" h-macro? - "form-expand-1" h-expand-1 "resolve-global" h-resolve-global - "form-syntax-quote-lower" h-syntax-quote-lower - "host-intern!" h-intern! - "inline-enabled?" h-inline-enabled? "inline-ir" h-inline-ir - "record-type?" h-record-type? "form-position" h-form-position - "record-ctor-key" h-record-ctor-key "record-shapes" h-record-shapes - "late-bind?" h-late-bind?}) - -(defn install! [ctx] - (def ns (ctx-find-ns ctx "jolt.host")) - (eachp [nm f] exports (ns-intern ns nm f)) - ns) diff --git a/src/jolt/host_interop.janet b/src/jolt/host_interop.janet deleted file mode 100644 index 1bd9b41..0000000 --- a/src/jolt/host_interop.janet +++ /dev/null @@ -1,19 +0,0 @@ -# Host interop aggregator (jolt-jx5l, phase 1 subdir split). -# -# The JVM class/method shim surface that portable cljc libraries call now lives in -# src/jolt/interop/ split by area: java_base (java.lang statics + java.time + -# shared coercion helpers), host_io (java.io/util/net/sql/text), collections -# (the late-bound .iterator/.nth/... hooks over jolt values). The registry -# MACHINERY (class-statics / tagged-methods / register-*!) still lives in the -# evaluator, which loads before this module — so the registries exist before any -# install! runs here. -# -# api imports this module (import ./host_interop) to trigger registration at load. -# Adding a JDK-area shim is now a one-file change under interop/ plus a line here. -(use ./interop/java_base) -(use ./interop/host_io) -(use ./interop/collections) - -(install!) -(install-io!) -(install-collections!) diff --git a/src/jolt/interop/collections.janet b/src/jolt/interop/collections.janet deleted file mode 100644 index 665d6a6..0000000 --- a/src/jolt/interop/collections.janet +++ /dev/null @@ -1,49 +0,0 @@ -# Host interop — collection interop: wires the evaluator's late-bound hooks to -# core's collection ops so Java-style interop (.iterator/.nth/.count/.seq/...) -# works over jolt values. Split from host_interop.janet (jolt-jx5l, phase 1). -# Late-bound because the evaluator loads before core. -(use ../evaluator) -(use ../core) -(use ../types) -(use ../lazyseq) -(use ../pv) -(use ../plist) -(import ../phm) - -# Collection interop: wires the evaluator's late-bound hooks to core's -# collection ops so Java-style interop works over jolt values (moved here from -# api — jolt-jx5l). Late-bound because the evaluator loads before core. -(defn install-collections! [] - # (.iterator coll) -> a jolt iterator over any seqable (hiccup's iterate!). - (set-coll-realizer! realize-for-iteration) - # clj-targeted libs build collections via JVM statics in their :clj branches; - # malli's entry parser uses these. createOwning takes ownership of an object - # array -> a vector; createWithCheck builds a map and throws on duplicate keys - # (malli catches that), detected by the built map being smaller than the kvs. - (register-class-statics! "LazilyPersistentVector" - @{"createOwning" (fn [arr] (make-vec arr))}) - (register-class-statics! "PersistentArrayMap" - @{"createWithCheck" - (fn [arr] - (def m (phm/make-phm arr)) - (if (= (* 2 (phm/phm-count m)) (length arr)) m - (error "PersistentArrayMap: duplicate key")))}) - # .nth/.count/.valAt/.get/.seq/.containsKey on a jolt collection -> the - # clojure.core equivalent. :jolt/ci-none means "not a collection method here". - (set-coll-interop! - (fn [target name args] - (if-not (or (pvec? target) (phm/phm? target) (plist? target) (lazy-seq? target) - (and (table? target) (= :jolt/set (get target :jolt/type))) - (shape-rec? target) # map-as-tuple record - (and (struct? target) (nil? (get target :jolt/type)))) # plain map literal - :jolt/ci-none - (cond - (= name "nth") (if (>= (length args) 2) (core-nth target (in args 0) (in args 1)) - (core-nth target (in args 0))) - (= name "count") (core-count target) - (or (= name "valAt") (= name "get")) - (if (>= (length args) 2) (core-get target (in args 0) (in args 1)) - (core-get target (in args 0))) - (= name "seq") (core-seq target) - (= name "containsKey") (core-contains? target (in args 0)) - :jolt/ci-none))))) diff --git a/src/jolt/interop/host_io.janet b/src/jolt/interop/host_io.janet deleted file mode 100644 index 4186233..0000000 --- a/src/jolt/interop/host_io.janet +++ /dev/null @@ -1,537 +0,0 @@ -# Host interop — java.io / java.util / java.net / java.sql / java.text shims that -# carry portable cljc libraries (Selmer's char-by-char reader, ring-codec, -# migratus, yogthos/config). Split from host_interop.janet (jolt-jx5l, phase 1). -# install-io! registers them; depends on java_base for the shared chr/pad2 -# coercion helpers and the java.time `formatter` (SimpleDateFormat et al.). -(use ../evaluator) -(use ../regex) -(use ../core) -(use ../pv) -(use ../plist) -(use ../types) -(use ../lazyseq) -(import ../phm) -(use ./java_base) - -# --- java.io / java.lang shims (Selmer's template reader) --------------------- - -(defn- string-reader [src] - # :close makes with-open's __close happy (it calls (get x :close) when - # present); :read-line-fn matches the 50-io reader convention so line-seq - # works over readers io/reader hands back - (def self @{:jolt/type :jolt/jio-string-reader :s (string src) :pos 0 - :close (fn [] nil)}) - (put self :read-line-fn - (fn [] - (def {:s s :pos pos} self) - (when (< pos (length s)) - (def i (string/find "\n" s pos)) - (if (nil? i) - (do (put self :pos (length s)) (string/slice s pos)) - (do (put self :pos (+ i 1)) (string/slice s pos i)))))) - self) -(defn- string-builder [&opt init] - # a numeric arg is a CAPACITY (java.lang.StringBuilder(int)), not content - @{:jolt/type :jolt/string-builder - :buf (cond (nil? init) @"" (number? init) (buffer/new init) (buffer init))}) - -(defn make-string-writer [] - # :close lets with-open close the writer (core-close-resource calls :close); - # it's a no-op so .toString after with-open still sees the buffer. - @{:jolt/type :jolt/writer :buf @"" :sink nil :close (fn [] nil)}) -(defn make-out-writer [] - @{:jolt/type :jolt/writer :buf nil :sink prin}) - -(defn- render-piece [x] - (cond - (nil? x) "null" - (and (struct? x) (= :jolt/char (get x :jolt/type))) (string/from-bytes (x :ch)) - (string x))) - -# Writer.write(int) writes the CHAR for that code (unlike StringBuilder.append(int), -# which appends the int's digits). jolt chars are bytes, so this round-trips UTF-8 -# byte-for-byte with readLine. -(defn- writer-piece [x] - (if (number? x) (string/from-bytes (math/trunc x)) (render-piece x))) - -# Read one unit from any reader-ish value: our shims dispatch through their -# tagged "read"; a janet core/file reads one byte. -1 at EOF. -(defn- read-unit [r] - (cond - (and (or (table? r) (struct? r)) (get r :jolt/type)) - (((get tagged-methods (r :jolt/type)) "read") r) - (= :core/file (type r)) - (let [b (file/read r 1)] (if (or (nil? b) (= 0 (length b))) -1 (b 0))) - (error (string "not a reader: " (type r))))) - -(defn- pushback-reader [rdr] - # java.io.PushbackReader: read delegates to the wrapped reader unless - # something was unread; unread takes a char (or char code) and pushes it back - (def self @{:jolt/type :jolt/pushback-reader :rdr rdr :pushed @[] - :close (fn [] nil)}) - self) - -(defn install-io! [] - (register-tagged-methods! :jolt/pushback-reader - @{"read" (fn [self] - (if (> (length (self :pushed)) 0) - (array/pop (self :pushed)) - (read-unit (self :rdr)))) - "unread" (fn [self ch] - (array/push (self :pushed) - (if (number? ch) ch (get ch :ch))) - nil) - "close" (fn [self] nil)}) - (register-tagged-methods! :jolt/jio-string-reader - @{"read" (fn [self] - (if (>= (self :pos) (length (self :s))) - -1 - (let [b ((self :s) (self :pos))] - (put self :pos (+ 1 (self :pos))) - b))) - "readLine" (fn [self] ((self :read-line-fn))) - "mark" (fn [self &opt limit] (put self :marked (self :pos)) nil) - "reset" (fn [self] (put self :pos (or (self :marked) 0)) nil) - "skip" (fn [self n] (put self :pos (min (length (self :s)) (+ (self :pos) n))) n) - "close" (fn [self] nil)}) - # java.io.Writer / StringWriter — the print-method protocol surface - # (jolt-g1r). A writer either pushes to a sink fn (stdout/custom) or - # accumulates in a buffer (StringWriter). write/append coerce chars the - # same way StringBuilder does. - (register-tagged-methods! :jolt/writer - @{"write" (fn [self x] - (if (self :sink) - ((self :sink) (writer-piece x)) - (buffer/push-string (self :buf) (writer-piece x))) - nil) - "append" (fn [self x] - (if (self :sink) - ((self :sink) (render-piece x)) - (buffer/push-string (self :buf) (render-piece x))) - self) - "flush" (fn [self] nil) - "close" (fn [self] nil) - "toString" (fn [self] (string (or (self :buf) "")))}) - (register-tagged-methods! :jolt/string-builder - @{"append" (fn [self x] (buffer/push (self :buf) (render-piece x)) self) - "toString" (fn [self] (string (self :buf))) - "length" (fn [self] (length (self :buf))) - "setLength" (fn [self n] - (def buf (self :buf)) - (if (< n (length buf)) - (buffer/popn buf (- (length buf) n)) - (while (< (length buf) n) (buffer/push buf "\0"))) - nil) - "charAt" (fn [self i] {:jolt/type :jolt/char :ch ((self :buf) i)})}) - (each nm ["File" "java.io.File"] - (register-class-statics! nm @{"separator" "/" "separatorChar" {:jolt/type :jolt/char :ch 47}})) - (register-class-statics! "Boolean" - @{"parseBoolean" (fn [s] (= "true" (string/ascii-lower (string s)))) - "TRUE" true "FALSE" false}) - (register-class-statics! "Class" - @{"forName" (fn [nm] @{:jolt/type :jolt/class :name nm})}) - (each nm ["StringReader" "java.io.StringReader"] - (register-class-ctor! nm string-reader)) - (each nm ["StringBuilder" "java.lang.StringBuilder"] - (register-class-ctor! nm string-builder)) - (each nm ["StringWriter" "java.io.StringWriter"] - (register-class-ctor! nm make-string-writer)) - # --- java.net / java.util surface for ring-codec (ring-core enablement) --- - # URLEncoder/URLDecoder: www-form-urlencoded (space <-> +, %XX bytes, - # [A-Za-z0-9.*_-] literal). Charset args are accepted and ignored beyond - # the name (everything is UTF-8 bytes here). - (defn- url-unreserved? [b] - (or (and (>= b 48) (<= b 57)) (and (>= b 65) (<= b 90)) - (and (>= b 97) (<= b 122)) (= b 46) (= b 42) (= b 95) (= b 45))) - (defn- url-encode-www [s & _] - (def out @"") - (each b (string/bytes (string s)) - (cond - (url-unreserved? b) (buffer/push-byte out b) - (= b 32) (buffer/push-string out "+") - (buffer/push-string out (string/format "%%%02X" b)))) - (string out)) - (defn- hexv [b] - (cond (and (>= b 48) (<= b 57)) (- b 48) - (and (>= b 65) (<= b 70)) (- b 55) - (and (>= b 97) (<= b 102)) (- b 87) - (error "URLDecoder: malformed escape"))) - (defn- url-decode-www [s & _] - (def bytes (string/bytes (string s))) - (def n (length bytes)) - (def out @"") - (var i 0) - (while (< i n) - (def b (in bytes i)) - (cond - (= b 43) (do (buffer/push-string out " ") (++ i)) - (= b 37) (if (< (+ i 2) n) - (do (buffer/push-byte out (+ (* 16 (hexv (in bytes (+ i 1)))) (hexv (in bytes (+ i 2))))) - (+= i 3)) - (error "URLDecoder: incomplete escape")) - (do (buffer/push-byte out b) (++ i)))) - (string out)) - (each nm ["URLEncoder" "java.net.URLEncoder"] - (register-class-statics! nm @{"encode" url-encode-www})) - (each nm ["URLDecoder" "java.net.URLDecoder"] - (register-class-statics! nm @{"decode" url-decode-www})) - (each nm ["Charset" "java.nio.charset.Charset"] - (register-class-statics! nm @{"forName" (fn [nm*] @{:jolt/type :jolt/charset :name nm*})})) - # Base64 (RFC 4648): encoder/decoder singletons with encode/decode methods. - (def- b64-alphabet "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") - (defn- b64-encode [bs] - (def bytes (if (bytes? bs) bs (string bs))) - (def n (length bytes)) - (def out @"") - (var i 0) - (while (< i n) - (def b0 (in bytes i)) - (def b1 (if (< (+ i 1) n) (in bytes (+ i 1)))) - (def b2 (if (< (+ i 2) n) (in bytes (+ i 2)))) - (buffer/push-byte out (in b64-alphabet (brshift b0 2))) - (buffer/push-byte out (in b64-alphabet (bor (blshift (band b0 3) 4) (brshift (or b1 0) 4)))) - (buffer/push-string out (if (nil? b1) "=" (string/from-bytes (in b64-alphabet (bor (blshift (band b1 0xf) 2) (brshift (or b2 0) 6)))))) - (buffer/push-string out (if (nil? b2) "=" (string/from-bytes (in b64-alphabet (band b2 0x3f))))) - (+= i 3)) - (string out)) - (def- b64-rev (do (def t @{}) (eachp [i c] b64-alphabet (put t c i)) t)) - (defn- b64-decode [s] - (def cleaned (string/replace-all "=" "" (string s))) - (def out @"") - (var acc 0) (var bits 0) - (each c (string/bytes cleaned) - (def v (get b64-rev c)) - (when (nil? v) (error "Base64: illegal character")) - (set acc (bor (blshift acc 6) v)) - (+= bits 6) - (when (>= bits 8) - (-= bits 8) - (buffer/push-byte out (band (brshift acc bits) 0xff)))) - out) - (register-tagged-methods! :jolt/base64-encoder @{"encode" (fn [self bs] (b64-encode bs)) "encodeToString" (fn [self bs] (b64-encode bs))}) - (register-tagged-methods! :jolt/base64-decoder @{"decode" (fn [self s] (b64-decode s))}) - (each nm ["Base64" "java.util.Base64"] - (register-class-statics! nm - @{"getEncoder" (fn [] @{:jolt/type :jolt/base64-encoder}) - "getDecoder" (fn [] @{:jolt/type :jolt/base64-decoder})})) - # Integer statics: valueOf with optional radix. Returns a plain number — - # byteValue/intValue live on the number method surface in the evaluator. - (register-class-statics! "Integer" - @{"valueOf" (fn [x &opt radix] - (cond - (number? x) x - (nil? radix) (or (scan-number (string x)) (error (string "NumberFormatException: " x))) - (= radix 16) (or (scan-number (string "16r" x)) (error (string "NumberFormatException: " x))) - (= radix 8) (or (scan-number (string "8r" x)) (error (string "NumberFormatException: " x))) - (= radix 2) (or (scan-number (string "2r" x)) (error (string "NumberFormatException: " x))) - (error (string "Integer/valueOf: unsupported radix " radix)))) - "parseInt" (fn [x &opt radix] - (or (scan-number (string (case radix 16 "16r" 8 "8r" 2 "2r" "") x)) - (error (string "NumberFormatException: " x)))) - "MAX_VALUE" 2147483647 - "MIN_VALUE" -2147483648}) - # StringTokenizer: eager split on any delimiter char, empty tokens skipped. - (defn- tokenize [s delims] - (def dset @{}) - (each b (string/bytes delims) (put dset b true)) - (def toks @[]) - (def cur @"") - (each b (string/bytes (string s)) - (if (get dset b) - (when (> (length cur) 0) (array/push toks (string cur)) (buffer/clear cur)) - (buffer/push-byte cur b))) - (when (> (length cur) 0) (array/push toks (string cur))) - toks) - (register-tagged-methods! :jolt/string-tokenizer - @{"hasMoreTokens" (fn [self] (< (self :pos) (length (self :toks)))) - "countTokens" (fn [self] (- (length (self :toks)) (self :pos))) - "nextToken" (fn [self] - (if (< (self :pos) (length (self :toks))) - (let [t (in (self :toks) (self :pos))] - (put self :pos (+ 1 (self :pos))) t) - (error "NoSuchElementException")))}) - (each nm ["StringTokenizer" "java.util.StringTokenizer"] - (register-class-ctor! nm (fn [s &opt delims] - @{:jolt/type :jolt/string-tokenizer - :toks (tokenize s (or delims " \t\n\r\f")) - :pos 0}))) - # clojure.lang.MapEntry: a 2-tuple, jolt's map-entry representation. - # java.util.HashMap: a mutable wrapper over a janet table, keyed by canonical - # key (so jolt collection keys compare by value). reitit uses it as a fast - # read cache: (HashMap. m) copies a map's entries, (.get hm k) reads. - # raw value-keys: reitit's HashMap keys are strings/keywords/tuples, all of - # which janet tables key by value — no canonicalization needed here. - (defn- hm-entries [m] - (cond (phm/phm? m) (phm/phm-entries m) - (struct? m) (pairs m) - (table? m) (pairs m) - @[])) - (register-tagged-methods! :jolt/hashmap - @{"get" (fn [self k] (get (self :tbl) k)) - "put" (fn [self k v] (put (self :tbl) k v) v) - "putAll" (fn [self m] (each pair (hm-entries m) (put (self :tbl) (in pair 0) (in pair 1))) nil) - "containsKey" (fn [self k] (not (nil? (get (self :tbl) k)))) - "size" (fn [self] (length (self :tbl)))}) - (each nm ["HashMap" "java.util.HashMap"] - # java.util.HashMap constructors: (), (initialCapacity), (initialCapacity, - # loadFactor) all start empty; (Map m) copies entries. A numeric first arg is - # a capacity (sizing hint we ignore), not content. - (register-class-ctor! nm - (fn [& args] - (def tbl @{}) - (def init (if (> (length args) 0) (in args 0) nil)) - (when (and init (not (number? init))) - (each pair (hm-entries init) (put tbl (in pair 0) (in pair 1)))) - @{:jolt/type :jolt/hashmap :tbl tbl}))) - (each nm ["MapEntry" "clojure.lang.MapEntry"] - (register-class-ctor! nm (fn [k v] [k v]))) - # (String. bytes) / (String. bytes charset): UTF-8 bytes to string. - (each nm ["String" "java.lang.String"] - (register-class-ctor! nm (fn [x &opt charset] (string x)))) - # String statics. valueOf(Object) yields "null" for nil, else toString — - # hiccup's compiler emits (String/valueOf (or arg "")) to stringify attribute - # values; core-str gives jolt's str semantics for keywords/numbers/etc. - (each nm ["String" "java.lang.String"] - (register-class-statics! nm - @{"valueOf" (fn [x &opt off cnt] (if (nil? x) "null" (core-str x)))})) - # java.net.URL: enough for selmer's template cache — file: URLs only. - # A protocol-less spec throws (selmer catches MalformedURLException and - # prepends file:///), and getPath hands back a stat-able filesystem path. - (defn url-path [spec] - (var p (if (string/has-prefix? "file:" spec) (string/slice spec 5) spec)) - (while (and (> (length p) 1) (string/has-prefix? "//" p)) - (set p (string/slice p 1))) - p) - (register-tagged-methods! :jolt/url - @{"getPath" (fn [self] (url-path (self :spec))) - "getFile" (fn [self] (url-path (self :spec))) - "toString" (fn [self] (self :spec)) - "toExternalForm" (fn [self] (self :spec))}) - (each nm ["URL" "java.net.URL"] - (register-class-ctor! nm - (fn [spec & _] - (def s (string spec)) - (def colon (string/find ":" s)) - (if (or (nil? colon) (= colon 0) - (string/find "/" (string/slice s 0 colon))) - (error (string "MalformedURLException: no protocol: " s)) - @{:jolt/type :jolt/url :spec s})))) - (each nm ["PushbackReader" "java.io.PushbackReader"] - (register-class-ctor! nm (fn [rdr &opt size] (pushback-reader rdr)))) - (each nm ["BigInteger" "java.math.BigInteger"] - (register-class-ctor! nm - (fn [v] - (or (scan-number (string/trim (string v))) - (error (string "NumberFormatException: For input string: \"" v "\"")))))) - (each nm ["Locale" "java.util.Locale"] - (register-class-ctor! nm (fn [id &opt _country] @{:jolt/type :jolt/locale :id (string id)}))) - # java.util.regex.Pattern statics: Pattern/compile, Pattern/quote, Pattern/MULTILINE. - # Pattern/compile returns jolt's native :jolt/regex compiled value so that - # str/replace, re-matches, .split etc accept it transparently. - (defn- pattern-quote [s] - (def meta "\\.[]{}()*+-?^$|&") - (def buf @"") - (var i 0) - (while (< i (length s)) - (def c (s i)) - (if (string/find (string/from-bytes c) meta) - (buffer/push buf (chr "\\"))) - (buffer/push buf (string/from-bytes c)) - (++ i)) - (string buf)) - (def pattern-multiline 8) - (each nm ["Pattern" "java.util.regex.Pattern"] - (register-class-statics! nm - @{"compile" (fn [s &opt flags] - (if (and flags (= (band flags pattern-multiline) pattern-multiline)) - (re-pattern (string "(?m)" s)) - (re-pattern s))) - "quote" (fn [s] (pattern-quote s)) - "MULTILINE" pattern-multiline})) - # .split on compiled regex values: delegates to re-split, drops trailing empties - (register-tagged-methods! :jolt/regex - @{"split" (fn [self s &opt limit] - (def parts (re-split self s)) - (while (and (> (length parts) 0) (= "" (last parts))) - (array/pop parts)) - parts)}) - # JVM exception constructors: (Exception. msg), (IllegalArgumentException. msg), - # (InterruptedException. msg). Return the message string so getMessage works. - (each nm ["Exception" "java.lang.Exception"] - (register-class-ctor! nm (fn [msg] (string msg)))) - (each nm ["IllegalArgumentException" "java.lang.IllegalArgumentException"] - (register-class-ctor! nm (fn [msg] (string msg)))) - (each nm ["InterruptedException" "java.lang.InterruptedException"] - (register-class-ctor! nm (fn [msg] (string msg)))) - # Character class statics (ASCII — the engine is byte-based). - (register-class-statics! "Character" - @{"isUpperCase" (fn [ch] (and (>= (ch :ch) 65) (<= (ch :ch) 90))) - "isLowerCase" (fn [ch] (and (>= (ch :ch) 97) (<= (ch :ch) 122)))}) - # java.net.URI constructor: stores the spec string, rounds-trips through str. - (each nm ["URI" "java.net.URI"] - (register-class-ctor! nm (fn [spec] (string spec)))) - # java.util.Date: millis-valued instants; no-arg = now. - (defn- make-date [&opt ms] - @{:jolt/type :jolt/date :ms (or ms (math/floor (* 1000 (os/clock :realtime))))}) - (each nm ["Date" "java.util.Date"] - (register-class-ctor! nm make-date)) - (register-tagged-methods! :jolt/date - @{"getTime" (fn [self] (self :ms)) - "toString" (fn [self] (string (self :ms)))}) - # java.util.TimeZone: getTimeZone(id) -> a tz value. - (defn- make-tz [id] @{:jolt/type :jolt/tz :id (string id)}) - (register-class-statics! "TimeZone" - @{"getTimeZone" (fn [id] (make-tz id))}) - (register-class-statics! "java.util.TimeZone" - @{"getTimeZone" (fn [id] (make-tz id))}) - # java.text.SimpleDateFormat: minimal formatter supporting y M d H m s tokens. - # (pad2 is the module-level helper above.) - (defn- sdf-format [pattern ms utc?] - (def d (os/date (math/floor (/ ms 1000)) (not utc?))) - (def out @"") - (var i 0) - (while (< i (length pattern)) - (def c (pattern i)) - (def k (do (var j i) - (while (and (< j (length pattern)) (= (pattern j) c)) (++ j)) - (- j i))) - (cond - (= c (chr "y")) (do (buffer/push out (if (>= k 4) (string (d :year)) (pad2 (mod (d :year) 100)))) (+= i k)) - (= c (chr "M")) (do (buffer/push out (if (= k 1) (string (+ 1 (d :month))) (pad2 (+ 1 (d :month))))) (+= i k)) - (= c (chr "d")) (do (buffer/push out (if (= k 1) (string (+ 1 (d :month-day))) (pad2 (+ 1 (d :month-day))))) (+= i k)) - (= c (chr "H")) (do (buffer/push out (if (= k 1) (string (d :hours)) (pad2 (d :hours)))) (+= i k)) - (= c (chr "m")) (do (buffer/push out (if (= k 1) (string (d :minutes)) (pad2 (d :minutes)))) (+= i k)) - (= c (chr "s")) (do (buffer/push out (if (= k 1) (string (d :seconds)) (pad2 (d :seconds)))) (+= i k)) - (do (buffer/push out (string/from-bytes c)) (++ i)))) - (string out)) - (defn- make-sdf [pattern] - @{:jolt/type :jolt/sdf :pattern pattern :utc true}) - (each nm ["SimpleDateFormat" "java.text.SimpleDateFormat"] - (register-class-ctor! nm make-sdf)) - (register-tagged-methods! :jolt/sdf - @{"setTimeZone" (fn [self tz] - (put self :utc (= "UTC" (get tz :id))) - self) - "format" (fn [self date] - (sdf-format (self :pattern) (date :ms) (self :utc)))}) - # Thread stub: getContextClassLoader returns a stub so migratus jar/create code - # that walks Thread/currentThread doesn't crash. - (register-tagged-methods! :jolt/thread - @{"getContextClassLoader" (fn [self] @{:jolt/type :jolt/classloader})}) - # ClassLoader degrade (jolt-hjw): there is no classpath, so getResource returns - # nil and migratus's find-migration-dir falls through to the filesystem branch - # (resources/). getSystemClassLoader yields the same stub. - (each nm ["ClassLoader" "java.lang.ClassLoader"] - (register-class-statics! nm @{"getSystemClassLoader" (fn [] @{:jolt/type :jolt/classloader})})) - # No STM on jolt: a transaction is never running, so logging libraries that - # gate agent-vs-direct on it (clojure.tools.logging/log*) always log directly. - (register-class-statics! "clojure.lang.LockingTransaction" @{"isRunning" (fn [] false)}) - (register-tagged-methods! :jolt/classloader - @{"getResource" (fn [self path] nil) - "getResources" (fn [self path] nil) - "getResourceAsStream" (fn [self path] nil)}) - # next.jdbc host shims (paired with the __jdbc-* builtins in core.janet and the - # instance? Connection case in evaluator.janet). The wrapped connection carries - # a clj :exec callback (run one SQL string) and a :close callback. - # java.sql.Timestamp: migratus builds (Timestamp. millis) for the applied - # column; represent it as the millis number so it stores and sorts directly. - (each nm ["Timestamp" "java.sql.Timestamp"] - (register-class-ctor! nm (fn [ms] ms))) - (register-tagged-methods! :jolt/jdbc-conn - @{"setAutoCommit" (fn [self _] self) - "isClosed" (fn [self] (get (get self :closed) 0)) - "close" (fn [self] - (unless (get (get self :closed) 0) - ((get self :close)) - (put (get self :closed) 0 true)) - nil) - "getMetaData" (fn [self] @{:jolt/type :jolt/jdbc-meta :product (get self :product)})}) - (register-tagged-methods! :jolt/jdbc-meta - @{"getDatabaseProductName" (fn [self] (get self :product))}) - # Statement batch: addBatch accumulates SQL strings, executeBatch runs each via - # the connection's clj :exec callback (which executes inside the transaction). - (register-tagged-methods! :jolt/jdbc-stmt - @{"addBatch" (fn [self sql] (array/push (get self :cmds) sql) nil) - "executeBatch" (fn [self] - (def out @[]) - (each c (get self :cmds) (array/push out ((get self :exec) c))) - out) - "close" (fn [self] nil)}) - # java.io.File model (jolt-hjw). A :jolt/file carries its path; io/file and the - # File. ctor build it (see core.janet's __make-file). The method surface below - # is backed by os/ and file/. listFiles returns child :jolt/file values so - # file-seq (File-aware) yields :jolt/file leaves migratus can call methods on. - (defn- jfile-path [x] - (if (and (table? x) (= :jolt/file (get x :jolt/type))) (get x :path) (string x))) - (defn- make-jfile [path &opt child] - @{:jolt/type :jolt/file - :path (if child (string (jfile-path path) "/" (jfile-path child)) (jfile-path path))}) - (defn- last-slash [p] - (var idx nil) (var i 0) - (while (< i (length p)) (when (= (p i) 47) (set idx i)) (++ i)) - idx) - (defn- jfile-name [p] - (if-let [i (last-slash p)] (string/slice p (+ i 1)) p)) - (defn- jfile-abs [p] - (if (string/has-prefix? "/" p) p (string (os/cwd) "/" p))) - (each nm ["File" "java.io.File"] - (register-class-ctor! nm make-jfile)) - (register-tagged-methods! :jolt/file - @{"getPath" (fn [self] (get self :path)) - "toString" (fn [self] (get self :path)) - "getName" (fn [self] (jfile-name (get self :path))) - "getParent" (fn [self] (let [p (get self :path)] - (if-let [i (last-slash p)] (string/slice p 0 i) nil))) - "getAbsolutePath" (fn [self] (jfile-abs (get self :path))) - "getCanonicalPath" (fn [self] (jfile-abs (get self :path))) - "getAbsoluteFile" (fn [self] (make-jfile (jfile-abs (get self :path)))) - "exists" (fn [self] (not (nil? (os/stat (get self :path))))) - "isFile" (fn [self] (= :file (os/stat (get self :path) :mode))) - "isDirectory" (fn [self] (= :directory (os/stat (get self :path) :mode))) - "canRead" (fn [self] (not (nil? (os/stat (get self :path))))) - # listFiles: child File values, or nil when not a directory (Clojure null) - "listFiles" (fn [self] - (let [p (get self :path)] - (when (= :directory (os/stat p :mode)) - (map (fn [e] (make-jfile p e)) (os/dir p))))) - "list" (fn [self] - (let [p (get self :path)] - (when (= :directory (os/stat p :mode)) (os/dir p)))) - "toPath" (fn [self] @{:jolt/type :jolt/nio-path :s (get self :path)}) - "toURI" (fn [self] (string "file:" (jfile-abs (get self :path)))) - "toURL" (fn [self] @{:jolt/type :jolt/url :spec (string "file:" (jfile-abs (get self :path)))}) - "delete" (fn [self] (let [r (protect (os/rm (get self :path)))] (truthy? (r 0)))) - "mkdir" (fn [self] (truthy? ((protect (os/mkdir (get self :path))) 0))) - "mkdirs" (fn [self] (truthy? ((protect (os/mkdir (get self :path))) 0))) - "createNewFile" (fn [self] - (let [p (get self :path)] - (if (os/stat p) false - (do (def f (file/open p :w)) (file/close f) true)))) - "equals" (fn [self o] (and (table? o) (= (get self :path) (get o :path)))) - "hashCode" (fn [self] (hash (get self :path)))}) - # java.nio.file degrade for migratus's script-excluded? glob check: just enough - # of Path / FileSystem / PathMatcher to match a filename against a glob, with a - # simple recursive * / ? matcher (no path-segment semantics — filenames only). - (defn- glob-matches? [glob s] - (defn m [gi si] - (cond - (= gi (length glob)) (= si (length s)) - (= (glob gi) 42) # * - (or (m (+ gi 1) si) - (and (< si (length s)) (m gi (+ si 1)))) - (and (< si (length s)) - (or (= (glob gi) 63) (= (glob gi) (s si)))) # ? or literal - (m (+ gi 1) (+ si 1)) - false)) - (m 0 0)) - (register-tagged-methods! :jolt/nio-path - @{"getFileSystem" (fn [self] @{:jolt/type :jolt/nio-fs}) - "toString" (fn [self] (get self :s))}) - (register-tagged-methods! :jolt/nio-fs - @{"getPath" (fn [self s & _] @{:jolt/type :jolt/nio-path :s s}) - "getPathMatcher" (fn [self spec] - @{:jolt/type :jolt/nio-matcher - :glob (if (string/has-prefix? "glob:" spec) - (string/slice spec 5) spec)})}) - (register-tagged-methods! :jolt/nio-matcher - @{"matches" (fn [self path] (glob-matches? (get self :glob) (get path :s)))})) diff --git a/src/jolt/interop/java_base.janet b/src/jolt/interop/java_base.janet deleted file mode 100644 index 5488545..0000000 --- a/src/jolt/interop/java_base.janet +++ /dev/null @@ -1,250 +0,0 @@ -# Host interop — java.lang static surfaces (Math/Thread/System/Long) + the -# java.time shim (epoch-ms values + a DateTimeFormatter pattern subset). Split -# from host_interop.janet (jolt-jx5l, phase 1). Everything registers through the -# evaluator's class-statics / tagged-methods registries via install!. Also the -# home of the shared coercion helpers (chr/pad2) that host_io reuses. -(use ../evaluator) -(use ../regex) -(use ../core) -(use ../pv) -(use ../plist) -(use ../types) -(use ../lazyseq) -(import ../phm) - -(defn chr [s] (get s 0)) - -# --- java.lang static surfaces (Math/Thread/System/Long) ---------------------- -# Registered through the generic class-statics registry below, same as every -# other class — there is no special-case dispatch (jolt-jx5l). -(def- math-statics - @{"sqrt" math/sqrt "pow" math/pow "floor" math/floor "ceil" math/ceil - "abs" (fn [x] (if (< x 0) (- x) x)) - "round" (fn [x] (math/round x)) - "sin" math/sin "cos" math/cos "tan" math/tan - "asin" math/asin "acos" math/acos "atan" math/atan - "log" math/log "log10" math/log10 "exp" math/exp - "max" (fn [a b] (if (> a b) a b)) "min" (fn [a b] (if (< a b) a b)) - "signum" (fn [x] (cond (< x 0) -1.0 (> x 0) 1.0 0.0)) - "PI" math/pi "E" math/e - "random" (fn [&] (math/random))}) - -# sleep parks the CURRENT thread's event loop — inside a future body that's the -# worker OS thread (ev/spawn-thread gives each worker its own loop), so a -# sleeping future doesn't block the parent. -(def- thread-statics - {"sleep" (fn [ms] (ev/sleep (/ ms 1000)) nil) - "yield" (fn [] (ev/sleep 0) nil) - "interrupted" (fn [] false) - "currentThread" (fn [] @{:jolt/type :jolt/thread :id "main"})}) - -# wall/monotonic clocks + properties/env (what portable timing/config code uses). -(def- system-statics - # realtime clock (sub-ms float epoch seconds) — os/time is whole seconds, - # which quantized every elapsed-time measurement to 1000ms. - {"currentTimeMillis" (fn [] (math/floor (* 1000 (os/clock :realtime)))) - "nanoTime" (fn [] (math/floor (* 1e9 (os/clock :monotonic)))) - "getProperty" (fn [k &opt dflt] - (case k - "os.name" (case (os/which) - :windows "Windows" :macos "Mac OS X" "Linux") - "line.separator" "\n" - "file.separator" "/" - "user.dir" (os/cwd) - "user.home" (os/getenv "HOME") - "java.io.tmpdir" (or (os/getenv "TMPDIR") "/tmp") - dflt)) - # JOLT_BAKE_ENV_ALLOWLIST (jolt-s3j): during an image bake (jpm build of a - # native executable, set by the project's build.sh) the env snapshot that - # libraries like config.core capture at load gets MARSHALED INTO THE BINARY - # — GitHub push protection once flagged real API tokens inside an example's - # build output. With the var set, System/getenv serves only the listed - # comma-separated names (single-var reads of unlisted names return nil), so - # nothing secret can bake. Unset (the normal runtime case), reads are live - # and unfiltered. - "getenv" (fn [&opt k] - (def allow (os/getenv "JOLT_BAKE_ENV_ALLOWLIST")) - (if (nil? allow) - (if k (os/getenv k) (os/environ)) - (let [names (string/split "," allow) - ok @{}] - (each n names (put ok (string/trim n) true)) - (if k - (when (get ok k) (os/getenv k)) - (let [e (os/environ) out @{}] - (eachp [ek ev] e (when (get ok ek) (put out ek ev))) - out))))) - # the property subset getProperty serves, as an iterable map - "getProperties" (fn [] - {"os.name" (case (os/which) - :windows "Windows" :macos "Mac OS X" "Linux") - "line.separator" "\n" - "file.separator" "/" - "user.dir" (os/cwd) - "user.home" (or (os/getenv "HOME") "") - "java.io.tmpdir" (or (os/getenv "TMPDIR") "/tmp")}) - # terminate the process with the given status code - "exit" (fn [&opt status] (os/exit (if (nil? status) 0 status)))}) - -# sentinels portable code compares against. jolt numbers are doubles, so these -# are the f64 approximations. -(def- long-statics - {"MAX_VALUE" 9223372036854775807 - "MIN_VALUE" -9223372036854775808 - "parseLong" (fn [s &opt radix] - (def n (scan-number (string/trim (string s)) (or radix 10))) - (if (and n (= n (math/floor n))) - n - (error (string "NumberFormatException: For input string: \"" s "\"")))) - "valueOf" (fn [s &opt radix] - (def n (scan-number (string/trim (string s)) (or radix 10))) - (if (and n (= n (math/floor n))) - n - (error (string "NumberFormatException: For input string: \"" s "\""))))}) - -# --- values ------------------------------------------------------------------- - -(defn- instant [ms] @{:jolt/type :jolt/instant :ms ms}) -(defn- zoned [ms zone] @{:jolt/type :jolt/zoned-dt :ms ms :zone zone}) -(defn- local-dt [ms] @{:jolt/type :jolt/local-dt :ms ms}) -(defn formatter [pattern &opt locale] @{:jolt/type :jolt/dt-formatter :pattern pattern :locale locale}) - -(def- zone-default @{:jolt/type :jolt/zone-id :id "system"}) - -# ms of any date-ish shim value (or a :jolt/inst) -(defn- ms-of [d] - (cond - (number? d) d - (and (or (table? d) (struct? d)) - (or (= :jolt/inst (get d :jolt/type)) - (= :jolt/instant (get d :jolt/type)) - (= :jolt/zoned-dt (get d :jolt/type)) - (= :jolt/local-dt (get d :jolt/type)))) - (get d :ms) - (error (string "not a date value: " (type d))))) - -# --- formatting ---------------------------------------------------------------- - -(def- month-names ["January" "February" "March" "April" "May" "June" "July" - "August" "September" "October" "November" "December"]) -(def- day-names ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"]) - -(defn pad2 [n] (if (< n 10) (string "0" n) (string n))) - -# Format epoch-ms with a (subset of the) JVM DateTimeFormatter pattern: -# yyyy yy MMMM MMM MM M dd d EEEE EEE HH H hh h mm m ss s a, quoted literals -# with '...'. Unknown letters pass through. -(defn- format-ms [pattern ms] - (def d (os/date (math/floor (/ ms 1000)) true)) - (def out @"") - (var i 0) - (def n (length pattern)) - (defn run-len [c] - (var j i) - (while (and (< j n) (= (pattern j) c)) (++ j)) - (- j i)) - (while (< i n) - (def c (pattern i)) - (def k (run-len c)) - (cond - (= c (chr "'")) - # quoted literal up to the closing quote ('' = literal quote) - (if (and (< (+ i 1) n) (= (pattern (+ i 1)) (chr "'"))) - (do (buffer/push out "'") (+= i 2)) - (let [close (string/find "'" pattern (+ i 1))] - (buffer/push out (string/slice pattern (+ i 1) close)) - (set i (+ close 1)))) - (= c (chr "y")) - (do (buffer/push out (if (>= k 4) (string (d :year)) - (pad2 (mod (d :year) 100)))) - (+= i k)) - (= c (chr "M")) - (do (buffer/push out (case k - 1 (string (+ 1 (d :month))) - 2 (pad2 (+ 1 (d :month))) - 3 (string/slice (in month-names (d :month)) 0 3) - (in month-names (d :month)))) - (+= i k)) - (= c (chr "d")) - (do (buffer/push out (if (= k 1) (string (+ 1 (d :month-day))) (pad2 (+ 1 (d :month-day))))) - (+= i k)) - (= c (chr "E")) - (do (buffer/push out (if (>= k 4) (in day-names (d :week-day)) - (string/slice (in day-names (d :week-day)) 0 3))) - (+= i k)) - (= c (chr "H")) - (do (buffer/push out (if (= k 1) (string (d :hours)) (pad2 (d :hours)))) (+= i k)) - (= c (chr "h")) - (let [h12 (let [h (mod (d :hours) 12)] (if (= h 0) 12 h))] - (buffer/push out (if (= k 1) (string h12) (pad2 h12))) (+= i k)) - (= c (chr "m")) - (do (buffer/push out (if (= k 1) (string (d :minutes)) (pad2 (d :minutes)))) (+= i k)) - (= c (chr "s")) - (do (buffer/push out (if (= k 1) (string (d :seconds)) (pad2 (d :seconds)))) (+= i k)) - (= c (chr "a")) - (do (buffer/push out (if (< (d :hours) 12) "AM" "PM")) (+= i k)) - (do (buffer/push out (string/from-bytes c)) (++ i)))) - (string out)) - -# Localized FormatStyle approximations (no locale database on this host). -(def- style-patterns - {[:date :short] "M/d/yy" [:date :medium] "MMM d, yyyy" - [:date :long] "MMMM d, yyyy" [:date :full] "EEEE, MMMM d, yyyy" - [:time :short] "h:mm a" [:time :medium] "h:mm:ss a" - [:time :long] "h:mm:ss a" [:time :full] "h:mm:ss a" - [:datetime :short] "M/d/yy, h:mm a" - [:datetime :medium] "MMM d, yyyy, h:mm:ss a" - [:datetime :long] "MMMM d, yyyy, h:mm:ss a" - [:datetime :full] "EEEE, MMMM d, yyyy, h:mm:ss a"}) - -(defn- style-fmt [kind style] - (formatter (get style-patterns [kind (get style :style)] "yyyy-MM-dd HH:mm:ss"))) - -# --- registration -------------------------------------------------------------- - -(defn install! [] - # java.lang statics through the generic registry (no resolve-sym special-case). - (register-class-statics! "Math" math-statics) - (register-class-statics! "Thread" thread-statics) - (register-class-statics! "System" system-statics) - (register-class-statics! "Long" long-statics) - (def fs (fn [style] @{:jolt/type :jolt/format-style :style style})) - (register-class-statics! "FormatStyle" - @{"SHORT" (fs :short) "MEDIUM" (fs :medium) "LONG" (fs :long) "FULL" (fs :full)}) - (register-class-statics! "DateTimeFormatter" - @{"ofPattern" (fn [p &opt locale] (formatter p locale)) - "ISO_LOCAL_DATE" (formatter "yyyy-MM-dd") - "ISO_LOCAL_DATE_TIME" (formatter "yyyy-MM-dd'T'HH:mm:ss") - "ofLocalizedDate" (fn [style] (style-fmt :date style)) - "ofLocalizedTime" (fn [style] (style-fmt :time style)) - "ofLocalizedDateTime" (fn [style] (style-fmt :datetime style))}) - (register-class-statics! "Instant" - @{"ofEpochMilli" (fn [ms] (instant ms)) - "now" (fn [] (instant (math/floor (* 1000 (os/clock :realtime)))))}) - (register-class-statics! "ZoneId" - @{"systemDefault" (fn [] zone-default)}) - (register-class-statics! "LocalDateTime" - @{"ofInstant" (fn [inst zone] (local-dt (ms-of inst))) - "now" (fn [] (local-dt (math/floor (* 1000 (os/clock :realtime)))))}) - (let [locale-statics @{"getDefault" (fn [] @{:jolt/type :jolt/locale :id "default"}) - "ENGLISH" @{:jolt/type :jolt/locale :id "en"} - "US" @{:jolt/type :jolt/locale :id "en-US"} - "ROOT" @{:jolt/type :jolt/locale :id "root"}}] - (each nm ["Locale" "java.util.Locale"] - (register-class-statics! nm locale-statics))) - (register-tagged-methods! :jolt/instant - @{"atZone" (fn [self zone] (zoned (self :ms) zone)) - "toEpochMilli" (fn [self] (self :ms))}) - (register-tagged-methods! :jolt/zoned-dt - @{"toLocalDateTime" (fn [self] (local-dt (self :ms))) - "toInstant" (fn [self] (instant (self :ms)))}) - (register-tagged-methods! :jolt/local-dt - @{"atZone" (fn [self zone] (zoned (self :ms) zone))}) - # a :jolt/inst (#inst — Clojure's java.util.Date) supports the Date methods - # Selmer's fix-date path calls - (register-tagged-methods! :jolt/inst - @{"toInstant" (fn [self] (instant (self :ms))) - "getTime" (fn [self] (self :ms))}) - (register-tagged-methods! :jolt/dt-formatter - @{"withLocale" (fn [self locale] (formatter (self :pattern) locale)) - "format" (fn [self d] (format-ms (self :pattern) (ms-of d)))})) diff --git a/src/jolt/lazyseq.janet b/src/jolt/lazyseq.janet deleted file mode 100644 index 097072a..0000000 --- a/src/jolt/lazyseq.janet +++ /dev/null @@ -1,86 +0,0 @@ -# LazySeq — cell-by-cell lazy sequence (Clojure-compatible) -# -# Model: a thunk returns nil (empty) or a [first-val, rest-thunk] pair; each -# step produces one element + a thunk for the rest. Supports self-referencing -# sequences like fib-seq. Self-contained (janet builtins only) — the Clojure -# seq layer (core_coll.janet) and the interpreter build on these primitives. -# -# REP vs API: this file is ONLY the lazy-cell representation (ls-* primitives). -# The Clojure-facing seq ops (first/rest/seq/cons/count dispatch, realization) -# live in core_coll.janet, branching on `:jolt/type :jolt/lazy-seq`. -# -# Extracted from phm.janet (jolt-bvek): a lazy sequence has nothing to do with -# hash maps; both were tagged tables, which is why they shared a file. - -(defn lazy-seq? - "Check if x is a LazySeq." - [x] - (and (table? x) (= :jolt/lazy-seq (x :jolt/type)))) - -(defn make-lazy-seq [thunk] - @{:jolt/type :jolt/lazy-seq :fn thunk :realized false :val nil}) - -(defn realize-ls - "Force a LazySeq cell. Returns nil (empty) or [first-val, rest-thunk]. - If the thunk returns another lazy-seq, recursively realize it. - Uses :jolt/pending sentinel to detect self-referencing cycles." - [ls] - (if (get ls :realized) - (ls :val) - (do - (put ls :val :jolt/pending) - (put ls :realized true) - (let [raw ((ls :fn)) - v (if (lazy-seq? raw) (realize-ls raw) raw)] - (put ls :val v) - v)))) - -(defn ls-first [ls] - (let [cell (realize-ls ls)] - (if (or (nil? cell) (= :jolt/pending cell) (= 0 (length cell))) nil (in cell 0)))) - -# The memoized rest wrapper for a node whose cell yielded rest-thunk rt. -# EVERY walk must go through this (not a fresh make-lazy-seq) or independent -# walks re-run the shared thunks and side effects duplicate. -(defn ls-rest-cached [ls rt] - (or (get ls :rest-ls) - (let [w (make-lazy-seq rt)] - (put ls :rest-ls w) - w))) - -(defn ls-rest [ls] - (let [cell (realize-ls ls)] - (if (or (nil? cell) (= 0 (length cell))) nil - (let [rt (in cell 1)] - (if (nil? rt) nil - # Memoized wrapper (see ls-rest-cached): a fresh table per call gave - # every independent walk its own realization state, so the shared - # rest-thunks re-ran — duplicating side effects (a doall'd seq of - # futures re-spawned them on the deref walk, serializing pmap). - (ls-rest-cached ls rt)))))) - -(defn ls-seq [ls] - (var result @[]) - (var cur ls) - (while (not (nil? cur)) - (let [cell (realize-ls cur)] - (if (nil? cell) (break)) - (array/push result (in cell 0)) - (set cur (ls-rest cur)))) - (if (= 0 (length result)) nil result)) - -(defn ls-count [ls] - (var cnt 0) - (var cur ls) - (while (not (nil? cur)) - (let [cell (realize-ls cur)] - (if (nil? cell) (break)) - (++ cnt) - (set cur (ls-rest cur)))) - cnt) - -(defn lazy-cons - "Returns a LazySeq whose first element is x and whose rest is produced by - rest-thunk (a 0-arg function returning nil or a LazySeq)." - [x rest-thunk] - (make-lazy-seq (fn [] @[x rest-thunk]))) diff --git a/src/jolt/loader.janet b/src/jolt/loader.janet deleted file mode 100644 index 7c82476..0000000 --- a/src/jolt/loader.janet +++ /dev/null @@ -1,136 +0,0 @@ -# Jolt Loader -# Namespace loading with optional compilation. -# Supports in-memory bytecode caching when :compile? is enabled. - -(use ./reader) -(use ./types) -(use ./evaluator) -(import ./backend :as backend) - -# Stateful / context-modifying forms always interpret: they mutate the context -# (namespaces, macros, types, multimethods, dynamic vars, …) in ways the compiler -# doesn't model. Kept here so the compile/interpret routing lives in one place, -# used by both load-ns and the public eval-one. Shrinking toward the frozen -# host-coupled set (Stage 2 jolt-eaa): forms move off this list as they gain a -# compile path; syntax-quote already compiles via the analyzer's `handled` set. -(defn- stateful-head? [head-name] - (or (= head-name "defmacro") - (= head-name "set!") - (= head-name ".") (= head-name "new") - (= head-name "eval"))) - -(defn- form-head-name [form] - (when (array? form) - (let [ff (first form)] - (when (and (struct? ff) (= :symbol (ff :jolt/type))) (ff :name))))) - -(defn- eval-toplevel-1 - [ctx form] - # Repair point for the interpreted-fn ns swap: a body runs with current-ns - # rebound to its defining ns and restores it on normal return; an UNWINDING - # throw skips those restores (they're plain trailing calls — defer/try per - # call would cost a fiber per frame and blow the C stack on deep recursion). - # So save here, and on error put the entry ns back before re-raising — the - # ctx never leaks a callee's ns across top-level forms. - (def entry-ns (ctx-current-ns ctx)) - (defn- run [] - (defn try-compile [] (backend/compile-and-eval ctx form)) - (if (get (ctx :env) :compile?) - (if (array? form) - # A call/list: compile it unless its head is a stateful special form. - (let [hn (form-head-name form)] - (if (and hn (stateful-head? hn)) - (eval-form ctx @{} form) - (try-compile))) - # A bare symbol or vector literal compiles; anything else interprets. - (if (or (and (struct? form) (= :symbol (form :jolt/type))) (tuple? form)) - (try-compile) - (eval-form ctx @{} form))) - (eval-form ctx @{} form))) - (try - (run) - ([err fib] - (ctx-set-current-ns ctx entry-ns) - # Stash the full trace TEXT at this innermost boundary: janet's - # debug/stacktrace walks the propagation chain (fiber->child, no public - # accessor), so this is the only place the user's compiled frames - # (in _r$ns/fn--N ...) are reachable. Innermost capture wins; the CLI's - # report-error filters + demangles it. (jolt-2o7.1/2) - (when (nil? (get (ctx :env) :error-trace)) - (def buf @"") - (with-dyns [:err buf] (debug/stacktrace fib err "")) - (put (ctx :env) :error-trace (string buf))) - # propagate (not error): re-raising with `error` discards the failing - # fiber's stack - (propagate err fib)))) - -(defn eval-toplevel - "Evaluate one top-level form for ctx, honoring :compile?. Stateful forms always - interpret; otherwise the form runs through the self-hosted compile pipeline - (portable Clojure analyzer -> IR -> Janet back end), which falls back to the - interpreter for forms it can't compile. Only the compile step is guarded — - runtime errors in compiled code propagate (no double-eval, no hidden errors)." - [ctx form] - # Clojure's top-level `do` rule: children are compiled AND evaluated one at - # a time, so a child's runtime effects (defmulti's var intern, requires, …) - # are visible while the NEXT child compiles. Without the split, (do - # (defmulti area …) (area …)) can't analyze — `area` only exists once the - # defmulti has RUN, and unresolved symbols are analysis errors now - # (jolt-2o7.3). - (if (and (array? form) (= "do" (form-head-name form))) - (do - (var res nil) - (each child (array/slice form 1) (set res (eval-toplevel ctx child))) - res) - (eval-toplevel-1 ctx form))) - -(defn eval-forms-positioned - "Evaluate parsed [form line] pairs, recording WHERE an error happened: the - innermost failing form's {:file :line} goes to (env :error-pos) and each - file unwound through joins the (env :error-loading) chain — the CLI's - report-error prints 'at file:line' and 'while loading …' from these. - (jolt-2o7.4)" - [ctx pairs file] - (var res nil) - (each [form line] pairs - (try - (set res (eval-toplevel ctx form)) - ([err fib] - (def env (ctx :env)) - (when (nil? (get env :error-pos)) - (put env :error-pos {:file file :line line})) - (when (nil? (get env :error-loading)) (put env :error-loading @[])) - (def chain (get env :error-loading)) - (when (not= (last chain) file) (array/push chain file)) - (propagate err fib)))) - res) - -(defn load-ns - "Load a Clojure namespace from a .clj file. Per-form routing (compile-or- - interpret, stateful forms interpret) is shared with eval-one via eval-toplevel. - - (load-ns ctx filepath) → namespace symbol string" - [ctx filepath] - (def source (slurp filepath)) - (when (or (checker-enabled?) (get (ctx :env) :inline?)) - (track-positions! true) - (put (ctx :env) :tc-source source) - (put (ctx :env) :tc-file filepath)) - (def pairs (parse-all-positioned source filepath)) - (var ns-name nil) - (each [form _] pairs - # Extract ns name from the first ns form - (when (and (nil? ns-name) - (array? form) - (> (length form) 0) - (and (struct? (first form)) - (= :symbol ((first form) :jolt/type)) - (= "ns" ((first form) :name)))) - (let [name-form (in form 1)] - (set ns-name (if (struct? name-form) (name-form :name) (string name-form)))))) - - (when (nil? ns-name) - (error (string "No ns form found in " filepath))) - - (eval-forms-positioned ctx pairs filepath) - ns-name) diff --git a/src/jolt/main.janet b/src/jolt/main.janet deleted file mode 100644 index 9a826c5..0000000 --- a/src/jolt/main.janet +++ /dev/null @@ -1,826 +0,0 @@ -# Jolt REPL -# Read-eval-print loop for Clojure expressions. - -(use ./api) -(use ./types) -(use ./phm) -(use ./phs) -(use ./lazyseq) -(use ./pv) -(use ./plist) -(use ./config) -(use ./reader) -(import ./core :as jcore) -(import ./deps :as deps) -(import ./cgen_build :as cgen-build) - -(def jolt-version "0.1.0") - -# Compile by default: the shipped runtime runs each form through the self-hosted -# pipeline (portable Clojure analyzer -> IR -> Janet back end) to native bytecode -# (hybrid — forms the analyzer can't compile fall back to the interpreter, so the -# result always matches the interpreter; see backend.janet / loader/eval-toplevel). -# Set JOLT_INTERPRET=1 to force the tree-walking interpreter (debugging / A-B). -(def compile-default? (not (= "1" (os/getenv "JOLT_INTERPRET")))) -# A var, not a def: a -m run may replace it with a forked deps-image ctx that -# already has every dependency compiled (see run-main / the deps image cache). -(var ctx (init {:compile? compile-default?})) -(ctx-set-current-ns ctx "user") - -(defn read-line [prompt] - (prin prompt) - (flush) - (let [line (file/read stdin :line)] - (if line (string/trim line) nil))) - -# Forward declaration for mutual recursion -(var write-value nil) - -(defn- push-str [buf s] - (buffer/push-string buf s)) - -(defn- write-collection [v buf] - (cond - (pvec? v) - (do - (push-str buf "[") - (let [a (pv->array v) n (pv-count v)] - (var i 0) - (while (< i n) - (write-value (in a i) buf) - (when (< (+ i 1) n) (push-str buf " ")) - (++ i))) - (push-str buf "]")) - - (plist? v) - (do - (push-str buf "(") - (let [a (pl->array v) n (length a)] - (var i 0) - (while (< i n) - (write-value (in a i) buf) - (when (< (+ i 1) n) (push-str buf " ")) - (++ i))) - (push-str buf ")")) - - (tuple? v) - (do - (push-str buf "[") - (var i 0) - (let [n (length v)] - (while (< i n) - (write-value (in v i) buf) - (when (< (+ i 1) n) (push-str buf " ")) - (++ i))) - (push-str buf "]")) - - # LazySeq — realize the cell chain and print as a list. Capped to avoid - # hanging on infinite sequences; prints "..." when truncated. - (and (table? v) (= :jolt/lazy-seq (v :jolt/type))) - (do - (push-str buf "(") - (var cur v) - (var i 0) - (var go true) - (while (and go (< i 1000)) - (let [cell (realize-ls cur)] - (if (or (nil? cell) (= :jolt/pending cell) (= 0 (length cell))) - (set go false) - (do - (when (> i 0) (push-str buf " ")) - (write-value (in cell 0) buf) - (++ i) - (let [rt (in cell 1)] - (if (nil? rt) (set go false) (set cur (ls-rest-cached cur rt)))))))) - (when (and go (>= i 1000)) (push-str buf " ...")) - (push-str buf ")")) - - (array? v) - (do - # mutable mode: arrays are vectors -> [] ; immutable: arrays are lists -> () - (push-str buf (if mutable? "[" "(")) - (var i 0) - (let [n (length v)] - (while (< i n) - (write-value (in v i) buf) - (when (< (+ i 1) n) (push-str buf " ")) - (++ i))) - (push-str buf (if mutable? "]" ")"))) - - (and (table? v) (= :jolt/set (v :jolt/type))) - (do - (push-str buf "#{") - (var first? true) - (each k (phs-seq v) - (if first? (set first? false) (push-str buf " ")) - (write-value k buf)) - (push-str buf "}")) - - (and (table? v) (= :jolt/transient (v :jolt/type))) - (push-str buf (string "#")) - - (and (table? v) (= :jolt/chan (v :jolt/type))) - (push-str buf "#") - - (phm? v) - (do - (push-str buf "{") - (var first? true) - (each pair (phm-entries v) - (if first? (set first? false) (push-str buf ", ")) - (write-value (in pair 0) buf) (push-str buf " ") (write-value (in pair 1) buf)) - (push-str buf "}")) - - (and (table? v) (= :jolt/regex (v :jolt/type))) - (do (push-str buf "#\"") (push-str buf (v :source)) (push-str buf "\"")) - - # sorted colls: their comparator-ordered entries, materialized from the - # red-black tree via the value's own :entries op (jolt-0hbr), is all the - # printer reads. - (and (table? v) (= :jolt/sorted-map (v :jolt/type))) - (do - (push-str buf "{") - (var first? true) - (each e (let [ef (let [o (v :ops)] (and o (o :entries))) es (if ef (ef v) (v :entries))] (if (pvec? es) (pv->array es) es)) - (if first? (set first? false) (push-str buf ", ")) - (write-value (if (pvec? e) (pv-nth e 0) (in e 0)) buf) - (push-str buf " ") - (write-value (if (pvec? e) (pv-nth e 1) (in e 1)) buf)) - (push-str buf "}")) - - (and (table? v) (= :jolt/sorted-set (v :jolt/type))) - (do - (push-str buf "#{") - (var first? true) - (each x (let [ef (let [o (v :ops)] (and o (o :entries))) es (if ef (ef v) (v :entries))] (if (pvec? es) (pv->array es) es)) - (if first? (set first? false) (push-str buf " ")) - (write-value x buf)) - (push-str buf "}")) - - (and (table? v) (get v :jolt/deftype)) - (do - (push-str buf "{") - (var first? true) - (each [k val] (pairs v) - (when (and (not= k :jolt/deftype) (not= k :cnt) (not= k :buckets) - (not= k :_meta) (not= k :jolt/type) (not= k :phm)) - (if first? (set first? false) (push-str buf " ")) - (write-value k buf) - (push-str buf " ") - (write-value val buf))) - (push-str buf "}")) - - (struct? v) - (do - (push-str buf "{") - (var first? true) - (each [k val] (pairs v) - (if first? (set first? false) (push-str buf " ")) - (write-value k buf) - (push-str buf " ") - (write-value val buf)) - (push-str buf "}")) - - (table? v) - (do - (push-str buf "{") - (var first? true) - (each [k val] (pairs v) - (when (not= k :jolt/type) - (if first? (set first? false) (push-str buf " ")) - (write-value k buf) - (push-str buf " ") - (write-value val buf))) - (push-str buf "}")))) - -(set write-value (fn [v buf] - (cond - (nil? v) (push-str buf "nil") - (= true v) (push-str buf "true") - (= false v) (push-str buf "false") - (number? v) (push-str buf (string v)) - (string? v) (push-str buf v) - (keyword? v) (do (push-str buf ":") (push-str buf (string v))) - (and (struct? v) (= :jolt/char (get v :jolt/type))) - (do (push-str buf "\\") - (push-str buf (case (v :ch) - 10 "newline" 32 "space" 9 "tab" 13 "return" - 12 "formfeed" 8 "backspace" 0 "nul" - (string/from-bytes (v :ch))))) - (and (struct? v) (= :symbol (get v :jolt/type))) - (let [ns (get v :ns) name (get v :name)] - (if ns - (push-str buf (string ns "/" name)) - (push-str buf name))) - (and (table? v) (= :jolt/var (v :jolt/type))) - (push-str buf (string "#'" (ctx-current-ns ctx) "/" (var-name v))) - (or (tuple? v) (array? v) (struct? v) (table? v)) - (write-collection v buf) - true (push-str buf (string v))))) - -(defn print-value [v] - (def buf @"") - (write-value v buf) - (print (string buf))) - -(defn- err-message [err] - (cond - (string? err) err - (and (or (table? err) (struct? err)) (= :jolt/exception (get err :jolt/type))) - (err-message (get err :value)) - (and (or (table? err) (struct? err)) (= :jolt/ex-info (get err :jolt/type))) - (let [m (get err :message) d (get err :data)] - (if (and d (not (empty? d))) (string m " " (string/format "%q" d)) (string m))) - (string? err) err - (string/format "%q" err))) - -# --- error presentation (jolt-2o7.2, rephrase-inspired) ---------------------- -# Host messages rewritten into Clojure-shaped ones; stack frames filtered to -# the USER'S code (compiled jolt fns carry _r$ns/name--N janet names — round -# 2o7.1). JOLT_DEBUG=1 restores the raw janet trace for jolt development. - -(defn- demangle - "_r$app.deep/level3--105 -> app.deep/level3 (nil for non-jolt names)." - [nm] - (when (string/has-prefix? "_r$" nm) - (def s (string/slice nm 3)) - # the counter suffix is the LAST --N run - (var cut (length s)) - (var i (string/find "--" s)) - (while (not (nil? i)) - (set cut i) - (set i (string/find "--" s (+ i 1)))) - (string/slice s 0 cut))) - -(defn- fmt-val [x] - (cond - (string? x) (string `"` x `"`) - (nil? x) "nil" - (string x))) - -(def- op-words - {"+" "add" "-" "subtract" "*" "multiply" "/" "divide" - "<" "compare" ">" "compare" "<=" "compare" ">=" "compare"}) - -(defn- rewrite-message - "Host/janet error text -> a user-facing message. Unknown messages verbatim." - [msg] - (def msg (string msg)) - (cond - # janet polymorphic arithmetic. Binary: "could not find method :+ for 1 or - # :r+ for "a"". Unary (inc/dec/-): "could not find method :+ for "x"" — no - # "or :r" clause, so orpos is nil; handle both without crashing the reporter. - (string/has-prefix? "could not find method :" msg) - (let [rest* (string/slice msg (length "could not find method :")) - sp (string/find " " rest*) - op (string/slice rest* 0 sp) - tail (string/slice rest* (+ sp (length " for "))) - orpos (string/find " or :r" tail)] - (if (nil? orpos) - # unary form: one operand - (string "Cannot " (get op-words op op) " " tail - " — " op " expects numbers") - (let [a (string/slice tail 0 orpos) - forpos (string/find " for " tail (+ orpos 1)) - b (string/slice tail (+ forpos 5))] - (string "Cannot " (get op-words op op) " " a " and " b - " — " op " expects numbers")))) - # janet fixed-arity: called with 2 arguments, expected 1 - (and (string/has-prefix? " called with " msg)) - (let [nm-end (string/find ">" msg) - nm (string/slice msg (length " called with "))) - n-end (string/find " " tail) - n (string/slice tail 0 n-end) - exp (if-let [i (string/find "expected " tail)] - (string " (expected " (string/slice tail (+ i 9)) ")") "")] - (string "Wrong number of args (" n ") passed to: " pretty exp)) - # a typo'd symbol compiles to nil today (round 2o7.3 will fix resolution) - (= msg "Cannot call nil as a function") - (string msg " — often an undefined (misspelled?) symbol") - msg)) - -(defn- print-user-trace - "Filter the stashed janet trace down to frames a jolt user can act on: - compiled jolt fns (the _r$ns/name--N janet names, demangled) and frames - from non-jolt source files. Internal janet/jolt frames are dropped." - [trace] - (var shown 0) - (each line (string/split "\n" trace) - (def t (string/trim line)) - (when (string/has-prefix? "in " t) - (def rest* (string/slice t 3)) - (def sp (or (string/find " " rest*) (length rest*))) - (def nm (string/slice rest* 0 sp)) - (cond - (string/has-prefix? "_r$" nm) - (do (eprint " at " (demangle nm)) (++ shown)) - # a frame from a real source file outside jolt internals - (and (string/find "[" rest*) - (not (string/find "src/jolt/" rest*)) - (not (string/find "boot.janet" rest*)) - (not (string/find "[eval]" rest*))) - (do (eprint " " t) (++ shown)) - nil))) - shown) - -(defn- report-error [err fib] - (eprint "Error: " (rewrite-message (err-message err))) - (def env (ctx :env)) - (def stashed (get env :error-trace)) - (def pos (get env :error-pos)) - (def chain (get env :error-loading)) - (put env :error-trace nil) - (put env :error-pos nil) - (put env :error-loading nil) - # :1 is the synthetic require/apply string the CLI feeds itself (and - # any one-line -e) — no information there - (when (and pos (not (and (= (pos :file) "") (= (pos :line) 1)))) - (eprint " at " (pos :file) ":" (pos :line))) - (cond - (os/getenv "JOLT_DEBUG") - (if stashed (eprin stashed) (when fib (debug/stacktrace fib ""))) - stashed (print-user-trace stashed) - fib (when fib nil)) - # requires unwound through, innermost first; the failing file itself is - # already on the 'at' line - (when chain - (each f chain - (unless (or (= f "") (and pos (= f (pos :file)))) - (eprint " while loading " f))))) - -(defn- run-repl [] - (print "Jolt — Clojure on Janet") - (print "Type (exit) to quit.\n") - (var running true) - (var pending "") # accumulates a form split across multiple input lines - (while running - (let [prompt (if (= pending "") (string (ctx-current-ns ctx) "=> ") " #_=> ") - line (read-line prompt)] - (cond - (nil? line) (set running false) - (let [input (if (= pending "") line (string pending "\n" line)) - trimmed (string/trim input)] - (cond - (= trimmed "(exit)") (set running false) - (= trimmed "") (set pending "") - # Try to parse the accumulated input; if it's an incomplete form - # (unterminated list/vector/map/string), keep reading more lines. - (let [parsed (protect (parse-string input))] - (if (and (= (parsed 0) false) - (string/find "nterminated" (string (parsed 1)))) - (set pending input) - (do - (set pending "") - (try - (print-value (eval-string ctx input)) - ([err fib] (report-error err fib)))))))))))) - -(defn- set-command-line-args [argv] - # bind clojure.core/*command-line-args* to a vector of the remaining args - (ns-intern (ctx-find-ns ctx "clojure.core") "*command-line-args*" - (tuple/slice (tuple ;argv)))) - -(defn- run-file [path argv] - (set-command-line-args argv) - (ns-intern (ctx-find-ns ctx "clojure.core") "*file*" path) - (if (not (os/stat path)) - (do (eprint "Error: file not found: " path) (os/exit 1)) - (let [src (slurp path)] - (try - (load-string ctx src path) - ([err fib] (report-error err fib) (os/exit 1)))))) - -(defn- run-eval [expr argv] - (set-command-line-args argv) - (try - (let [v (load-string ctx expr)] - (when (not (nil? v)) (print-value v))) - ([err fib] (report-error err fib) (os/exit 1)))) - -(defn- ensure-nrepl-loaded [] - # jolt.nrepl is part of the baked-in stdlib, so require finds it anywhere. - (eval-string ctx "(require '[jolt.nrepl])")) - -(defn- run-nrepl [argv] - # addr is [host:]port; bare number is a port. Default 127.0.0.1:7888. - (def addr (get argv 0)) - (var host "127.0.0.1") - (var port 7888) - (when addr - (if-let [i (string/find ":" addr)] - (do (when (> i 0) (set host (string/slice addr 0 i))) - (set port (scan-number (string/slice addr (+ i 1))))) - (set port (scan-number addr)))) - (ensure-nrepl-loaded) - (eval-string ctx (string "(jolt.nrepl/start-server! {:host \"" host "\" :port " port "})")) - # Editors auto-discover the port from this file (nREPL convention). - (spit ".nrepl-port" (string port)) - # Remove .nrepl-port on exit — on a clean unwind (defer) and on Ctrl-C/SIGTERM - # (signal handlers). A hard SIGKILL can't be caught, so it may still be left. - (def cleanup (fn [&] (protect (os/rm ".nrepl-port")))) - (os/sigaction :int (fn [&] (cleanup) (os/exit 0)) true) - (os/sigaction :term (fn [&] (cleanup) (os/exit 0)) true) - (print "Jolt nREPL server started on " host ":" port) - (print "Wrote .nrepl-port — connect your editor; Ctrl-C to stop.") - (flush) - # Keep the main fiber alive so the event loop serves connections. - (defer (cleanup) - (forever (ev/sleep 60)))) - -(defn- print-version [] - (print "jolt v" jolt-version)) - -# --- Deps image cache: compile the dependencies ONCE ------------------------- -# The baked binary loads core in ~10ms (it's marshaled in), but a program still -# re-compiles ALL of its dependency namespaces (reitit, ring, …) from source on -# every run — seconds of analyzer->IR->emit that never change between runs. Like -# Clojure's AOT or Stalin's compile-once model, snapshot the ctx AFTER the -# require chain and reuse it: the first run compiles + caches, later runs fork -# the image (~10ms) and skip compilation entirely. The key includes the jolt -# version, entry ns, source roots, and the compile flags; the image carries a -# manifest of every loaded source file's mtime, so any source edit (app or dep) -# invalidates it. JOLT_NO_DEPS_CACHE=1 disables. -(defn- deps-image-path [ns-name] - (def dir (or (os/getenv "JOLT_IMAGE_CACHE_DIR") (os/getenv "TMPDIR") "/tmp")) - # Key on the jolt version + entry ns + every ctx-shaping env var (ctx-cache-key, - # jolt-q5ql): the run-mode flags this image bakes are all derived from those - # vars, so keying on the canonical list can't miss one the way the old - # hand-built positional key could. - (def key (ctx-cache-key [:jolt-version jolt-version :ns ns-name])) - (string dir "/jolt-deps-" (band (hash key) 0x7FFFFFFF) ".jimg")) - -(defn- manifest-of [files] - (def m @{}) - (each f files (when-let [st (os/stat f)] (put m f (st :modified)))) - m) - -(defn- manifest-current? [manifest] - (var ok true) - (eachp [f mt] manifest - (def st (os/stat f)) - (unless (and st (= (st :modified) mt)) (set ok false))) - ok) - -(defn- try-load-deps-image [path] - (unless (os/getenv "JOLT_NO_DEPS_CACHE") - # load-ctx-image forks + validates + rewires (shared with init-cached, jolt-q5ql); - # the deps-specific validity check is the source-mtime manifest. - (load-ctx-image path jcore/install-print-method-cb! - (fn [c] (let [m (get (c :env) :deps-manifest)] - (and m (manifest-current? m))))))) - -(defn- save-deps-image [c path] - (unless (os/getenv "JOLT_NO_DEPS_CACHE") - (put (c :env) :deps-manifest (manifest-of (or (get (c :env) :loaded-files) @[]))) - (save-ctx-image c path))) - -(defn- run-main [ns-name argv] - (when (nil? ns-name) (eprint "Error: -m/--main requires a namespace") (os/exit 1)) - (try - (do - (def path (deps-image-path ns-name)) - (if-let [cached (try-load-deps-image path)] - # cache hit: every dependency is already compiled in the image - (do (set ctx cached) (ctx-set-current-ns ctx "user")) - # cache miss: compile the requires, then snapshot for next time. Track the - # loaded files for the manifest. - (do - (put (ctx :env) :loaded-files @[]) - (load-string ctx (string "(require '[" ns-name "])")) - # whole-program (jolt-t34): every unit is loaded now — run the one - # closed-world fixpoint over all of them before -main. - (when (get (ctx :env) :whole-program?) - (when-let [ip (get (ctx :env) :infer-program!)] (protect (ip ctx))) - (put (ctx :env) :infer-program-done? true)) - (save-deps-image ctx path))) - # Bind *command-line-args* on the FINAL ctx, AFTER any cache swap: a cache - # hit replaces ctx with the saved image, which carries the args baked when - # it was saved — the current run's argv must win (jolt-4mui). - (set-command-line-args argv) - (load-string ctx (string "(apply " ns-name "/-main *command-line-args*)"))) - ([err fib] (report-error err fib) (os/exit 1)))) - -# --- uberscript dead-code elimination (jolt-atg) --------------------------- -# A bundle is closed-world: everything it needs is inlined and nothing is -# required afterward, so a user `defn` unreachable from the entry's reference -# graph can be dropped. Conservative + sound: only plain defn/defn- are -# prunable; a defn is kept if its (bare or ns-qualified) name appears in any -# kept form, the closure runs to a fixpoint, and any use of dynamic resolution -# disables pruning entirely. The drop is by exact source span, so formatting -# and reader macros in the surviving code are untouched. -(defn- dce-sym? [x] (and (struct? x) (= :symbol (get x :jolt/type)))) -(def- dce-bailout-syms - {"resolve" true "ns-resolve" true "requiring-resolve" true "find-var" true - "intern" true "eval" true "load-string" true}) -(defn- dce-collect-syms [form acc] - (cond - (dce-sym? form) (do (put acc (get form :name) true) - (when (get form :ns) - (put acc (string (get form :ns) "/" (get form :name)) true))) - (indexed? form) (each x form (dce-collect-syms x acc)) - (or (struct? form) (table? form)) (each k (keys form) - (dce-collect-syms k acc) - (dce-collect-syms (get form k) acc))) - acc) -(defn- dce-defn-name [form] - (when (and (indexed? form) (>= (length form) 2) (dce-sym? (get form 0)) - (let [nm (get (in form 0) :name)] (or (= nm "defn") (= nm "defn-"))) - (dce-sym? (get form 1))) - (get (in form 1) :name))) -(defn- dce-strip-spans [src dead] - (if (empty? dead) src - (do - (sort dead (fn [a b] (< (a 0) (b 0)))) - (def buf @"") - (var cur 0) - (each [s e] dead - (when (> s cur) (buffer/push-string buf (string/slice src cur s))) - (set cur (max cur e))) - (buffer/push-string buf (string/slice src cur)) - (string buf)))) - -(defn- run-uberscript [out main-ns] - # Bundle main-ns and everything it requires (from JOLT_PATH roots) into one - # .clj that runs on a plain jolt — no deps, no jpm. We require the entry and - # collect the load order the loader records (deps before dependents). - (when (or (nil? out) (nil? main-ns)) - (eprint "Usage: jolt uberscript OUT.clj -m NS") (os/exit 1)) - (put (ctx :env) :loaded-files @[]) - (try - (load-string ctx (string "(require '[" main-ns "])")) - ([err fib] (report-error err fib) (os/exit 1))) - (def seen @{}) - (def files @[]) - (each f (get (ctx :env) :loaded-files) - (unless (get seen f) (put seen f true) (array/push files f))) - # read every file's source and parse it into top-level forms with byte spans; - # if ANY file fails to parse, fall back to verbatim bundling (DCE off) so the - # uberscript stays exactly as robust as a plain concatenation. - (def srcs @{}) - (def file-forms @{}) - (def all-forms @[]) - (var dce-ok true) - (each f files - (def src (slurp f)) - (put srcs f src) - (def lst @[]) - (try - (each [form s e] (parse-all-spans src f) - (def entry @{:start s :end e :dname (dce-defn-name form) :form form}) - (array/push lst entry) - (array/push all-forms entry)) - ([_err _fib] (set dce-ok false))) - (put file-forms f lst)) - # disable DCE if the bundle resolves names dynamically (a defn could be - # reached by a string/symbol the reference scan can't see). - (when dce-ok - (def allsyms @{}) - (each e all-forms (dce-collect-syms (e :form) allsyms)) - (each nm (keys allsyms) (when (get dce-bailout-syms nm) (set dce-ok false)))) - # reachability: seed from the entry (-main) and every non-prunable form, then - # close over the bodies of defns that become live. - (def live @{}) - (when dce-ok - (def referenced @{"-main" true}) - (each e all-forms (unless (e :dname) (dce-collect-syms (e :form) referenced))) - (var changed true) - (while changed - (set changed false) - (each e all-forms - (when (and (e :dname) (not (get live e)) (get referenced (e :dname))) - (put live e true) - (dce-collect-syms (e :form) referenced) - (set changed true))))) - (var dropped 0) - (def buf @"") - (buffer/push-string buf (string ";; Generated by `jolt uberscript` — " (length files) " namespace(s)\n\n")) - (each f files - (buffer/push-string buf (string ";; --- " f " ---\n")) - (def src (get srcs f)) - (if-not dce-ok - (buffer/push-string buf src) - (do - (def dead @[]) - (each e (get file-forms f) - (when (and (e :dname) (not (get live e))) - (++ dropped) - (array/push dead [(e :start) (e :end)]))) - (buffer/push-string buf (dce-strip-spans src dead)))) - (buffer/push-string buf "\n")) - (buffer/push-string buf (string "\n(apply " main-ns "/-main *command-line-args*)\n")) - (spit out (string buf)) - (print "Wrote " out " (" (length files) " namespace(s)" - (if (and dce-ok (> dropped 0)) (string ", " dropped " dead fn(s) dropped") "") ")")) - -(defn- run-cgen-build [argv] - # jolt cgen-build -m NS -o OUT [--keep]: fuse the app's hot numeric-leaf fns - # (compiled to native code) + the app source into one static executable. - (var main-ns nil) - (var out nil) - (var keep false) - (var i 0) - (while (< i (length argv)) - (def a (argv i)) - (cond - (or (= a "-m") (= a "--main")) (do (set main-ns (get argv (+ i 1))) (+= i 2)) - (or (= a "-o") (= a "--out")) (do (set out (get argv (+ i 1))) (+= i 2)) - (= a "--keep") (do (set keep true) (++ i)) - (++ i))) - (when (or (nil? main-ns) (nil? out)) - (eprint "Usage: jolt cgen-build -m NS -o OUT [--keep]") - (os/exit 1)) - (try - (let [r (cgen-build/build-app {:main main-ns :out out :keep keep})] - (print "Wrote " (r :out) " (" (r :native-count) " native fn(s) linked)")) - ([err fib] (report-error err fib) (os/exit 1)))) - -(defn- print-help [] - (print "Jolt — a Clojure interpreter on Janet\n") - (print "Usage: jolt [opt] [args]\n") - (print " (no args), repl Start a REPL") - (print " FILE [args] Run a Clojure file (binds *command-line-args*, *file*)") - (print " - Run a program read from stdin") - (print " -e, --eval EXPR Evaluate EXPR and print the result") - (print " -f, --file FILE Run a Clojure file") - (print " -m, --main NS [args] Require NS and call its -main with the remaining args") - (print " nrepl-server [addr] Start an nREPL server (addr = [host:]port, default 7888)") - (print " (aliases: --nrepl-server, nrepl)") - (print " uberscript OUT -m NS Bundle NS + its required namespaces into one .clj") - (print " cgen-build -m NS -o OUT Build NS into a single static binary (hot fns") - (print " compiled to native code, no toolchain to run)") - (print " --version, version Print the Jolt version") - (print " -h, --help, help Show this help\n") - (print "Dependencies (deps.edn, git + :local deps — resolved into JOLT_PATH):") - (print " -M:a[:b] [args] Run the alias(es) :main-opts ++ args") - (print " -A:a[:b] CMD [args] Run CMD (repl/-m/nrepl-server/…) with the alias paths") - (print " run FILE [args] Run FILE with deps.edn resolved") - (print " path Print the resolved source roots (':'-joined)") - (print " tasks List :tasks from deps.edn") - (print " task NAME [args] Run a :tasks entry (shell string or :main-opts)") - (print " A deps.edn in the working dir is auto-resolved for repl/-m/-e/nrepl-server/FILE.\n") - (print "Running a program (a file, -m/-M) direct-links by default; type inference") - (print "and specialization are opt-in via JOLT_OPTIMIZE (the cost is paid once, then") - (print "cached). The repl, -e, and nrepl-server stay open so you can redefine vars.") - (print "Environment:") - (print " JOLT_OPTIMIZE=1 type-infer + specialize (whole-program over app nses)") - (print " JOLT_NO_DIRECT_LINK=1 keep a program run open/redefinable (no optimization)") - (print " JOLT_NO_WHOLE_PROGRAM=1 direct-link but skip the cross-namespace pass") - (print " JOLT_DIRECT_LINK=1 force direct-linking + optimization on (e.g. for -e)") - (print " JOLT_WHOLE_PROGRAM=1 force the whole-program pass on") - (print " JOLT_INTERPRET=1 run the tree-walking interpreter\n") - (print " JOLT_PATH=dir1:dir2 extra source roots (set automatically by deps resolution)")) - -(def- help-flags {"-h" true "--help" true "help" true "-?" true}) -(def- version-flags {"--version" true "version" true}) -(def- nrepl-flags {"nrepl-server" true "--nrepl-server" true "nrepl" true}) -(def- eval-flags {"-e" true "--eval" true}) -(def- file-flags {"-f" true "--file" true}) -(def- main-flags {"-m" true "--main" true}) - -# --- deps.edn integration (the old jolt-deps tool, folded in) ---------------- -# The runtime stays deps-agnostic: it reads source roots from JOLT_PATH (applied -# in `main`, below). This layer resolves a deps.edn into those roots IN-PROCESS, -# so a single `jolt` binary both resolves dependencies and runs code. ./deps -# loads jpm (git fetch + cache) lazily — only at an actual resolve — so a run -# with no deps.edn never pulls it in, and an app baked from its own entry (which -# imports jolt/api, not this CLI) never links the resolver at all. - -(defn- parse-alias-flag - ``"-A:dev:test" / "-M:dev" -> [:dev :test].`` - [arg] - (map keyword (filter |(not= "" $) (string/split ":" (string/slice arg 2))))) - -(defn- deps-roots [aliases] - (if (os/stat "deps.edn") (deps/resolve-deps-cached "deps.edn" nil aliases) @[])) - -(defn- set-deps-env! [aliases] - # Prepend the resolved roots to any existing JOLT_PATH; `main` (below) applies - # them to the ctx source-paths. JOLT_APP_PATHS scopes whole-program inference - # to the project's own namespaces — deps load-infer per-ns instead (jolt-87e). - (def rs (string/join (deps-roots aliases) ":")) - (def existing (os/getenv "JOLT_PATH")) - (os/setenv "JOLT_PATH" (if (and existing (> (length existing) 0)) (string rs ":" existing) rs)) - (when (os/stat "deps.edn") - (os/setenv "JOLT_APP_PATHS" (string/join (deps/project-source-roots "deps.edn" aliases) ":")))) - -(defn- resolve-deps-argv - ``Resolve deps.edn (when relevant) and de-sugar the deps subcommands into a - plain runtime argv that `main` then dispatches on. The pure deps queries - (path/tasks/task) print and exit. A runnable command resolves a deps.edn in - cwd when one is present — so `jolt repl` / `-m` / `nrepl-server` pick up the - project and its dependencies — and is a no-op (resolver untouched) with none.`` - [argv] - # leading -A:alias flags apply to whatever command follows - (var aliases nil) - (var rest argv) - (while (string/has-prefix? "-A" (or (get rest 0) "")) - (set aliases (array/concat (or aliases @[]) (parse-alias-flag (get rest 0)))) - (set rest (array/slice rest 1))) - (def cmd (get rest 0)) - (cond - # pure deps queries — produce output and exit, never start the runtime - (= cmd "path") - (do (print (string/join (deps-roots aliases) ":")) (os/exit 0)) - (= cmd "tasks") - (do (each row (deps/tasks "deps.edn") - (print (row 0) (if (row 1) (string "\t" (row 1)) ""))) - (os/exit 0)) - (= cmd "task") - (let [name (get rest 1) - spec (when name (deps/task-spec "deps.edn" name))] - (cond - (nil? name) (do (eprint "jolt: task needs a name") (os/exit 1)) - (nil? spec) (do (eprint "jolt: no such task: " name) (os/exit 1)) - (= :shell (spec :type)) - (os/exit (os/execute ["sh" "-c" (string/join [(spec :cmd) ;(array/slice rest 2)] " ")] :p)) - (do (set-deps-env! aliases) - (array/concat @[] (spec :argv) (array/slice rest 2))))) - # -M:aliases — resolve and run the alias's :main-opts ++ extra args - (and cmd (string/has-prefix? "-M" cmd)) - (let [als (array/concat (or aliases @[]) (parse-alias-flag cmd)) - mo (deps/alias-main-opts "deps.edn" als)] - (if mo - (do (set-deps-env! als) (array/concat @[] mo (array/slice rest 1))) - (do (eprint "jolt: no :main-opts in alias(es) " (string/format "%j" (map string als))) - (os/exit 1)))) - # explicit `run FILE` — resolve, then run the file - (= cmd "run") - (do (set-deps-env! aliases) (array/slice rest 1)) - # any runnable command: resolve a deps.edn if present (or if -A forced it); - # help/version never resolve, and with no deps.edn + no -A the resolver and - # jpm are never touched. - (and (not (help-flags cmd)) (not (version-flags cmd)) - (or aliases (os/stat "deps.edn"))) - (do (set-deps-env! aliases) rest) - # nothing deps-related — argv unchanged - true rest)) - -(defn main [&] - (def args (or (dyn :args) @[])) # @["jolt" arg1 arg2 ...] - # Resolve deps.edn + de-sugar deps subcommands (jolt-deps folded in): sets - # JOLT_PATH/JOLT_APP_PATHS in our env (read just below) and rewrites argv to a - # plain runtime command. A no-deps invocation passes through untouched. - (def argv (resolve-deps-argv (if (> (length args) 1) (array/slice args 1) @[]))) - (ctx-set-current-ns ctx "user") - # JOLT_PATH must be applied at runtime: this `ctx` is built into the image at - # build time, so its source-paths can't capture the runtime environment. - # resolve-deps-argv (above) sets it from the resolved deps.edn source roots. - (when-let [jp (os/getenv "JOLT_PATH")] - (each p (string/split ":" jp) - (when (> (length p) 0) (array/push (get (ctx :env) :source-paths) p)))) - # JOLT_APP_PATHS (jolt-87e), likewise applied at runtime: the project's own - # source roots, set by jolt-deps. Whole-program inference is scoped to - # namespaces under these (deps compile at default cost), so a dep-heavy app's - # optimize-mode startup doesn't re-infer every transitive dependency. Read here - # for the same baked-at-build-time reason as JOLT_PATH above. - (let [aps @[]] - (when-let [jap (os/getenv "JOLT_APP_PATHS")] - (each p (string/split ":" jap) (when (> (length p) 0) (array/push aps p)))) - (put (ctx :env) :app-source-paths aps)) - # JOLT_FEATURES, likewise, must be applied at runtime: reader-features-set! - # runs at module load, which for a baked binary is BUILD time — so a process - # that sets JOLT_FEATURES (e.g. to read a clj-targeted lib's :clj branches) - # would otherwise be ignored, and unmatched #?(...) forms silently splice to - # nothing. Re-read it here so the env wins in the running process. - (when-let [jf (os/getenv "JOLT_FEATURES")] - (reader-features-set! (filter |(> (length $) 0) (string/split "," jf)))) - # Linking default depends on the run MODE. Running a PROGRAM (a file, -f, -m/-M, - # stdin) is a closed world — all code is loaded, then it executes to completion - # — so it direct-links by default: user code gets inlining + shapes + the type - # inference's specialization (jolt-87f). INTERACTIVE modes (repl, -e, the nREPL - # server) stay indirect/open so redefinition works — direct-linking would seal - # callers against a redef. Explicit env always wins: JOLT_NO_DIRECT_LINK forces - # the open path even for a program run (runtime redefinition / hot-reload), - # JOLT_DIRECT_LINK forces it on even for -e. Core is already compiled into the - # image; this only governs user code compiled at runtime. - (def open-mode? - (or (empty? argv) - (help-flags (argv 0)) (version-flags (argv 0)) - (= (argv 0) "repl") (nrepl-flags (argv 0)) (eval-flags (argv 0)) - (= (argv 0) "uberscript"))) - (def main-entry? (and (not (empty? argv)) (main-flags (argv 0)))) - # Run-mode policy lives in config/resolve-run-mode now (jolt-q5ql) — unit- - # testable without the CLI, and the same canonical knob list backs the cache - # keys. Install the resolved knobs onto the runtime env (the baked ctx computed - # them at build time; a program run recomputes from the live env). - (let [mode (resolve-run-mode open-mode? main-entry?)] - (eachp [k v] mode (put (ctx :env) k v))) - (cond - (empty? argv) (run-repl) - (help-flags (argv 0)) (print-help) - (version-flags (argv 0)) (print-version) - (= (argv 0) "repl") (run-repl) - (nrepl-flags (argv 0)) (run-nrepl (array/slice argv 1)) - (eval-flags (argv 0)) (run-eval (get argv 1 "") (array/slice argv 2)) - (file-flags (argv 0)) (run-file (get argv 1) (array/slice argv 2)) - (main-flags (argv 0)) (run-main (get argv 1) (array/slice argv 2)) - (= (argv 0) "uberscript") - (let [out (get argv 1) - rest (array/slice argv 2) - mi (or (index-of "-m" rest) (index-of "--main" rest))] - (run-uberscript out (if mi (get rest (+ mi 1)) nil))) - (= (argv 0) "cgen-build") (run-cgen-build (array/slice argv 1)) - (= (argv 0) "-") (run-file "/dev/stdin" (array/slice argv 1)) - (run-file (argv 0) (array/slice argv 1)))) diff --git a/src/jolt/phm.janet b/src/jolt/phm.janet deleted file mode 100644 index bfbc609..0000000 --- a/src/jolt/phm.janet +++ /dev/null @@ -1,381 +0,0 @@ -# PersistentHashMap for Jolt — a HAMT (hash array mapped trie), the structure -# Clojure/ClojureScript/jank use. 32-way branching, 5 hash bits per level, with -# structural sharing: assoc/dissoc/get are O(log32 n) ~ effectively constant. -# Replaces the old flat copy-on-write bucket array, which was O(n) per assoc -# (O(n^2) to build — jolt-684u). Translated from the ClojureScript -# PersistentHashMap (cljs.core: BitmapIndexedNode / ArrayNode / HashCollisionNode). -# -# REP vs API: this file is ONLY the map representation (phm-* primitives). The -# Clojure-facing map ops (assoc/dissoc/get/conj/count/seq dispatch, nil-key, -# merge) live in core_coll.janet / core_types.janet, which recognize phm by its -# `:jolt/deftype` string and call these primitives. PersistentHashSet is layered -# on top in phs.janet. Transients are a separate mutable-table rep (core_types), -# so they don't touch this file. -# -# Node representation (Janet tuples, tagged at index 0; their arrays are built -# fresh on every modify and never mutated in place, so sharing is safe): -# [:bin bitmap arr] bitmap-indexed: arr is [k v k v ...]; a nil k means v is -# a sub-node (the slot recurses one level deeper). -# [:an cnt arr] array-node: arr is 32 slots of sub-node-or-nil. -# [:hcn hash cnt arr] hash-collision: arr is [k v k v ...] of same-hash keys. -# The map itself stays a table tagged :jolt/phm with :cnt (read directly by -# core), plus :root (the trie, nil when empty) and :has-nil/:nil-val (Clojure -# maps allow a nil key, which the trie can't store because a nil k marks a -# sub-node). -# -# Note on Janet `=`: it is STRUCTURAL on tuples, not identity, so cljs's -# `(identical? n node)` "nothing changed" early-outs are dropped here — we just -# rebuild the O(log32 n) path (an extra alloc only when overwriting an identical -# value). nil returns (a node that became empty) are kept; those are real nils. - -(def- DEFTYPE "jolt.lang.persistent-hash-map.PersistentHashMap") - -(defn phm? [x] - (and (table? x) (= DEFTYPE (x :jolt/deftype)))) - -# Keys are hashed and compared by VALUE. Scalars are value-hashable in Janet; -# collection keys (a phm/pvec/plist/vector) are Janet tables hashed by identity, -# so they're canonicalized to a value-hashable struct/tuple first. -# `canonicalize-key` is injected by core (which knows those types); phm stays -# dependency-free. Keys are STORED as-is, so retrieval/iteration return originals. -(var canonicalize-key nil) -(defn set-canonicalize-key! - "Install the value-canonicalizer for collection keys (called by core)." - [f] - (set canonicalize-key f)) -(defn- ck [k] - (if (and canonicalize-key (or (table? k) (struct? k) (array? k) (tuple? k))) - (canonicalize-key k) - k)) -(defn canon - "Public canonicalizer: maps a key to its value-hashable form (identity for - scalars). Used by callers that index the same canonicalized tables phm uses." - [k] (ck k)) -# Identity/scalar equality first (the common case), then value equality. -(defn- key= [a b] (or (= a b) (= (ck a) (ck b)))) -# Janet bit ops are 32-bit and split awkwardly: band/bor/bxor want SIGNED -# operands, brushift wants UNSIGNED — and `hash` is a signed 32-bit int. So we -# carry the hash as an UNSIGNED 32-bit value, extract the 5-bit level index with -# arithmetic (mask), and test/count bits with band against (1<= nkeys 16) - # expand to an array-node - (let [nodes (array/new-filled 32 nil) - jdx (mask h shift)] - (put nodes jdx (bin-assoc EMPTY-BIN (+ shift 5) h key val added)) - (var i 0) (var j 0) - (while (< i 32) - (unless (zero? (band bitmap (blshift 1 i))) - (let [ek (in arr (* 2 j)) ev (in arr (+ 1 (* 2 j)))] - (put nodes i (if (nil? ek) ev - (bin-assoc EMPTY-BIN (+ shift 5) (khash ek) ek ev added))) - (++ j))) - (++ i)) - [:an (+ nkeys 1) nodes]) - # insert (key val) into the bin arr at pair-index idx - (let [out (array)] - (array/concat out (array/slice arr 0 (* 2 idx))) - (array/push out key) (array/push out val) - (array/concat out (array/slice arr (* 2 idx))) - (put added 0 true) - [:bin (bor bitmap bit) out]))) - # slot occupied - (let [kon (in arr (* 2 idx)) von (in arr (+ 1 (* 2 idx)))] - (cond - (nil? kon) - [:bin bitmap (cset1 arr (+ 1 (* 2 idx)) (node-assoc von (+ shift 5) h key val added))] - (key= key kon) - [:bin bitmap (cset1 arr (+ 1 (* 2 idx)) val)] - (do (put added 0 true) - [:bin bitmap (cset2 arr (* 2 idx) nil (+ 1 (* 2 idx)) - (create-node (+ shift 5) kon von h key val))]))))) - -(defn- an-assoc [node shift h key val added] - (def cnt (in node 1)) (def arr (in node 2)) - (def idx (mask h shift)) (def sub (in arr idx)) - (if (nil? sub) - [:an (+ cnt 1) (cset1 arr idx (bin-assoc EMPTY-BIN (+ shift 5) h key val added))] - [:an cnt (cset1 arr idx (node-assoc sub (+ shift 5) h key val added))])) - -(defn- hcn-assoc [node shift h key val added] - (def chash (in node 1)) (def cnt (in node 2)) (def arr (in node 3)) - (if (= h chash) - (let [idx (hcn-find arr cnt key)] - (if (= idx -1) - (let [out (array ;arr)] (array/push out key) (array/push out val) - (put added 0 true) [:hcn chash (+ cnt 1) out]) - (if (= (in arr (+ 1 idx)) val) node - [:hcn chash cnt (cset1 arr (+ 1 idx) val)]))) - # different hash at this level: wrap in a bin node, then assoc - (bin-assoc [:bin (bitpos chash shift) (array nil node)] shift h key val added))) - -(set create-node (fn [shift k1 v1 k2h k2 v2] - (def k1h (khash k1)) - (if (= k1h k2h) - [:hcn k1h 2 (array k1 v1 k2 v2)] - (let [added @[false] - n1 (bin-assoc EMPTY-BIN shift k1h k1 v1 added)] - (bin-assoc n1 shift k2h k2 v2 added))))) - -(set node-assoc (fn [node shift h key val added] - (case (in node 0) - :bin (bin-assoc node shift h key val added) - :an (an-assoc node shift h key val added) - :hcn (hcn-assoc node shift h key val added)))) - -(defn- bin-lookup [node shift h key nf] - (def bitmap (in node 1)) (def arr (in node 2)) - (def m (mask h shift)) (def bit (blshift 1 m)) - (if (zero? (band bitmap bit)) nf - (let [idx (bidx bitmap m) kon (in arr (* 2 idx)) von (in arr (+ 1 (* 2 idx)))] - (cond - (nil? kon) (node-lookup von (+ shift 5) h key nf) - (key= key kon) von - nf)))) - -(defn- an-lookup [node shift h key nf] - (def sub (in (in node 2) (mask h shift))) - (if (nil? sub) nf (node-lookup sub (+ shift 5) h key nf))) - -(defn- hcn-lookup [node shift h key nf] - (def idx (hcn-find (in node 3) (in node 2) key)) - (if (< idx 0) nf (in (in node 3) (+ 1 idx)))) - -(set node-lookup (fn [node shift h key nf] - (case (in node 0) - :bin (bin-lookup node shift h key nf) - :an (an-lookup node shift h key nf) - :hcn (hcn-lookup node shift h key nf)))) - -(defn- bin-without [node shift h key] - (def bitmap (in node 1)) (def arr (in node 2)) - (def m (mask h shift)) (def bit (blshift 1 m)) - (if (zero? (band bitmap bit)) node - (let [idx (bidx bitmap m) kon (in arr (* 2 idx)) von (in arr (+ 1 (* 2 idx)))] - (cond - (nil? kon) - (let [nn (node-without von (+ shift 5) h key)] - (cond (not (nil? nn)) [:bin bitmap (cset1 arr (+ 1 (* 2 idx)) nn)] - (= bitmap bit) nil - [:bin (bxor bitmap bit) (remove-pair arr idx)])) - (key= key kon) - (if (= bitmap bit) nil [:bin (bxor bitmap bit) (remove-pair arr idx)]) - node)))) - -(defn- an-without [node shift h key] - (def cnt (in node 1)) (def arr (in node 2)) - (def idx (mask h shift)) (def sub (in arr idx)) - (if (nil? sub) node - (let [nn (node-without sub (+ shift 5) h key)] - (cond - (nil? nn) (if (<= cnt 8) (pack-array-node arr idx) [:an (- cnt 1) (cset1 arr idx nil)]) - [:an cnt (cset1 arr idx nn)])))) - -(defn- hcn-without [node shift h key] - (def chash (in node 1)) (def cnt (in node 2)) (def arr (in node 3)) - (def idx (hcn-find arr cnt key)) - (cond (= idx -1) node - (= cnt 1) nil - [:hcn chash (- cnt 1) (remove-pair arr (brshift idx 1))])) - -(set node-without (fn [node shift h key] - (case (in node 0) - :bin (bin-without node shift h key) - :an (an-without node shift h key) - :hcn (hcn-without node shift h key)))) - -# depth-first walk: call (f k v) for every entry (the nil key is handled at the -# map level, not in the trie). -(defn- node-each [node f] - (case (in node 0) - :bin (let [arr (in node 2) L (length arr)] - (var i 0) - (while (< i L) - (let [k (in arr i) v (in arr (+ i 1))] - (if (nil? k) (when v (node-each v f)) (f k v))) - (+= i 2))) - :an (let [arr (in node 2)] - (var i 0) (while (< i 32) (when (in arr i) (node-each (in arr i) f)) (++ i))) - :hcn (let [arr (in node 3) L (* 2 (in node 2))] - (var i 0) (while (< i L) (f (in arr i) (in arr (+ i 1))) (+= i 2))))) - -# --- map value + public API ------------------------------------------------- -(defn- mk [cnt root has-nil nil-val meta] - @{:jolt/type :jolt/phm :jolt/deftype DEFTYPE - :cnt cnt :root root :has-nil has-nil :nil-val nil-val :_meta meta}) - -(defn phm-get [m k &opt default] - (default default nil) - (if (nil? k) - (if (m :has-nil) (m :nil-val) default) - (let [root (m :root)] - (if root (node-lookup root 0 (khash k) k default) default)))) - -(def- NF (gensym)) -(defn phm-contains? [m k] - (if (nil? k) (truthy? (m :has-nil)) - (let [root (m :root)] - (if root (not= (node-lookup root 0 (khash k) k NF) NF) false)))) - -(defn phm-assoc [m k v] - (if (nil? k) - (mk (if (m :has-nil) (m :cnt) (+ (m :cnt) 1)) (m :root) true v (m :_meta)) - (let [added @[false] - root (or (m :root) EMPTY-BIN) - nroot (node-assoc root 0 (khash k) k v added)] - (mk (if (in added 0) (+ (m :cnt) 1) (m :cnt)) nroot (m :has-nil) (m :nil-val) (m :_meta))))) - -(defn phm-dissoc [m k] - (if (nil? k) - (if (m :has-nil) (mk (- (m :cnt) 1) (m :root) false nil (m :_meta)) m) - (let [root (m :root)] - (if (and root (phm-contains? m k)) - (mk (- (m :cnt) 1) (node-without root 0 (khash k) k) (m :has-nil) (m :nil-val) (m :_meta)) - m)))) - -(defn phm-entries [m] - (def out @[]) - (when (m :has-nil) (array/push out [nil (m :nil-val)])) - (when (m :root) (node-each (m :root) (fn [k v] (array/push out [k v])))) - out) - -(defn phm-to-struct [m] - # a Janet struct can't hold a nil key (matches Clojure struct/keys behavior); - # every other entry carries over. - (def t @{}) - (when (m :root) (node-each (m :root) (fn [k v] (put t k v)))) - (table/to-struct t)) - -(defn phm-count [m] (m :cnt)) - -(defn phm-has-nil? [m] (truthy? (m :has-nil))) - -# --- bulk bottom-up build (jolt-5vsp collections) --------------------------- -# Build the HAMT in one pass from a native array of entries, instead of n -# incremental phm-assoc calls (each of which rebuilt the O(log32 n) path with -# fresh arrays AND allocated a fresh map wrapper). The structure produced is -# IDENTICAL to the incremental one: the trie shape is a function of the key set -# (hash-partitioned, with the same bin<=16 / array-node>=17 promotion threshold -# at each level), so nth/lookup/assoc/without/each read it unchanged. Only a -# hash-collision node's internal order is insertion-dependent, and we preserve -# insertion order there too. Validated against phm-assoc across the size and -# branching boundaries (see the throwaway script in the PR). -# -# Entries are @[h key val] triples (h = khash key). build-node takes a non-empty -# group all destined for the same parent slot and returns its node. -(defn- all-same-hash? [entries] - (def h0 (in (in entries 0) 0)) - (var same true) (var i 1) (def L (length entries)) - (while (< i L) (when (not= (in (in entries i) 0) h0) (set same false) (break)) (++ i)) - same) - -(defn- build-node [entries shift] - (if (and (> (length entries) 1) (all-same-hash? entries)) - # all keys share a full 32-bit hash -> collision node (insertion order) - (let [arr (array)] - (each e entries (array/push arr (in e 1)) (array/push arr (in e 2))) - [:hcn (in (in entries 0) 0) (length entries) arr]) - # partition by the 5-bit mask at this level; iterate slots 0..31 ascending - # so the bin arr / array-node slots land in canonical (bidx) order. - (let [groups @{}] - (each e entries - (def m (mask (in e 0) shift)) - (if-let [g (in groups m)] (array/push g e) (put groups m @[e]))) - (def occupied (array)) - (var i 0) (while (< i 32) (when (in groups i) (array/push occupied i)) (++ i)) - (def s (length occupied)) - (if (>= s 17) - # array-node: every occupied slot is a sub-node (a lone key becomes its - # own single-key bin node at shift+5, matching the expand path). - (let [slots (array/new-filled 32 nil)] - (each m occupied (put slots m (build-node (in groups m) (+ shift 5)))) - [:an s slots]) - # bitmap-indexed node: lone key -> leaf pair, group -> nil + sub-node. - (let [arr (array)] - (var bitmap 0) - (each m occupied - (def g (in groups m)) - (set bitmap (bor bitmap (blshift 1 m))) - (if (= 1 (length g)) - (do (array/push arr (in (in g 0) 1)) (array/push arr (in (in g 0) 2))) - (do (array/push arr nil) (array/push arr (build-node g (+ shift 5)))))) - [:bin bitmap arr]))))) - -(defn phm-from-pairs [pairs &opt meta] - "Bulk-build a phm from an indexed collection of native [k v] pairs. Duplicate - keys follow assoc semantics (last value wins, first-seen key object kept). The - caller must pass native tuples/arrays (phm stays free of the value layer)." - (default meta nil) - (def entries @[]) - (def seen @{}) # canon-key -> index into entries (dedup) - (var has-nil false) (var nil-val nil) - (each p pairs - (def k (in p 0)) (def v (in p 1)) - (if (nil? k) - (do (set has-nil true) (set nil-val v)) - (let [c (ck k)] - (if-let [idx (in seen c)] - (put (in entries idx) 2 v) # last value wins - (do (put seen c (length entries)) - (array/push entries @[(khash k) k v])))))) - (def cnt (+ (length entries) (if has-nil 1 0))) - (def root (if (= 0 (length entries)) nil (build-node entries 0))) - (mk cnt root has-nil nil-val meta)) - -(defn make-phm [&opt kvs] - (default kvs nil) - (if (or (nil? kvs) (= 0 (length kvs))) - (mk 0 nil false nil nil) - # pair up the flat [k0 v0 k1 v1 ...] array and bulk-build - (let [pairs (array) n (length kvs)] - (var i 0) (while (< i n) (array/push pairs [(in kvs i) (in kvs (+ i 1))]) (+= i 2)) - (phm-from-pairs pairs)))) diff --git a/src/jolt/phs.janet b/src/jolt/phs.janet deleted file mode 100644 index c28c62a..0000000 --- a/src/jolt/phs.janet +++ /dev/null @@ -1,60 +0,0 @@ -# PersistentHashSet — a set backed by a PersistentHashMap (members are keys -# mapped to true). Extracted from phm.janet (jolt-bvek) so phm.janet is purely -# the hash map; the set is a thin layer over it. -# -# REP vs API: this file is ONLY the set representation (phs-* primitives). The -# Clojure-facing set ops (conj/disj/contains?/count/seq dispatch, set-as-fn -# membership) live in core_coll.janet / core_types.janet, branching on -# `:jolt/type :jolt/set`. - -(use ./phm) - -(defn set? - "Check if x is a PersistentHashSet." - [x] - (and (table? x) (= :jolt/set (x :jolt/type)))) - -(defn phs-from-seq [xs] - "Bulk-build a PersistentHashSet from an indexed collection of members. Members - back a phm as keys mapped to true, so the bulk HAMT builder (phm-from-pairs, - which dedups by canonical key) gives set semantics in one pass instead of an - immutable phm-assoc per element." - (def pairs @[]) - (each x xs (array/push pairs [x true])) - (def m (phm-from-pairs pairs)) - @{:jolt/type :jolt/set :phm m :cnt (phm-count m)}) - -(defn make-phs [& xs] - "Create a PersistentHashSet from items." - (phs-from-seq xs)) - -(defn phs-conj [s & xs] - (var m (s :phm)) - (each x xs (set m (phm-assoc m x true))) - @{:jolt/type :jolt/set :phm m :cnt (phm-count m)}) - -(defn phs-disj [s & xs] - (var m (s :phm)) - (each x xs (set m (phm-dissoc m x))) - @{:jolt/type :jolt/set :phm m :cnt (phm-count m)}) - -(defn phs-contains? [s x] - (phm-contains? (s :phm) x)) - -(defn phs-count [s] - (s :cnt)) - -(defn phs-empty? [s] - (= 0 (s :cnt))) - -(defn phs-seq [s] - # phm-to-struct drops a nil member (a Janet struct can't hold a nil key), so - # re-attach it from the phm's has-nil slot. Keep the struct-key order for the - # non-nil members so set printing stays stable. - (def m (s :phm)) - (def ks (keys (phm-to-struct m))) - (if (phm-has-nil? m) (tuple nil ;ks) (tuple ;ks))) - -(defn phs-get [s x &opt default] - (default default nil) - (if (phm-contains? (s :phm) x) x default)) diff --git a/src/jolt/plist.janet b/src/jolt/plist.janet deleted file mode 100644 index a32a284..0000000 --- a/src/jolt/plist.janet +++ /dev/null @@ -1,76 +0,0 @@ -# Persistent list — an immutable singly-linked cons cell, modeled on Clojure's -# PersistentList. The whole point is O(1) prepend (conj/cons): a new node simply -# points at the existing list as its tail, sharing all of it, so building a list -# with repeated conj is O(n) total instead of O(n²) array copies. -# -# A node is: -# @{:jolt/type :jolt/plist -# :first x head element -# :rest r tail: another plist, or a Janet array/tuple (a list that -# was conj'd onto), or nil for the empty tail -# :count n} element count, or nil when unknown (cons onto a lazy tail) -# -# `:rest` may be a plain array/tuple so `(conj some-list x)` needn't copy the -# original list — the node just references it. pl->array materializes the chain. -# -# REP vs API: this file is ONLY the cons-list representation (pl-* primitives). -# The Clojure-facing list/seq ops (conj/cons/first/rest/count/seq dispatch) live -# in core_coll.janet, which branches on `:jolt/type :jolt/plist`. - -(defn plist? [x] - (and (table? x) (= :jolt/plist (get x :jolt/type)))) - -(defn- counted - "Count of a tail value if known in O(1), else nil." - [r] - (cond - (nil? r) 0 - (plist? r) (get r :count) - (or (array? r) (tuple? r) (string? r) (buffer? r)) (length r) - nil)) - -(defn pl-cons - "Prepend x onto tail r (a plist / array / tuple / nil). O(1)." - [x r] - (def c (counted r)) - @{:jolt/type :jolt/plist :first x :rest r :count (if c (+ c 1) nil)}) - -(def EMPTY-PLIST @{:jolt/type :jolt/plist :first nil :rest nil :count 0}) - -(defn pl-empty? [p] (= 0 (get p :count))) -(defn pl-first [p] (get p :first)) - -(defn pl->array - "Materialize the cons chain to a fresh Janet array." - [p] - (def out @[]) - (var cur p) - (while (plist? cur) - (if (= 0 (get cur :count)) - (set cur nil) - (do (array/push out (get cur :first)) (set cur (get cur :rest))))) - # cur is now a non-plist tail (array/tuple) or nil - (when (and (not (nil? cur)) (or (array? cur) (tuple? cur))) - (each x cur (array/push out x))) - out) - -(defn pl-count [p] - (def c (get p :count)) - (if (nil? c) (length (pl->array p)) c)) - -(defn pl-rest - "The tail as a seqable (array). Returns an empty array for a one-element list." - [p] - (if (or (= 0 (get p :count)) (nil? (get p :rest))) - @[] - (get p :rest))) - -(defn pl-from-indexed - "Build a plist from a Janet array/tuple, preserving order. O(n)." - [xs] - (var p EMPTY-PLIST) - (var i (- (length xs) 1)) - (while (>= i 0) - (set p (pl-cons (in xs i) p)) - (-- i)) - p) diff --git a/src/jolt/png.janet b/src/jolt/png.janet deleted file mode 100644 index de45943..0000000 --- a/src/jolt/png.janet +++ /dev/null @@ -1,104 +0,0 @@ -# Minimal PNG encoder (the host side of `jolt.png`). 8-bit truecolour RGB -# (colour type 2), no interlace, filter 0 (None), and STORED (uncompressed) -# DEFLATE blocks — a valid zlib stream that needs no compressor. Files are larger -# than a compressed PNG but decode everywhere. -# -# Lives in Janet, not Clojure: jolt's per-op cost makes per-byte work (CRC32 over -# every byte) impractical in the overlay, so the whole encode runs here natively -# and jolt calls `write` once with a raw-RGB buffer. Exposed to jolt as -# `janet.png/...` via eval_base's module-load-env (see eval_base.janet). -# -# Janet's bit ops are 32-bit SIGNED (0xFFFFFFFF overflows), so the 32-bit -# unsigned arithmetic of CRC32/Adler32 is done with plain number ops (doubles -# hold 2^32 exactly) plus byte-level bxor, whose operands are always 0..255. - -(defn- u8 [v] (% v 256)) # low byte -(defn- shr [v n] (math/floor (/ v n))) # logical shift-right by a power of two - -# 32-bit xor via 4 byte-wise xors (each operand 0..255, safely in 32-bit range). -(defn- xor32 [a b] - (var r 0) - (var m 1) - (for i 0 4 - (set r (+ r (* (bxor (% (shr a m) 256) (% (shr b m) 256)) m))) - (set m (* m 256))) - r) - -(def- crc-table - (let [t (array/new-filled 256 0)] - (for n 0 256 - (var c n) - (for _ 0 8 - (set c (if (= 1 (% c 2)) (xor32 0xEDB88320 (shr c 2)) (shr c 2)))) - (put t n c)) - t)) - -(defn- crc32 [buf] - (var c 0xFFFFFFFF) - (def n (length buf)) - (for i 0 n - (set c (xor32 (get crc-table (bxor (% c 256) (get buf i))) (shr c 256)))) - (- 0xFFFFFFFF c)) # final xor with all-ones = complement - -(defn- adler32 [buf] - (var a 1) - (var b 0) - (def n (length buf)) - (for i 0 n - (set a (% (+ a (get buf i)) 65521)) - (set b (% (+ b a) 65521))) - (+ (* b 65536) a)) - -(defn- push-u32be [out v] - (buffer/push-byte out (% (shr v 16777216) 256) (% (shr v 65536) 256) - (% (shr v 256) 256) (% v 256))) - -(defn- push-chunk [out typ data] - (push-u32be out (length data)) - (def tagged (buffer typ data)) # CRC covers type + data - (buffer/push-string out tagged) - (push-u32be out (crc32 tagged))) - -# zlib stream of `raw` as stored DEFLATE blocks (<=65535 bytes each). -(defn- zlib-store [raw] - (def out (buffer/new (+ (length raw) 64))) - (buffer/push-byte out 0x78 0x01) # zlib header: CM=8 CINFO=7, FCHECK ok - (def n (length raw)) - (var pos 0) - (while (< pos n) - (def len (min 65535 (- n pos))) - (def final (if (>= (+ pos len) n) 1 0)) - (def nlen (- 65535 len)) # one's-complement of len in 16 bits - (buffer/push-byte out final (% len 256) (shr len 256) (% nlen 256) (shr nlen 256)) - (buffer/push-string out (buffer/slice raw pos (+ pos len))) - (set pos (+ pos len))) - (push-u32be out (adler32 raw)) - out) - -(defn encode - "Encode a w*h*3 raw-RGB buffer (row-major, top row first) as a PNG buffer." - [w h rgb] - (assert (= (length rgb) (* w h 3)) "png/encode: rgb length != w*h*3") - (def out (buffer/new (+ 64 (* w h 3)))) - (buffer/push-string out "\x89PNG\r\n\x1a\n") - (def ihdr (buffer/new 13)) - (push-u32be ihdr w) - (push-u32be ihdr h) - (buffer/push-byte ihdr 8 2 0 0 0) # bit depth 8, colour type 2 (RGB), … - (push-chunk out "IHDR" ihdr) - # scanlines, each prefixed with filter byte 0 (None) - (def stride (* w 3)) - (def raw (buffer/new (* h (+ 1 stride)))) - (for y 0 h - (buffer/push-byte raw 0) - (def off (* y stride)) - (buffer/push-string raw (buffer/slice rgb off (+ off stride)))) - (push-chunk out "IDAT" (zlib-store raw)) - (push-chunk out "IEND" (buffer/new 0)) - out) - -(defn write - "Encode and write a w*h*3 raw-RGB buffer to `path` as a PNG." - [path w h rgb] - (spit path (encode w h rgb)) - path) diff --git a/src/jolt/pv.janet b/src/jolt/pv.janet deleted file mode 100644 index e4f43d4..0000000 --- a/src/jolt/pv.janet +++ /dev/null @@ -1,189 +0,0 @@ -# Persistent vector — a 32-way branching trie with a tail buffer, modeled on -# Clojure's PersistentVector. Immutable: every update returns a new vector that -# structurally shares unchanged subtrees with the old one, so conj/assoc/pop are -# O(log32 n) and share memory instead of copying the whole vector. -# -# Layout: -# @{:jolt/type :jolt/pvec -# :cnt n number of elements -# :shift s bits to shift the index for the root level (5 * depth) -# :root node trie root: a tuple of up to 32 children -# :tail tail} a tuple of up to 32 trailing elements (append fast-path) -# -# Trie nodes are immutable tuples so unchanged subtrees are shared by identity. -# -# REP vs API: this file is ONLY the trie representation (pv-* primitives). The -# Clojure-facing vector ops (nth/conj/assoc/subvec, the count/seq/first/rest -# dispatch, and tuple↔pvec polymorphism) live in core_coll.janet / -# core_types.janet, which dispatch on `:jolt/type :jolt/pvec`. - -(def- bits 5) -(def- width 32) # 2^bits -(def- mask 31) # width - 1 - -(def empty-node []) - -(defn pvec? [x] - (and (table? x) (= :jolt/pvec (get x :jolt/type)))) - -(defn make-pv [cnt shift root tail] - @{:jolt/type :jolt/pvec :cnt cnt :shift shift :root root :tail tail}) - -(def EMPTY (make-pv 0 bits empty-node [])) - -(defn pv-count [pv] (get pv :cnt)) - -# Index of the first element held in the tail (everything before lives in the trie). -(defn- tail-offset [cnt] - (if (< cnt width) 0 (blshift (brshift (- cnt 1) bits) bits))) - -# Return the 32-element leaf array containing index i. -(defn- leaf-for [pv i] - (if (>= i (tail-offset (get pv :cnt))) - (get pv :tail) - (do - (var node (get pv :root)) - (var level (get pv :shift)) - (while (> level 0) - (set node (get node (band (brshift i level) mask))) - (set level (- level bits))) - node))) - -(defn pv-nth [pv i &opt dflt] - (if (and (>= i 0) (< i (get pv :cnt))) - (get (leaf-for pv i) (band i mask)) - dflt)) - -# --- conj ------------------------------------------------------------------- - -# Push the full tail down into the trie, returning a new root node array. -(defn- push-tail [level parent tail cnt] - (def sub-idx (band (brshift (- cnt 1) level) mask)) - (def child - (if (= level bits) - tail - (let [c (get parent sub-idx)] - (if c - (push-tail (- level bits) c tail cnt) - (push-tail (- level bits) empty-node tail cnt))))) - (def arr (array/slice parent)) - (put arr sub-idx child) - (tuple/slice arr)) - -(defn pv-conj [pv val] - (def cnt (get pv :cnt)) - (def tail (get pv :tail)) - (if (< (length tail) width) - # Room in the tail: just append to it. - (make-pv (+ cnt 1) (get pv :shift) - (get pv :root) - (tuple/slice (tuple ;tail val))) - # Tail is full: push it into the trie, start a fresh tail with val. - (let [shift (get pv :shift) - root (get pv :root)] - (if (> (brshift cnt bits) (blshift 1 shift)) - # Root overflow: grow the trie one level taller. - (let [new-root (tuple root (push-tail shift empty-node tail cnt))] - (make-pv (+ cnt 1) (+ shift bits) new-root [val])) - (make-pv (+ cnt 1) shift (push-tail shift root tail cnt) [val]))))) - -# --- assoc ------------------------------------------------------------------ - -(defn- assoc-in-node [level node i val] - (def arr (array/slice node)) - (if (= level 0) - (put arr (band i mask) val) - (let [sub-idx (band (brshift i level) mask)] - (put arr sub-idx (assoc-in-node (- level bits) (get node sub-idx) i val)))) - (tuple/slice arr)) - -(defn pv-assoc [pv i val] - (def cnt (get pv :cnt)) - (cond - (= i cnt) (pv-conj pv val) - (and (>= i 0) (< i cnt)) - (if (>= i (tail-offset cnt)) - (let [tail (array/slice (get pv :tail))] - (put tail (band i mask) val) - (make-pv cnt (get pv :shift) (get pv :root) (tuple/slice tail))) - (make-pv cnt (get pv :shift) - (assoc-in-node (get pv :shift) (get pv :root) i val) - (get pv :tail))) - (error (string "Index " i " out of bounds for vector of length " cnt)))) - -# --- pop -------------------------------------------------------------------- - -(defn- pop-tail [level node cnt] - (def sub-idx (band (brshift (- cnt 2) level) mask)) - (cond - (> level bits) - (let [child (pop-tail (- level bits) (get node sub-idx) cnt)] - (if (and (nil? child) (= sub-idx 0)) - nil - (let [arr (array/slice node)] (put arr sub-idx child) (tuple/slice arr)))) - (= sub-idx 0) nil - (let [arr (array/slice node)] (put arr sub-idx nil) (tuple/slice arr)))) - -(defn pv-pop [pv] - (def cnt (get pv :cnt)) - (cond - (= cnt 0) (error "Can't pop empty vector") - (= cnt 1) EMPTY - (> (- cnt (tail-offset cnt)) 1) - # More than one element in the tail: drop the last tail element. - (let [tail (get pv :tail)] - (make-pv (- cnt 1) (get pv :shift) (get pv :root) - (tuple/slice tail 0 (- (length tail) 1)))) - # Tail has one element: the new tail is the last leaf of the trie. - (let [shift (get pv :shift) - new-tail (leaf-for pv (- cnt 2)) - new-root-raw (pop-tail shift (get pv :root) cnt) - new-root (if (nil? new-root-raw) empty-node new-root-raw)] - (if (and (> shift bits) (nil? (get new-root 1))) - # Trie lost a level: promote the single remaining child to root. - (make-pv (- cnt 1) (- shift bits) (get new-root 0) new-tail) - (make-pv (- cnt 1) shift new-root new-tail))))) - -# --- conversions ------------------------------------------------------------ - -(defn pv->array [pv] - (def out @[]) - (def cnt (get pv :cnt)) - (var i 0) - (while (< i cnt) - (array/push out (pv-nth pv i)) - (++ i)) - out) - -(defn pv-from-indexed [xs] - # Build a pvec from any Janet-indexed collection (tuple/array) by constructing - # the trie BOTTOM-UP in one pass, instead of n incremental pv-conj calls (each - # of which allocated a pv wrapper and copied the tail). The structure produced - # is identical to the incremental one — tail-offset(n) = ((n-1)>>5)<<5 is - # exactly the trie/tail split, so leaf-for/nth/conj/assoc all read it the same. - # This is the bulk path behind vec/mapv/into-a-vector (jolt-5vsp collections). - (def n (length xs)) - (if (<= n width) - # everything fits in the tail (matches EMPTY's shift) - (make-pv n bits empty-node (tuple/slice xs)) - (let [tail-len (+ 1 (mod (- n 1) width)) - trie-count (- n tail-len) # = tail-offset(n), a multiple of width - tail (tuple/slice xs trie-count n)] - # value leaves: full 32-element tuples over [0, trie-count) - (def leaves @[]) - (var i 0) - (while (< i trie-count) - (array/push leaves (tuple/slice xs i (+ i width))) - (set i (+ i width))) - # group nodes 32-wide, bottom-up, until <=32 remain; that becomes the root - (var level leaves) - (var shift bits) - (while (> (length level) width) - (def parent @[]) - (var j 0) - (while (< j (length level)) - (array/push parent (tuple/slice level j (min (length level) (+ j width)))) - (set j (+ j width))) - (set level parent) - (set shift (+ shift bits))) - (make-pv n shift (tuple/slice level) tail)))) diff --git a/src/jolt/reader.janet b/src/jolt/reader.janet deleted file mode 100644 index 8fe95b6..0000000 --- a/src/jolt/reader.janet +++ /dev/null @@ -1,833 +0,0 @@ -# Jolt Clojure Reader -# Recursive descent parser for Clojure source text. -# Output convention: -# Symbols foo, foo/bar → {:jolt/type :symbol :ns "foo" :name "bar"} -# Keywords :foo, :foo/bar → Janet keyword :foo, :foo/bar -# Lists (a b c) → Janet array @[a b c] -# Vectors [a b c] → Janet tuple [a b c] -# Maps {:a 1} → Janet struct {:a 1} -# Sets #{1 2} → tagged struct {:jolt/type :jolt/set :value [1 2]} - -(use ./types) -(import ./phm :as phm) - -# Forward declaration for mutual recursion -(var read-form nil) -(var read-meta nil) # forward decl: read-dispatch (#^) calls it before its defn below - -# Source-position tracking for the success checker (jolt-fqy). When enabled, the -# reader records each LIST form's absolute start offset (lists are the forms that -# become :invoke nodes — what the checker reports on). Off by default: a flag -# check per list is the only cost when the checker isn't running. Keyed by form -# IDENTITY (lists are fresh arrays, never interned), so a position survives -# macroexpansion exactly when the user's own sub-form is spliced through, and is -# absent for macro-synthesized structure — which is what we want (fall back to -# the call site). Not cleared between parses: nested parses (a require mid-load) -# would otherwise drop an outer file's positions; the table is bounded by forms -# compiled this process and only populated when the checker is on. -(def form-pos-table @{}) -(var track-positions false) -(var pos-base 0) # absolute offset of the slice read-form currently sees - -(defn track-positions! - "Enable/disable list-form position recording (jolt-fqy)." - [on] (set track-positions on)) - -(defn set-pos-base! - "Tell the reader the absolute offset of the slice it is about to read, so - recorded list positions are absolute (parse-all-positioned reads a shrinking - remainder)." - [b] (set pos-base b)) - -(defn form-pos - "Absolute start offset recorded for a list form, or nil." - [form] (get form-pos-table form)) - -(defn checker-enabled? - "True when JOLT_TYPE_CHECK selects a non-off level — the loaders use this to - decide whether to record form positions for the checker (jolt-fqy)." - [] - (def tc (os/getenv "JOLT_TYPE_CHECK")) - (if (and tc (not= tc "off") (not= tc "0")) true false)) - -(def whitespace-chars " \t\n\r,") - -(defn whitespace? [c] - (or (= c 32) # space - (= c 10) # \n - (= c 9) # \t - (= c 13) # \r - (= c 44))) # comma - -# Reader errors carry the raw byte OFFSET; the parse entry points (parse-string, -# parse-all-positioned) convert offset -> line:col against the full source and -# re-raise Clojure's 'Syntax error reading source at (file:line:col): msg' -# shape. Raising structured here keeps the 15 error sites one-liners. -# (jolt-2o7.5) -(defn- reader-error [msg pos] - (error {:jolt/type :jolt/reader-error :msg msg :pos pos})) - -(defn line-col - "1-based [line col] of byte offset in source." - [source offset] - (var line 1) - (var bol 0) - (def stop (min offset (length source))) - (loop [i :range [0 stop]] - (when (= (in source i) (chr "\n")) (++ line) (set bol (+ i 1)))) - [line (+ 1 (- stop bol))]) - -(defn format-reader-error - "Clojure-shaped syntax error message for a reader-error struct raised - against source; file may be nil (omitted)." - [e source file] - (def [l c] (line-col source (e :pos))) - (if file - (string "Syntax error reading source at (" file ":" l ":" c "): " (e :msg)) - (string "Syntax error reading source at (" l ":" c "): " (e :msg)))) - -(defn reader-error? [e] - (and (struct? e) (= :jolt/reader-error (e :jolt/type)))) - -(defn skip-whitespace [s pos] - (if (and (< pos (length s)) - (whitespace? (s pos))) - (skip-whitespace s (+ pos 1)) - pos)) - -(defn digit? [c] - (and (>= c 48) (<= c 57))) - -(defn hex-digit? [c] - (or (and (>= c 48) (<= c 57)) - (and (>= c 65) (<= c 70)) - (and (>= c 97) (<= c 102)))) - -(defn symbol-start? [c] - (or (and (>= c 65) (<= c 90)) # A-Z - (and (>= c 97) (<= c 122)) # a-z - (= c 42) # * - (= c 43) # + - (= c 33) # ! - (= c 95) # _ - (= c 45) # - - (= c 63) # ? - (= c 46) # . - (= c 60) # < - (= c 62) # > - (= c 61) # = - (= c 38) # & - (= c 124) # | - (= c 36) # $ - (= c 37) # % - (= c 47))) # / - -(defn symbol-char? [c] - (or (symbol-start? c) - (digit? c) - (= c 35) # # - (= c 39) # ' - (= c 58))) # : - -(defn read-symbol-name [s pos end] - (if (and (< end (length s)) - (symbol-char? (s end))) - (read-symbol-name s pos (+ end 1)) - end)) - -(defn make-symbol - "Create a Jolt symbol struct." - [name] - (let [slash (string/find "/" name)] - (if (and slash (> slash 0)) - {:jolt/type :symbol - :ns (string/slice name 0 slash) - :name (string/slice name (+ slash 1))} - {:jolt/type :symbol - :ns nil - :name name}))) - -(defn sym - "Convenience to create a symbol during testing." - [name] - (make-symbol name)) - -(defn read-symbol [s pos] - (let [end (read-symbol-name s pos pos)] - (if (= end pos) - (reader-error (string "Unrecognized character: " (string/from-bytes (s pos))) pos) - (let [name (string/slice s pos end)] - (if (= name "nil") [nil end] - (if (= name "true") [true end] - (if (= name "false") [false end] - [(make-symbol name) end]))))))) - -(defn read-keyword-name [s pos end] - (if (and (< end (length s)) - (symbol-char? (s end))) - (read-keyword-name s pos (+ end 1)) - end)) - -(defn read-keyword [s pos] - # pos is at the first colon - (if (and (< (+ pos 1) (length s)) (= (s (+ pos 1)) 58)) - # ::foo/bar — auto-resolved keyword - (let [start (+ pos 2) - end (read-keyword-name s start start) - name (string/slice s start end)] - [(keyword name) end]) - # :foo or :foo/bar - (let [start (+ pos 1) - end (read-keyword-name s start start) - name (string/slice s start end)] - [(keyword name) end]))) - -(defn escape-char [c] - (if (= c 110) "\n" - (if (= c 116) "\t" - (if (= c 114) "\r" - (if (= c 92) "\\" - (if (= c 34) "\"" - (string/from-bytes c))))))) - -(defn read-string-chars [s pos end chars] - (if (>= pos end) - (reader-error "Unterminated string" pos) - (let [c (s pos)] - (if (= c 92) # backslash - (let [next-pos (+ pos 1)] - (if (>= next-pos end) - (reader-error "Unterminated escape" pos) - (read-string-chars s (+ pos 2) end - (array/push chars (escape-char (s next-pos)))))) - (if (= c 34) # closing quote - [pos chars] - (read-string-chars s (+ pos 1) end - (array/push chars (string/from-bytes c)))))))) - -(defn read-string [s pos] - # pos is at opening double-quote - (let [end (length s) - [new-pos chars] (read-string-chars s (+ pos 1) end @[])] - [(string/join chars "") (+ new-pos 1)])) - -(defn read-hex-digits [s pos end] - (if (and (< end (length s)) (hex-digit? (s end))) - (read-hex-digits s pos (+ end 1)) - end)) - -(defn read-digits [s pos end] - (if (and (< end (length s)) (digit? (s end))) - (read-digits s pos (+ end 1)) - end)) - -(defn read-fractional [s pos end] - (if (and (< end (length s)) (digit? (s end))) - (read-fractional s pos (+ end 1)) - end)) - -# Value of an alphanumeric digit for radix parsing (0-9, a-z/A-Z = 10-35). -(defn- radix-digit-val [c] - (cond - (and (>= c 48) (<= c 57)) (- c 48) # 0-9 - (and (>= c 97) (<= c 122)) (+ 10 (- c 97)) # a-z - (and (>= c 65) (<= c 90)) (+ 10 (- c 65)) # A-Z - nil)) -(defn- read-alnum [s pos end] - (if (and (< end (length s)) (not (nil? (radix-digit-val (s end))))) - (read-alnum s pos (+ end 1)) - end)) -(defn- read-exponent - "If s[end] is e/E (optionally with sign) followed by digits, return the index - past the exponent; else end." - [s end] - (let [len (length s)] - (if (and (< end len) (or (= (s end) 101) (= (s end) 69))) # e / E - (let [p (if (and (< (+ end 1) len) (or (= (s (+ end 1)) 43) (= (s (+ end 1)) 45))) (+ end 2) (+ end 1)) - de (read-digits s p p)] - (if (> de p) de end)) - end))) - -# Jolt has no true bignum/ratio types (see README): an integer/float literal -# suffixed N (bigint) or M (bigdec) reads as the plain number, a ratio a/b reads -# as the double quotient, and radixed integers (2r101, 16rFF) are parsed by base. -(defn read-number [s pos] - (var start pos) # start is mutable for sign handling - (var neg false) - (def len (length s)) - # optional sign - (if (and (< pos len) (= (s pos) 45)) - (do (set start (+ pos 1)) (set neg true))) - - (let [pos start - hex? (and (< (+ pos 1) len) - (= (s pos) 48) (or (= (s (+ pos 1)) 120) (= (s (+ pos 1)) 88)))] # 0x / 0X - (if hex? - (let [hs (+ pos 2) he (read-hex-digits s hs hs)] - (if (= he hs) (reader-error "Expected hex digits" pos)) - (let [he2 (if (and (< he len) (= (s he) 78)) (+ he 1) he) # trailing N - val (scan-number (string "0x" (string/slice s hs he)))] - [(if neg (- val) val) he2])) - (let [iend (read-digits s pos pos)] - (if (= iend pos) (reader-error "Expected number" pos)) - (cond - # radix integer: r, e.g. 2r1010, 16rFF, 36rZ - (and (< iend len) (or (= (s iend) 114) (= (s iend) 82))) - (let [base (scan-number (string/slice s pos iend)) - ds (+ iend 1) - de (read-alnum s ds ds)] - (if (= de ds) (reader-error "Expected radix digits" ds)) - (var acc 0) - (var i ds) - (while (< i de) (set acc (+ (* acc base) (radix-digit-val (s i)))) (++ i)) - [(if neg (- acc) acc) de]) - # ratio: / (only when a digit follows the slash) - (and (< (+ iend 1) len) (= (s iend) 47) (digit? (s (+ iend 1)))) - (let [ds (+ iend 1) de (read-digits s ds ds) - numr (scan-number (string/slice s pos iend)) - den (scan-number (string/slice s ds de))] - [(if neg (- (/ numr den)) (/ numr den)) de]) - # fractional and/or exponent, optional trailing N/M - (let [frac-end (if (and (< iend len) (= (s iend) 46)) - (let [fs (+ iend 1) fe (read-fractional s fs fs)] - (if (= fe fs) (error "Expected digit after .")) fe) - iend) - exp-end (read-exponent s frac-end) - val (scan-number (string/slice s start exp-end)) - # consume a trailing N (bigint) or M (bigdec) suffix - fin (if (and (< exp-end len) (or (= (s exp-end) 78) (= (s exp-end) 77))) - (+ exp-end 1) exp-end)] - [(if neg (- val) val) fin])))))) - -# Read forms until `close` (a byte), returning [items end-pos]. Shared by the -# list/vector/set readers: skip #_ discards and splice #?@ items uniformly, so the -# skip/splice handling can't drift between them (it did once). The map reader -# keeps its own loop — its key/value pairing needs a different value-slot scan. -(defn read-delimited [s start-pos close err] - (defn read-items [s pos items] - (let [pos (skip-whitespace s pos)] - (if (>= pos (length s)) - (reader-error err pos)) - (if (= (s pos) close) - [items (+ pos 1)] - (let [[form new-pos] (read-form s pos)] - # skip #_ discarded forms - (if (and (struct? form) (= :jolt/skip (form :jolt/type))) - (read-items s new-pos items) - # splice #?@ items into the collection - (if (and (struct? form) (= :jolt/splice (form :jolt/type))) - (read-items s new-pos (array/concat items (form :items))) - (read-items s new-pos (array/push items form)))))))) - (read-items s start-pos @[])) - -(defn read-list [s pos] - # pos is at opening paren - (read-delimited s (+ pos 1) 41 "Unterminated list")) # ) - -(defn read-vector [s pos] - # pos is at opening bracket - (let [[items end] (read-delimited s (+ pos 1) 93 "Unterminated vector")] # ] - [(tuple/slice (tuple ;items)) end])) - -# A map-literal form. Janet structs drop nil keys/values, so when a key or value -# is nil (e.g. {:a nil}) build a phm — it preserves nil, matching Clojure. The -# common nil-free case stays a struct: fast, and what the downstream map-form -# handling (evaluator/analyzer) already expects. Collection keys are left to -# eval-time construction (build-map-literal/eval-form), which phm-ifies them. -# Public so the jolt.host contract (host_iface form-make-map) can build a map FORM -# with the same source-order kv tracking the portable Clojure reader relies on. -(defn reader-map [kvs] - (var has-nil false) (var i 0) - (while (< i (length kvs)) (when (nil? (in kvs i)) (set has-nil true) (break)) (++ i)) - # Source order rides along out-of-band (jolt-p3c): struct iteration is hash - # order, but Clojure evaluates literal entries left to right. A struct - # PROTOTYPE carries it without changing the form's map behavior (keys/kvs/ - # length ignore protos; jolt-equal? compares maps structurally); the phm rep - # (nil key/value present) gets a plain extra field. - (if has-nil - (let [m (phm/make-phm kvs)] - (put m :jolt/kv-order (tuple/slice kvs)) - m) - (struct/with-proto (struct :jolt/kv-order (tuple/slice kvs)) ;kvs))) - -(defn form-kv-order - "Source-ordered [k v k v ...] tuple of a map FORM (nil for maps built at - runtime, which carry no reader order)." - [form] - (cond - (struct? form) (get (struct/getproto form) :jolt/kv-order) - (table? form) (get form :jolt/kv-order))) - -(defn read-map [s pos] - # pos is at opening brace - (defn read-kvs [s pos kvs] - (let [pos (skip-whitespace s pos)] - (if (>= pos (length s)) - (reader-error "Unterminated map" pos)) - (if (= (s pos) 125) # } - [(reader-map kvs) (+ pos 1)] - (let [[key new-pos] (read-form s pos)] - (if (and (struct? key) (= :jolt/skip (key :jolt/type))) - (read-kvs s new-pos kvs) - (if (and (struct? key) (= :jolt/splice (key :jolt/type))) - (read-kvs s new-pos (array/concat kvs (key :items))) - (let [pos (skip-whitespace s new-pos) - # The VALUE slot must skip comments/#_ while KEEPING the - # pending key: dropping both (the old behavior) desynced - # the kv pairing — {:a ; comment\n 1} read 1 as the next - # KEY and the closing } landed in value position - # ("Unmatched closing brace", jolt-ou8 / Selmer deps.edn). - [val new-pos2] - (do - (var vp pos) - (var v nil) - (var looking true) - (while looking - (def [f np] (read-form s vp)) - (set vp np) - (if (and (struct? f) (= :jolt/skip (f :jolt/type))) - (set vp (skip-whitespace s np)) - (do (set v f) (set looking false)))) - [v vp])] - (if (and (struct? val) (= :jolt/splice (val :jolt/type))) - # Only push key if splice contributes items - (if (> (length (val :items)) 0) - (do (array/push kvs key) (read-kvs s new-pos2 (array/concat kvs (val :items)))) - (read-kvs s new-pos2 kvs)) - (read-kvs s new-pos2 (-> kvs (array/push key) (array/push val))))))))))) - (read-kvs s (+ pos 1) @[])) - -(defn read-set [s pos] - # pos is at #, next char is { - (let [[items end] (read-delimited s (+ pos 2) 125 "Unterminated set")] # } - [{:jolt/type :jolt/set :value (tuple/slice (tuple ;items))} end])) - -(defn read-char-name-end [s pos] - (if (and (< pos (length s)) (symbol-char? (s pos))) - (read-char-name-end s (+ pos 1)) - pos)) - -(defn read-char [s pos] - # pos is at backslash; produce a char value directly (self-evaluating) - (when (>= (+ pos 1) (length s)) - (error "unexpected end of input after \\")) - (let [end (read-char-name-end s (+ pos 1))] - (if (= end (+ pos 1)) - # The char right after \ isn't a symbol char (e.g. \{ \( \, \% \" ): it's a - # one-character literal of that character itself. - [(make-char (s (+ pos 1))) (+ pos 2)] - (let [char-name (string/slice s (+ pos 1) end)] - [(char-from-name char-name) end])))) - -(defn read-anon-fn [s pos] - # pos is at #, next char is ( - (let [[form new-pos] (read-form s (+ pos 1))] - # Positional index of a %-symbol name: % and %1 are both 1, %N is N, %& is the - # rest param (:rest); anything else is not a positional (nil). The fixed arity - # is the MAX index used (Clojure semantics: #(do %2 %&) -> [p1 p2 & rest], so - # unused lower positions still get a placeholder param and %& starts after %2). - (defn- pct-index [nm] - (cond - (= nm "%") 1 - (= nm "%&") :rest - (and (> (length nm) 1) (= "%" (string/slice nm 0 1))) - (let [n (scan-number (string/slice nm 1))] - (if (and n (= n (math/floor n)) (>= n 1)) n nil)) - nil)) - # Pass 1: max positional index + whether %& is used. - (var max-n 0) - (var has-rest false) - (defn- scan-pct [f] - (cond - (and (struct? f) (= :symbol (f :jolt/type))) - (let [i (pct-index (f :name))] - (cond (= i :rest) (set has-rest true) - (and i (> i max-n)) (set max-n i))) - (or (array? f) (tuple? f)) (each x f (scan-pct x)) - # set literal form — scan its elements (#(... #{%} ...)) - (and (struct? f) (= :jolt/set (f :jolt/type))) (each x (f :value) (scan-pct x)) - # map literal form — scan its keys AND values (#(... {:k %} ...)) - (not (nil? (form-kv-order f))) (each x (form-kv-order f) (scan-pct x)) - nil)) - (scan-pct form) - # One canonical gensym per slot 1..max-n (placeholders for unused), plus rest. - # Param names carry a trailing `#` (auto-gensym suffix, matching Clojure's - # `p1__N#`) so a #() written inside a syntax-quote survives: sq-symbol treats - # `#`-suffixed names as auto-gensyms (mapped consistently, left unqualified) - # rather than qualifying them to the current ns — a qualified symbol is not a - # valid fn param. Harmless outside a backtick (just a regular symbol name). - (def slot-syms @{}) - (var i 1) - (while (<= i max-n) (put slot-syms i (sym (string (gensym) "#"))) (++ i)) - (def rest-sym (if has-rest (sym (string (gensym) "#")) nil)) - # Pass 2: replace each %-symbol with its slot's gensym. - (defn- replace-pct [f] - (cond - (and (struct? f) (= :symbol (f :jolt/type))) - (let [idx (pct-index (f :name))] - (cond (= idx :rest) rest-sym - idx (get slot-syms idx) - f)) - (array? f) (array ;(map replace-pct f)) - (tuple? f) (tuple ;(map replace-pct f)) - (and (struct? f) (= :jolt/set (f :jolt/type))) - {:jolt/type :jolt/set :value (tuple ;(map replace-pct (f :value)))} - (not (nil? (form-kv-order f))) - (reader-map (array ;(map replace-pct (form-kv-order f)))) - f)) - (def replaced (replace-pct form)) - (def arg-names @[]) - (set i 1) - (while (<= i max-n) (array/push arg-names (get slot-syms i)) (++ i)) - (when has-rest - (array/push arg-names (sym "&")) - (array/push arg-names rest-sym)) - [@[(sym "fn*") (tuple ;arg-names) replaced] new-pos])) - -# The reader-conditional feature set (spec 02-reader S18): jolt is its own -# dialect, so the portable convention applies — the dialect key plus :default. -# Matching is by CLAUSE order (the first clause whose key is in the feature -# set wins), exactly like Clojure — NOT key-priority. JOLT_FEATURES overrides -# (comma-separated, e.g. "jolt,clj,default") for compat experiments and A/B -# measurement; :default is always honored. -# Mutable so a loading context can opt a clj-targeted foreign library into -# :clj compatibility (e.g. SCI) — see reader-features-set!. jolt itself and -# the conformance surface read under the portable set. -(var reader-features nil) - -(defn reader-features-set! - "Replace the active reader-conditional feature set (a list of keyword-name - strings or keywords). :default is always honored. Returns the previous set - so callers can restore." - [names] - (def prev reader-features) - (def t @{}) - (each n names (put t (if (keyword? n) n (keyword n)) true)) - (put t :default true) - (set reader-features t) - prev) - -(reader-features-set! - (let [env (os/getenv "JOLT_FEATURES")] - (if env (filter |(> (length $) 0) (string/split "," env)) - ["jolt" "default"]))) - -(defn read-reader-conditional [s pos] - # pos is at #, next char is ? or ?@ - (def splice? (and (< (+ pos 2) (length s)) (= (s (+ pos 2)) 64))) # @ = 64 - (def form-start (if splice? (+ pos 3) (+ pos 2))) - (let [[form new-pos] (read-form s form-start)] - (if (array? form) - (do - # First clause (in clause order) whose feature key is in the set. - # `matched` is tracked separately: a matched clause may be nil. - (var result nil) - (var matched false) - (var i 0) - (while (and (not matched) (< i (length form))) - (when (get reader-features (in form i)) - (set result (in form (+ i 1))) - (set matched true)) - (+= i 2)) - (if splice? - # #?@ splicing: resolve :clj branch, wrap for splice - (let [items (if (nil? result) - @[] - (if (or (array? result) (tuple? result)) - result - @[result]))] - [{:jolt/type :jolt/splice :items items} new-pos]) - # #? non-splicing: skip nil results (from :cljs branches on CLJ) - (if (nil? result) - [{:jolt/type :jolt/skip} new-pos] - [result new-pos]))) - [{:jolt/type :jolt/reader-conditional :clauses form} new-pos]))) - -(defn read-var-quote [s pos] - # pos is at #, next char is ' - (let [[form new-pos] (read-form s (+ pos 2))] - [(array (sym "var") form) new-pos])) - -(defn read-regex [s pos] - # pos is at #, next char is " - # Read until unescaped closing " - (var i (+ pos 2)) - (var done nil) - (while (and (< i (length s)) (not done)) - (if (= (s i) 92) # backslash — skip next char - (+= i 2) - (if (= (s i) 34) # closing quote - (set done [(struct ;[:jolt/type :jolt/tagged :tag :regex :form (string/slice s (+ pos 2) i)]) - (+ i 1)]) - (++ i)))) - (if done done (reader-error "Unterminated regex literal" pos))) - -(defn read-dispatch [s pos] - # pos is at # - (if (>= (+ pos 1) (length s)) - (error "Unexpected end after #")) - (let [c (s (+ pos 1))] - (cond - (= c 123) (read-set s pos) # #{ - (= c 40) (read-anon-fn s pos) # #( - (= c 63) (read-reader-conditional s pos) # #? - (= c 95) (let [[_ new-pos] (read-form s (+ pos 2))] # #_ - [{:jolt/type :jolt/skip} new-pos]) - (= c 39) (read-var-quote s pos) # #' - (= c 94) (read-meta s (+ pos 1)) # #^ — deprecated metadata reader macro (= ^) - (= c 34) (read-regex s pos) # #"regex - (= c 35) # ## symbolic value: ##Inf ##-Inf ##NaN - (let [end (read-symbol-name s (+ pos 2) (+ pos 2)) - name (string/slice s (+ pos 2) end)] - (cond - (= name "Inf") [math/inf end] - (= name "-Inf") [(- math/inf) end] - (= name "NaN") [math/nan end] - (reader-error (string "Invalid symbolic value: ##" name) pos))) - # unknown dispatch — tagged literal - (let [end (read-symbol-name s pos pos) - tag (string/slice s pos end) - [form new-pos] (read-form s end)] - [{:jolt/type :jolt/tagged :tag (keyword tag) :form form} new-pos])))) - -(defn- self-evaluating-literal? - "True for forms syntax-quote passes through unchanged: strings, numbers, - booleans, nil, keywords, and character literals. NOT symbols (they qualify) - or collections (they template)." - [form] - (or (nil? form) (= true form) (= false form) (number? form) - (string? form) (buffer? form) (keyword? form) - (and (struct? form) (= :jolt/char (form :jolt/type))))) - -(defn read-quote [s new-pos token-sym] - (let [[form final-pos] (read-form s new-pos)] - # Spec 02-reader S25: syntax-quote of a self-evaluating literal is the - # literal, collapsed at READ time (matching Clojure's reader) — so nested - # backticks over literals are inert: ```"meow" reads as "meow". - (if (and (= "syntax-quote" (token-sym :name)) (self-evaluating-literal? form)) - [form final-pos] - [(array token-sym form) final-pos]))) - -(defn- meta-form->map - "Normalize a metadata reader form (Clojure semantics): a symbol or string is a - :tag, a keyword is {kw true}. Returns a metadata table, or nil if it isn't one - of those simple shapes (e.g. a map literal — handled via with-meta instead)." - [meta-form] - (cond - (keyword? meta-form) {meta-form true} - # A symbol tag keeps its namespace qualifier (^t/Ray -> "t/Ray", not "Ray") so - # an aliased/qualified record hint resolves through the ns's aliases the same - # way a bare referred one does; dropping it silently mis-hinted across - # namespaces. Bare symbols (^Ray, ^String) are unchanged. - (and (struct? meta-form) (= :symbol (meta-form :jolt/type))) - {:tag (if (meta-form :ns) - (string (meta-form :ns) "/" (meta-form :name)) - (meta-form :name))} - (string? meta-form) {:tag meta-form} - nil)) - -(set read-meta (fn read-meta [s pos] - # pos is at ^ - (let [[meta-form new-pos] (read-form s (+ pos 1)) - [form new-pos2] (read-form s new-pos) - m (meta-form->map meta-form)] - (if (and m (struct? form) (= :symbol (form :jolt/type))) - # Attach the metadata to the symbol itself and keep it a bare symbol, so - # type hints (^String x) and ^:dynamic etc. are transparent in every - # position (params, lets, bodies) — the evaluator reads :name and ignores - # :meta. This is what makes type hints "parse and otherwise do nothing". - [(struct ;(kvs form) :meta (merge (or (form :meta) {}) m)) new-pos2] - # Non-symbol targets (collections etc.) keep a runtime with-meta form. Use the - # NORMALIZED metadata map (:kw -> {:kw true}, tag -> {:tag …}); a map-literal - # meta-form (m is nil) is already a map, so pass it through. - [(array (sym "with-meta") form (if m m meta-form)) new-pos2])))) - -(defn read-until-newline [s pos] - (if (or (>= pos (length s)) (= (s pos) 10)) - pos - (read-until-newline s (+ pos 1)))) - -(set read-form (fn [s pos] - (let [pos (skip-whitespace s pos)] - (if (>= pos (length s)) - [nil pos] - (let [c (s pos)] - (cond - # comment - (= c 59) - (let [line-end (read-until-newline s pos)] - [{:jolt/type :jolt/skip} line-end]) - - # dispatch - (= c 35) - (read-dispatch s pos) - - # string - (= c 34) - (read-string s pos) - - # list - (= c 40) - (let [r (read-list s pos)] - (when track-positions (put form-pos-table (in r 0) (+ pos-base pos))) - r) - - # unmatched closing delimiters - (= c 41) - (reader-error "Unmatched delimiter: )" pos) - - (= c 93) - (reader-error "Unmatched delimiter: ]" pos) - - (= c 125) - (reader-error "Unmatched delimiter: }" pos) - - # vector - (= c 91) - (read-vector s pos) - - # map - (= c 123) - (read-map s pos) - - # keyword - (= c 58) - (read-keyword s pos) - - # quote - (= c 39) - (read-quote s (+ pos 1) (sym "quote")) - - # syntax-quote / backtick - (= c 96) - (read-quote s (+ pos 1) (sym "syntax-quote")) - - # unquote ~ - (= c 126) - (if (and (< (+ pos 1) (length s)) (= (s (+ pos 1)) 64)) - (read-quote s (+ pos 2) (sym "unquote-splicing")) - (read-quote s (+ pos 1) (sym "unquote"))) - - # deref — @x is (clojure.core/deref x), QUALIFIED like Clojure, so it - # still derefs even where a ns shadows `deref` (malli excludes and - # redefines clojure.core/deref for its own schema-deref). - (= c 64) - (read-quote s (+ pos 1) (sym "clojure.core/deref")) - - # metadata - (= c 94) - (read-meta s pos) - - # character - (= c 92) - (read-char s pos) - - # number or symbol - (if (or (digit? c) - (and (= c 45) (< (+ pos 1) (length s)) (digit? (s (+ pos 1)))) - (and (= c 43) (< (+ pos 1) (length s)) (digit? (s (+ pos 1))))) - (read-number s pos) - (read-symbol s pos)))))))) - -(defn parse-string - "Parse a Clojure source string and return the first form." - [s] - (try - (let [[form pos] (read-form s 0)] - (if (and (struct? form) (= :jolt/skip (form :jolt/type))) - (parse-string (string/slice s pos)) - form)) - ([err fib] - (if (reader-error? err) - (error (format-reader-error err s nil)) - (propagate err fib))))) - -(defn parse-next - "Parse the first form from a string. Returns [form remaining-string]." - [s] - (defn- parse-next-loop [pos] - (let [[form new-pos] (read-form s pos)] - (if (and (struct? form) (= :jolt/skip (form :jolt/type))) - (parse-next-loop new-pos) - [form (string/slice s new-pos)]))) - (parse-next-loop 0)) - -(defn parse-all-positioned - "Parse every top-level form of source, returning an array of [form line] - where line is the 1-based source line the form starts on. parse-next eats - leading trivia itself, so the form's start line is the running newline - count plus the newlines in the trivia (whitespace, commas, ; comments) - ahead of it. (jolt-2o7.4)" - [source &opt file] - (def out @[]) - (var s source) - (var line 1) - (while (> (length (string/trim s)) 0) - # newlines in the leading trivia belong BEFORE the form's line - (var i 0) - (def n (length s)) - (var scanning true) - (while (and scanning (< i n)) - (def c (in s i)) - (cond - (= c (chr "\n")) (do (++ line) (++ i)) - (or (= c (chr " ")) (= c (chr "\t")) (= c (chr "\r")) (= c (chr ","))) (++ i) - (= c (chr ";")) (while (and (< i n) (not= (in s i) (chr "\n"))) (++ i)) - (set scanning false))) - # list-form positions recorded during this parse-next are relative to s; - # tell the reader the slice base so they land absolute (jolt-fqy) - (when track-positions (set-pos-base! (- (length source) (length s)))) - (def [form rest*] - (try (parse-next s) - ([err fib] - (if (reader-error? err) - # err's :pos is relative to the remaining slice — rebase onto the - # full source so line:col are absolute (jolt-2o7.5) - (error (format-reader-error - {:jolt/type :jolt/reader-error :msg (err :msg) - :pos (+ (- (length source) (length s)) (err :pos))} - source file)) - (propagate err fib))))) - (def consumed (- (length s) (length rest*))) - (def form-line line) - # count newlines inside the consumed chunk past the trivia - (loop [j :range [i consumed]] - (when (= (in s j) (chr "\n")) (++ line))) - (set s rest*) - (when (not (nil? form)) (array/push out [form form-line]))) - out) - -(defn parse-all-spans - "Parse every top-level form of source, returning an array of - [form abs-start abs-end] where abs-start is the byte offset of the form's - first non-trivia char and abs-end is just past it (leading whitespace/comment - trivia is excluded). Lets a caller reconstruct source by slicing verbatim — - used by `jolt uberscript`'s dead-code elimination to drop a defn's exact byte - span without re-printing (so formatting and reader macros survive)." - [source &opt file] - (def out @[]) - (var s source) - (while (> (length (string/trim s)) 0) - (def base (- (length source) (length s))) - (var i 0) - (def n (length s)) - (var scanning true) - (while (and scanning (< i n)) - (def c (in s i)) - (cond - (or (= c (chr "\n")) (= c (chr " ")) (= c (chr "\t")) (= c (chr "\r")) (= c (chr ","))) (++ i) - (= c (chr ";")) (while (and (< i n) (not= (in s i) (chr "\n"))) (++ i)) - (set scanning false))) - (def [form rest*] - (try (parse-next s) - ([err fib] - (if (reader-error? err) - (error (format-reader-error - {:jolt/type :jolt/reader-error :msg (err :msg) - :pos (+ base (err :pos))} - source file)) - (propagate err fib))))) - (def consumed (- (length s) (length rest*))) - (set s rest*) - (when (not (nil? form)) (array/push out [form (+ base i) (+ base consumed)]))) - out) diff --git a/src/jolt/regex.janet b/src/jolt/regex.janet deleted file mode 100644 index d0e12cf..0000000 --- a/src/jolt/regex.janet +++ /dev/null @@ -1,499 +0,0 @@ -# Regex support for Jolt, compiled to Janet's PEG engine. -# -# Path A: a real regex parser -> AST -> PEG grammar with continuation passing -# and position-based group captures. This gives genuine backtracking (greedy and -# lazy) that threads through capturing groups, plus capturing groups returned in -# Clojure's [whole g1 g2 ...] order, lookahead, anchors, classes, flags. -# -# Supported: literals, `.`, char classes `[...]`/`[^...]` (ranges, POSIX, -# `\d \w \s` etc.), quantifiers `* + ? {n} {n,} {n,m}` (greedy + lazy `?`), -# groups `(...)` (numbered), non-capturing `(?:...)`, lookahead `(?=...)`/`(?!...)`, -# alternation `|`, anchors `^ $ \b \B`, escapes, inline flag `(?i)`, and -# single-digit backreferences `\1`..`\9` (a backreferenced group matches -# possessively — no backtracking back into it; rare in practice). -# Not supported: lookbehind, named groups (rare; documented). - -(defn- chr [s] (get s 0)) -(defn regex? [x] (and (table? x) (= :jolt/regex (x :jolt/type)))) - -# ============================================================ -# Parser: regex source -> AST -# ============================================================ -# AST nodes (structs): {:op ...} -# :char {:b byte :ci bool} :any {:dotall bool} -# :class {:peg :neg bool} :pred {:peg } -# :seq {:items [...]} :alt {:items [...]} -# :star/:plus/:quest {:item ast :greedy bool} -# :rep {:item ast :min n :max m-or-nil :greedy bool} -# :group {:n num :item ast} :ncgroup {:item ast} -# :look {:neg bool :item ast} -# :anchor {:kind :start/:end/:wordb/:nwordb} - -(defn- lower-b [b] (if (and (>= b 65) (<= b 90)) (+ b 32) b)) -(defn- upper-b [b] (if (and (>= b 97) (<= b 122)) (- b 32) b)) - -(defn- pred-frag [c] - (case c - (chr "d") '(range "09") - (chr "D") '(if-not (range "09") 1) - (chr "w") '(choice (range "az" "AZ" "09") (set "_")) - (chr "W") '(if-not (choice (range "az" "AZ" "09") (set "_")) 1) - (chr "s") '(set " \t\n\r\f\v") - (chr "S") '(if-not (set " \t\n\r\f\v") 1) - nil)) - -# Unicode property classes \p{...} (jolt-xlp), mapped onto the byte PEGs: -# ASCII exactly; any high byte (>= 0x80, i.e. inside a UTF-8 sequence) counts -# as a LETTER byte — so ^\p{L}+$ accepts UTF-8 words, while \p{N}/\p{Z} -# stay ASCII-only. Lu/Ll are ASCII (case is byte-based throughout this -# engine). Unknown property names error at compile. -(defn- prop-frag [name] - (case name - "L" '(choice (range "az" "AZ") (range "\x80\xFF")) - "Lu" '(range "AZ") - "Ll" '(range "az") - "N" '(range "09") - "Nd" '(range "09") - "Z" '(set " ") - "Zs" '(set " ") - "P" '(set "!\"#%&'()*,-./:;?@[\\]_{}") - "Ps" '(set "([{") - "Pe" '(set ")]}") - "Alpha" '(choice (range "az" "AZ") (range "\x80\xFF")) - "Digit" '(range "09") - nil)) - -# At s[i] = backslash: if this is \p{Name} / \P{Name}, return [peg-frag end-i] -# (end-i past the closing brace), else nil. -(defn- parse-prop [s i] - (def pc (get s (+ i 1))) - (when (and (or (= pc (chr "p")) (= pc (chr "P"))) - (= (get s (+ i 2)) (chr "{"))) - (def close (string/find "}" s (+ i 3))) - (unless close (error "regex: unterminated \\p{...}")) - (def nm (string/slice s (+ i 3) close)) - (def frag (prop-frag nm)) - (unless frag (error (string "regex: unsupported property class \\p{" nm "}"))) - [(if (= pc (chr "P")) ~(if-not ,frag 1) frag) (+ close 1)])) - -(defn- esc-byte [c] - (case c - (chr "n") 10 (chr "t") 9 (chr "r") 13 (chr "f") 12 (chr "v") 11 (chr "0") 0 - c)) - -# Parse a [...] character class body, returns a PEG fragment + negation flag. -(defn- parse-class [s start ci] - (var i start) - (def neg (and (< i (length s)) (= (s i) (chr "^")))) - (when neg (++ i)) - (def alts @[]) - (while (and (< i (length s)) (not= (s i) (chr "]"))) - (cond - # POSIX class [:alpha:] etc. - (and (= (s i) (chr "[")) (< (+ i 1) (length s)) (= (s (+ i 1)) (chr ":"))) - (let [close (string/find ":]" s i) - name (string/slice s (+ i 2) close)] - (array/push alts (case name - "alpha" '(range "az" "AZ") - "digit" '(range "09") - "alnum" '(range "az" "AZ" "09") - "space" '(set " \t\n\r\f\v") - "upper" '(range "AZ") - "lower" '(range "az") - '(set ""))) - (set i (+ close 2))) - # escape inside class — \p{...} first (multi-char), then 2-char escapes - (= (s i) (chr "\\")) - (if-let [pr (parse-prop s i)] - (do (array/push alts (pr 0)) (set i (pr 1))) - (let [c (s (+ i 1)) p (pred-frag c)] - (if p (array/push alts p) - (array/push alts ~(set ,(string/from-bytes (esc-byte c))))) - (set i (+ i 2)))) - # range a-z - (and (< (+ i 2) (length s)) (= (s (+ i 1)) (chr "-")) (not= (s (+ i 2)) (chr "]"))) - (do - (if ci - (array/push alts ~(range ,(string/from-bytes (lower-b (s i)) (lower-b (s (+ i 2))) - (upper-b (s i)) (upper-b (s (+ i 2)))))) - (array/push alts ~(range ,(string/from-bytes (s i) (s (+ i 2)))))) - (set i (+ i 3))) - # single char - (do - (if ci - (array/push alts ~(set ,(string/from-bytes (lower-b (s i)) (upper-b (s i))))) - (array/push alts ~(set ,(string/from-bytes (s i))))) - (++ i)))) - (def frag (if (= 1 (length alts)) (alts 0) ~(choice ,;alts))) - [(if neg ~(if-not ,frag 1) frag) (+ i 1)]) # i is at ], skip it - -(var parse-alt nil) - -(defn- parse-atom [st] - # returns ast; advances (st :pos) - (def s (st :s)) - (def c (s (st :pos))) - (def ci (st :ci)) - (cond - (= c (chr "(")) - (let [nx (if (< (+ (st :pos) 1) (length s)) (s (+ (st :pos) 1)) 0)] - (if (= nx (chr "?")) - (let [k (s (+ (st :pos) 2))] - (cond - (= k (chr ":")) (do (+= (st :pos) 3) - (let [inner (parse-alt st)] (+= (st :pos) 1) {:op :ncgroup :item inner})) - (= k (chr "=")) (do (+= (st :pos) 3) - (let [inner (parse-alt st)] (+= (st :pos) 1) {:op :look :neg false :item inner})) - (= k (chr "!")) (do (+= (st :pos) 3) - (let [inner (parse-alt st)] (+= (st :pos) 1) {:op :look :neg true :item inner})) - # inline flags (?i) / (?m) / (?im:...) etc. - (do - (var j (+ (st :pos) 2)) - (var seti false) - (var setm false) - (while (and (< j (length s)) (not= (s j) (chr ")")) (not= (s j) (chr ":"))) - (when (= (s j) (chr "i")) (set seti true)) - (when (= (s j) (chr "m")) (set setm true)) - (++ j)) - (if (= (s j) (chr ":")) - (do (set (st :pos) (+ j 1)) - (def savedci (st :ci)) - (def savedml (st :ml)) - (when seti (set (st :ci) true)) - (when setm (set (st :ml) true)) - (def inner (parse-alt st)) - (set (st :ci) savedci) - (set (st :ml) savedml) - (+= (st :pos) 1) - {:op :ncgroup :item inner}) - (do (set (st :pos) (+ j 1)) # (?i) / (?m) — flag for rest of pattern - (when seti (set (st :ci) true)) - (when setm (set (st :ml) true)) - {:op :seq :items @[]}))))) - # capturing group - (let [n (++ (st :ngroup))] - (+= (st :pos) 1) - (let [inner (parse-alt st)] - (+= (st :pos) 1) # skip ) - {:op :group :n n :item inner})))) - (= c (chr "[")) - (let [[frag np] (parse-class s (+ (st :pos) 1) ci)] - (set (st :pos) np) - {:op :class :peg frag}) - (= c (chr ".")) - (do (++ (st :pos)) {:op :any :dotall (st :dotall)}) - (= c (chr "\\")) - (if-let [pr (parse-prop s (st :pos))] - (do (set (st :pos) (pr 1)) {:op :pred :peg (pr 0)}) - (let [nc (s (+ (st :pos) 1)) p (pred-frag nc)] - (+= (st :pos) 2) - (cond - p {:op :pred :peg p} - (= nc (chr "b")) {:op :anchor :kind :wordb} - (= nc (chr "B")) {:op :anchor :kind :nwordb} - # \1..\9 backreference (single digit) — record the referenced group so - # the emitter knows to tag-capture its text - (and (>= nc (chr "1")) (<= nc (chr "9"))) - (let [n (- nc (chr "0"))] (put (st :refs) n true) {:op :backref :n n}) - {:op :char :b (esc-byte nc) :ci ci}))) - (= c (chr "^")) (do (++ (st :pos)) {:op :anchor :kind :start}) - (= c (chr "$")) (do (++ (st :pos)) {:op :anchor :kind :end}) - (do (++ (st :pos)) {:op :char :b c :ci ci}))) - -(defn- parse-quant [st] - (def atom (parse-atom st)) - (def s (st :s)) - (if (>= (st :pos) (length s)) - atom - (let [q (s (st :pos))] - # called after advancing past the quantifier char: a trailing `?` -> lazy - (defn lazy? [] - (if (and (< (st :pos) (length s)) (= (s (st :pos)) (chr "?"))) - (do (++ (st :pos)) false) # lazy -> greedy=false - true)) - (cond - (= q (chr "*")) (do (++ (st :pos)) {:op :star :item atom :greedy (lazy?)}) - (= q (chr "+")) (do (++ (st :pos)) {:op :plus :item atom :greedy (lazy?)}) - (= q (chr "?")) (do (++ (st :pos)) {:op :quest :item atom :greedy (lazy?)}) - (= q (chr "{")) - (let [close (string/find "}" s (st :pos)) - spec (string/slice s (+ (st :pos) 1) close) - comma (string/find "," spec)] - (set (st :pos) (+ close 1)) - (def greedy (lazy?)) - (if comma - (let [lo (scan-number (string/slice spec 0 comma)) - hs (string/slice spec (+ comma 1)) - hi (if (= 0 (length hs)) nil (scan-number hs))] - {:op :rep :item atom :min lo :max hi :greedy greedy}) - {:op :rep :item atom :min (scan-number spec) :max (scan-number spec) :greedy greedy})) - atom)))) - -(defn- parse-seq [st] - (def s (st :s)) - (def items @[]) - (while (and (< (st :pos) (length s)) - (not= (s (st :pos)) (chr "|")) - (not= (s (st :pos)) (chr ")"))) - (array/push items (parse-quant st))) - (if (= 1 (length items)) (items 0) {:op :seq :items items})) - -(set parse-alt (fn [st] - (def branches @[(parse-seq st)]) - (def s (st :s)) - (while (and (< (st :pos) (length s)) (= (s (st :pos)) (chr "|"))) - (++ (st :pos)) - (array/push branches (parse-seq st))) - (if (= 1 (length branches)) (branches 0) {:op :alt :items branches}))) - -(defn- parse [source] - (def st @{:s source :pos 0 :ngroup 0 :ci false :ml false :dotall false :refs @{}}) - (def ast (parse-alt st)) - [ast (st :ngroup) (st :ml) (st :refs)]) - -# ============================================================ -# Emit: AST -> PEG grammar (continuation passing) -# ============================================================ - -(def- word-frag '(choice (range "az" "AZ" "09") (set "_"))) - -(defn- char-peg [b ci] - (if (and ci (not= (lower-b b) (upper-b b))) - ~(set ,(string/from-bytes (lower-b b) (upper-b b))) - ~(set ,(string/from-bytes b)))) - -(defn- make-emitter [grammar ml refs] - (var ctr 0) - (defn fresh [] (++ ctr) (keyword (string "r" ctr))) - (var emit nil) - (set emit (fn [ast k] - (case (ast :op) - :char ~(sequence ,(char-peg (ast :b) (ast :ci)) ,k) - :any ~(sequence ,(if (ast :dotall) 1 ~(if-not "\n" 1)) ,k) - :class ~(sequence ,(ast :peg) ,k) - :pred ~(sequence ,(ast :peg) ,k) - :seq (do (var acc k) (var i (dec (length (ast :items)))) - (while (>= i 0) (set acc (emit (in (ast :items) i) acc)) (-- i)) acc) - :alt (let [kr (fresh)] - (put grammar kr k) - ~(choice ,;(map (fn [a] (emit a (keyword kr))) (ast :items)))) - :star (let [r (fresh)] - (put grammar r (if (ast :greedy) - ~(choice ,(emit (ast :item) (keyword r)) ,k) - ~(choice ,k ,(emit (ast :item) (keyword r))))) - (keyword r)) - :plus (let [r (fresh)] - (put grammar r (if (ast :greedy) - ~(choice ,(emit (ast :item) (keyword r)) ,k) - ~(choice ,k ,(emit (ast :item) (keyword r))))) - (emit (ast :item) (keyword r))) - :quest (if (ast :greedy) - ~(choice ,(emit (ast :item) k) ,k) - ~(choice ,k ,(emit (ast :item) k))) - :rep (let [lo (ast :min) hi (ast :max) item (ast :item) greedy (ast :greedy)] - # desugar: lo required, then (hi-lo) optional, or star if hi is nil - (var tail (if (nil? hi) - (let [r (fresh)] - (put grammar r (if greedy - ~(choice ,(emit item (keyword r)) ,k) - ~(choice ,k ,(emit item (keyword r))))) - (keyword r)) - # Each optional level is its OWN grammar rule that - # references the previous level by name. Inlining instead - # (choice (emit item acc) acc) duplicates `acc` per level, - # so {0,n} built a structure the PEG compiler expanded to - # 2^n nodes and hung (jolt-3xur). Naming keeps it O(n). - (do (def kr (fresh)) (put grammar kr k) - (var acc (keyword kr)) (var c (- hi lo)) - (while (> c 0) - (let [r (fresh)] - (put grammar r (if greedy ~(choice ,(emit item acc) ,acc) - ~(choice ,acc ,(emit item acc)))) - (set acc (keyword r))) - (-- c)) - acc))) - (var acc tail) (var c lo) - (while (> c 0) (set acc (emit item acc)) (-- c)) - acc) - :group (let [n (ast :n)] - (if (and refs (refs n)) - # backreferenced group: also capture its text under tag :gN so a - # later \N can (backmatch). The item runs with just the end-marker - # as its continuation, so it matches POSSESSIVELY — backtracking - # INTO a backreferenced group isn't supported (rare; the usual - # (x)...\1 patterns don't need it). - (let [tag (keyword (string "g" n))] - ~(sequence (/ (position) ,(fn [p] [n :s p])) - (<- ,(emit (ast :item) ~(/ (position) ,(fn [p] [n :e p]))) ,tag) - ,k)) - ~(sequence (/ (position) ,(fn [p] [n :s p])) - ,(emit (ast :item) - ~(sequence (/ (position) ,(fn [p] [n :e p])) ,k))))) - :backref ~(sequence (backmatch ,(keyword (string "g" (ast :n)))) ,k) - :ncgroup (emit (ast :item) k) - :look (if (ast :neg) - ~(sequence (not ,(emit (ast :item) 0)) ,k) - ~(sequence (not (not ,(emit (ast :item) 0))) ,k)) - :anchor (case (ast :kind) - :start (if ml - ~(sequence (choice (not (look -1 1)) (look -1 "\n")) ,k) - ~(sequence (not (look -1 1)) ,k)) - :end (if ml - ~(sequence (choice (not 1) (not (not "\n"))) ,k) - ~(sequence (not 1) ,k)) - :wordb ~(sequence (choice (sequence (look -1 ,word-frag) (not ,word-frag)) - (sequence (not (look -1 ,word-frag)) (not (not ,word-frag)))) - ,k) - :nwordb ~(sequence (choice (sequence (look -1 ,word-frag) (not (not ,word-frag))) - (sequence (not (look -1 ,word-frag)) (not ,word-frag))) - ,k) - ~(sequence 0 ,k)) - (error (string "regex emit: unhandled op " (ast :op)))))) - emit) - -(defn compile-regex [source] - (def [ast ngroups ml refs] (parse source)) - (def grammar @{}) - (def emit (make-emitter grammar ml refs)) - # group 0 = whole match: mark start, body, mark end - (def body (emit ast ~(sequence (/ (position) ,(fn [p] [0 :e p])) 0))) - (put grammar :main ~(sequence (/ (position) ,(fn [p] [0 :s p])) ,body)) - (def gstruct (table/to-struct grammar)) - # anchored variant for re-matches: whole input must be consumed - (def anchored (table/to-struct (merge grammar {:main ~(sequence ,(grammar :main) -1)}))) - @{:jolt/type :jolt/regex - :source source - :ngroups ngroups - :peg (peg/compile gstruct) - :anchored (peg/compile anchored)}) - -(defn re-pattern [source] - (if (regex? source) source (compile-regex source))) - -# ============================================================ -# Matching -# ============================================================ - -(defn- marks->groups [marks s ngroups] - # marks: array of [n :s pos] / [n :e pos]; build [g0 g1 ... gN], slicing input - (def starts (array/new-filled (+ ngroups 1))) - (def ends (array/new-filled (+ ngroups 1))) - (each m marks - # backreferenced groups also leave a tagged TEXT capture (a string) on the - # stack — skip those; only the [n :s/:e pos] position tuples carry group spans - (when (indexed? m) - (let [n (m 0)] - (if (= (m 1) :s) (put starts n (m 2)) (put ends n (m 2)))))) - (def groups (array/new-filled (+ ngroups 1))) - (var n 0) - (while (<= n ngroups) - (if (and (not (nil? (in starts n))) (not (nil? (in ends n)))) - (put groups n (string/slice s (in starts n) (in ends n))) - (put groups n nil)) - (++ n)) - groups) - -(defn- match-at [re s start] - # returns groups array or nil - (def marks (peg/match (re :peg) s start)) - (if marks (marks->groups marks s (re :ngroups)) nil)) - -(defn- groups->result [groups ngroups] - # 0 groups -> whole-match string; else tuple [whole g1 ...] - (if (= ngroups 0) (in groups 0) (tuple/slice groups))) - -(defn re-find [re s] - (def re (re-pattern re)) - (var result nil) (var pos 0) - (while (and (nil? result) (<= pos (length s))) - (def g (match-at re s pos)) - (if g (set result (groups->result g (re :ngroups))) (++ pos))) - result) - -(defn re-matches [re s] - (def re (re-pattern re)) - (def marks (peg/match (re :anchored) s 0)) - (if marks (groups->result (marks->groups marks s (re :ngroups)) (re :ngroups)) nil)) - -(defn re-seq [re s] - (def re (re-pattern re)) - (def out @[]) (var pos 0) - (while (<= pos (length s)) - (def g (match-at re s pos)) - (if g - (let [whole (in g 0)] - (array/push out (groups->result g (re :ngroups))) - (set pos (+ pos (max 1 (length whole))))) - (++ pos))) - # Clojure's re-seq is nil (not an empty seq) when there are no matches, so - # `(if-let [m (re-seq ...)] ...)` works — an empty seq would be truthy. - (if (= 0 (length out)) nil out)) - -(defn re-split [re s &opt limit] - # limit (Java Pattern.split n>0): at most `limit` parts — stop after limit-1 - # splits and keep the rest of the string as the final unsplit part. nil/<=0 - # splits at every match. - (def re (re-pattern re)) - (def lim (if (and limit (> limit 0)) limit nil)) - (def out @[]) (var pos 0) (var last 0) - (while (and (<= pos (length s)) (or (nil? lim) (< (length out) (dec lim)))) - (def g (match-at re s pos)) - (if (and g (> (length (in g 0)) 0)) - (do (array/push out (string/slice s last pos)) - (set pos (+ pos (length (in g 0)))) - (set last pos)) - (++ pos))) - (array/push out (string/slice s last)) - out) - -(defn- expand-replacement [repl groups] - # $0 / $1 ... substitution in replacement string - (def buf @"") (var i 0) - (while (< i (length repl)) - (let [c (repl i)] - (if (and (= c (chr "$")) (< (+ i 1) (length repl)) (>= (repl (+ i 1)) 48) (<= (repl (+ i 1)) 57)) - (let [n (- (repl (+ i 1)) 48)] - (when (and (< n (length groups)) (in groups n)) (buffer/push-string buf (in groups n))) - (set i (+ i 2))) - (do (buffer/push-string buf (string/from-bytes c)) (++ i))))) - (string buf)) - -(defn- replacement-for - "One match's replacement text. A string replacement gets $N expansion; a FN - replacement (Clojure: fn of the match — string, or [whole g1 ...] when the - pattern has groups) is called and its result used literally." - [replacement g ngroups] - (cond - (string? replacement) (expand-replacement replacement g) - (or (function? replacement) (cfunction? replacement)) - (string (replacement (groups->result g ngroups))) - (string replacement))) - -(defn re-replace-all [re s replacement] - (def re (re-pattern re)) - (def buf @"") (var pos 0) (var last 0) - (while (<= pos (length s)) - (def g (match-at re s pos)) - (if (and g (> (length (in g 0)) 0)) - (do (buffer/push-string buf (string/slice s last pos)) - (buffer/push-string buf (replacement-for replacement g (re :ngroups))) - (set pos (+ pos (length (in g 0)))) - (set last pos)) - (++ pos))) - (buffer/push-string buf (string/slice s last)) - (string buf)) - -(defn re-replace-first [re s replacement] - (def re (re-pattern re)) - (var pos 0) (var done nil) - (while (and (nil? done) (<= pos (length s))) - (def g (match-at re s pos)) - (if (and g (> (length (in g 0)) 0)) - (set done [pos g]) - (++ pos))) - (if done - (let [[p g] done] - (string (string/slice s 0 p) - (replacement-for replacement g (re :ngroups)) - (string/slice s (+ p (length (in g 0)))))) - s)) diff --git a/src/jolt/stdlib_embed.janet b/src/jolt/stdlib_embed.janet deleted file mode 100644 index 6dd5eb6..0000000 --- a/src/jolt/stdlib_embed.janet +++ /dev/null @@ -1,35 +0,0 @@ -# Bakes the Clojure stdlib (.clj/.cljc under src/jolt/clojure and src/jolt/jolt) -# into the image at build time, so the runtime can load clojure.string, jolt.http, -# jolt.nrepl, etc. from any directory — not just when run from the repo. -# -# `sources` is built at module-load time. During `jpm build` that's the build -# (cwd = repo), so the map is captured into the image and frozen; in the shipped -# binary the files are never read from disk. Running from source rebuilds it. - -(defn- relpath->ns [rel] - # string/replace-all takes the string LAST, so thread with ->> - (->> rel (string/replace-all "/" ".") (string/replace-all "_" "-"))) - -(defn- strip-ext [name] - (cond - (string/has-suffix? ".cljc" name) (string/slice name 0 (- (length name) 5)) - (string/has-suffix? ".clj" name) (string/slice name 0 (- (length name) 4)) - name)) - -(defn- collect [root prefix acc] - (when (os/stat root) - (each e (os/dir root) - (def p (string root "/" e)) - (cond - (= :directory (os/stat p :mode)) (collect p (string prefix e "/") acc) - (or (string/has-suffix? ".clj" e) (string/has-suffix? ".cljc" e)) - (put acc (relpath->ns (string prefix (strip-ext e))) (slurp p))))) - acc) - -(def sources - (let [acc @{}] - (collect "src/jolt/clojure" "clojure/" acc) - (collect "src/jolt/jolt" "jolt/" acc) - # Portable Clojure core (analyzer/IR/…): jolt-core/jolt/foo.clj -> jolt.foo - (collect "jolt-core" "" acc) - acc)) diff --git a/src/jolt/types.janet b/src/jolt/types.janet deleted file mode 100644 index 094a4d2..0000000 --- a/src/jolt/types.janet +++ /dev/null @@ -1,11 +0,0 @@ -# Jolt value layer (types) -# -# AGGREGATOR (jolt-bvek phase 5a): the value/var/ns/ctx/protocol concerns now -# live in sibling modules, loaded here in dependency order and re-exported -# (:export true) so every consumer keeps its single `(use ./types)`. - -(import ./types_symbols :prefix "" :export true) -(import ./types_var :prefix "" :export true) -(import ./types_ns :prefix "" :export true) -(import ./types_ctx :prefix "" :export true) -(import ./types_protocols :prefix "" :export true) diff --git a/src/jolt/types_ctx.janet b/src/jolt/types_ctx.janet deleted file mode 100644 index 4a5c9a7..0000000 --- a/src/jolt/types_ctx.janet +++ /dev/null @@ -1,241 +0,0 @@ -# Jolt value layer — Context (+ inst/uuid values) -# Extracted from types.janet (jolt-bvek phase 5a split). - -(use ./types_symbols) -(use ./types_var) -(use ./types_ns) -# ============================================================ -# Context -# ============================================================ - -(defn ctx-find-ns - "Find or create a namespace in the context by name symbol." - [ctx ns-sym] - (let [env (ctx :env) - namespaces (env :namespaces)] - (or (get namespaces ns-sym) - (let [ns (make-ns ns-sym)] - (put namespaces ns-sym ns) - ns)))) - -# Instant value: an immutable tagged struct keyed by epoch milliseconds, so -# equality and map-key hashing are by INSTANT (offset-normalized): two #inst -# literals with different offsets denoting the same moment are =. -(defn make-inst [ms] - {:jolt/type :jolt/inst :ms ms}) - -(defn parse-inst - "Parse an RFC3339 timestamp with Clojure's partial defaults - (yyyy[-MM[-dd[Thh[:mm[:ss[.fff]]]]]][Z|+hh:mm|-hh:mm]) to an inst value. - Errors on a malformed timestamp." - [ts] - (def pat (peg/compile - ~(sequence - (capture (repeat 4 :d)) # year - (opt (sequence "-" (capture (repeat 2 :d)))) # month - (opt (sequence "-" (capture (repeat 2 :d)))) # day - (opt (sequence "T" (capture (repeat 2 :d)) # hour - (opt (sequence ":" (capture (repeat 2 :d)) # min - (opt (sequence ":" (capture (repeat 2 :d)) # sec - (opt (sequence "." (capture (some :d)))))))))) # frac - (opt (choice (capture "Z") - (sequence (capture (set "+-")) (capture (repeat 2 :d)) - ":" (capture (repeat 2 :d))))) - -1))) - (def m (peg/match pat ts)) - (when (nil? m) (error (string "Unrecognized #inst timestamp: " ts))) - # captures arrive positionally; classify by shape: digits runs + offset parts. - (var year nil) (var month 1) (var day 1) - (var hh 0) (var mm 0) (var ss 0) (var frac "0") - (var off-sign nil) (var off-h 0) (var off-m 0) - (var i 0) - (def fields @[:year :month :day :hh :mm :ss]) - (var fi 0) - (while (< i (length m)) - (def part (in m i)) - (cond - (= part "Z") nil - (or (= part "+") (= part "-")) - (do (set off-sign part) - (set off-h (scan-number (in m (+ i 1)))) - (set off-m (scan-number (in m (+ i 2)))) - (+= i 2)) - # fractional seconds arrive right after :ss was filled - (and (>= fi 6)) - (set frac part) - (do - (def v (scan-number part)) - (case (in fields fi) - :year (set year v) :month (set month v) :day (set day v) - :hh (set hh v) :mm (set mm v) :ss (set ss v)) - (++ fi))) - (++ i)) - (when (nil? year) (error (string "Unrecognized #inst timestamp: " ts))) - (def base-s (os/mktime {:year year :month (- month 1) :month-day (- day 1) - :hours hh :minutes mm :seconds ss})) - # fractional part -> milliseconds (truncate beyond 3 digits) - (def frac3 (string/slice (string frac "000") 0 3)) - (def ms-frac (scan-number frac3)) - (def off-s (* (if (= off-sign "-") -1 1) (+ (* off-h 3600) (* off-m 60)))) - (make-inst (- (+ (* base-s 1000) ms-frac) (* off-s 1000)))) - -(defn inst->rfc3339 - "Canonical print form: yyyy-MM-ddThh:mm:ss.fff-00:00 (UTC, like Clojure)." - [inst] - (def ms (inst :ms)) - (def s (math/floor (/ ms 1000))) - (def frac (- ms (* s 1000))) - (def d (os/date s)) - (string/format "%04d-%02d-%02dT%02d:%02d:%02d.%03d-00:00" - (d :year) (+ 1 (d :month)) (+ 1 (d :month-day)) - (d :hours) (d :minutes) (d :seconds) frac)) - -# UUID value: an immutable tagged struct. Lowercased at construction so -# equality and map-key hashing are case-insensitive by value (struct equality), -# matching Clojure (java.util.UUID equality / cljs UUID). -(defn make-uuid [s] - {:jolt/type :jolt/uuid :str (string/ascii-lower s)}) - -(defn make-ctx - "Create a new evaluation context. - (make-ctx) — empty context with 'user namespace - (make-ctx opts) — context with initial namespaces from opts - - opts may contain: - :namespaces — struct of {ns-symbol → {sym → value, ...}, ...}" - [&opt opts] - (default opts nil) - (let [compile? (if opts (get opts :compile?) false) - # Direct-linking (call-site/unit property, like Clojure). :aot-core? - # (default true; JOLT_AOT_CORE=0 disables) compiles the core tiers + - # compiler with direct-linking on. :direct-linking? is the per-unit flag - # the back end reads while emitting; it defaults to the user-code setting - # (off unless opted in) and load-core-overlay! flips it on around core. - aot-core? (let [o (if opts (get opts :aot-core?) nil)] - (if (nil? o) (not (= "0" (os/getenv "JOLT_AOT_CORE"))) o)) - # Macro expanders compile in EVERY mode (macros are ordinary compiled - # fns, as in Clojure) — including interpret mode, where evaluation stays - # interpreted but expansion runs native. :compile-macros? false (or - # JOLT_INTERPRET_MACROS=1) opts back into the fully-interpreted oracle. - compile-macros? (let [o (if opts (get opts :compile-macros?) nil)] - (if (nil? o) - (not (= "1" (os/getenv "JOLT_INTERPRET_MACROS"))) - o)) - env @{:namespaces @{} - :class->opts @{} - :current-ns "user" - :compile? compile? - :aot-core? aot-core? - :compile-macros? compile-macros? - # User-code direct-linking default (off unless opted in), the - # apples-to-apples analog of jank's -Odirect-call / Clojure's - # :direct-linking. JOLT_DIRECT_LINK=1 turns it on for user units; - # this is also the gate the inline pass reads (a call is only - # inline-safe when the callee won't be redefined). load-core-overlay! - # still flips core to :aot-core? around the tiers and restores this. - :direct-linking? (let [o (if opts (get opts :direct-linking?) nil)] - (if (nil? o) (= "1" (os/getenv "JOLT_DIRECT_LINK")) o)) - # Inline + scalar-replacement passes (jolt-87f). OFF for all of init - # (core load + self-hosted compiler recompile), so core/bootstrap - # compile exactly as before; api/init flips it on to the user - # direct-linking setting AFTER init, so only opted-in user code - # inlines. The inline pass also reads this (via host/inline-enabled?). - :inline? false - # Ordered roots searched (after the stdlib) to resolve a namespace - # to a .clj/.cljc file. jolt-core holds the portable Clojure layer - # (analyzer/IR/core); deps.edn resolution appends dep src dirs. - :source-paths @["jolt-core" "src/jolt"] - :type-registry @{} - :data-readers (let [dr @{}] - (put dr (keyword "#inst") (fn [s] (parse-inst s))) - (put dr (keyword "#uuid") (fn [s] (make-uuid s))) - dr)} - # create the user namespace via a partial context - _ (ctx-find-ns {:env env} "user")] - # initialize from opts - (when opts - (when-let [ns-opts (get opts :namespaces)] - (loop [[ns-sym mappings] :pairs ns-opts] - (let [ns (ctx-find-ns {:env env} ns-sym)] - (loop [[sym val] :pairs mappings] - (ns-intern ns sym val)))))) - {:jolt/type :jolt/context - :env env})) - -(defn ctx? - "Check if x is a Jolt Context." - [x] - (and (struct? x) (= :jolt/context (x :jolt/type)))) - -(defn ctx-env - "Return the env atom from the context." - [ctx] - (ctx :env)) - -(defn ctx-current-ns - "Get the current namespace symbol." - [ctx] - (get (ctx :env) :current-ns)) - -(defn ctx-set-current-ns - "Set the current namespace symbol. Also keeps the *ns* dynamic var's root in - sync (the var table is cached on the env by install-stateful-fns! — one table - put on this hot path, no ns lookup chain)." - [ctx ns-sym] - (put (ctx :env) :current-ns ns-sym) - (when-let [v (get (ctx :env) :ns-var)] - (put v :root (ctx-find-ns ctx ns-sym)))) - -(defn all-ns - "Return a list of all namespaces in the context." - [ctx] - (let [namespaces (get (ctx :env) :namespaces) - result @[]] - (loop [[_ ns] :pairs namespaces] - (array/push result ns)) - result)) - -(defn remove-ns - "Remove a namespace from the context by name string." - [ctx ns-name] - (put (get (ctx :env) :namespaces) ns-name nil) nil) - -(defn create-ns - "Create a new namespace." - [ctx ns-name] - (ctx-find-ns ctx ns-name)) - -(defn the-ns - "Return the current namespace object." - [ctx] - (ctx-find-ns ctx (ctx-current-ns ctx))) - -(defn ns-interns - "Return the map of all interned vars in the current namespace." - [ctx] - (let [ns (ctx-find-ns ctx (ctx-current-ns ctx))] - (ns :mappings))) - -(defn ns-aliases - "Return the alias map of the current namespace." - [ctx] - (let [ns (ctx-find-ns ctx (ctx-current-ns ctx))] - (ns :aliases))) - -(defn find-var - "Resolve a symbol to a var in the current context. - Looks in current namespace first, then clojure.core." - [ctx sym-s] - (let [name (sym-s :name) - ns-sym (sym-s :ns)] - (if ns-sym - (let [ns (ctx-find-ns ctx ns-sym)] - (ns-find ns name)) - (let [current-ns (ctx-find-ns ctx (ctx-current-ns ctx)) - v (ns-find current-ns name)] - (if v v - (let [core-ns (ctx-find-ns ctx "clojure.core")] - (ns-find core-ns name))))))) - - -# ============================================================ diff --git a/src/jolt/types_ns.janet b/src/jolt/types_ns.janet deleted file mode 100644 index d484811..0000000 --- a/src/jolt/types_ns.janet +++ /dev/null @@ -1,100 +0,0 @@ -# Jolt value layer — Namespace -# Extracted from types.janet (jolt-bvek phase 5a split). - -(use ./types_symbols) -(use ./types_var) -# ============================================================ -# Namespace -# ============================================================ - -(defn make-ns - "Create a new namespace. - (make-ns name) — empty namespace - name is a symbol struct {:jolt/type :symbol ...}" - [name] - (struct - :jolt/type :jolt/namespace - :name name - :mappings @{} - :imports @{} - :aliases @{})) - -(defn ns? - "Check if x is a Jolt Namespace." - [x] - (and (or (struct? x) (table? x)) (= :jolt/namespace (x :jolt/type)))) - -(defn ns-name - "Return the name symbol of a namespace." - [ns] - (ns :name)) - -(defn ns-map - "Return the mappings table (symbol → var) for a namespace." - [ns] - (ns :mappings)) - -(defn ns-intern - "Find or create a var named by sym in namespace ns, setting root binding to val if given. - (ns-intern ns sym) — find or create unbound var - (ns-intern ns sym val) — find or create with root binding" - [ns sym &opt val] - (default val nil) - (let [mappings (ns :mappings) - existing (get mappings sym)] - (if existing - (do - (when (not (nil? val)) - (bind-root existing val)) - existing) - # Store the namespace *name*, not the ns table: a back-pointer to the ns - # would make the var cyclic (ns -> mappings -> var -> ns), and the compiler - # embeds var cells as constants, which can't be cyclic. - (let [v (make-var sym val {:ns (get ns :name) :name sym})] - (put mappings sym v) - v)))) - -(defn ns-find - "Find a var by symbol in the namespace. Returns nil if not found." - [ns sym] - (get (ns :mappings) sym)) - -(defn ns-unmap - "Remove a mapping by symbol from the namespace." - [ns sym] - (put (ns :mappings) sym nil)) - -(defn ns-resolve - "Resolve a symbol in a namespace. Looks in own mappings first, - then aliases. Returns the var or nil." - [ns sym] - (or (ns-find ns sym) - (let [qualified? (sym? sym)] - (when qualified? - # qualified symbol: look up via alias (string-keyed store) - (let [alias-ns (get (ns :aliases) (sym :ns))] - (when alias-ns - (ns-find alias-ns (sym :name)))))))) - -(defn ns-import - "Add an import to the namespace. class-name is local symbol, fq-class-name is the full qualified name." - [ns class-name fq-class-name] - (put (ns :imports) class-name fq-class-name)) - -(defn ns-import-lookup - "Look up an import in the namespace. Returns the full qualified name or nil." - [ns class-name] - (get (ns :imports) class-name)) - -(defn ns-add-alias - "Add an alias: alias-name (string) -> target ns NAME (string). The ONE alias - store (jolt-ark): resolution and ns-aliases both read it; :imports is class - imports only." - [ns alias-name target-ns-name] - (put (ns :aliases) alias-name target-ns-name)) - -(defn ns-alias-lookup - "The target ns NAME for alias-name, or nil." - [ns alias-name] - (get (ns :aliases) alias-name)) - diff --git a/src/jolt/types_protocols.janet b/src/jolt/types_protocols.janet deleted file mode 100644 index c692644..0000000 --- a/src/jolt/types_protocols.janet +++ /dev/null @@ -1,156 +0,0 @@ -# Jolt value layer — protocol/type registry + shape-records -# Extracted from types.janet (jolt-bvek phase 5a split). - -(use ./types_symbols) -(use ./types_var) -(use ./types_ns) -(use ./types_ctx) -# Protocol type registry -# ============================================================ - -(defn register-protocol-method - "Register a protocol method implementation for a type." - [ctx type-tag protocol-name method-name fn] - (let [env (ctx :env) - registry (get env :type-registry) - type-impls (or (get registry type-tag) - (do (put registry type-tag @{}) (get registry type-tag))) - proto-impls (or (get type-impls protocol-name) - (do (put type-impls protocol-name @{}) (get type-impls protocol-name)))] - (put proto-impls method-name fn) - # Bump the registry generation so any dispatch cache keyed on it invalidates. - (put env :type-registry-gen (+ 1 (or (get env :type-registry-gen) 0))))) - -(defn find-protocol-method - "Find a protocol method implementation for a type." - [ctx type-tag protocol-name method-name] - (let [registry (get (ctx :env) :type-registry) - type-impls (get registry type-tag)] - (when type-impls - (let [proto-impls (get type-impls protocol-name)] - (when proto-impls - (get proto-impls method-name)))))) - -(defn find-method-any-protocol - "Find a method implementation for a type, searching every protocol it - implements (dot calls name the method but not the protocol)." - [ctx type-tag method-name] - (let [type-impls (get (get (ctx :env) :type-registry) type-tag)] - (when type-impls - (var r nil) - (eachp [_ proto-impls] type-impls - (when (nil? r) (set r (get proto-impls method-name)))) - r))) - -(defn type-satisfies? - "Check if a type satisfies a protocol." - [ctx type-tag protocol-name] - (let [registry (get (ctx :env) :type-registry) - type-impls (get registry type-tag)] - (if (and type-impls (get type-impls protocol-name)) true false))) - -# --- shape records (hidden classes, jolt-t34) ------------------------------- -# A "shape record" is a cheap fixed-layout representation for a map literal -# whose keys are a known compile-time set (e.g. a vec3 {:r :g :b}). It is a -# Janet tuple [SHAPE v0 v1 ...] where SHAPE is an interned descriptor struct -# {:jolt/shape KEYS :idx {k->pos}}. Construction is a tuple (≈2x cheaper than a -# struct), const-keyword lookup compiles to an index, and general map ops below -# recognize it via shape-rec? and treat it as a map — so it is transparent -# wherever it flows. Created only by the backend when JOLT_SHAPE is on and the -# inference proves the shape; the runtime support here is always present so a -# shape value is handled correctly regardless. -(def- shape-cache @{}) # canonical-keys-tuple -> interned shape descriptor -# Canonical key order, OWNED BY THE RUNTIME (jolt-t34): every site that builds or -# reads a shape (shape-for, emit-map, emit-kw-lookup, build-map-literal) derives -# the layout from this one function, so they always agree regardless of what -# order the inference passed the keys in. Sorted by the keys' jdn print form — -# deterministic and total across keywords/strings/numbers/bools. -(defn shape-sort [ks] - (sort (array ;ks) (fn [a b] (< (string/format "%j" a) (string/format "%j" b))))) -(defn shape-for - "Interned shape descriptor for a key set. Keys are canonicalized internally, - so callers need not pre-sort and any permutation yields the same descriptor." - [keyv] - (def sk (tuple ;(shape-sort keyv))) - (or (get shape-cache sk) - (let [idx @{}] - (var i 0) (each k sk (put idx k i) (++ i)) - (def desc (struct :jolt/shape sk :idx (table/to-struct idx))) - (put shape-cache sk desc) - desc))) -(defn shape-rec? [x] - (and (tuple? x) (> (length x) 0) - (struct? (in x 0)) (not (nil? (in (in x 0) :jolt/shape))))) -(defn shape-keys [rec] ((in rec 0) :jolt/shape)) -(defn shape-get [rec k default] - (def desc (in rec 0)) - (def pos (get (desc :idx) k)) - (cond - (not (nil? pos)) (in rec (+ pos 1)) - # records respond to the virtual :jolt/deftype key with their type tag, so - # every existing (get obj :jolt/deftype) dispatch site keeps working - (and (= k :jolt/deftype) (desc :type)) (desc :type) - default)) -(defn shape-assoc [rec k v] - # assoc on a known key keeps the layout. A new key: a record keeps its type - # and grows a slot (Clojure records stay records when extended); a plain - # shape-rec falls back to a struct. - (def desc (in rec 0)) - (def pos (get (desc :idx) k)) - (cond - (not (nil? pos)) (let [a (array ;rec)] (put a (+ pos 1) v) (tuple ;a)) - (desc :type) - (let [new-keys (array ;(desc :jolt/shape) k) idx @{}] - (var i 0) (each kk new-keys (put idx kk i) (++ i)) - (def ndesc (struct :jolt/shape (tuple ;new-keys) :idx (table/to-struct idx) :type (desc :type))) - (def out @[ndesc]) - (each kk (desc :jolt/shape) (array/push out (shape-get rec kk nil))) - (array/push out v) - (tuple ;out)) - (let [t @{}] (each kk (desc :jolt/shape) (put t kk (shape-get rec kk nil))) (put t k v) (table/to-struct t)))) -(defn shape-count [rec] (- (length rec) 1)) -(defn shape-contains? [rec k] (not (nil? (get ((in rec 0) :idx) k)))) -# a struct snapshot of a shape-rec — the reusable bridge for ops that already -# handle structs (dissoc, vals, seq, equality, print, ...) without per-op code -(defn shape->struct [rec] - (def desc (in rec 0)) (def t @{}) - (each kk (desc :jolt/shape) (put t kk (in rec (+ 1 (get (desc :idx) kk))))) - (table/to-struct t)) - -# --- records as shapes (jolt-t34 R3) ---------------------------------------- -# A user record (deftype/defrecord) is a shape-rec whose descriptor ALSO carries -# :type (the type tag). Field layout is the DECLARED field order (not sorted), -# so the positional ->Name constructor maps args to slots directly. The -# descriptor is interned per type tag, so all instances of a type share it. -# record-tag unifies the type accessor over both the new shape-rec records and -# the table form still used for reified protocol objects. -(def- record-desc-cache @{}) -(defn record-desc [type-tag field-keys] - "Build a record descriptor (interned in declared field order) for the given - key set. Not cached — used for records extended past their declared fields." - (let [idx @{}] - (var i 0) (each k field-keys (put idx k i) (++ i)) - (struct :jolt/shape (tuple ;field-keys) :idx (table/to-struct idx) :type type-tag))) -# Interned per (type-tag, field-keys): keying on the tag alone would hand back a -# STALE descriptor after a record is redefined with different fields (a REPL -# redefine, or two same-named records in different test cases) — the new instance -# would carry the old layout. Old instances keep their own descriptor and stay -# valid; new ones get the new layout. (jolt-t34) -(defn record-shape-for [type-tag field-keys] - (def ck (tuple type-tag (tuple ;field-keys))) - (or (get record-desc-cache ck) - (let [desc (record-desc type-tag field-keys)] - (put record-desc-cache ck desc) - desc))) -(defn make-record [type-tag field-keys args] - (def out @[(record-shape-for type-tag field-keys)]) - (var i 0) (each k field-keys (array/push out (in args i)) (++ i)) - (tuple ;out)) -(defn record-tag - "The deftype/record type tag of x, or nil. Covers shape-rec records (descriptor - :type) and the table form (reified objects, :jolt/deftype)." - [x] - (cond - (and (tuple? x) (> (length x) 0) (struct? (in x 0))) (get (in x 0) :type) - (and (table? x) (get x :jolt/deftype)) (get x :jolt/deftype))) - diff --git a/src/jolt/types_symbols.janet b/src/jolt/types_symbols.janet deleted file mode 100644 index 487a9ae..0000000 --- a/src/jolt/types_symbols.janet +++ /dev/null @@ -1,41 +0,0 @@ -# Jolt value layer — characters + symbol helpers -# Extracted from types.janet (jolt-bvek phase 5a split). - -# Jolt Types -# Core types for the Clojure-on-Janet interpreter. -# -# Types: -# JoltVar — mutable container with metadata (like Clojure Var) -# JoltNamespace — namespace with symbol→var mappings and imports -# JoltContext — evaluation context (env atom, namespaces) -# -# Symbols are represented as {:jolt/type :symbol :ns :name } -# as produced by the reader. - -# Characters are {:jolt/type :jolt/char :ch }, distinct from strings. -(defn make-char [code] {:jolt/type :jolt/char :ch code}) - -(def- char-named @{"newline" 10 "space" 32 "tab" 9 "return" 13 - "formfeed" 12 "backspace" 8 "newpage" 12 "nul" 0}) - -(defn char-from-name - "Resolve a reader char-literal name (\\a, \\newline, \\uNNNN, \\oNNN) to a char value." - [name] - (cond - (= 1 (length name)) (make-char (in name 0)) - (get char-named name) (make-char (get char-named name)) - (and (> (length name) 1) (= (in name 0) (get "u" 0))) - (make-char (scan-number (string "16r" (string/slice name 1)))) - (and (> (length name) 1) (= (in name 0) (get "o" 0))) - (make-char (scan-number (string "8r" (string/slice name 1)))) - (error (string "Unsupported character: \\" name)))) - -# ============================================================ -# Symbol helpers -# ============================================================ - -(defn sym? - "Check if x is a Jolt symbol struct." - [x] - (and (struct? x) (= :symbol (x :jolt/type)))) - diff --git a/src/jolt/types_var.janet b/src/jolt/types_var.janet deleted file mode 100644 index f19f9f8..0000000 --- a/src/jolt/types_var.janet +++ /dev/null @@ -1,179 +0,0 @@ -# Jolt value layer — Var -# Extracted from types.janet (jolt-bvek phase 5a split). - -(use ./types_symbols) -# ============================================================ -# Var -# ============================================================ - -# Dynamic-var binding stack. Stored fiber-locally (via Janet's dyn), so that -# concurrent go blocks — each a Janet fiber — don't interleave each other's -# dynamic bindings, and a go block conveys the bindings in effect when it was -# spawned (see snapshot-bindings/install-bindings). Each fiber lazily gets its -# own array on first use. -(defn cur-binding-stack [] - (or (dyn :jolt/binding-stack) - (let [s @[]] (setdyn :jolt/binding-stack s) s))) - -(defn push-thread-bindings - "Push a frame of dynamic var bindings. Takes a struct of var→value." - [bindings] - (array/push (cur-binding-stack) bindings)) - -(defn pop-thread-bindings - "Pop the most recent frame of dynamic var bindings." - [] - (array/pop (cur-binding-stack))) - -(defn snapshot-bindings - "Shallow copy of the current binding stack (frames are immutable value maps). - Captured by a go block at spawn time for binding conveyance." - [] - (array/slice (cur-binding-stack))) - -(defn install-bindings - "Install a snapshot as this fiber's binding stack (a fresh copy, so the - fiber's own push/pop/var-set don't mutate the snapshot's frames array)." - [snap] - (setdyn :jolt/binding-stack (array/slice snap))) - -(defn make-var - "Create a new Jolt Var. - (make-var name) — unbound var - (make-var name init-val) — var with root binding - (make-var name init-val meta) — var with root and metadata - - name is a symbol struct {:jolt/type :symbol ...}" - [name &opt init-val meta] - (default init-val nil) - (default meta nil) - (let [m (if meta meta {:name name}) - result @{:jolt/type :jolt/var - :name name - :root init-val - :meta m - # Generation: bumped on every root change (redefinition). Call - # sites / dispatch caches keyed on this can detect a redef and - # invalidate; direct-linked (sealed) sites can detect staleness. - :gen 0 - :dynamic (if meta (get meta :dynamic) false) - :macro (if meta (get meta :macro) false) - :ns (if meta (get meta :ns) nil)}] - result)) - -(defn var? - "Check if x is a Jolt Var." - [x] - (and (table? x) (= :jolt/var (x :jolt/type)))) - -(defn var-dynamic? - "Check if var is marked :dynamic." - [v] - (v :dynamic)) - -(defn var-macro? - "Check if var is marked :macro." - [v] - (v :macro)) - -(defn var-name - "Return the symbol name of the var." - [v] - (v :name)) - -(defn var-meta - "Return the metadata of the var." - [v] - (v :meta)) - -(defn var-ns - "Return the namespace of the var." - [v] - (v :ns)) - -(defn var-get - "Deref the var. If the var is dynamic and has a thread-local binding, return that. - Otherwise return the root binding." - [v] - # Fast path: no dynamic bindings are active (the common case — the stack is - # only non-empty inside a `binding` block), so the value is just the root. This - # is the hot path for every global deref; skip building the walk otherwise. - (def bs (cur-binding-stack)) - (if (= 0 (length bs)) - (v :root) - # walk binding stack top-down for this var - (do - (var result nil) - (var i (dec (length bs))) - (while (>= i 0) - (let [frame (in bs i) - val (get frame v)] - (if (not (nil? val)) - (do - (set result (if (var? val) (var-get val) val)) - (set i -1)) - (-- i)))) - (if (not (nil? result)) result (v :root))))) - -(defn var-set - "Set a var's value. If the var has a thread-local binding on the stack, update - the innermost frame that binds it (matching Clojure, where var-set targets the - current binding); otherwise set the root." - [v val] - (def bs (cur-binding-stack)) - (var i (dec (length bs))) - (var done false) - (while (and (not done) (>= i 0)) - (let [frame (in bs i)] - (if (not (nil? (get frame v))) - (do (put bs i (merge frame {v val})) (set done true)) - (-- i)))) - (unless done (do (put v :root val) (put v :gen (+ 1 (or (v :gen) 0))))) - val) - -(defn alter-var-root - "Atomically alter the root binding of v by applying f to current value plus args." - [v f & args] - (let [new-val (f (v :root) ;args)] - (put v :root new-val) - (put v :gen (+ 1 (or (v :gen) 0))) - new-val)) - -(defn alter-meta! - "Atomically update a var's metadata via (apply f args)." - [v f & args] - (let [new-meta (apply f (var-meta v) args)] - (put v :meta new-meta) - new-meta)) - -(defn reset-meta! - "Reset a var's metadata to the given value." - [v meta] - (put v :meta meta) - meta) - - -(defn with-meta - "Return a new var with updated metadata. The original var is unchanged." - [v meta] - # build new meta as a table first (to allow adding keys), then convert - (let [new-meta-table (merge @{} (v :meta) meta) - # convert to struct by extracting all keys - new-meta (table/to-struct new-meta-table)] - @{:jolt/type :jolt/var - :name (v :name) - :root (v :root) - :meta new-meta - :gen (or (v :gen) 0) - :dynamic (v :dynamic) - :macro (v :macro) - :ns (v :ns)})) - -(defn bind-root - "Set the root binding and bump the var's generation (the redefinition - chokepoint: def, ns-intern-with-val, and the root-set paths all route here)." - [v val] - (put v :root val) - (put v :gen (+ 1 (or (v :gen) 0))) - val) - diff --git a/test/bench/core-bench.janet b/test/bench/core-bench.janet deleted file mode 100644 index cc95a60..0000000 --- a/test/bench/core-bench.janet +++ /dev/null @@ -1,50 +0,0 @@ -# Performance baseline for the clojure.core migration (jolt-1j0). -# -# Times representative core operations end-to-end (compile path) so a phase that -# moves fns from native Janet to the self-hosted Clojure overlay can be checked -# for regressions. Same programs before/after a phase -> relative delta is the -# migration's perf impact. Run: JOLT_BENCH=1 janet test/bench/core-bench.janet -# (skipped under `jpm test` — it asserts nothing; see main). -# -# Each program carries its own internal iteration so the measured work dominates -# parse/compile overhead. Reports the min of N runs (least noisy). - -(import ../../src/jolt/api :as api) - -(def runs 5) - -(def benches - [[:fib "(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (fib 28)"] - [:seq-pipe "(loop [i 0 a 0] (if (< i 300) (recur (inc i) (+ a (reduce + 0 (map inc (filter even? (range 200)))))) a))"] - [:reduce "(loop [i 0 a 0] (if (< i 2000) (recur (inc i) (+ a (reduce + 0 (range 500)))) a))"] - [:into-vec "(loop [i 0 a 0] (if (< i 1000) (recur (inc i) (+ a (count (into [] (map inc (range 100)))))) a))"] - [:map-build "(loop [i 0 a 0] (if (< i 2000) (recur (inc i) (+ a (count (reduce (fn [m k] (assoc m k k)) {} (range 50))))) a))"] - [:map-read "(let [m (zipmap (range 100) (range 100))] (loop [i 0 a 0] (if (< i 5000) (recur (inc i) (+ a (get m (mod i 100) 0))) a)))"] - [:str-join "(loop [i 0 a 0] (if (< i 1000) (recur (inc i) (+ a (count (apply str (map str (range 100)))))) a))"] - [:hof "(loop [i 0 a 0] (if (< i 2000) (recur (inc i) (+ a (reduce + 0 (map (comp inc inc) (range 200))))) a))"]]) - -(defn time-bench [ctx src] - (var best math/inf) - (for _ 0 runs - (def t0 (os/clock)) - (api/load-string ctx src) - (def dt (* 1000 (- (os/clock) t0))) - (when (< dt best) (set best dt))) - best) - -(defn main [&] - # `jpm test` recurses test/ and would run this every gate, but it's a manual - # perf tool that asserts nothing (just reports timings) — so skip it unless - # opted in with JOLT_BENCH=1. Keeps ~35s of unasserted benchmark work out of - # the correctness gate (same pattern as suite-worker's no-arg no-op). - (unless (os/getenv "JOLT_BENCH") - (print "core-bench: SKIP (set JOLT_BENCH=1 to run)") - (os/exit 0)) - (def ctx (api/init {:compile? true})) - (print "bench (compile mode), min of " runs " runs, ms:") - (var total 0) - (each [name src] benches - (def ms (time-bench ctx src)) - (+= total ms) - (printf " %-10s %8.2f ms" name ms)) - (printf " %-10s %8.2f ms" "TOTAL" total)) diff --git a/test/chez/_atomwatch.janet b/test/chez/_atomwatch.janet deleted file mode 100644 index e80f497..0000000 --- a/test/chez/_atomwatch.janet +++ /dev/null @@ -1,49 +0,0 @@ -# jolt-mn9o — atom watches + validators on Chez. The Chez atom record carries -# watches (alist) + validator slots; swap!/reset! validate-then-set-then-notify; -# add-watch/remove-watch/set-validator!/get-validator are native (post-prelude.ss -# re-asserts them over the overlay's ref-put!-based versions). -# -# janet test/chez/_atomwatch.janet -(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/joltc")) - -# [expr expected] — :throws asserts a non-zero exit (validator rejection); the -# exception message text is not compared. -(def cases - [["(let [a (atom 0) seen (atom 0)] (add-watch a :k (fn [k r o n] (reset! seen 1))) (reset! a 5) @seen)" "1"] - ["(let [a (atom 0) seen (atom 0)] (add-watch a :k (fn [k r o n] (swap! seen inc))) (remove-watch a :k) (reset! a 5) @seen)" "0"] - ["(let [a (atom 0) log (atom [])] (add-watch a :k (fn [k r o n] (swap! log conj [o n]))) (reset! a 1) (reset! a 2) @log)" "[[0 1] [1 2]]"] - ["(let [a (atom 0)] (set-validator! a number?) (reset! a 5) @a)" "5"] - ["(let [a (atom 5)] (set-validator! a pos?) (swap! a inc) @a)" "6"] - ["(let [a (atom 0)] (set-validator! a number?) (fn? (get-validator a)))" "true"] - ["(let [a (atom 0)] (nil? (get-validator a)))" "true"] - ["(let [a (atom 0)] (set-validator! a pos?) (reset! a -1))" :throws] - ["(let [a (atom 5)] (set-validator! a pos?) (swap! a (fn [_] -1)) @a)" :throws] - ["(let [a (atom 0) c (atom 0)] (add-watch a :k (fn [k r o n] (swap! c inc))) (swap! a inc) (swap! a inc) @c)" "2"]]) - -(defn run-capture [bin expr] - (def proc (os/spawn [bin "-e" expr] :p {:out :pipe :err :pipe})) - (def out (ev/read (proc :out) 0x100000)) - (def err (ev/read (proc :err) 0x100000)) - (def code (os/proc-wait proc)) - (def lines (filter (fn [l] (not (empty? l))) - (string/split "\n" (string/trim (if out (string out) ""))))) - [code (if (empty? lines) "" (last lines)) (string/trim (if err (string err) ""))]) - -(var pass 0) -(def fails @[]) -(each [expr expected] cases - (def [code got err] (run-capture jolt-bin expr)) - (cond - (= expected :throws) - (if (not= code 0) (++ pass) - (array/push fails [expr (string "expected throw; exit " code)])) - (not= code 0) (array/push fails [expr (string "exit " code "; err: " err)]) - (= got expected) (++ pass) - (array/push fails [expr (string "want `" expected "`, got `" got "`")]))) - -(printf "\n_atomwatch parity [%s]: %d/%d passed" jolt-bin pass (length cases)) -(when (> (length fails) 0) - (printf "%d FAIL(s):" (length fails)) - (each [e m] fails (printf " FAIL %s\n %s" e m))) -(flush) -(os/exit (if (empty? fails) 0 1)) diff --git a/test/chez/_class.janet b/test/chez/_class.janet deleted file mode 100644 index 211b887..0000000 --- a/test/chez/_class.janet +++ /dev/null @@ -1,59 +0,0 @@ -# jolt-13zk — bare class-name tokens + (class x) on Chez. A class name (String, -# Keyword, File...) evaluates to its JVM canonical-name STRING — the same value -# (class instance) returns — so (= String (class "x")) holds and a (defmethod m -# String ...) keys against a (class ...) dispatch. host-class.ss ports -# Scalar (class x) returns the JVM-style class-name symbol. -# Collection (class ...) is host-taxonomy-dependent and is NOT compared here. -# -# janet test/chez/_class.janet -(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/joltc")) - -(def cases - [# --- bare class tokens evaluate to canonical strings --- - ["String" "java.lang.String"] - ["Number" "java.lang.Number"] - ["Keyword" "clojure.lang.Keyword"] - ["File" "java.io.File"] - ["Exception" "java.lang.Exception"] - ["MapEntry" "clojure.lang.MapEntry"] - # --- (class x) on scalars matches core-class --- - ["(class 1)" "java.lang.Number"] - ["(class 1.5)" "java.lang.Number"] - ["(class \"s\")" "java.lang.String"] - ["(class :k)" "clojure.lang.Keyword"] - ["(class true)" "java.lang.Boolean"] - ["(class false)" "java.lang.Boolean"] - ["(class nil)" ""] - # --- token <-> class equality --- - ["(= String (class \"abc\"))" "true"] - ["(= Number (class 7))" "true"] - ["(= String (class 7))" "false"] - # --- defmulti dispatch on class --- - ["(do (defmulti cm (fn [x] (class x))) (defmethod cm String [x] :str) (cm \"a\"))" ":str"] - ["(do (defmulti cn (fn [x] (class x))) (defmethod cn nil [x] :nil) (defmethod cn String [x] :str) (cn nil))" ":nil"] - ["(do (defmulti cn (fn [x] (class x))) (defmethod cn nil [x] :nil) (defmethod cn String [x] :str) (cn \"z\"))" ":str"]]) - -(defn run-capture [bin expr] - (def proc (os/spawn [bin "-e" expr] :p {:out :pipe :err :pipe})) - (def out (ev/read (proc :out) 0x100000)) - (def err (ev/read (proc :err) 0x100000)) - (def code (os/proc-wait proc)) - (def lines (filter (fn [l] (not (empty? l))) - (string/split "\n" (string/trim (if out (string out) ""))))) - [code (if (empty? lines) "" (last lines)) (string/trim (if err (string err) ""))]) - -(var pass 0) -(def fails @[]) -(each [expr expected] cases - (def [code got err] (run-capture jolt-bin expr)) - (cond - (not= code 0) (array/push fails [expr (string "exit " code "; err: " err)]) - (= got expected) (++ pass) - (array/push fails [expr (string "want `" expected "`, got `" got "`")]))) - -(printf "\n_class parity [%s]: %d/%d passed" jolt-bin pass (length cases)) -(when (> (length fails) 0) - (printf "%d FAIL(s):" (length fails)) - (each [e m] fails (printf " FAIL %s\n %s" e m))) -(flush) -(os/exit (if (empty? fails) 0 1)) diff --git a/test/chez/_dotform.janet b/test/chez/_dotform.janet deleted file mode 100644 index 5df57a9..0000000 --- a/test/chez/_dotform.janet +++ /dev/null @@ -1,68 +0,0 @@ -# jolt-kuic — the `.` special form + `.-field` field-access desugar on Chez. The -# analyzer lowers (. target member arg*) and (.-field target) to a :host-call; -# the Chez emit routes a non-shimmed :host-call through record-method-dispatch, -# which dot-forms.ss extends with field access + map/vector member dispatch. -# Each case carries its expected printed value. -# -# janet test/chez/_dotform.janet -(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/joltc")) - -(def cases - [# strings: method calls via the String surface - ["(. \"HI\" toLowerCase)" "hi"] - ["(. \"abc\" length)" "3"] - ["(. \"abc\" toUpperCase)" "ABC"] - # vectors / maps: collection interop (count/nth/get/containsKey) - ["(. [1 2 3] count)" "3"] - ["(. [10 20 30] nth 1)" "20"] - ["(. {:a 1 :b 2} count)" "2"] - ["(. {:a 1 :b 2} get :b)" "2"] - ["(. {:a 1} containsKey :a)" "true"] - ["(. {:count 99} count)" "1"] - # map member: stored fn called with self (+ args), else field value - ["(. {:value 41 :describe (fn [self] (str \"v=\" (:value self)))} describe)" "v=41"] - ["(. {:greet (fn [self n] (str \"Hello \" n))} greet \"Alice\")" "Hello Alice"] - ["(. {:value 41} value)" "41"] - # field access via .-field head - ["(.-value {:value 41})" "41"] - ["(.-x {:x 7 :y 9})" "7"] - # field access via (. obj -field) - ["(. {:value 41} -value)" "41"] - # records: .-field reads a field, .method dispatches the protocol method - ["(do (defrecord Rf [x]) (.-x (->Rf 7)))" "7"] - ["(do (defrecord Rg [a b]) (.-b (->Rg 1 2)))" "2"] - ["(do (defprotocol Greet (hi [_])) (defrecord Rh [nm] Greet (hi [_] (str \"hi \" nm))) (. (->Rh \"x\") hi))" "hi x"] - # universal object-methods on a non-record map win over a field lookup - ["(try (throw (ex-info \"bad\" {})) (catch Throwable e (.getMessage e)))" "bad"] - ["(try (throw (ex-info \"bad\" {:k 1})) (catch Throwable e (.getMessage e)))" "bad"] - ["(try (throw \"boom\") (catch Throwable e (.getMessage e)))" "boom"] - ["(try (throw (Exception. \"boom\")) (catch Throwable e (.getMessage e)))" "boom"] - ["(try (throw (IllegalArgumentException. \"bad\")) (catch Exception e (.getMessage e)))" "bad"] - ["(.equals \"a\" \"a\")" "true"] - ["(.equals \"a\" \"b\")" "false"] - ["(. {:value 41 :describe (fn [self] (str \"v=\" (:value self)))} describe)" "v=41"]]) - -(defn run-capture [bin expr] - (def proc (os/spawn [bin "-e" expr] :p {:out :pipe :err :pipe})) - (def out (ev/read (proc :out) 0x100000)) - (def err (ev/read (proc :err) 0x100000)) - (def code (os/proc-wait proc)) - (def lines (filter (fn [l] (not (empty? l))) - (string/split "\n" (string/trim (if out (string out) ""))))) - [code (if (empty? lines) "" (last lines)) (string/trim (if err (string err) ""))]) - -(var pass 0) -(def fails @[]) -(each [expr expected] cases - (def [code got err] (run-capture jolt-bin expr)) - (cond - (not= code 0) (array/push fails [expr (string "exit " code "; err: " err)]) - (= got expected) (++ pass) - (array/push fails [expr (string "want `" expected "`, got `" got "`")]))) - -(printf "\n_dotform parity [%s]: %d/%d passed" jolt-bin pass (length cases)) -(when (> (length fails) 0) - (printf "%d FAIL(s):" (length fails)) - (each [e m] fails (printf " FAIL %s\n %s" e m))) -(flush) -(os/exit (if (empty? fails) 0 1)) diff --git a/test/chez/_dynbind.janet b/test/chez/_dynbind.janet deleted file mode 100644 index 0b7fcda..0000000 --- a/test/chez/_dynbind.janet +++ /dev/null @@ -1,75 +0,0 @@ -# jolt-2o7x — dynamic var binding (binding / with-bindings* / var-set / -# thread-bound? / with-local-vars / with-redefs / bound-fn* / get-thread-bindings). -# Expectations are the JVM-canonical values. TDD harness: bin/joltc -# -e per case, last non-empty line == expected. -# -# janet test/chez/_dynbind.janet -(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/joltc")) - -(def cases - [# --- binding: install / restore / seen across a fn call --- - ["binding rebinds" "(do (def ^:dynamic *bx* 10) (binding [*bx* 99] *bx*))" "99"] - ["binding restores" "(do (def ^:dynamic *by* 10) (binding [*by* 99] *by*) *by*)" "10"] - ["binding seen by fn" "(do (def ^:dynamic *bz* 0) (defn rdz [] *bz*) (binding [*bz* 7] (rdz)))" "7"] - ["binding both: vec" "(do (def ^:dynamic *bv* 1) [(binding [*bv* 2] *bv*) *bv*])" "[2 1]"] - ["nested binding" "(do (def ^:dynamic *bn* 1) (binding [*bn* 2] (binding [*bn* 3] *bn*)))" "3"] - ["nested binding outer" "(do (def ^:dynamic *bo* 1) (binding [*bo* 2] (binding [*bo* 3] nil) *bo*))" "2"] - # (a macro reading a dynamic var — corpus 606/607 — needs top-level defmacro - # in the -e path, which the Chez driver can't compile yet; out of scope here.) - - # --- var-set inside a binding targets the frame; restored on exit --- - ["var-set in binding" "(do (def ^:dynamic *z* 1) (binding [*z* 0] (var-set (var *z*) 5) *z*))" "5"] - ["var-set frame restores" "(do (def ^:dynamic *zr* 1) (binding [*zr* 0] (var-set (var *zr*) 5)) *zr*)" "1"] - - # --- thread-bound? --- - ["thread-bound? unbound" "(do (def ^:dynamic *tb* 1) (thread-bound? (var *tb*)))" "false"] - ["thread-bound? in scope" "(do (def ^:dynamic *tc* 1) (binding [*tc* 2] (thread-bound? (var *tc*))))" "true"] - - # --- with-bindings* / bound-fn* / get-thread-bindings --- - # Binding frames look up by var cell identity, so a var-keyed binding map - # resolves: the Clojure-correct value is 7. - ["with-bindings*" "(do (def ^:dynamic *wb* 1) (with-bindings* {(var *wb*) 7} (fn [] *wb*)))" "7"] - ["bound-fn* conveys" "(do (def ^:dynamic *cf* 1) (let [g (binding [*cf* 3] (bound-fn* (fn [] *cf*)))] (g)))" "3"] - ["get-thread-bindings" "(do (def ^:dynamic *gb* 1) (binding [*gb* 9] (get (get-thread-bindings) (var *gb*))))" "9"] - - # --- with-local-vars --- - ["local-var get" "(with-local-vars [x 1] (var-get x))" "1"] - ["local-var set" "(with-local-vars [x 1] (var-set x 2) (var-get x))" "2"] - ["local-var two" "(with-local-vars [a 1 b 2] [(var-get a) (var-get b)])" "[1 2]"] - ["local-var as value" "(with-local-vars [x 0] (let [bump (fn [v] (var-set v (+ 5 (var-get v))))] (bump x) (var-get x)))" "5"] - ["local-var init outer" "(let [y 3] (with-local-vars [x y] (var-get x)))" "3"] - ["local-var body result" "(with-local-vars [x 1] :done)" ":done"] - - # --- with-redefs --- - ["with-redefs rebinds" "(do (defn wrf [] 1) (with-redefs [wrf (fn [] 42)] (wrf)))" "42"] - ["with-redefs restores" "(do (defn wrg [] 1) (with-redefs [wrg (fn [] 42)]) (wrg))" "1"] - ["with-redefs on throw" "(do (defn wrh [] 1) (try (with-redefs [wrh (fn [] 42)] (throw (ex-info \"x\" {}))) (catch :default e nil)) (wrh))" "1"] - ["with-redefs-fn" "(do (defn wri [] 1) (with-redefs-fn {(var wri) (fn [] 42)} (fn [] (wri))))" "42"] - - # --- alter-var-root --- - ["alter-var-root" "(do (def av 1) (alter-var-root (var av) inc) av)" "2"]]) - -(defn run-capture [expr] - (def proc (os/spawn [jolt-bin "-e" expr] :p {:out :pipe :err :pipe})) - (def out (ev/read (proc :out) 0x100000)) - (def err (ev/read (proc :err) 0x100000)) - (def code (os/proc-wait proc)) - (def lines (filter (fn [l] (not (empty? l))) - (string/split "\n" (string/trim (if out (string out) ""))))) - [code (if (empty? lines) "" (last lines)) (if err (string err) "")]) - -(var pass 0) -(def fails @[]) -(each [label expr expected] cases - (def [code got err] (run-capture expr)) - (cond - (not= code 0) (array/push fails [label (string "exit " code "; err: " (string/trim err))]) - (= got expected) (++ pass) - (array/push fails [label (string "want `" expected "`, got `" got "`")]))) - -(printf "\n_dynbind parity [%s]: %d/%d passed" jolt-bin pass (length cases)) -(when (> (length fails) 0) - (printf "%d FAIL(s):" (length fails)) - (each [l m] fails (printf " FAIL [%s] %s" l m))) -(flush) -(os/exit (if (empty? fails) 0 1)) diff --git a/test/chez/_insttime.janet b/test/chez/_insttime.janet deleted file mode 100644 index e70d2d6..0000000 --- a/test/chez/_insttime.janet +++ /dev/null @@ -1,74 +0,0 @@ -# jolt-at0a (inc X) — #inst / #uuid literals + java.time formatting on Chez. -# #inst lowers (analyzer :inst node) to a jinst value (RFC3339 ms, partial -# defaults + offsets); #uuid to a juuid; the java.time shim (DateTimeFormatter/ -# Instant/ZoneId/LocalDateTime/FormatStyle/Locale/Date. -# Reader data-readers and statics emit the runtime value -# (host/chez/inst-time.ss). -# -# -# janet test/chez/_insttime.janet -(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/joltc")) - -(def cases - [# --- #inst reading + identity --- - ["(inst? #inst \"2020-01-01T00:00:00Z\")" "true"] - ["(inst-ms #inst \"1970-01-01T00:00:01Z\")" "1000"] - ["(inst-ms #inst \"1970-01-01T00:00:00.123Z\")" "123"] - ["(inst-ms #inst \"2020-01-01T00:00:00Z\")" "1577836800000"] - ["(inst-ms* #inst \"1970-01-01T00:00:00Z\")" "0"] - ["(some? #inst \"2020-01-01T00:00:00Z\")" "true"] - ["(str (type #inst \"2020-01-01T00:00:00Z\"))" ":jolt/inst"] - # --- partial timestamps + offsets (value equality by instant) --- - ["(= #inst \"2020\" #inst \"2020-01-01T00:00:00.000Z\")" "true"] - ["(= #inst \"2020-03\" #inst \"2020-03-01T00:00:00Z\")" "true"] - ["(= #inst \"2020-03-15\" #inst \"2020-03-15T00:00:00Z\")" "true"] - ["(= #inst \"2020-01-01T01:00:00+01:00\" #inst \"2020-01-01T00:00:00Z\")" "true"] - ["(= #inst \"2019-12-31T23:00:00-01:00\" #inst \"2020-01-01T00:00:00Z\")" "true"] - ["(= #inst \"2020-01-01T00:00:00Z\" #inst \"2020-01-01T00:00:01Z\")" "false"] - # --- map key + pr-str round trip --- - ["(get {#inst \"2020-01-01T00:00:00Z\" :v} #inst \"2020-01-01T00:00:00.000Z\")" ":v"] - ["(pr-str #inst \"2020-01-01T00:00:00Z\")" "#inst \"2020-01-01T00:00:00.000-00:00\""] - ["(str #inst \"2020-01-01T00:00:00Z\")" "2020-01-01T00:00:00.000-00:00"] - # --- #uuid --- - ["(uuid? #uuid \"550e8400-e29b-41d4-a716-446655440000\")" "true"] - ["(= #uuid \"550E8400-E29B-41D4-A716-446655440000\" #uuid \"550e8400-e29b-41d4-a716-446655440000\")" "true"] - ["(pr-str #uuid \"550e8400-e29b-41d4-a716-446655440000\")" "#uuid \"550e8400-e29b-41d4-a716-446655440000\""] - # --- java.util.Date / java.time.Instant interop --- - ["(.getTime #inst \"1970-01-01T00:00:00Z\")" "0"] - ["(instance? java.util.Date #inst \"2020-01-01T00:00:00Z\")" "true"] - ["(instance? java.sql.Timestamp #inst \"2020-01-01T00:00:00Z\")" "false"] - ["(.toEpochMilli (Instant/ofEpochMilli 1234))" "1234"] - ["(instance? java.time.Instant (Instant/ofEpochMilli 0))" "true"] - ["(> (.toEpochMilli (Instant/now)) 1500000000000)" "true"] - ["(instance? LocalDateTime (-> #inst \"2020-03-05T13:45:30Z\" (.toInstant) (.atZone (ZoneId/systemDefault)) (.toLocalDateTime)))" "true"] - # --- DateTimeFormatter pattern engine --- - ["(.format (DateTimeFormatter/ofPattern \"yyyy-MM-dd\") #inst \"2020-03-05T13:45:30Z\")" "2020-03-05"] - ["(boolean (re-matches #\"[A-Z][a-z]{2} \\d{1,2}, 2020 \\d{1,2}:\\d{2} [AP]M\" (.format (DateTimeFormatter/ofPattern \"MMM d, yyyy h:mm a\") #inst \"2020-03-05T13:45:30Z\")))" "true"] - ["(boolean (re-matches #\"\\d{4}-\\d{2}-\\d{2}T\\d{2}:\\d{2}:\\d{2}\" (.format DateTimeFormatter/ISO_LOCAL_DATE_TIME #inst \"2020-03-05T13:45:30Z\")))" "true"] - ["(string? (.format (DateTimeFormatter/ofLocalizedDate FormatStyle/MEDIUM) #inst \"2020-03-05T13:45:30Z\"))" "true"] - ["(string? (.format (.withLocale (DateTimeFormatter/ofPattern \"yyyy\") (java.util.Locale. \"en\")) #inst \"2020-01-01T00:00:00Z\"))" "true"]]) - -(defn run-capture [bin expr] - (def proc (os/spawn [bin "-e" expr] :p {:out :pipe :err :pipe})) - (def out (ev/read (proc :out) 0x100000)) - (def err (ev/read (proc :err) 0x100000)) - (def code (os/proc-wait proc)) - (def lines (filter (fn [l] (not (empty? l))) - (string/split "\n" (string/trim (if out (string out) ""))))) - [code (if (empty? lines) "" (last lines)) (string/trim (if err (string err) ""))]) - -(var pass 0) -(def fails @[]) -(each [expr expected] cases - (def [code got err] (run-capture jolt-bin expr)) - (cond - (not= code 0) (array/push fails [expr (string "exit " code "; err: " err)]) - (= got expected) (++ pass) - (array/push fails [expr (string "want `" expected "`, got `" got "`")]))) - -(printf "\n_insttime parity [%s]: %d/%d passed" jolt-bin pass (length cases)) -(when (> (length fails) 0) - (printf "%d FAIL(s):" (length fails)) - (each [e m] fails (printf " FAIL %s\n %s" e m))) -(flush) -(os/exit (if (empty? fails) 0 1)) diff --git a/test/chez/_io.janet b/test/chez/_io.janet deleted file mode 100644 index 02aa157..0000000 --- a/test/chez/_io.janet +++ /dev/null @@ -1,61 +0,0 @@ -# jolt-yyud — clojure.java.io/file + java.io.File interop + slurp/spit/flush/ -# file-seq on Chez. A File is a path-backed jfile record (instance? java.io.File, -# str -> path, the File method surface). This is a Chez-native implementation. -# Reader-coupled cases (line-seq, slurp over a reader, toURL) are deferred to jolt-at0a. -# -# -# janet test/chez/_io.janet -(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/joltc")) - -(defn io [body] (string "(do (require (quote [clojure.java.io :as io])) " body ")")) - -(def cases - [# --- File construction + method surface --- - [(io "(str (io/file \"/a/b\"))") "/a/b"] - [(io "(str (io/file \"/a\" \"b\"))") "/a/b"] - [(io "(.getName (io/file \"/a/b/c.txt\"))") "c.txt"] - [(io "(.getPath (io/file \"/a\" \"b\"))") "/a/b"] - [(io "(.isDirectory (io/file \"docs\"))") "true"] - [(io "(.isFile (io/file \"project.janet\"))") "true"] - [(io "(.isFile (io/file \"docs\"))") "false"] - [(io "(.exists (io/file \"/no/such/path/xyz\"))") "false"] - [(io "(.exists (io/file \"project.janet\"))") "true"] - # --- instance? + type --- - [(io "(instance? java.io.File (io/file \"/a/b\"))") "true"] - [(io "(instance? java.io.File \"/a/b\")") "false"] - [(io "(str (type (io/file \"/a\")))") ":jolt/file"] - # --- file-seq --- - [(io "(every? (fn [f] (instance? java.io.File f)) (file-seq (io/file \"docs\")))") "true"] - [(io "(pos? (count (filter (fn [f] (.isFile f)) (file-seq (io/file \"docs\")))))") "true"] - ["(do (require (quote [clojure.string :as s])) (boolean (some (fn [p] (s/ends-with? p \"project.janet\")) (file-seq \".\"))))" "true"] - # --- slurp / spit / flush --- - ["(string? (slurp \"project.janet\"))" "true"] - ["(do (spit \"/tmp/jolt-io-test.txt\" \"hello\") (slurp \"/tmp/jolt-io-test.txt\"))" "hello"] - ["(do (spit \"/tmp/jolt-io-test.txt\" \"a\") (spit \"/tmp/jolt-io-test.txt\" \"b\" :append true) (slurp \"/tmp/jolt-io-test.txt\"))" "ab"] - ["(flush)" ""] - [(io "(string? (slurp (io/file \"project.janet\")))") "true"]]) - -(defn run-capture [bin expr] - (def proc (os/spawn [bin "-e" expr] :p {:out :pipe :err :pipe})) - (def out (ev/read (proc :out) 0x100000)) - (def err (ev/read (proc :err) 0x100000)) - (def code (os/proc-wait proc)) - (def lines (filter (fn [l] (not (empty? l))) - (string/split "\n" (string/trim (if out (string out) ""))))) - [code (if (empty? lines) "" (last lines)) (string/trim (if err (string err) ""))]) - -(var pass 0) -(def fails @[]) -(each [expr expected] cases - (def [code got err] (run-capture jolt-bin expr)) - (cond - (not= code 0) (array/push fails [expr (string "exit " code "; err: " err)]) - (= got expected) (++ pass) - (array/push fails [expr (string "want `" expected "`, got `" got "`")]))) - -(printf "\n_io parity [%s]: %d/%d passed" jolt-bin pass (length cases)) -(when (> (length fails) 0) - (printf "%d FAIL(s):" (length fails)) - (each [e m] fails (printf " FAIL %s\n %s" e m))) -(flush) -(os/exit (if (empty? fails) 0 1)) diff --git a/test/chez/_ioreader.janet b/test/chez/_ioreader.janet deleted file mode 100644 index e55062b..0000000 --- a/test/chez/_ioreader.janet +++ /dev/null @@ -1,61 +0,0 @@ -# jolt-at0a (inc W) — reader-coupled io deferred from inc V (jolt-yyud): -# clojure.java.io/reader (a StringReader over slurp/string/char[]/File/path), -# char-array, File.toURL/.toURI (-> a java.net.URL jhost), slurp draining a -# StringReader, and with-open's __close seam over both jhost readers and plain -# :close maps. All Chez-native (host/chez/io.ss); no analyzer change. Reader/edn -# runtime read (clojure.edn/read over a PushbackReader) stays jolt-r8ku. -# -# -# janet test/chez/_ioreader.janet -(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/joltc")) - -(defn io [body] (string "(do (require (quote [clojure.java.io :as io])) " body ")")) - -(def cases - [# --- char-array --- - ["(str (char-array \"abc\"))" "(\\a \\b \\c)"] - ["(.read (StringReader. (apply str (char-array \"Qz\"))))" "81"] - # --- io/reader: char[] / string-reader passthrough / path --- - [(io "(.read (io/reader (char-array \"abc\")))") "97"] - [(io "(.read (io/reader (StringReader. \"k\")))") "107"] - [(io "(slurp (io/reader (char-array \"xyz\")))") "xyz"] - [(io "(string? (slurp (io/reader \"project.janet\")))") "true"] - # --- File.toURL / .toURI --- - [(io "(.toString (.toURL (io/file \"/tmp/x\")))") "file:/tmp/x"] - [(io "(.toURI (io/file \"/tmp/x\"))") "file:/tmp/x"] - [(io "(.getPath (.toURL (io/file \"/tmp/x\")))") "/tmp/x"] - [(io "(.getAbsolutePath (io/file \"/a/b\"))") "/a/b"] - # --- slurp drains a StringReader (+ ignores :encoding opts) --- - ["(slurp (StringReader. \"a=1\"))" "a=1"] - ["(slurp (StringReader. \"b\") :encoding \"UTF-8\")" "b"] - # --- with-open: jhost reader + plain :close map --- - ["(with-open [r (StringReader. \"a\")] (.read r))" "97"] - ["(let [log (atom [])] (with-open [c {:close (fn [] (swap! log conj :closed))}] :r) (deref log))" "[:closed]"] - ["(let [log (atom [])] (try (with-open [c {:close (fn [] (swap! log conj :closed))}] (throw (ex-info \"boom\" {}))) (catch Exception e nil)) (deref log))" "[:closed]"] - ["(let [log (atom [])] (with-open [a {:close (fn [] (swap! log conj :outer))} b {:close (fn [] (swap! log conj :inner))}] :r) (deref log))" "[:inner :outer]"] - ["(with-open [c {:close (fn [] nil) :v 5}] (:v c))" "5"]]) - -(defn run-capture [bin expr] - (def proc (os/spawn [bin "-e" expr] :p {:out :pipe :err :pipe})) - (def out (ev/read (proc :out) 0x100000)) - (def err (ev/read (proc :err) 0x100000)) - (def code (os/proc-wait proc)) - (def lines (filter (fn [l] (not (empty? l))) - (string/split "\n" (string/trim (if out (string out) ""))))) - [code (if (empty? lines) "" (last lines)) (string/trim (if err (string err) ""))]) - -(var pass 0) -(def fails @[]) -(each [expr expected] cases - (def [code got err] (run-capture jolt-bin expr)) - (cond - (not= code 0) (array/push fails [expr (string "exit " code "; err: " err)]) - (= got expected) (++ pass) - (array/push fails [expr (string "want `" expected "`, got `" got "`")]))) - -(printf "\n_ioreader parity [%s]: %d/%d passed" jolt-bin pass (length cases)) -(when (> (length fails) 0) - (printf "%d FAIL(s):" (length fails)) - (each [e m] fails (printf " FAIL %s\n %s" e m))) -(flush) -(os/exit (if (empty? fails) 0 1)) diff --git a/test/chez/_javastatic.janet b/test/chez/_javastatic.janet deleted file mode 100644 index 9322d2c..0000000 --- a/test/chez/_javastatic.janet +++ /dev/null @@ -1,89 +0,0 @@ -# jolt-avt6 — host class statics + constructors on Chez. The analyzer lowers -# Class/member to :host-static and (Class. ...) to :host-new; the Chez emit lowers -# them to host-static-ref/host-static-call/host-new (host-static.ss registry). -# Each case carries its expected printed value. Env-dependent values (os.name) are -# asserted via a predicate so the case stays portable across machines. -# -# janet test/chez/_javastatic.janet -(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/joltc")) - -(def cases - [["(Math/sqrt 16)" "4"] - ["(Math/abs -3)" "3"] - ["(Math/max 2 7)" "7"] - ["(pos? Long/MAX_VALUE)" "true"] - ["(String/valueOf 42)" "42"] - ["(String/valueOf \"hi\")" "hi"] - ["(String/valueOf :k)" ":k"] - ["(String/valueOf nil)" "null"] - ["(Long/parseLong \"42\")" "42"] - ["(Long/valueOf \"42\")" "42"] - ["(Integer/parseInt \"ff\" 16)" "255"] - ["(.byteValue (Integer/valueOf \"ff\" 16))" "-1"] - ["(Boolean/parseBoolean \"true\")" "true"] - ["(Boolean/parseBoolean \"yes\")" "false"] - ["(Character/isUpperCase \\A)" "true"] - ["(Character/isLowerCase \\a)" "true"] - ["(Character/isUpperCase \\a)" "false"] - ["(Thread/interrupted)" "false"] - ["(string? (System/getProperty \"os.name\"))" "true"] - ["(string? (get (System/getenv) \"HOME\"))" "true"] - ["(string? (System/getenv \"HOME\"))" "true"] - ["(fn? System/exit)" "true"] - ["(string? (get (System/getProperties) \"os.name\"))" "true"] - ["(pos? (count (seq (System/getenv))))" "true"] - ["(let [es (map (fn [[k v]] [k v]) (System/getenv))] (and (pos? (count es)) (every? vector? es)))" "true"] - # constructors + their methods - ["(.toString (StringBuilder. \"x\"))" "x"] - ["(.toString (-> (StringBuilder.) (.append \"a\") (.append \\b) (.append 1)))" "ab1"] - ["(.toString (.append (StringBuilder. 16) \"x\"))" "x"] - ["(let [sb (StringBuilder.)] (.append sb \"abcd\") (.setLength sb 2) (.toString sb))" "ab"] - ["(let [w (StringWriter.)] (.write w \"a\") (.append w \\b) (.toString w))" "ab"] - ["(let [r (StringReader. \"ab\")] [(.read r) (.read r) (.read r)])" "[97 98 -1]"] - ["(let [r (StringReader. \"ab\")] (.mark r 1) [(.read r) (do (.reset r) (.read r))])" "[97 97]"] - ["(let [r (java.io.PushbackReader. (java.io.StringReader. \"ab\"))] [(.read r) (.read r)])" "[97 98]"] - ["(let [r (PushbackReader. (StringReader. \"ab\")) a (.read r)] (.unread r a) [a (.read r) (.read r)])" "[97 97 98]"] - ["(let [r (PushbackReader. (StringReader. \"a\"))] (.unread r \\x) [(.read r) (.read r)])" "[120 97]"] - ["(BigInteger. \"123\")" "123"] - ["(let [m (HashMap. {:a 1 :b 2})] (.get m :b))" "2"] - ["(let [m (HashMap. {})] (.put m :x 1) (.put m :y 2) (.size m))" "2"] - ["(let [t (StringTokenizer. \"a=1&b=2\" \"&\")] [(.nextToken t) (.nextToken t)])" "[a=1 b=2]"] - ["(.toString (StringBuilder. \"x\"))" "x"] - # ring-codec surface - ["(URLEncoder/encode \"a b=c\")" "a+b%3Dc"] - ["(URLDecoder/decode (URLEncoder/encode \"x &=%?\"))" "x &=%?"] - ["(String. (.encode (Base64/getEncoder) (.getBytes \"hello\")))" "aGVsbG8="] - ["(String. (.decode (Base64/getDecoder) (String. (.encode (Base64/getEncoder) (.getBytes \"hello\")))))" "hello"] - ["(Integer/parseInt \"ff\" 16)" "255"] - # Pattern statics - ["(regex? (Pattern/compile \"a.c\"))" "true"] - ["(.split (Pattern/compile \",\") \"a,b,c\")" "(a b c)"] - ["(do (require '[clojure.string :as s]) (s/replace \"a1b2\" (Pattern/compile \"[0-9]\") \"\"))" "ab"] - ["(boolean (re-find (Pattern/compile \"^x\" Pattern/MULTILINE) \"y\\nx\"))" "true"] - ["(boolean (re-find (re-pattern (Pattern/quote \"a.c\")) \"za.cy\"))" "true"] - ["(boolean (re-find (re-pattern (Pattern/quote \"a.c\")) \"zabcy\"))" "false"]]) - -(defn run-capture [bin expr] - (def proc (os/spawn [bin "-e" expr] :p {:out :pipe :err :pipe})) - (def out (ev/read (proc :out) 0x100000)) - (def err (ev/read (proc :err) 0x100000)) - (def code (os/proc-wait proc)) - (def lines (filter (fn [l] (not (empty? l))) - (string/split "\n" (string/trim (if out (string out) ""))))) - [code (if (empty? lines) "" (last lines)) (string/trim (if err (string err) ""))]) - -(var pass 0) -(def fails @[]) -(each [expr expected] cases - (def [code got err] (run-capture jolt-bin expr)) - (cond - (not= code 0) (array/push fails [expr (string "exit " code "; err: " err)]) - (= got expected) (++ pass) - (array/push fails [expr (string "want `" expected "`, got `" got "`")]))) - -(printf "\n_javastatic parity [%s]: %d/%d passed" jolt-bin pass (length cases)) -(when (> (length fails) 0) - (printf "%d FAIL(s):" (length fails)) - (each [e m] fails (printf " FAIL %s\n %s" e m))) -(flush) -(os/exit (if (empty? fails) 0 1)) diff --git a/test/chez/_ns.janet b/test/chez/_ns.janet deleted file mode 100644 index 76d3cf6..0000000 --- a/test/chez/_ns.janet +++ /dev/null @@ -1,54 +0,0 @@ -# jolt-yxqm — namespace value model (find-ns/ns-name/all-ns/resolve/ns-publics/ -# in-ns/*ns* …). TDD harness: drives bin/joltc -e per case (fresh subprocess -# = per-case isolation), checks the LAST printed line == expected. Expected -# values are the JVM-canonical reference, baked per case. -# -# janet test/chez/_ns.janet -(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/joltc")) - -# [label expr expected-last-line] -(def cases - [["find-ns existing" "(some? (find-ns 'clojure.core))" "true"] - ["find-ns missing" "(nil? (find-ns 'does.not.exist))" "true"] - ["resolve native-op +" "(var? (resolve '+))" "true"] - ["resolve undefined" "(nil? (resolve 'totally-undefined-xyz))" "true"] - ["ns-publics has def" "(do (def npv 1) (some? (get (ns-publics 'user) 'npv)))" "true"] - ["ns-map has def" "(do (def nmv 1) (some? (get (ns-map 'user) 'nmv)))" "true"] - ["ns-aliases is a map" "(map? (ns-aliases 'clojure.core))" "true"] - ["ns-interns is a map" "(map? (ns-interns 'user))" "true"] - ["ns-interns count pos" "(do (def q 1) (pos? (count (ns-interns 'user))))" "true"] - ["all-ns count pos" "(pos? (count (all-ns)))" "true"] - ["ns-name *ns* = user" "(= (ns-name *ns*) (ns-name (find-ns 'user)))" "true"] - ["in-ns returns ns str" "(str (in-ns 'jolt.test-ns-b))" "jolt.test-ns-b"] - ["in-ns updates *ns*" "(do (in-ns 'jolt.test-ns-a) (str *ns*))" "jolt.test-ns-a"] - ["ns-unmap clears var" "(do (def nuv 1) (ns-unmap 'user 'nuv) (nil? (resolve 'nuv)))" "true"] - ["in-ns no error" "(do (in-ns 'my.ns) (symbol? 'x))" "true"] - ["str ns-name *ns*" "(str (ns-name *ns*))" "user"] - ["find-var qualified" "(var? (find-var 'clojure.core/map))" "true"] - ["the-ns ns-name" "(= 'user (ns-name (the-ns 'user)))" "true"] - ["create-ns ns-name" "(= 'foo.bar (ns-name (create-ns 'foo.bar)))" "true"]]) - -(defn run-capture [expr] - (def proc (os/spawn [jolt-bin "-e" expr] :p {:out :pipe :err :pipe})) - (def out (ev/read (proc :out) 0x100000)) - (def err (ev/read (proc :err) 0x100000)) - (def code (os/proc-wait proc)) - (def lines (filter (fn [l] (not (empty? l))) - (string/split "\n" (string/trim (if out (string out) ""))))) - [code (if (empty? lines) "" (last lines)) (if err (string err) "")]) - -(var pass 0) -(def fails @[]) -(each [label expr expected] cases - (def [code got err] (run-capture expr)) - (cond - (not= code 0) (array/push fails [label (string "exit " code "; err: " (string/trim err))]) - (= got expected) (++ pass) - (array/push fails [label (string "want `" expected "`, got `" got "`")]))) - -(printf "\n_ns parity [%s]: %d/%d passed" jolt-bin pass (length cases)) -(when (> (length fails) 0) - (printf "%d FAIL(s):" (length fails)) - (each [l m] fails (printf " FAIL [%s] %s" l m))) -(flush) -(os/exit (if (empty? fails) 0 1)) diff --git a/test/chez/_reader.janet b/test/chez/_reader.janet deleted file mode 100644 index 7ad7c09..0000000 --- a/test/chez/_reader.janet +++ /dev/null @@ -1,95 +0,0 @@ -# jolt-r8ku (inc Y) — Chez-side Clojure data reader: read-string / read / -# read+string / with-in-str / clojure.edn. The reader (host/chez/reader.ss) -# produces jolt forms directly; the *in* family and -# clojure.edn are Clojure over the read-string / __parse-next seams. -# -# Outputs are kept order-stable (equality checks, scalars) so set/map iteration -# order — which is host-dependent — doesn't masquerade as a -# divergence. -# -# janet test/chez/_reader.janet -(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/joltc")) - -(def cases - [# --- scalars + collections (value equality, order-independent) --- - ["(= 42 (read-string \"42\"))" "true"] - ["(= 42 (read-string \"0x2A\"))" "true"] - # numeric tower (jolt-n6al): "1/2" reads as an exact Ratio (= JVM), so a - # category-aware = against the double 0.5 is false; assert numeric value (==), - # which holds in both the all-flonum and tower models. - ["(== 0.5 (read-string \"1/2\"))" "true"] - ["(= -3.5 (read-string \"-3.5\"))" "true"] - ["(== 1000.0 (read-string \"1e3\"))" "true"] - ["(= 1 (read-string \"1N\"))" "true"] - ["(integer? (read-string \"7\"))" "true"] - ["(= :foo (read-string \":foo\"))" "true"] - ["(= :a/b (read-string \":a/b\"))" "true"] - ["(= :foo (read-string \"::foo\"))" "true"] - ["(= (quote sym) (read-string \"sym\"))" "true"] - ["(= (quote ns/sym) (read-string \"ns/sym\"))" "true"] - ["(nil? (read-string \"nil\"))" "true"] - ["(true? (read-string \"true\"))" "true"] - ["(false? (read-string \"false\"))" "true"] - ["(= \\a (read-string \"\\\\a\"))" "true"] - ["(= \\newline (read-string \"\\\\newline\"))" "true"] - ["(= \\space (read-string \"\\\\space\"))" "true"] - ["(= \"a\\nb\" (read-string \"\\\"a\\\\nb\\\"\"))" "true"] - ["(= [1 2 3] (read-string \"[1 2 3]\"))" "true"] - ["(= (quote (+ 1 2)) (read-string \"(+ 1 2)\"))" "true"] - ["(= {:a 1 :b 2} (read-string \"{:a 1 :b 2}\"))" "true"] - # core read-string returns the raw set FORM (edn->value builds the real set) - ["(:value (read-string \"#{1 2 3}\"))" "[1 2 3]"] - ["(= :jolt/set (:jolt/type (read-string \"#{1 2 3}\")))" "true"] - ["(= [1 [2 3] {:k :v}] (read-string \"[1 [2 3] {:k :v}]\"))" "true"] - # --- reader macros --- - ["(= (quote (quote x)) (read-string \"'x\"))" "true"] - ["(= (quote (clojure.core/deref a)) (read-string \"@a\"))" "true"] - ["(= (quote (syntax-quote (a (unquote b)))) (read-string \"`(a ~b)\"))" "true"] - ["(= (quote (unquote-splicing xs)) (read-string \"~@xs\"))" "true"] - # --- whitespace / comments / discard --- - ["(= 42 (read-string \"; comment\\n42\"))" "true"] - ["(= [1 2] (read-string \"[1 #_ 9 2]\"))" "true"] - ["(nil? (read-string \"\"))" "true"] - ["(nil? (read-string \" , ,\"))" "true"] - # --- metadata ^ on a symbol --- - ["(:tag (meta (read-string \"^String x\")))" "String"] - ["(:foo (meta (read-string \"^:foo x\")))" "true"] - # --- *in* reader family: read / read+string / with-in-str --- - ["(= 42 (with-in-str \"42\" (read)))" "true"] - ["(= (quote (+ 1 2)) (with-in-str \"(+ 1 2)\" (read)))" "true"] - ["(with-in-str \"1 2\" [(read) (read)])" "[1 2]"] - ["(= :done (with-in-str \"\" (read *in* false :done)))" "true"] - ["(let [[v s] (with-in-str \"42 rest\" (read+string))] (and (= v 42) (string? s)))" "true"] - ["(= [1 2] (with-in-str \"1 2\" [(first (read+string)) (first (read+string))]))" "true"] - # --- clojure.edn (set/tagged forms built into real values) --- - ["(do (require (quote [clojure.edn :as e0])) (= #{1 2} (e0/read-string \"#{1 2}\")))" "true"] - ["(do (require (quote [clojure.edn :as e0])) (uuid? (e0/read-string \"#uuid \\\"550e8400-e29b-41d4-a716-446655440000\\\"\")))" "true"] - ["(do (require (quote [clojure.edn :as e0])) (inst? (e0/read-string \"#inst \\\"2020-01-01T00:00:00Z\\\"\")))" "true"] - ["(do (require (quote [clojure.edn :as e0])) (= :end (e0/read-string {:eof :end} \"\")))" "true"] - ["(do (require (quote [clojure.edn :as e0])) (= [:custom 5] (e0/read-string {:readers {(quote custom) (fn [v] [:custom v])}} \"#custom 5\")))" "true"] - ["(do (require (quote clojure.edn)) (= {:a 1 :b 2} (clojure.edn/read-string \"{:a 1\\n :b 2}\")))" "true"]]) - -(defn run-capture [bin expr] - (def proc (os/spawn [bin "-e" expr] :p {:out :pipe :err :pipe})) - (def out (ev/read (proc :out) 0x100000)) - (def err (ev/read (proc :err) 0x100000)) - (def code (os/proc-wait proc)) - (def lines (filter (fn [l] (not (empty? l))) - (string/split "\n" (string/trim (if out (string out) ""))))) - [code (if (empty? lines) "" (last lines)) (string/trim (if err (string err) ""))]) - -(var pass 0) -(def fails @[]) -(each [expr expected] cases - (def [code got err] (run-capture jolt-bin expr)) - (cond - (not= code 0) (array/push fails [expr (string "exit " code "; err: " err)]) - (= got expected) (++ pass) - (array/push fails [expr (string "want `" expected "`, got `" got "`")]))) - -(printf "\n_reader parity [%s]: %d/%d passed" jolt-bin pass (length cases)) -(when (> (length fails) 0) - (printf "%d FAIL(s):" (length fails)) - (each [e m] fails (printf " FAIL %s\n %s" e m))) -(flush) -(os/exit (if (empty? fails) 0 1)) diff --git a/test/chez/_seqpred.janet b/test/chez/_seqpred.janet deleted file mode 100644 index 526832d..0000000 --- a/test/chez/_seqpred.janet +++ /dev/null @@ -1,65 +0,0 @@ -# sequential? / seq? on lazy seqs (jolt-2o7x follow-up). The inc M fix made the -# native seq? var recognize a lazy-seq (re-def-var!, not just set!). sequential? -# is overlay (`(defn sequential? [x] (or (vector? x) (seq? x)))`), so it inherits -# the fix transitively; this pins that both predicates agree with the JVM oracle -# over every lazy-seq-producing form (and the native =/hash path via set!). -# Expectations are the JVM-canonical values. -# -# janet test/chez/_seqpred.janet -(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/joltc")) - -(def cases - [# --- seq? over lazy seqs --- - # (NB: range is lazy, so (type (range 3)) is :seq not :vector - # seq; a range-container divergence, not the predicate. sequential? agrees on it.) - ["seq? map" "(seq? (map inc [1 2 3]))" "true"] - ["seq? filter" "(seq? (filter odd? [1 2 3]))" "true"] - ["seq? lazy-seq" "(seq? (lazy-seq (cons 1 nil)))" "true"] - ["seq? take iterate" "(seq? (take 3 (iterate inc 0)))" "true"] - ["seq? cons onto lazy" "(seq? (cons 0 (range 3)))" "true"] - ["seq? vector false" "(seq? [1 2 3])" "false"] - ["seq? map-coll false" "(seq? {:a 1})" "false"] - ["seq? nil false" "(seq? nil)" "false"] - - # --- sequential? over lazy seqs (overlay, delegates to seq?) --- - ["sequential? range" "(sequential? (range 3))" "true"] - ["sequential? map" "(sequential? (map inc [1 2 3]))" "true"] - ["sequential? filter" "(sequential? (filter odd? [1 2 3]))" "true"] - ["sequential? lazy-seq" "(sequential? (lazy-seq (cons 1 nil)))" "true"] - ["sequential? infinite" "(sequential? (take 2 (repeat 9)))" "true"] - ["sequential? vector" "(sequential? [1 2 3])" "true"] - ["sequential? list" "(sequential? '(1 2 3))" "true"] - ["sequential? map false" "(sequential? {:a 1})" "false"] - ["sequential? set false" "(sequential? #{1 2})" "false"] - ["sequential? nil false" "(sequential? nil)" "false"] - - # --- native =/hash path (jolt-sequential? via set!) over a raw lazy seq --- - ["= vec lazyseq" "(= [0 1 2] (range 3))" "true"] - ["= lazyseq vec" "(= (range 3) [0 1 2])" "true"] - ["= lazyseq list" "(= (map inc [0 1]) '(1 2))" "true"] - ["set contains lazyseq" "(contains? #{[0 1 2]} (vec (range 3)))" "true"]]) - -(defn run-capture [expr] - (def proc (os/spawn [jolt-bin "-e" expr] :p {:out :pipe :err :pipe})) - (def out (ev/read (proc :out) 0x100000)) - (def err (ev/read (proc :err) 0x100000)) - (def code (os/proc-wait proc)) - (def lines (filter (fn [l] (not (empty? l))) - (string/split "\n" (string/trim (if out (string out) ""))))) - [code (if (empty? lines) "" (last lines)) (if err (string err) "")]) - -(var pass 0) -(def fails @[]) -(each [label expr expected] cases - (def [code got err] (run-capture expr)) - (cond - (not= code 0) (array/push fails [label (string "exit " code "; err: " (string/trim err))]) - (= got expected) (++ pass) - (array/push fails [label (string "want `" expected "`, got `" got "`")]))) - -(printf "\n_seqpred parity [%s]: %d/%d passed" jolt-bin pass (length cases)) -(when (> (length fails) 0) - (printf "%d FAIL(s):" (length fails)) - (each [l m] fails (printf " FAIL [%s] %s" l m))) -(flush) -(os/exit (if (empty? fails) 0 1)) diff --git a/test/chez/_stdlib.janet b/test/chez/_stdlib.janet deleted file mode 100644 index ca8f183..0000000 --- a/test/chez/_stdlib.janet +++ /dev/null @@ -1,77 +0,0 @@ -# jolt-j5vg / jolt-22vo / clojure.pprint — Phase-2 stdlib parity closeout. -# -# clojure.set — pure Clojure (src/jolt/clojure/set.clj) added to the Chez -# prelude tier (driver.janet stdlib-ns-files). -# clojure.math — native flonum-math shims (host/chez/math.ss) def-var!'d into -# the clojure.math ns; the analyzer already knows the ns exists -# (api.janet install-clojure-math!), so refs lower to var-deref. -# clojure.pprint — minimal shim on the prelude; pprint's 2-arity no longer uses -# (binding [*out* writer] ...) (uncompilable on the no-fallback -# Chez back end; *out* isn't a bindable var — output always goes -# through the host seam). -# -# Outputs are order-stable (value-equality / scalars) so set/map iteration order -# — which is host-dependent — never masquerades as a divergence. -# -# -# janet test/chez/_stdlib.janet -(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/joltc")) - -(def cases - [# --- clojure.math (jolt-22vo / jolt-h79) --- - ["(< 1.4142 (clojure.math/sqrt 2) 1.4143)" "true"] - ["(long (clojure.math/pow 2 10))" "1024"] - ["(long (clojure.math/tan 0))" "0"] - ["(clojure.math/round 2.6)" "3"] - ["(clojure.math/floor 2.9)" "2"] - ["(clojure.math/signum -7.2)" "-1"] - ["(< 3.14 (clojure.math/to-radians 180) 3.15)" "true"] - ["(< 3.14 clojure.math/PI 3.15)" "true"] - ["(< 2.71 clojure.math/E 2.72)" "true"] - ["(long (clojure.math/cbrt 27))" "3"] - ["(< 4.6 (clojure.math/log 100) 4.7)" "true"] - # Chez has no native log10 (computed as log(x)/log(10)), so it can differ from - # C log10 in the last ulp (3 vs 2.9999…); range-check, don't pin. - ["(< 2.99 (clojure.math/log10 1000) 3.01)" "true"] - ["(do (require (quote [clojure.math :as m])) (long (m/hypot 3 4)))" "5"] - ["(mapv (comp long clojure.math/sqrt) [1 4])" "[1 2]"] - ["(long (clojure.math/atan2 0 1))" "0"] - # --- clojure.set (jolt-j5vg) --- - ["(do (require (quote [clojure.set :as s])) (= #{1 2 3 4} (s/union #{1 2} #{3 4})))" "true"] - ["(do (require (quote [clojure.set :as s])) (= #{2} (s/intersection #{1 2} #{2 3})))" "true"] - ["(do (require (quote [clojure.set :as s])) (= #{1} (s/difference #{1 2} #{2 3})))" "true"] - ["(do (require (quote [clojure.set :as s])) (s/subset? #{1} #{1 2}))" "true"] - ["(do (require (quote [clojure.set :as s])) (s/superset? #{1 2} #{1}))" "true"] - ["(do (require (quote [clojure.set :as s])) (= {1 :a 2 :b} (s/map-invert {:a 1 :b 2})))" "true"] - ["(do (require (quote [clojure.set :as s])) (= #{:a} (s/select keyword? #{:a})))" "true"] - ["(do (require (quote [clojure.set :as s])) (= #{{:a 1 :b 2}} (s/join #{{:a 1}} #{{:b 2}})))" "true"] - ["(do (require (quote [clojure.set :as s])) (= {:b 1} (s/rename-keys {:a 1} {:a :b})))" "true"] - ["(do (require (quote [clojure.set :as s])) (= 2 (count (s/index #{{:k 1} {:k 2}} [:k]))))" "true"] - # --- clojure.pprint (minimal shim) --- - ["(do (require (quote [clojure.pprint :as pp])) (= \"[1 2 3]\\n\" (with-out-str (pp/pprint [1 2 3]))))" "true"] - ["(do (require (quote [clojure.pprint :as pp])) (pp/with-pprint-dispatch pp/code-dispatch 42))" "42"]]) - -(defn run-capture [bin expr] - (def proc (os/spawn [bin "-e" expr] :p {:out :pipe :err :pipe})) - (def out (ev/read (proc :out) 0x100000)) - (def err (ev/read (proc :err) 0x100000)) - (def code (os/proc-wait proc)) - (def lines (filter (fn [l] (not (empty? l))) - (string/split "\n" (string/trim (if out (string out) ""))))) - [code (if (empty? lines) "" (last lines)) (string/trim (if err (string err) ""))]) - -(var pass 0) -(def fails @[]) -(each [expr expected] cases - (def [code got err] (run-capture jolt-bin expr)) - (cond - (not= code 0) (array/push fails [expr (string "exit " code "; err: " err)]) - (= got expected) (++ pass) - (array/push fails [expr (string "want `" expected "`, got `" got "`")]))) - -(printf "\n_stdlib parity [%s]: %d/%d passed" jolt-bin pass (length cases)) -(when (> (length fails) 0) - (printf "%d FAIL(s):" (length fails)) - (each [e m] fails (printf " FAIL %s\n %s" e m))) -(flush) -(os/exit (if (empty? fails) 0 1)) diff --git a/test/chez/_str.janet b/test/chez/_str.janet deleted file mode 100644 index 7946c5b..0000000 --- a/test/chez/_str.janet +++ /dev/null @@ -1,65 +0,0 @@ -# jolt-nfca — host java.lang.String method interop on Chez: (.toUpperCase s), -# (.indexOf s x), (.substring s a b), the regex methods (.matches/.replaceAll/ -# .replaceFirst), etc. The string-methods surface. Each case carries its -# expected value. -# An expected of :throws asserts a non-zero exit (unsupported method). -# -# janet test/chez/_str.janet -(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/joltc")) - -(def cases - [["toLowerCase" "(.toLowerCase \"HI\")" "hi"] - ["toUpperCase" "(.toUpperCase \"hi\")" "HI"] - ["trim" "(.trim \" x \")" "x"] - ["length" "(.length \"abc\")" "3"] - ["isEmpty" "[(.isEmpty \"\") (.isEmpty \"a\")]" "[true false]"] - ["indexOf hit" "(.indexOf \"abc\" \"b\")" "1"] - ["indexOf miss" "(.indexOf \"abc\" \"z\")" "-1"] - ["indexOf from" "(.indexOf \"abab\" \"a\" 1)" "2"] - ["indexOf int code" "(.indexOf \"a=b\" 61)" "1"] - ["lastIndexOf" "(.lastIndexOf \"abab\" \"b\")" "3"] - ["substring 1" "(.substring \"abc\" 1)" "bc"] - ["substring 1 2" "(.substring \"abc\" 1 2)" "b"] - ["startsWith" "(.startsWith \"abc\" \"ab\")" "true"] - ["endsWith" "(.endsWith \"abc\" \"bc\")" "true"] - ["contains" "(.contains \"abc\" \"b\")" "true"] - ["replace literal" "(.replace \"abc\" \"b\" \"x\")" "axc"] - ["replace all occ" "(.replace \"aaa\" \"a\" \"b\")" "bbb"] - ["charAt" "(.charAt \"abc\" 1)" "\\b"] - ["equalsIgnoreCase" "(.equalsIgnoreCase \"AbC\" \"aBc\")" "true"] - ["toString" "(.toString \"hi\")" "hi"] - ["concat" "(.concat \"ab\" \"cd\")" "abcd"] - ["matches whole" "(.matches \"abc\" \"a.c\")" "true"] - ["matches partial" "(.matches \"abcd\" \"a.c\")" "false"] - ["replaceAll" "(.replaceAll \"a_b_c\" \"_\" \"-\")" "a-b-c"] - ["replaceFirst" "(.replaceFirst \"a_b_c\" \"_\" \"-\")" "a-b_c"] - ["split regex" "(vec (.split \"a,b,c\" \",\"))" "[a b c]"] - ["unsupported" "(.frobnicate \"abc\")" :throws]]) - -(defn run-capture [expr] - (def proc (os/spawn [jolt-bin "-e" expr] :p {:out :pipe :err :pipe})) - (def out (ev/read (proc :out) 0x100000)) - (def err (ev/read (proc :err) 0x100000)) - (def code (os/proc-wait proc)) - (def lines (filter (fn [l] (not (empty? l))) - (string/split "\n" (string/trim (if out (string out) ""))))) - [code (if (empty? lines) "" (last lines)) (if err (string err) "")]) - -(var pass 0) -(def fails @[]) -(each [label expr expected] cases - (def [code got err] (run-capture expr)) - (cond - (= expected :throws) - (if (not= code 0) (++ pass) - (array/push fails [label (string "want throw, got `" got "` (exit 0)")])) - (not= code 0) (array/push fails [label (string "exit " code "; err: " (string/trim err))]) - (= got expected) (++ pass) - (array/push fails [label (string "want `" expected "`, got `" got "`")]))) - -(printf "\n_str parity [%s]: %d/%d passed" jolt-bin pass (length cases)) -(when (> (length fails) 0) - (printf "%d FAIL(s):" (length fails)) - (each [l m] fails (printf " FAIL [%s] %s" l m))) -(flush) -(os/exit (if (empty? fails) 0 1)) \ No newline at end of file diff --git a/test/chez/_strns.janet b/test/chez/_strns.janet deleted file mode 100644 index 64aa5b5..0000000 --- a/test/chez/_strns.janet +++ /dev/null @@ -1,66 +0,0 @@ -# jolt-nfca (clojure.string half) — the clojure.string namespace on Chez via the -# alias `s` established by a runtime (require '[clojure.string :as s]). The Chez -# AOT driver pre-evals require forms against the ctx so the alias resolves at -# analyze time, and clojure.string is emitted as a prelude tier over the str-* -# primitives. Each case carries its expected value. -# -# janet test/chez/_strns.janet -(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/joltc")) - -(defn- with-req [body] (string "(do (require (quote [clojure.string :as s])) " body ")")) - -# [label body-after-require expected] -(def cases - [["upper-case" "(s/upper-case \"abc\")" "ABC"] - ["lower-case" "(s/lower-case \"ABC\")" "abc"] - ["capitalize" "(s/capitalize \"hello\")" "Hello"] - ["trim" "(s/trim \" x \")" "x"] - ["triml" "(= \"x \" (s/triml \" x \"))" "true"] - ["trimr" "(= \" x\" (s/trimr \" x \"))" "true"] - ["blank? empty" "(s/blank? \"\")" "true"] - ["blank? ws" "(s/blank? \" \")" "true"] - ["blank? no" "(s/blank? \"x\")" "false"] - ["blank? nil" "(s/blank? nil)" "true"] - ["includes? y" "(s/includes? \"abcd\" \"bc\")" "true"] - ["includes? n" "(s/includes? \"abcd\" \"zz\")" "false"] - ["starts-with? y" "(s/starts-with? \"abc\" \"ab\")" "true"] - ["starts-with? n" "(s/starts-with? \"abc\" \"bc\")" "false"] - ["ends-with? y" "(s/ends-with? \"abc\" \"bc\")" "true"] - ["join no sep" "(s/join [\"a\" \"b\" \"c\"])" "abc"] - ["join sep" "(s/join \",\" [\"a\" \"b\" \"c\"])" "a,b,c"] - ["join nums" "(s/join \"-\" [1 2 3])" "1-2-3"] - ["split literal" "(s/split \"a,b,c\" \",\")" "[a b c]"] - ["split regex" "(s/split \"a1b2c\" #\"[0-9]\")" "[a b c]"] - ["split-lines" "(s/split-lines \"a\\nb\\nc\")" "[a b c]"] - ["replace lit" "(s/replace \"a_b_c\" \"_\" \"-\")" "a-b-c"] - ["replace regex" "(s/replace \"a1b2\" #\"[0-9]\" \"\")" "ab"] - ["replace-first" "(s/replace-first \"a_b_c\" \"_\" \"-\")" "a-b_c"] - ["reverse" "(s/reverse \"abc\")" "cba"] - ["index-of hit" "(s/index-of \"abc\" \"b\")" "1"] - ["index-of miss" "(nil? (s/index-of \"abc\" \"z\"))" "true"] - ["trim-newline" "(s/trim-newline \"abc\\n\\n\")" "abc"]]) - -(defn run-capture [expr] - (def proc (os/spawn [jolt-bin "-e" expr] :p {:out :pipe :err :pipe})) - (def out (ev/read (proc :out) 0x100000)) - (def err (ev/read (proc :err) 0x100000)) - (def code (os/proc-wait proc)) - (def lines (filter (fn [l] (not (empty? l))) - (string/split "\n" (string/trim (if out (string out) ""))))) - [code (if (empty? lines) "" (last lines)) (if err (string err) "")]) - -(var pass 0) -(def fails @[]) -(each [label body expected] cases - (def [code got err] (run-capture (with-req body))) - (cond - (not= code 0) (array/push fails [label (string "exit " code "; err: " (string/trim err))]) - (= got expected) (++ pass) - (array/push fails [label (string "want `" expected "`, got `" got "`")]))) - -(printf "\n_strns parity [%s]: %d/%d passed" jolt-bin pass (length cases)) -(when (> (length fails) 0) - (printf "%d FAIL(s):" (length fails)) - (each [l m] fails (printf " FAIL [%s] %s" l m))) -(flush) -(os/exit (if (empty? fails) 0 1)) \ No newline at end of file diff --git a/test/chez/_type.janet b/test/chez/_type.janet deleted file mode 100644 index ecdcba4..0000000 --- a/test/chez/_type.janet +++ /dev/null @@ -1,81 +0,0 @@ -# jolt-fmm4 — (type x) on Chez: :type meta override, record class-name symbol, -# and a comprehensive value->taxonomy mapping (no value type crashes -> must be -# total, the recorded gotcha). Each case carries its expected value. -# (type (range 3)) is :seq (range is lazy); range-container divergences are -# covered elsewhere. -# -# janet test/chez/_type.janet -(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/joltc")) - -(def cases - [# --- scalars --- - ["int" "(type 5)" ":number"] - ["float" "(type 5.0)" ":number"] - ["ratio-ish" "(type (/ 10 2))" ":number"] - ["string" "(type \"s\")" ":string"] - ["keyword" "(type :k)" ":keyword"] - ["symbol" "(type 'x)" ":symbol"] - ["true" "(type true)" ":boolean"] - ["false" "(type false)" ":boolean"] - ["nil" "(type nil)" ""] - ["char" "(type \\a)" ":char"] - - # --- collections --- - ["vector" "(type [1 2])" ":vector"] - ["empty vector" "(type [])" ":vector"] - ["map" "(type {:a 1})" ":map"] - ["set" "(type #{1})" ":set"] - ["list" "(type '(1 2))" ":seq"] - ["empty list" "(type '())" ":seq"] - ["map entry" "(type (first {:a 1}))" ":vector"] - ["lazy map" "(type (map inc [1 2]))" ":seq"] - ["lazy filter" "(type (filter odd? [1 2 3]))" ":seq"] - ["lazy-seq" "(type (lazy-seq (cons 1 nil)))" ":seq"] - ["take iterate" "(type (take 2 (iterate inc 0)))" ":seq"] - ["fn" "(type inc)" ":fn"] - ["sorted-map" "(type (sorted-map :a 1))" ":map"] - ["sorted-set" "(type (sorted-set 1))" ":jolt/sorted-set"] - - # --- :type meta override (the headline jolt-fmm4 case) --- - ["meta override" "(type (with-meta [1] {:type :custom}))" ":custom"] - ["meta override map" "(type (with-meta {:a 1} {:type :rec}))" ":rec"] - ["meta no :type" "(type (with-meta [1] {:other 9}))" ":vector"] - - # --- record -> ns-qualified class-name symbol --- - ["record symbol" "(do (defrecord TyR [a]) (type (->TyR 1)))" "user.TyR"] - ["record roundtrip" "(do (defrecord TyR [a]) (= (symbol (str (type (->TyR 1)))) (type (->TyR 1))))" "true"] - ["record is symbol" "(do (defrecord TyR [a]) (symbol? (type (->TyR 1))))" "true"] - - # --- exotic host wrappers (seed :jolt/* tags; total, never crash) --- - ["atom" "(type (atom 1))" ":jolt/atom"] - ["volatile" "(type (volatile! 1))" ":jolt/volatile"] - ["regex" "(type #\"re\")" ":jolt/regex"] - ["var" "(do (def vx 1) (type (var vx)))" ":jolt/var"] - ["transient" "(type (transient []))" ":jolt/transient"] - ["uuid" "(type (random-uuid))" ":jolt/uuid"] - ["ex-info" "(type (ex-info \"x\" {}))" ":jolt/ex-info"]]) - -(defn run-capture [expr] - (def proc (os/spawn [jolt-bin "-e" expr] :p {:out :pipe :err :pipe})) - (def out (ev/read (proc :out) 0x100000)) - (def err (ev/read (proc :err) 0x100000)) - (def code (os/proc-wait proc)) - (def lines (filter (fn [l] (not (empty? l))) - (string/split "\n" (string/trim (if out (string out) ""))))) - [code (if (empty? lines) "" (last lines)) (if err (string err) "")]) - -(var pass 0) -(def fails @[]) -(each [label expr expected] cases - (def [code got err] (run-capture expr)) - (cond - (not= code 0) (array/push fails [label (string "exit " code "; err: " (string/trim err))]) - (= got expected) (++ pass) - (array/push fails [label (string "want `" expected "`, got `" got "`")]))) - -(printf "\n_type parity [%s]: %d/%d passed" jolt-bin pass (length cases)) -(when (> (length fails) 0) - (printf "%d FAIL(s):" (length fails)) - (each [l m] fails (printf " FAIL [%s] %s" l m))) -(flush) -(os/exit (if (empty? fails) 0 1)) diff --git a/test/chez/_var_meta.janet b/test/chez/_var_meta.janet deleted file mode 100644 index 733fa67..0000000 --- a/test/chez/_var_meta.janet +++ /dev/null @@ -1,45 +0,0 @@ -# jolt-zikh — var def-time metadata capture (^:private / ^Type tag / docstring). -# (meta (var v)) must carry the def-time reader metadata + :ns/:name, matching the -# JVM-canonical reference. TDD harness: bin/joltc -e per case, last line == -# expected. -# -# janet test/chez/_var_meta.janet -(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/joltc")) - -(def cases - # NOTE: ^{:map} metadata on a def name (e.g. (def ^{:doc "hi"} dv 1)) reads as - # (def (with-meta name m) v) and is uncompilable for the COMPILER generally - # (analyzer.clj rejects it) — out of subset, not a meta-capture gap. Shorthand - # ^:kw / ^Type - # and the docstring form keep the name a plain symbol, so they're in scope. - [["^:private on var" "(do (def ^:private pv 1) (:private (meta (var pv))))" "true"] - ["^Type tag on var" "(do (def ^String tv \"a\") (:tag (meta (var tv))))" "String"] - ["(def name doc val)" "(do (def dv2 \"hi\" 1) (:doc (meta (var dv2))))" "hi"] - ["meta carries :name" "(do (def mv 1) (:name (meta (var mv))))" "mv"] - ["meta carries :ns" "(do (def nv 1) (:ns (meta (var nv))))" "user"] - ["plain def: no user meta" "(do (def pl 1) (nil? (:private (meta (var pl)))))" "true"]]) - -(defn run-capture [expr] - (def proc (os/spawn [jolt-bin "-e" expr] :p {:out :pipe :err :pipe})) - (def out (ev/read (proc :out) 0x100000)) - (def err (ev/read (proc :err) 0x100000)) - (def code (os/proc-wait proc)) - (def lines (filter (fn [l] (not (empty? l))) - (string/split "\n" (string/trim (if out (string out) ""))))) - [code (if (empty? lines) "" (last lines)) (if err (string err) "")]) - -(var pass 0) -(def fails @[]) -(each [label expr expected] cases - (def [code got err] (run-capture expr)) - (cond - (not= code 0) (array/push fails [label (string "exit " code "; err: " (string/trim err))]) - (= got expected) (++ pass) - (array/push fails [label (string "want `" expected "`, got `" got "`")]))) - -(printf "\n_var_meta parity [%s]: %d/%d passed" jolt-bin pass (length cases)) -(when (> (length fails) 0) - (printf "%d FAIL(s):" (length fails)) - (each [l m] fails (printf " FAIL [%s] %s" l m))) -(flush) -(os/exit (if (empty? fails) 0 1)) diff --git a/test/chez/_walk.janet b/test/chez/_walk.janet deleted file mode 100644 index 858617a..0000000 --- a/test/chez/_walk.janet +++ /dev/null @@ -1,77 +0,0 @@ -# jolt-75sv — list? (a list marker on cseq, since cseq backs both lists and -# realized/lazy seqs) + map-entry-as-vector + clojure.walk. -# -# janet test/chez/_walk.janet -(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/joltc")) - -# -e reads only the FIRST form — wrap require + use in a single (do ...). -(defn w [body] (string "(do (require (quote [clojure.walk :as w])) " body ")")) - -(def cases - [# --- list? : true for lists, cons/reverse/conj-on-list; false for seqs --- - ["(list? (list 1 2))" "true"] - ["(list? (list 1))" "true"] - ["(list? '(1 2))" "true"] - ["(list? '())" "true"] - ["(list? (list))" "true"] - ["(list? (cons 1 nil))" "true"] - ["(list? (cons 1 [2]))" "true"] - ["(list? (cons 1 '(2)))" "true"] - ["(list? (conj (list 1) 0))" "true"] - ["(list? (conj '() 1))" "true"] - ["(list? (reverse [1 2]))" "true"] - ["(list? (reverse '(1 2)))" "true"] - ["(list? [1 2])" "false"] - ["(list? {:a 1})" "false"] - ["(list? (map inc [1 2]))" "false"] - ["(list? (filter odd? [1 2 3]))" "false"] - ["(list? (seq [1 2]))" "false"] - ["(list? (rest (list 1 2)))" "false"] - ["(list? (next (list 1 2)))" "false"] - ["(list? (take 2 (list 1 2 3)))" "false"] - ["(list? (concat '(1) '(2)))" "false"] - ["(list? (rest [1 2]))" "false"] - ["(list? 5)" "false"] - ["(list? nil)" "false"] - # --- map-entry IS a vector (Clojure MapEntry; seed agrees) --- - ["(vector? (first {:a 1}))" "true"] - ["(vector? (first (seq {:a 1})))" "true"] - ["(map-entry? (first {:a 1}))" "true"] - ["(= (first {:a 1}) [:a 1])" "true"] - ["(vector? [1 2])" "true"] - ["(vector? (rest [1 2 3]))" "false"] - # --- clojure.walk --- - [(w "(w/postwalk (fn [x] (if (number? x) (inc x) x)) {:a 1})") "{:a 2}"] - [(w "(w/keywordize-keys {\"a\" 1})") "{:a 1}"] - [(w "(= {\"a\" 1} (w/stringify-keys {:a 1}))") "true"] - [(w "(w/postwalk-replace {'x 2} '(+ x x))") "(+ 2 2)"] - [(w "(w/postwalk (fn [n] (if (symbol? n) :a n)) '(x y))") "(:a :a)"] - [(w "(w/prewalk-replace {'* '* 'y 3} '(* y y))") "(* 3 3)"] - [(w "(w/postwalk-replace {:a 1 :b 2} '(:a [:b :a]))") "(1 [2 1])"] - [(w "(w/postwalk-replace {1 :one} [1 2 1])") "[:one 2 :one]"] - ["(do (require (quote [clojure.template :as t])) (t/apply-template '[x y] '(+ x y) '(1 2)))" "(+ 1 2)"]]) - -(defn run-capture [bin expr] - (def proc (os/spawn [bin "-e" expr] :p {:out :pipe :err :pipe})) - (def out (ev/read (proc :out) 0x100000)) - (def err (ev/read (proc :err) 0x100000)) - (def code (os/proc-wait proc)) - (def lines (filter (fn [l] (not (empty? l))) - (string/split "\n" (string/trim (if out (string out) ""))))) - [code (if (empty? lines) "" (last lines)) (string/trim (if err (string err) ""))]) - -(var pass 0) -(def fails @[]) -(each [expr expected] cases - (def [code got err] (run-capture jolt-bin expr)) - (cond - (not= code 0) (array/push fails [expr (string "exit " code "; err: " err)]) - (= got expected) (++ pass) - (array/push fails [expr (string "want `" expected "`, got `" got "`")]))) - -(printf "\n_walk parity [%s]: %d/%d passed" jolt-bin pass (length cases)) -(when (> (length fails) 0) - (printf "%d FAIL(s):" (length fails)) - (each [e m] fails (printf " FAIL %s\n %s" e m))) -(flush) -(os/exit (if (empty? fails) 0 1)) diff --git a/test/chez/bench-pipeline.janet b/test/chez/bench-pipeline.janet deleted file mode 100644 index 9f5dac2..0000000 --- a/test/chez/bench-pipeline.janet +++ /dev/null @@ -1,102 +0,0 @@ -# Phase 1 (jolt-cf1q.2) close-out bench — the compute benches run END TO END -# through the REAL pipeline (Clojure source -> Janet-hosted analyzer -> IR -> -# Scheme emitter -> Chez compile -> run), timed in-process (Chez startup -# excluded), and reported against the spike ceiling (spike/chez/RESULTS.md). -# -# This is the Phase 1 gate evidence: (1) compile-only is TOTAL for the compute -# subset — every form emits, no interpreter fallback (Chez has none); (2) the -# emitted code runs at ~the substrate ceiling, with the residual gap being -# exactly the typed fl*/fx* emission that Phase 4 owns. -# -# JOLT_CHEZ_BENCH=1 janet test/chez/bench-pipeline.janet -# Opt-in (like core-bench); skipped in the normal gate. -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/reader :as r) -(import ../../host/chez/driver :as d) -(import ../../host/chez/emit :as emit) - -(unless (os/getenv "JOLT_CHEZ_BENCH") - (print "skip: set JOLT_CHEZ_BENCH=1 to run the Chez pipeline bench") - (os/exit 0)) -(unless (d/chez-available?) - (print "skip: chez not on PATH") - (os/exit 0)) - -(def ctx (d/make-ctx)) - -# Emit a top-level program (one or more defns) through the real pipeline. Returns -# the concatenated Scheme for every form — each form must emit (compile-only is -# total) or this throws, which is itself the totality check. -(defn emit-program [src] - (def forms (map first (r/parse-all-positioned src))) - (string/join (map (fn [f] (emit/emit (backend/analyze-form ctx f))) forms) "\n")) - -(def fib-src "(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))") - -# mandelbrot kernel: loop/recur + let + or-expansion + cross-var call, all flonum. -(def mandel-src `` -(defn count-point [cr ci cap] - (loop [i 0 zr 0.0 zi 0.0] - (if (or (>= i cap) (> (+ (* zr zr) (* zi zi)) 4.0)) - i - (recur (inc i) - (+ (- (* zr zr) (* zi zi)) cr) - (+ (* 2.0 (* zr zi)) ci))))) -(defn run [n] - (let [cap 200 nd (* 1.0 n)] - (loop [y 0 acc 0] - (if (>= y n) acc - (let [ci (- (* 2.0 (/ (* 1.0 y) nd)) 1.0) - row (loop [x 0 a 0] - (if (>= x n) a - (let [cr (- (* 3.5 (/ (* 1.0 x) nd)) 2.5)] - (recur (inc x) (+ a (count-point cr ci cap))))))] - (recur (inc y) (+ acc row))))))) -``) - -(def fib-scm (emit-program fib-src)) -(def mandel-scm (emit-program mandel-src)) -(print "compile-only total: fib + mandelbrot emitted with no fallback") - -# One Chez program: load the RT, the emitted defns, a hand-written FLONUM fib -# reference (jolt's realistic ceiling given the all-double model), then time each -# end-to-end value (warm up first; exclude Chez startup via a monotonic clock). -(def prog - (string - "(import (chezscheme))\n(load \"host/chez/rt.ss\")\n" - fib-scm "\n" mandel-scm "\n" - "(define fib (var-deref \"user\" \"fib\"))\n" - "(define mrun (var-deref \"user\" \"run\"))\n" - # hand flonum fib — the substrate ceiling for jolt's number model - "(define (ffib n) (if (fl< n 2.0) n (fl+ (ffib (fl- n 1.0)) (ffib (fl- n 2.0)))))\n" - "(define (now-ns) (let ((t (current-time 'time-monotonic))) (+ (* (time-second t) 1000000000) (time-nanosecond t))))\n" - "(define (timed thunk) (let* ((t0 (now-ns)) (r (thunk)) (ms (/ (- (now-ns) t0) 1000000.0))) (cons r ms)))\n" - "(fib 24)(ffib 24.0)(mrun 30)\n" # warm up - "(let ((a (timed (lambda () (fib 30))))\n" - " (b (timed (lambda () (ffib 30.0))))\n" - " (c (timed (lambda () (mrun 200)))))\n" - " (printf \"~a ~a ~a ~a ~a ~a\\n\"\n" - " (jolt-pr-str (car a)) (exact->inexact (cdr a))\n" - " (jolt-pr-str (car b)) (exact->inexact (cdr b))\n" - " (jolt-pr-str (car c)) (exact->inexact (cdr c))))")) - -(def path (string "/tmp/chez-bench-pipeline-" (os/getpid) ".ss")) -(spit path prog) -(def proc (os/spawn ["chez" "--script" path] :p {:out :pipe :err :pipe})) -(def out (string/trim (string (ev/read (proc :out) 0x100000)))) -(def err (string/trim (string (or (ev/read (proc :err) 0x100000) "")))) -(def code (os/proc-wait proc)) -(unless (= code 0) (printf "BENCH FAILED (code %d): %s" code err) (os/exit 1)) - -(def p (string/split " " out)) -(defn num [i] (scan-number (get p i "0"))) -(printf "\nReal-pipeline compute benches (Chez startup excluded):\n") -(printf " fib 30 (jolt, flonum) = %s in %6.2f ms" (get p 0) (num 1)) -(printf " fib 30 (hand flonum ceiling) = %6.2f ms <- jolt's number-model ceiling" (num 3)) -(printf " fib 30 (spike fixnum ceiling)= 5.20 ms <- Phase 4 fl/fx typed-emit target") -(printf " mandelbrot 200 (jolt) = %s in %6.2f ms" (get p 4) (num 5)) -(printf " mandelbrot 200 (spike generic)= 98.10 ms <- generic-flonum ceiling") -(printf " mandelbrot 200 (spike typed) = 13.40 ms <- Phase 4 fl/fx typed-emit target") -(def fib-overhead (if (> (num 3) 0) (/ (num 1) (num 3)) 0)) -(printf "\n jolt fib is %.2fx the hand-flonum ceiling (residual = truthy/dispatch; typed-emit closes the fixnum gap)." fib-overhead) -(os/exit 0) diff --git a/test/chez/bootstrap-test.janet b/test/chez/bootstrap-test.janet deleted file mode 100644 index 24ad754..0000000 --- a/test/chez/bootstrap-test.janet +++ /dev/null @@ -1,72 +0,0 @@ -# Chez Phase 3 inc9a (jolt-9phg) — the pure-Chez self-build (no Janet in the loop). -# -# inc8 proved the on-Chez compiler reproduces itself. inc9a makes that the actual -# build: host/chez/bootstrap.ss loads the CHECKED-IN seed (host/chez/seed/{prelude, -# image}.ss — the bootstrap compiler, minted once via the fixpoint) and rebuilds the -# clojure.core prelude + compiler image FROM SOURCE on Chez. No Janet is invoked in -# the compile path — this test only spawns `chez`; the read->analyze->emit is 100% -# Chez. So a fresh checkout + Chez (no Janet) yields a working jolt. -# -# The seed is a JOINT byte-fixpoint, so rebuilding from an up-to-date seed -# reproduces it exactly. If the seed SOURCES change (core tiers, the compiler, the -# host contract, the reader, emit-image.ss) the rebuilt artifacts will differ and -# this test fails — re-mint the seed with driver/mint-chez-seed* (see the failure -# message) and commit the refreshed seed. -# -# janet test/chez/bootstrap-test.janet -(import ../../host/chez/driver :as d) - -(var total 0) (var fails 0) -(defn ok [name pred &opt extra] - (++ total) - (if pred (printf "ok: %s" name) - (do (++ fails) (printf "FAIL: %s %s" name (or extra ""))))) - -(unless (d/chez-available?) - (print "chez not on PATH — skipping bootstrap-test") - (os/exit 0)) - -(def seed-prelude "host/chez/seed/prelude.ss") -(def seed-image "host/chez/seed/image.ss") -(ok "checked-in seed prelude exists" (os/stat seed-prelude)) -(ok "checked-in seed image exists" (os/stat seed-image)) - -(when (and (os/stat seed-prelude) (os/stat seed-image)) - (def tmp (or (os/getenv "TMPDIR") "/tmp")) - (def out-prelude (string tmp "/jolt-bootstrap-pre-" (os/getpid) ".ss")) - (def out-image (string tmp "/jolt-bootstrap-img-" (os/getpid) ".ss")) - (def t0 (os/clock)) - # PURE CHEZ: spawn `chez --script bootstrap.ss` — no Janet in the compile path. - (def [code out err] (d/run-bootstrap seed-prelude seed-image out-prelude out-image)) - (printf "pure-Chez bootstrap pass: %.1fs" (- (os/clock) t0)) - (ok "bootstrap.ss runs cleanly on Chez (no Janet)" (= code 0) - (string "exit " code " " (string/slice err 0 (min 300 (length err))))) - - (defn- bytes= [a b] (and (os/stat a) (os/stat b) - (= (string (slurp a)) (string (slurp b))))) - (def remint "re-mint with driver/mint-chez-seed* and commit host/chez/seed/") - (when (= code 0) - (ok "rebuilt prelude == checked-in seed (joint fixpoint)" (bytes= out-prelude seed-prelude) - (string "seed is stale — " remint)) - (ok "rebuilt image == checked-in seed (joint fixpoint)" (bytes= out-image seed-image) - (string "seed is stale — " remint)) - - # The rebuilt artifacts must be a WORKING compiler. - (def cases - [["(let [x 1 y 2] (+ x y))" "3"] - ["(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (fib 10)" "55"] - ["(->> (range 10) (filter even?) (map #(* % %)) (reduce +))" "120"] - ["(let [{:keys [a b] :or {b 9}} {:a 1}] [a b])" "[1 9]"] - ["(require '[clojure.string :as s]) (s/join \",\" [1 2 3])" "1,2,3"] - ["(loop [i 0 acc 0] (if (< i 5) (recur (inc i) (+ acc i)) acc))" "10"]]) - (var pass 0) - (each [src want] cases - (def [c o _] (d/eval-zero-janet out-prelude out-image (string "(do " src ")"))) - (when (and (= c 0) (= o want)) (++ pass))) - (ok "Chez-built artifacts compile+run real cases" (= pass (length cases)) - (string pass "/" (length cases) " cases passed"))) - - (each p [out-prelude out-image] (when (os/stat p) (os/rm p)))) - -(printf "\nbootstrap-test: %d/%d checks passed" (- total fails) total) -(os/exit (if (zero? fails) 0 1)) diff --git a/test/chez/cli-test.janet b/test/chez/cli-test.janet deleted file mode 100644 index cd2f5e7..0000000 --- a/test/chez/cli-test.janet +++ /dev/null @@ -1,96 +0,0 @@ -# Chez Phase 3 inc9b (jolt-9phg) — the pure-Chez runtime CLI (no Janet). -# -# bin/joltc execs `chez --script host/chez/cli.ss`, which loads the checked-in -# bootstrap seed (host/chez/seed/) + the zero-Janet spine and compiles+evals a -# Clojure -e expression entirely on Chez. This test drives bin/joltc and checks -# results: with only Chez installed, jolt runs end to end — no Janet at build or -# run time. (This harness is Janet only to spawn the process; the compile+eval is -# 100% Chez.) -# -# janet test/chez/cli-test.janet -(import ../../host/chez/driver :as d) - -(var total 0) (var fails 0) -(defn ok [name pred &opt extra] - (++ total) - (if pred (printf "ok: %s" name) - (do (++ fails) (printf "FAIL: %s %s" name (or extra ""))))) - -(unless (d/chez-available?) - (print "chez not on PATH — skipping cli-test") - (os/exit 0)) - -(defn- joltc [expr] - (def proc (os/spawn ["bin/joltc" "-e" expr] :p {:out :pipe :err :pipe})) - (def out (string/trim (string (:read (proc :out) :all)))) - (def err (string/trim (string (or (:read (proc :err) :all) "")))) - (def code (os/proc-wait proc)) - [code out err]) - -(def cases - [["(+ 1 2)" "3"] - ["(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (fib 15)" "610"] - ["(->> (range 10) (filter even?) (map #(* % %)) (reduce +))" "120"] - ["(let [{:keys [a b] :or {b 99}} {:a 1}] [a b])" "[1 99]"] - ["(require '[clojure.string :as s]) (s/upper-case \"hello\")" "HELLO"] - ["(case 3 1 :a 2 :b :other)" ":other"] - ["(reduce + (vals (reduce (fn [m k] (assoc m k (* k k))) {} [1 2 3])))" "14"] - ["(map inc [1 2 3])" "(2 3 4)"] - ["nil" ""] - # jolt-r8ku: runtime eval / load-string / defmacro on the Chez spine. - ["(eval (quote (+ 1 2)))" "3"] - ["(eval (list (quote +) 1 2 3))" "6"] - ["(eval (quote (let [a 2 b 3] (* a b))))" "6"] - ["(load-string \"(+ 1 2)\")" "3"] - ["(load-string \"(def y 5) (* y y)\")" "25"] - ["(load-string \"\")" ""] - ["(map eval [(quote (+ 1 1)) (quote (* 3 3))])" "(2 9)"] - ["(defmacro add1 [x] (list (quote +) x 1)) (add1 10)" "11"] - ["(defmacro twice [x] `(do ~x ~x)) (twice (+ 2 3))" "5"] - ["(defmacro m [x] `(+ ~x 1)) (m (m (m 0)))" "3"] - # jolt-byjr: concurrency — futures/pmap/promise on real OS threads (shared heap). - ["(deref (future (+ 1 2)))" "3"] - ["@(future (* 6 7))" "42"] - ["(deref (future (mapv inc [1 2 3])))" "[2 3 4]"] - ["(let [f (future (+ 1 1))] [(deref f) (deref f)])" "[2 2]"] - ["(future? (future 1))" "true"] - ["(future? 42)" "false"] - ["(let [f (future 1)] (deref f) (future-done? f))" "true"] - ["(let [f (future 1)] (deref f) (realized? f))" "true"] - ["(let [f (future 42)] (deref f) (deref f 1000 :nope))" "42"] - ["(vec (pmap inc [1 2 3]))" "[2 3 4]"] - ["(vec (pmap + [1 2 3] [4 5 6]))" "[5 7 9]"] - ["(vec (pcalls (fn [] 1) (fn [] 2)))" "[1 2]"] - ["(vec (pvalues (+ 1 2) (+ 3 4)))" "[3 7]"] - # shared heap = JVM semantics (NOT Janet's isolated-heap snapshot): a captured - # atom is shared, so the future's swap! is visible to the parent. - ["(let [a (atom 0)] (deref (future (swap! a inc))) @a)" "1"] - ["(let [a (atom 0)] (dorun (pmap (fn [_] (swap! a inc)) [1 2 3 4])) @a)" "4"] - # promise blocks until delivered (JVM), unlike the Janet atom-shim. - ["(let [p (promise)] (deliver p 7) @p)" "7"] - ["(let [p (promise)] (future (deliver p :hi)) @p)" ":hi"] - # jolt-byjr: clojure.core.async on real-thread blocking channels. - ["(require (quote [clojure.core.async :refer [chan go ! ! c (+ 40 2))) (! ! c 1) (>! c 2) (>! c 3) (close! c)) (! ! x 10)) (go (>! y 32)) (! ! y :v)) (! ! c 1) (>! c 2) (>! c 3) (close! c)) (! (length src) 48) (string (string/slice src 0 48) "...") src)) - (and (= code 0) (= out want)) - (string "[" code "] got " (string/format "%j" out) " want " (string/format "%j" want) - (if (= "" err) "" (string " err: " (string/slice err 0 (min 120 (length err)))))))) - -(printf "\ncli-test: %d/%d checks passed" (- total fails) total) -(os/exit (if (zero? fails) 0 1)) diff --git a/test/chez/core-prelude-probe.janet b/test/chez/core-prelude-probe.janet deleted file mode 100644 index f1ad0c5..0000000 --- a/test/chez/core-prelude-probe.janet +++ /dev/null @@ -1,104 +0,0 @@ -# Phase 1 (jolt-cf1q.2, inc 3d) — clojure.core prelude emission probe. -# -# The path to an `-e`-capable jolt-chez: emit the clojure.core tiers -# (jolt-core/clojure/core/NN-*.clj) through the SAME live Janet analyzer -> -# host/chez/emit pipeline, as a Scheme PRELUDE of `def-var!` forms. User code's -# `(var-deref "clojure.core" "")` then resolves the fn at runtime. -# -# Most core fns are NOT native-ops, so they must be emitted; the ones that -# reference host interop / native Janet ops / unimplemented primitives can't be -# emitted yet (each a clean "out of subset" emit error). This probe reports how -# far the emit gets per tier and aggregates the gap list — the punch-list the -# next increments chase down. Measurement tool, gated out of the default suite. -# JOLT_CHEZ_PRELUDE=1 janet test/chez/core-prelude-probe.janet -(import ../../src/jolt/api :as api) -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/reader :as r) -(import ../../src/jolt/types_ctx :as tctx) -(import ../../host/chez/emit :as emit) - -(unless (os/getenv "JOLT_CHEZ_PRELUDE") - (print "skip: set JOLT_CHEZ_PRELUDE=1 to run the core-prelude emission probe") - (os/exit 0)) - -# load order — same as api/core-tiers (the kernel tier is bootstrap-compiled in -# the live system; here we just measure emit reach, so treat it like the rest). -(def tier-files - ["00-syntax" "00-kernel" "10-seq" "20-coll" "25-sorted" "30-macros" "40-lazy" "50-io"]) - -(defn- parse-all [src] - (def out @[]) - (var s src) - (while (> (length (string/trim s)) 0) - (def parsed (r/parse-next s)) - (set s (in parsed 1)) - (def f (in parsed 0)) - (unless (nil? f) (array/push out f))) - out) - -# jolt reader forms are arrays of jolt VALUES; a symbol is a struct -# {:jolt/type :symbol :name "..."} (jolt symbols aren't Janet symbols). -(defn- sym-name [x] - (when (and (struct? x) (= :symbol (get x :jolt/type))) (get x :name))) - -# A short label for a top-level form: the defn/def name, or the form head. -(defn- form-label [f] - (if (and (indexed? f) (> (length f) 1)) - (let [head (or (sym-name (in f 0)) "?") nm (sym-name (in f 1))] - (if nm (string head " " nm) head)) - (string/slice (string/format "%p" f) 0 40))) - -# Pull the unsupported fn/op name out of an emit error message for aggregation. -(defn- gap-key [msg] - (def m (string msg)) - (cond - (string/find "stdlib fn" m) (let [i (string/find "`" m)] (string "stdlib: " (string/slice m (inc i) (string/find "`" m (inc i))))) - (string/find "stdlib ref" m) (let [i (string/find "`" m)] (string "stdlib: " (string/slice m (inc i) (string/find "`" m (inc i))))) - (string/find "host call" m) "host-call" - (string/find "host ref" m) "host-ref" - (string/find "unhandled op" m) (string/slice m (max 0 (- (length m) 30))) - (string/find "unsupported literal" m) "unsupported-literal" - (string/slice m 0 (min 50 (length m))))) - -# Macros are analyze-time only (the Janet analyzer expands them away before emit), -# so they don't belong in a RUNTIME prelude — skip them, don't count as gaps. -(defn- macro-form? [f] - (and (indexed? f) (> (length f) 0) - (let [h (sym-name (in f 0))] (and h (or (= h "defmacro") (= h "definline")))))) - -(emit/set-prelude-mode! true) -(def ctx (api/init {:compile? true})) -(tctx/ctx-set-current-ns ctx "clojure.core") - -(var total 0) (var compiled 0) -(def gaps @{}) # gap-key -> count -(def gap-examples @{}) # gap-key -> first form label that hit it - -(each tf tier-files - (def src (slurp (string "jolt-core/clojure/core/" tf ".clj"))) - (def forms (parse-all src)) - (var t-total 0) (var t-ok 0) - (each f forms - (unless (macro-form? f) - (++ total) (++ t-total) - (def res (protect (emit/emit (backend/analyze-form ctx f)))) - (if (res 0) - (do (++ compiled) (++ t-ok)) - (let [k (gap-key (res 1))] - (put gaps k (+ 1 (or (get gaps k) 0))) - (unless (get gap-examples k) (put gap-examples k (form-label f))))))) - (printf " %-10s %3d/%-3d forms emit" tf t-ok t-total)) - -(printf "\nCore prelude emit reach: %d/%d top-level forms compile to Scheme" compiled total) -(printf "%d distinct gaps (fn/op the emit back end can't lower yet):" (length gaps)) -(def sorted-gaps (sort-by (fn [k] (- (get gaps k))) (keys gaps))) -(each k sorted-gaps - (printf " %4d x %-34s e.g. %s" (get gaps k) k (get gap-examples k))) -(flush) - -# Regression floor (raise it as new IR ops / RT shims land, like the suite -# baseline). Fails if prelude emit reach drops below the recorded baseline. -(def reach-floor 355) -(when (< compiled reach-floor) - (printf "REGRESSION: prelude emit reach %d < floor %d" compiled reach-floor) - (os/exit 1)) diff --git a/test/chez/corpus.edn b/test/chez/corpus.edn index aee491a..fe2b7f9 100644 --- a/test/chez/corpus.edn +++ b/test/chez/corpus.edn @@ -596,7 +596,7 @@ {:suite "host-interop / java.io.File" :label "getName" :expected "\"c.txt\"" :actual "(do (require '[clojure.java.io :as io]) (.getName (io/file \"/a/b/c.txt\")))"} {:suite "host-interop / java.io.File" :label "getPath joins" :expected "\"/a/b\"" :actual "(do (require '[clojure.java.io :as io]) (.getPath (io/file \"/a\" \"b\")))"} {:suite "host-interop / java.io.File" :label "isDirectory of repo dir" :expected "true" :actual "(do (require '[clojure.java.io :as io]) (.isDirectory (io/file \"docs\")))"} - {:suite "host-interop / java.io.File" :label "isFile of repo file" :expected "true" :actual "(do (require '[clojure.java.io :as io]) (.isFile (io/file \"project.janet\")))"} + {:suite "host-interop / java.io.File" :label "isFile of repo file" :expected "true" :actual "(do (require '[clojure.java.io :as io]) (.isFile (io/file \"README.md\")))"} {:suite "host-interop / java.io.File" :label "exists is false off-disk" :expected "false" :actual "(do (require '[clojure.java.io :as io]) (.exists (io/file \"/no/such/path/xyz\")))"} {:suite "host-interop / java.io.File" :label "file-seq yields File values" :expected "true" :actual "(do (require '[clojure.java.io :as io]) (every? (fn [f] (instance? java.io.File f)) (file-seq (io/file \"docs\"))))"} {:suite "host-interop / java.io.File" :label "file-seq finds files" :expected "true" :actual "(do (require '[clojure.java.io :as io]) (pos? (count (filter (fn [f] (.isFile f)) (file-seq (io/file \"docs\"))))))"} @@ -2137,14 +2137,14 @@ {:suite "sorted / seq fn interop" :label "vec of sorted-set" :expected "[1 2 3]" :actual "(vec (sorted-set 3 1 2))"} {:suite "sorted / seq fn interop" :label "into vec" :expected "[[1 :a] [2 :b]]" :actual "(into [] (sorted-map 2 :b 1 :a))"} {:suite "sorted / seq fn interop" :label "sorted-map-by 3way cmp" :expected "[3 2 1]" :actual "(vec (keys (sorted-map-by (fn [a b] (- b a)) 1 :a 2 :b 3 :c)))"} - {:suite "io / slurp, spit, printf, flush (host-classified)" :label "slurp returns string" :expected "true" :actual "(string? (slurp \"project.janet\"))"} - {:suite "io / slurp, spit, printf, flush (host-classified)" :label "slurp content" :expected "true" :actual "(do (require (quote [clojure.string :as s])) (s/includes? (slurp \"project.janet\") \"jolt\"))"} + {:suite "io / slurp, spit, printf, flush (host-classified)" :label "slurp returns string" :expected "true" :actual "(string? (slurp \"README.md\"))"} + {:suite "io / slurp, spit, printf, flush (host-classified)" :label "slurp content" :expected "true" :actual "(do (require (quote [clojure.string :as s])) (s/includes? (slurp \"README.md\") \"jolt\"))"} {:suite "io / slurp, spit, printf, flush (host-classified)" :label "spit + slurp round" :expected "\"hello\"" :actual "(do (spit \"/tmp/jolt-spit-test.txt\" \"hello\") (slurp \"/tmp/jolt-spit-test.txt\"))"} {:suite "io / slurp, spit, printf, flush (host-classified)" :label "spit append" :expected "\"ab\"" :actual "(do (spit \"/tmp/jolt-spit-test.txt\" \"a\") (spit \"/tmp/jolt-spit-test.txt\" \"b\" :append true) (slurp \"/tmp/jolt-spit-test.txt\"))"} {:suite "io / slurp, spit, printf, flush (host-classified)" :label "printf formats" :expected "\"x=1 y=a\"" :actual "(with-out-str (printf \"x=%d y=%s\" 1 \"a\"))"} {:suite "io / slurp, spit, printf, flush (host-classified)" :label "printf no newline" :expected "false" :actual "(do (require (quote [clojure.string :as s])) (s/includes? (with-out-str (printf \"%d\" 1)) \"\\n\"))"} {:suite "io / slurp, spit, printf, flush (host-classified)" :label "flush returns nil" :expected "nil" :actual "(flush)"} - {:suite "io / slurp, spit, printf, flush (host-classified)" :label "file-seq finds files" :expected "true" :actual "(do (require (quote [clojure.string :as s])) (boolean (some (fn [p] (s/ends-with? p \"project.janet\")) (file-seq \".\"))))"} + {:suite "io / slurp, spit, printf, flush (host-classified)" :label "file-seq finds files" :expected "true" :actual "(do (require (quote [clojure.string :as s])) (boolean (some (fn [p] (s/ends-with? p \"README.md\")) (file-seq \".\"))))"} {:suite "ns / ns-map, ns-unmap, ns-refers" :label "ns-map has var" :expected "true" :actual "(do (def nmv 1) (some? (get (ns-map (quote user)) (quote nmv))))"} {:suite "ns / ns-map, ns-unmap, ns-refers" :label "ns-unmap removes" :expected "nil" :actual "(do (def nuv 1) (ns-unmap (quote user) (quote nuv)) (resolve (quote nuv)))"} {:suite "ns / ns-map, ns-unmap, ns-refers" :label "ns-refers sees refer" :expected "true" :actual "(do (require (quote clojure.string)) (refer (quote clojure.string)) (some? (get (ns-refers (quote user)) (quote join))))"} diff --git a/test/chez/extract-corpus.janet b/test/chez/extract-corpus.janet deleted file mode 100644 index 5f0465f..0000000 --- a/test/chez/extract-corpus.janet +++ /dev/null @@ -1,130 +0,0 @@ -# Extract the case LIST (suite, label, actual) from the spec sources into corpus.edn. -# -# corpus.edn :expected is sourced from reference JVM Clojure by -# test/conformance/regen-corpus.clj — this extractor's :expected column is a -# placeholder. Use it to (re)derive the case list when adding spec rows, then run -# regen-corpus.clj to fill :expected from the JVM. Do not commit its raw output. -# -# Parses every test/spec/*.janet as DATA (no eval), pulls each -# (defspec "suite" [label expected actual] ...) triple. Run from repo root: -# janet test/chez/extract-corpus.janet -(use ../../src/jolt/reader) # not needed for parse, but keeps paths obvious - -(defn parse-all [src] - (def p (parser/new)) - (parser/consume p src) - (parser/eof p) - (def out @[]) - (while (parser/has-more p) (array/push out (parser/produce p))) - out) - -(defn edn-str [s] - # escape a Clojure-source string into an EDN/Janet string literal - (def b @`"`) - (each c s - (cond - (= c (chr `"`)) (buffer/push b `\"`) - (= c (chr "\\")) (buffer/push b "\\\\") - (= c (chr "\n")) (buffer/push b "\\n") - (= c (chr "\t")) (buffer/push b "\\t") - (buffer/push-byte b c))) - (buffer/push b `"`) - (string b)) - -(defn triples-from [form] - # form is (defspec "suite" [l e a] ...) as a parsed tuple - (when (and (indexed? form) (> (length form) 0) (= (first form) 'defspec)) - (def suite (in form 1)) - (def rows @[]) - (each case (slice form 2) - (when (and (indexed? case) (>= (length case) 3)) - (def label (in case 0)) - (def expected (in case 1)) - (def actual (in case 2)) - # expected is either a Clojure-source string or the :throws keyword; - # actual is always a Clojure-source string. Skip non-literal rows. - (when (and (string? label) (string? actual) - (or (string? expected) (keyword? expected))) - (array/push rows {:suite suite :label label - :expected expected :actual actual}))) - ) - rows)) - -(def spec-dir "test/spec") -(def all @[]) -(each f (sort (os/dir spec-dir)) - (when (string/has-suffix? "-spec.janet" f) - (def path (string spec-dir "/" f)) - (each form (parse-all (slurp path)) - (when-let [rows (triples-from form)] - (array/concat all rows))))) - -# --- fold in the inline conformance cases (jolt-ohtd) ------------------------- -# test/integration/conformance-test.janet carries ~355 hand-written cases as a -# (def cases [["label" "expected" "actual"] ...]) vector — historically invisible to -# the corpus because extract only reads test/spec/. Pull them in too, deduped by -# :actual against the spec rows, so the host-neutral corpus is the union of both. -# Suites come from the file's `### ---- section ----` headers via a line scan (the -# parser drops comments, so section structure is recovered from raw text). -(def conf-path "test/integration/conformance-test.janet") - -(defn- section-map [src] - # label-string -> section-name, by scanning raw lines: track the most recent - # `### ---- NAME ----` / `### ==== NAME ====` header above each `["label" ...]`. - (def out @{}) - (var section "misc") - (each line (string/split "\n" src) - (def tl (string/trim line)) - (cond - (string/has-prefix? "###" tl) - (let [body (string/trim (string/trim (string/trim tl "#") " ") "-= ")] - (when (> (length body) 0) (set section body))) - (string/has-prefix? "[\"" tl) - (let [close (string/find "\"" tl 2)] - (when close (put out (string/slice tl 2 close) section))))) - out) - -(def conf-src (slurp conf-path)) -(def sections (section-map conf-src)) -(def seen-actual (tabseq [r :in all] (r :actual) true)) -(var conf-added 0) -(each form (parse-all conf-src) - (when (and (indexed? form) (>= (length form) 3) - (= (first form) 'def) (= (in form 1) 'cases)) - (each c (in form 2) - (when (and (indexed? c) (= 3 (length c)) - (string? (in c 0)) (string? (in c 1)) (string? (in c 2))) - (def [label expected actual] [(in c 0) (in c 1) (in c 2)]) - (unless (seen-actual actual) - (put seen-actual actual true) - (++ conf-added) - (array/push all {:suite (string "conformance / " (get sections label "misc")) - :label label :expected expected :actual actual})))))) -(printf "folded %d unique conformance cases (deduped by :actual)" conf-added) - -# emit EDN-and-Janet-valid corpus. [suite label] is the canonical case id, so make -# it unique: a duplicate label within a suite gets " (N)" appended (jolt-3447 — the -# conformance fold can repeat a label, e.g. two "str/replace regex" rows). Rows are -# immutable structs, so disambiguate the label here at emit time. -(def label-seen @{}) -(def out @"[\n") -(each row all - (def k (string (row :suite) "\x00" (row :label))) - (def n (get label-seen k)) - (put label-seen k (if n (+ n 1) 1)) - (def label (if n (string (row :label) " (" (+ n 1) ")") (row :label))) - (buffer/push out - (string " {:suite " (edn-str (row :suite)) - " :label " (edn-str label) - " :expected " (if (keyword? (row :expected)) ":throws" (edn-str (row :expected))) - " :actual " (edn-str (row :actual)) "}\n"))) -(buffer/push out "]\n") -# corpus.edn is JVM-sourced (regen-corpus.clj); writing the Janet-extracted answers -# here would clobber it. Only write the case list to a separate path when explicitly -# asked (then re-source :expected with regen-corpus.clj). The test runner imports -# this file but never sets the flag, so it has no side effect. -(def out-path (os/getenv "JOLT_EXTRACT_CORPUS_OUT")) -(if out-path - (do (spit out-path out) - (printf "extracted %d cases from %s into %s" (length all) spec-dir out-path)) - (print "extract-corpus: set JOLT_EXTRACT_CORPUS_OUT= to write the case list (corpus.edn is JVM-sourced via regen-corpus.clj)")) diff --git a/test/chez/fixpoint-test.janet b/test/chez/fixpoint-test.janet deleted file mode 100644 index 74a501a..0000000 --- a/test/chez/fixpoint-test.janet +++ /dev/null @@ -1,126 +0,0 @@ -# Chez Phase 3 inc8 (jolt-bzni) — the self-hosting bootstrap fixpoint. -# -# The zero-Janet spine (spine-test / run-corpus-zero-janet) proves the ON-CHEZ -# analyzer+emitter compile arbitrary Clojure faithfully. This proves the stronger -# property from self-hosting-bootstrap-research §4: the emitted system reproduces -# ITSELF. Two artifacts are re-emitted ON CHEZ by the loaded compiler: -# -# COMPILER IMAGE (jolt.ir + jolt.analyzer + jolt.backend-scheme) -# stage1 = Janet analyzer/emitter cross-compiles the sources (the bootstrap input) -# stage2 = the on-Chez compiler (from stage1) re-emits them -# stage3 = the on-Chez compiler (from stage2) re-emits them -# FIXPOINT: stage2 == stage3 (stage1 differs only in gensym numbering — the -# Janet build allocates more gensyms before reaching the compiler emit). -# -# CORE PRELUDE (clojure.core tiers + clojure.string/walk/template/edn/set/pprint) -# pstage2 = on-Chez compiler re-emits the prelude with the JANET prelude loaded -# pstage3 = ... with pstage2 loaded -# pstage4 = ... with pstage3 loaded -# FIXPOINT: pstage3 == pstage4. The prelude converges one stage later than the -# compiler because its MACRO expanders bake an auto-gensym id (foo#) at emit -# time, so a macro emitted by Janet (pstage2's loaded prelude) carries a -# different baked id than one emitted by Chez — only once BOTH stages load a -# Chez-emitted prelude (pstage3 onward) does it stabilize. -# -# Finally we load the FULLY Chez-emitted system (Chez prelude + Chez compiler -# image, NO Janet-emitted artifact in the loop) and run real cases, proving the -# fixpoint is a working compiler, not a degenerate stable one. -# -# janet test/chez/fixpoint-test.janet -(import ../../host/chez/driver :as d) -(import ../../host/chez/jolt-chez :as jc) - -(var total 0) (var fails 0) -(defn ok [name pred &opt extra] - (++ total) - (if pred (printf "ok: %s" name) - (do (++ fails) (printf "FAIL: %s %s" name (or extra ""))))) - -(unless (d/chez-available?) - (print "chez not on PATH — skipping fixpoint-test") - (os/exit 0)) - -(def ctx (d/make-ctx)) -(def jprelude (jc/ensure-prelude ctx)) - -# stage1: the Janet cross-compiled compiler image, cached by source fingerprint -# (same scheme as spine-test / run-corpus-zero-janet). -(defn- image-fingerprint [] - (string/slice (string (hash (string/join - (map slurp ["jolt-core/jolt/ir.clj" "jolt-core/jolt/analyzer.clj" - "jolt-core/jolt/backend_scheme.clj" "host/chez/host-contract.ss" - "host/chez/compile-eval.ss"])))) 0)) -(def tmp (or (os/getenv "TMPDIR") "/tmp")) -(def stage1 (string tmp "/jolt-compiler-image-" (image-fingerprint) ".ss")) -(d/ensure-compiler-image ctx stage1) -(printf "stage1 compiler image (Janet cross-compile): %d bytes" (length (slurp stage1))) -(flush) - -(defn- bytes= [a b] (= (string (slurp a)) (string (slurp b)))) -(defn- first-diff [a b] - (def s (string (slurp a))) (def t (string (slurp b))) - (def n (min (length s) (length t))) - (var i 0) (while (and (< i n) (= (s i) (t i))) (++ i)) - (string "sizes " (length s) " vs " (length t) ", first diff at " i)) - -# ---- compiler-image fixpoint: stage2 == stage3 ------------------------------- -(def s2 (string tmp "/jolt-fixpoint-img2-" (os/getpid) ".ss")) -(def s3 (string tmp "/jolt-fixpoint-img3-" (os/getpid) ".ss")) -(def [c2 e2] (d/emit-image-on-chez jprelude stage1 s2)) -(ok "compiler image stage2 emits cleanly on Chez" (and (= c2 0) (os/stat s2)) - (string "exit " c2 " " (string/slice e2 0 (min 300 (length e2))))) -(def [c3 e3] (d/emit-image-on-chez jprelude s2 s3)) -(ok "compiler image stage3 emits cleanly on Chez" (and (= c3 0) (os/stat s3)) - (string "exit " c3 " " (string/slice e3 0 (min 300 (length e3))))) -(when (and (os/stat s2) (os/stat s3)) - (ok "compiler image: stage2 == stage3 (byte-for-byte fixpoint)" (bytes= s2 s3) - (first-diff s2 s3)) - (ok "compiler image is substantial (> 80KB)" (> (length (slurp s2)) 80000))) - -# ---- prelude fixpoint: pstage3 == pstage4 ------------------------------------ -(def p2 (string tmp "/jolt-fixpoint-prelude2-" (os/getpid) ".ss")) -(def p3 (string tmp "/jolt-fixpoint-prelude3-" (os/getpid) ".ss")) -(def p4 (string tmp "/jolt-fixpoint-prelude4-" (os/getpid) ".ss")) -(def [pc2 pe2] (d/emit-image-on-chez jprelude stage1 p2 "jolt-emit-prelude")) -(ok "prelude pstage2 emits cleanly on Chez (from Janet prelude)" (and (= pc2 0) (os/stat p2)) - (string "exit " pc2 " " (string/slice pe2 0 (min 300 (length pe2))))) -(when (os/stat p2) - (def [pc3 pe3] (d/emit-image-on-chez p2 stage1 p3 "jolt-emit-prelude")) - (ok "prelude pstage3 emits cleanly on Chez (from pstage2)" (and (= pc3 0) (os/stat p3)) - (string "exit " pc3 " " (string/slice pe3 0 (min 300 (length pe3))))) - (when (os/stat p3) - (def [pc4 pe4] (d/emit-image-on-chez p3 stage1 p4 "jolt-emit-prelude")) - (ok "prelude pstage4 emits cleanly on Chez (from pstage3)" (and (= pc4 0) (os/stat p4)) - (string "exit " pc4 " " (string/slice pe4 0 (min 300 (length pe4))))) - (when (os/stat p4) - (ok "prelude: pstage3 == pstage4 (byte-for-byte fixpoint)" (bytes= p3 p4) - (first-diff p3 p4)) - (ok "prelude is substantial (> 250KB)" (> (length (slurp p3)) 250000))))) - -# ---- the fully Chez-emitted system is a working compiler ---------------------- -# Chez-emitted prelude (pstage3) + Chez-emitted compiler image (s2): no Janet -# artifact in the loop. Drive real compile+eval through it. -(def verify-cases - [["(let [x 1 y 2] (+ x y))" "3"] - ["(when (> 5 3) (-> 10 (- 1) (* 2)))" "18"] - ["(defn f [a b] (* a b)) (f 6 7)" "42"] - ["(map inc [1 2 3])" "(2 3 4)"] - ["(reduce + 0 (range 5))" "10"] - ["(let [{:keys [a b]} {:a 7 :b 8}] (+ a b))" "15"] - ["(filter even? (range 10))" "(0 2 4 6 8)"] - ["(require '[clojure.string :as s]) (s/upper-case \"hi\")" "HI"] - ["(cond (= 1 2) :a (= 1 1) :b :else :c)" ":b"]]) -(when (and (os/stat p3) (os/stat s2)) - (var vpass 0) - (each [src want] verify-cases - (def [code out _] (d/eval-zero-janet p3 s2 (string "(do " src ")"))) - (when (and (= code 0) (= out want)) (++ vpass))) - (ok "fully Chez-emitted system (Chez prelude + Chez image) compiles+runs real cases" - (= vpass (length verify-cases)) - (string vpass "/" (length verify-cases) " cases passed"))) - -# cleanup temp stages -(each p [s2 s3 p2 p3 p4] (when (os/stat p) (os/rm p))) - -(printf "\nfixpoint-test: %d/%d checks passed" (- total fails) total) -(os/exit (if (zero? fails) 0 1)) diff --git a/test/chez/nil-names-probe.janet b/test/chez/nil-names-probe.janet deleted file mode 100644 index 118fd70..0000000 --- a/test/chez/nil-names-probe.janet +++ /dev/null @@ -1,63 +0,0 @@ -# Phase 2 (jolt-cf1q.3) — which clojure.core names resolve to jolt-nil on Chez? -# -# The parity gate buckets a missing native generically as "apply non-procedure -# jolt-nil" — it doesn't NAME the fn. This probe does: it assembles the prelude, -# enumerates every clojure.core var name, then runs ONE Chez program that -# var-derefs each name (after loading prelude + post-prelude) and prints the ones -# that are still nil. That list is the shim punch-list for the next increment. -# JOLT_CHEZ_NIL_PROBE=1 janet test/chez/nil-names-probe.janet -(import ../../host/chez/driver :as d) -(import ../../src/jolt/types_ctx :as tctx) - -(unless (os/getenv "JOLT_CHEZ_NIL_PROBE") - (print "skip: set JOLT_CHEZ_NIL_PROBE=1 to run the nil-names probe") - (os/exit 0)) -(unless (d/chez-available?) - (print "skip: chez not on PATH") - (os/exit 0)) - -(def ctx (d/make-ctx)) - -# Collect every clojure.core var name (mapping keys are symbol structs). -(def names @{}) -(each ns (tctx/all-ns ctx) - (when (= (get ns :name) "clojure.core") - (eachk sym (get ns :mappings) - (def n (cond (struct? sym) (get sym :name) - (string? sym) sym - (symbol? sym) (string sym) - nil)) - (when n (put names n true))))) -(def name-list (sort (keys names))) -(printf "clojure.core has %d interned names" (length name-list)) - -# Assemble the prelude once. -(def [prelude-scm emitted total] (d/emit-core-prelude ctx)) -(def prelude-path (string "/tmp/jolt-nil-probe-prelude-" (os/getpid) ".ss")) -(spit prelude-path prelude-scm) -(printf "prelude: %d/%d non-macro core forms emitted" emitted total) - -# Build a Chez program that derefs each name and prints the nil ones. -(def buf @"") -(buffer/push buf "(import (chezscheme))\n(load \"host/chez/rt.ss\")\n") -(buffer/push buf "(set-chez-ns! \"clojure.core\")\n") -(buffer/push buf (string "(load " (string/format "%j" prelude-path) ")\n")) -(buffer/push buf "(load \"host/chez/post-prelude.ss\")\n") -(buffer/push buf "(set-chez-ns! \"user\")\n") -(each n name-list - (buffer/push buf - (string "(when (jolt-nil? (var-deref \"clojure.core\" " (string/format "%j" n) - ")) (display " (string/format "%j" n) ") (newline))\n"))) -(def prog-path (string "/tmp/jolt-nil-probe-" (os/getpid) ".ss")) -(spit prog-path buf) - -(def proc (os/spawn ["chez" "--script" prog-path] :p {:out :pipe :err :pipe})) -(def out (ev/read (proc :out) 0x100000)) -(def err (ev/read (proc :err) 0x100000)) -(def code (os/proc-wait proc)) -(def nils (filter (fn [s] (> (length s) 0)) (string/split "\n" (string/trim (if out (string out) ""))))) -(printf "\n%d clojure.core names resolve to jolt-nil on Chez:" (length nils)) -(each n (sort nils) (print " " n)) -(when (and err (> (length (string/trim (string err))) 0)) - (printf "\nstderr:\n%s" (string err))) -(printf "\n(probe exit %d)" code) diff --git a/test/chez/run-corpus-zero-janet.janet b/test/chez/run-corpus-zero-janet.janet deleted file mode 100644 index e7fc6ea..0000000 --- a/test/chez/run-corpus-zero-janet.janet +++ /dev/null @@ -1,212 +0,0 @@ -# Phase 3 inc7 (jolt-qjr0) — FULL corpus on the ZERO-JANET spine. -# -# run-corpus-prelude.janet measures RUNTIME parity: it analyzes each case with the -# JANET-hosted analyzer (the oracle) and runs the emitted Scheme on Chez. This -# runner closes the last gap: it analyzes each case with the CHEZ-HOSTED analyzer -# (jolt.analyzer cross-compiled to Scheme, run on Chez over host-contract.ss) — -# read -> analyze -> IR -> emit -> eval, NO Janet in the loop (eval-zero-janet). -# -# So this is the real test of self-hosting: where run-corpus-prelude proves the -# RUNTIME is faithful, this proves the COMPILER-on-Chez is faithful. A case that -# the Janet analyzer compiles but the Chez analyzer can't surfaces here as a crash -# (analyzer/emitter raised) or a divergence (ran, wrong value). The buckets form -# the inc7 punch-list; genuinely host-coupled cases (Java interop, runtime eval) -# are deferred to Phase 4 / jolt-r8ku and allowlisted, like the prelude gate. -# -# JOLT_CHEZ_ZEROJANET_CORPUS=1 janet test/chez/run-corpus-zero-janet.janet -# JOLT_CORPUS_LIMIT=200 … (every-Nth stride, fast iteration) -(import ../../host/chez/driver :as d) -(import ../../host/chez/jolt-chez :as jc) - -(unless (os/getenv "JOLT_CHEZ_ZEROJANET_CORPUS") - (print "skip: set JOLT_CHEZ_ZEROJANET_CORPUS=1 to run the zero-Janet corpus gate") - (os/exit 0)) -(unless (d/chez-available?) - (print "skip: chez not on PATH") - (os/exit 0)) - -(def ctx (d/make-ctx)) -(def prelude-path (jc/ensure-prelude ctx)) - -# Compiler image (jolt.ir + jolt.analyzer + jolt.backend-scheme cross-compiled to -# Scheme), cached by the same source fingerprint the spine-test uses. -(defn- image-fingerprint [] - (string/slice (string (hash (string/join - (map slurp ["jolt-core/jolt/ir.clj" "jolt-core/jolt/analyzer.clj" - "jolt-core/jolt/backend_scheme.clj" "host/chez/host-contract.ss" - "host/chez/compile-eval.ss"])))) 0)) -(def image-path - (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-compiler-image-" (image-fingerprint) ".ss")) -(def t0 (os/clock)) -(d/ensure-compiler-image ctx image-path) -(printf "prelude + compiler image ready (%.1fs)" (- (os/clock) t0)) -(flush) - -(def corpus (parse (slurp "test/chez/corpus.edn"))) -(def cases - (if-let [n (os/getenv "JOLT_CORPUS_LIMIT")] - (let [stride (max 1 (math/floor (/ (length corpus) (scan-number n))))] - (seq [i :range [0 (length corpus) stride]] (in corpus i))) - corpus)) - -# Known divergences/crashes: cases the Chez-hosted compiler can't yet handle that -# are tracked elsewhere (NOT analyzer-faithfulness bugs). Tolerated so the gate -# fails only on a NEW regression. Keyed by label. -# - host interop (Java classes / constructors / .method on host types): Phase 4 -# jolt-cf1q.7. Same family the prelude gate buckets as crashes. -# - eval / load-string / read->eval: the jolt-r8ku tail (runtime compiler entry). -(def known-fail - # Conformance gaps vs the JVM spec: cases jolt does not match because it has no - # JVM host (no Class objects / Java arrays / BigDecimal), supports the :jolt - # reader-conditional feature, or prints its own forms for transients/atoms. - @{# --- host classes: a class token resolves to a name string, not a Class ------ - "class name evaluates to canonical string" true - "class number" true "class string" true "class keyword" true - "definterface defines" true - "getMessage on a thrown string" true - "type of record" true "chunked-seq? always false" true - "^Type tag on var" true "symbol hint -> :tag" true - "lists extended type" true "seq of tags" true - "close on throw" true # duck-typed with-open close, no .close interop - "macroexpand-1" true # returns a value, not the JVM Cons form - "ns-imports empty user" true - "bean is the map" true "proxy resolves nil" true - "unchecked-char" true - # --- *in* is a map on Chez, not a JVM Reader -------------------------------- - "*in* is bound" true "*in* bound" true - # --- no BigDecimal type ----------------------------------------------------- - "bigdec" true "bigdec int M" true "bigdec suffix M" true - # --- printer: jolt renders its own forms (transient/atom/Infinity, no - # print-method multimethod integration) where the JVM prints #object ------ - "transient vector" true "transient map" true - "atom override fires nested" true "inf inside coll" true "pr-str Infinity" true - "defmethod overrides a record, top level" true - "defmethod fires nested in a map" true "defmethod fires through prn" true - "direct builtin override" true "methods table inspectable" true - # --- reader: :jolt reader-conditional feature + syntax-quote literal collapse - - "reader conditional" true "reader cond :jolt" true "reader cond no match" true - "reader cond splice" true "reader cond splice no match" true - "nil nested" true "bool nested" true - "source order through syntax-quote" true # syntax-quote map: hash, not source, order - # --- Java arrays are distinct host objects, not seqs -------------------------- - "make-array" true "into-array" true "to-array" true "aclone vec" true - "boolean-array" true "int-array" true "long-array" true "double-array" true - "float-array" true "short-array" true "doubles" true "floats" true - "reader over char[]" true - # --- atom class identity not mapped on Chez --------------------------------- - "atom?" true "instance? Atom" true - # --- future-cancel races completion (timing-dependent) ----------------------- - "cancel an in-flight future returns true" true - "future-cancelled? after cancel" true - # --- (fn* foo) with no param vector throws; the JVM builds a fn object -------- - "no param vector" true}) - -# Cases that BLOCK forever on a shared-heap / JVM host (profile.edn :bucket -# :timeout) — skip them, like :throws: a single hung case would stall the whole -# batched process. (deref of an undelivered promise blocks on the JVM and now on -# Chez; Janet's non-blocking atom-shim returned nil.) -(def skip-blocking @{"promise undelivered" true}) - -(var pass 0) -(def crashes @[]) # nonzero chez exit (analyzer/emitter raised, or runtime gap) -(def diverged @[]) # ran, wrong value (a real Chez-compiler divergence) -(def known-hit @[]) -(def crash-keys @{}) -(defn- bucket [tbl k] (put tbl k (+ 1 (or (get tbl k) 0)))) - -# Group a chez stderr message into a coarse reason for the punch-list. -(defn- crash-reason [m] - (def m (string/trim m)) - (cond - (string/find "unsupported stdlib" m) "emit: unsupported stdlib fn" - (string/find "unsupported host" m) "emit: unsupported host call" - (string/find "host-static" m) "emit: host-static" - (string/find "syntax-quote" m) "form-syntax-quote-lower" - (string/find "uncompil" m) "analyzer: uncompilable" - (string/find "Unknown class" m) "runtime: unknown class" - (string/find "No constructor" m) "runtime: no constructor" - (string/find "No method" m) "runtime: no method" - (string/find "not a fn" m) "runtime: not a fn" - (string/find "not seqable" m) "runtime: not seqable" - (string/find "not a transient" m) "runtime: not a transient" - (string/find "integer->char" m) "runtime: integer->char" - (string/find "non-condition value" m) - (let [i (string/find "non-condition value" m)] - (string "raised: " (string/slice m (+ i 20) (min (length m) (+ i 60))))) - (string/slice m 0 (min 56 (length m))))) - -(def t1 (os/clock)) -(var throws 0) - -# Build the evaluable case list (skip :throws), keyed by index (labels aren't -# unique across suites). Each pair carries EXPECTED + ACTUAL as SEPARATE source -# strings; the runner evaluates ACTUAL as its own top-level program (so its -# top-level `do` unrolls and a macro defined in the program is usable later — -# matching certify.clj's eval-isolated) and compares to EXPECTED with =. Wrapping -# in (= E A) would nest ACTUAL's do and break runtime defmacro (jolt-cf1q.7). -(def rows-by-idx @{}) -(def pairs @[]) -(eachp [i row] cases - (def {:expected e :actual a :label l} row) - (if (or (= e :throws) (get skip-blocking l)) - (++ throws) - (let [key (string i)] - (put rows-by-idx key row) - (array/push pairs [key e a])))) - -(defn- handle [key verdict] - (def row (get rows-by-idx key)) - (def l (get row :label)) - (case (first verdict) - :pass (++ pass) - :crash (let [k (crash-reason (get verdict 1))] (bucket crash-keys k) (array/push crashes [l k])) - :diverge (if (known-fail l) (array/push known-hit l) - (array/push diverged [l (string "got " (get verdict 1))])))) - -(if (os/getenv "JOLT_ZJ_PERCASE") - # slow per-case path (each case its own chez process) — for isolating a hang/crash. - # Eval ACTUAL and EXPECTED top-level (separate processes), compare printed forms. - (each [key e a] pairs - (def [acode aout aerr] (d/eval-zero-janet prelude-path image-path a)) - (def [_ eout _] (d/eval-zero-janet prelude-path image-path e)) - (handle key (cond (not= acode 0) [:crash aerr] (= aout eout) [:pass] [:diverge aout]))) - # fast batched path: one chez process loads the runtime once, runs all cases - (let [{:results r :code c :stderr se :count n} (d/eval-corpus-zero-janet prelude-path image-path pairs)] - (when (< n (length pairs)) - (printf "WARNING: batched runner returned %d/%d results (chez exit %d): %s" - n (length pairs) c (string/slice se 0 (min 200 (length se))))) - (each [key _] pairs - (handle key (or (get r key) [:crash (string "no result (batch aborted) " se)]))))) - -(def n-eval (+ pass (length crashes) (length diverged) (length known-hit))) -(printf "\nZero-Janet corpus parity: %d/%d evaluated cases pass (%.1fs)" pass n-eval (- (os/clock) t1)) -(printf " crash: %d NEW divergence: %d known: %d (throws skipped: %d)" - (length crashes) (length diverged) (length known-hit) throws) - -(defn- report [title tbl] - (when (> (length tbl) 0) - (printf "\n%s:" title) - (each k (sort-by (fn [k] (- (get tbl k))) (keys tbl)) - (printf " %4d x %s" (get tbl k) k)))) -(report "crash reasons" crash-keys) -(when (os/getenv "JOLT_DUMP_CRASH_LABELS") - (printf "\nCRASH LABELS:") - (each [l k] (sort-by (fn [pair] (get pair 1)) crashes) - (printf " [%s] :: %s" k l)) - (printf "\nKNOWN-HIT LABELS:") - (each l (sort known-hit) (printf " %s" l))) -(when (> (length diverged) 0) - (printf "\nNEW divergences (ran, wrong value) — gate FAILS:") - (each [l m] (slice diverged 0 (min 40 (length diverged))) - (printf " [%s] %s" l m))) -(when (> (length known-hit) 0) - (printf "\n%d known (allowlisted) failures tolerated." (length known-hit))) -(flush) - -# Regression floor: cases that pass against the JVM corpus. The gate fails on any -# NEW divergence or if pass drops below the floor. Raise as host gaps close. -(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_ZJ_FLOOR") "2678"))) -(def floor (if (os/getenv "JOLT_CORPUS_LIMIT") 0 base-floor)) -(when (or (> (length diverged) 0) (< pass floor)) - (printf "REGRESSION: pass %d < floor %d or %d new divergence(s)" pass floor (length diverged))) -(os/exit (if (or (> (length diverged) 0) (< pass floor)) 1 0)) diff --git a/test/chez/spine-test.janet b/test/chez/spine-test.janet deleted file mode 100644 index a08b3ec..0000000 --- a/test/chez/spine-test.janet +++ /dev/null @@ -1,97 +0,0 @@ -# Chez Phase 3 inc6 (jolt-hs9n) — the zero-Janet spine. -# -# Validates that the analyzer + emitter, cross-compiled to Scheme and run ON CHEZ -# over the host contract (host-contract.ss), compile and run macro-free Clojure -# from source with NO Janet in the loop: read (reader.ss) -> analyze (jolt.analyzer -# on Chez) -> IR -> emit (jolt.backend-scheme on Chez) -> eval. -# -# Oracle = the Janet-hosted analyzer through the SAME Chez emitter/RT/printer -# (d/eval-e-with-prelude): the only difference under test is WHERE analysis runs -# (Janet vs Chez), so equal stdout means moving analysis onto Chez is behavior- -# preserving. Macros (let/when/->/defn) are inc6b (jolt-r8ku, runtime macros). -# -# janet test/chez/spine-test.janet -(import ../../src/jolt/api :as api) -(import ../../host/chez/driver :as d) -(import ../../host/chez/jolt-chez :as jc) - -(var total 0) (var fails 0) -(defn ok [name pred &opt extra] - (++ total) - (if pred (printf "ok: %s" name) - (do (++ fails) (printf "FAIL: %s %s" name (or extra ""))))) - -(unless (d/chez-available?) - (print "chez not on PATH — skipping spine-test") - (os/exit 0)) - -(def ctx (d/make-ctx)) -(def prelude-path (jc/ensure-prelude ctx)) - -# compiler image cache, keyed by the cross-compiled sources + the host contract. -(defn- image-fingerprint [] - (string/slice (string (hash (string/join - (map slurp ["jolt-core/jolt/ir.clj" "jolt-core/jolt/analyzer.clj" - "jolt-core/jolt/backend_scheme.clj" "host/chez/host-contract.ss" - "host/chez/compile-eval.ss"])))) 0)) -(def image-path - (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-compiler-image-" (image-fingerprint) ".ss")) -(d/ensure-compiler-image ctx image-path) - -# Each case: the Chez-hosted spine value must equal the Janet-hosted oracle value -# (both printed via jolt-final-str on Chez). -(defn check [src] - (def [ocode oout oerr] (d/eval-e-with-prelude ctx src prelude-path)) - (def [acode aout aerr] (d/eval-zero-janet prelude-path image-path src)) - (cond - (= ocode :emit-err) (ok src false (string "oracle emit-err: " oout)) - (not (zero? acode)) (ok src false (string "zero-janet exit " acode ": " aerr " | out=" aout)) - (ok src (= oout aout) (string "chez=" aout " oracle=" oout)))) - -# macro-free forms: handled specials (if/do/fn*), native ops, consts, invoke. -(each src - ["(if true 10 20)" - "(if false 10 20)" - "(do 1 2 3)" - "(+ 1 2)" - "(- 10 3 2)" - "((fn* [x] (* x x)) 7)" - "((fn* [x] (+ x 1)) 5)" - "((fn* [a b] (+ a b)) 3 4)" - "(if (< 3 5) :yes :no)" - "(if (> 3 5) :yes :no)" - "((fn* [x] (if x :t :f)) true)" - "(do (if true 1 2) (* 6 7))" - "((fn* [n] (* n n n)) 4)" - "(< 1 2)" - "(= 5 5)"] - (check src)) - -# inc6b (jolt-r9lm): runtime macros — the on-Chez analyzer expands core macros -# (emitted into the prelude as expander fns + a macro flag). Same oracle: the -# Janet analyzer expands them at analyze time, the value must match. -(each src - ["(when true 1)" - "(when false 1)" - "(when true 1 2 3)" - "(when-not false 5)" - "(let [a 1] (+ a 2))" - "(let [a 1 b 2] (+ a b))" - "(let [a 1 b (+ a 1)] (* a b))" - "(-> 1 inc inc)" - "(-> 5 (- 2))" - "(->> 3 (- 10))" - "(and 1 2 3)" - "(and 1 false 3)" - "(or nil 5)" - "(or false nil 7)" - "(cond false 1 true 2)" - "(cond false 1 :else 3)" - "(if-not false :a :b)" - "(do (defn f [x] (* x x)) (f 6))" - "(do (defn g [x y] (+ x y 1)) (g 3 4))" - "(let [a 1] (when (< a 5) (-> a inc inc)))"] - (check src)) - -(printf "\n%d/%d ok" (- total fails) total) -(when (> fails 0) (os/exit 1)) diff --git a/test/chez/unit.edn b/test/chez/unit.edn index 8c386d5..6c8f03b 100644 --- a/test/chez/unit.edn +++ b/test/chez/unit.edn @@ -114,27 +114,27 @@ {:suite "io" :expr "(do (require (quote [clojure.java.io :as io])) (.getName (io/file \"/a/b/c.txt\")))" :expected "c.txt"} {:suite "io" :expr "(do (require (quote [clojure.java.io :as io])) (.getPath (io/file \"/a\" \"b\")))" :expected "/a/b"} {:suite "io" :expr "(do (require (quote [clojure.java.io :as io])) (.isDirectory (io/file \"docs\")))" :expected "true"} - {:suite "io" :expr "(do (require (quote [clojure.java.io :as io])) (.isFile (io/file \"project.janet\")))" :expected "true"} + {:suite "io" :expr "(do (require (quote [clojure.java.io :as io])) (.isFile (io/file \"README.md\")))" :expected "true"} {:suite "io" :expr "(do (require (quote [clojure.java.io :as io])) (.isFile (io/file \"docs\")))" :expected "false"} {:suite "io" :expr "(do (require (quote [clojure.java.io :as io])) (.exists (io/file \"/no/such/path/xyz\")))" :expected "false"} - {:suite "io" :expr "(do (require (quote [clojure.java.io :as io])) (.exists (io/file \"project.janet\")))" :expected "true"} + {:suite "io" :expr "(do (require (quote [clojure.java.io :as io])) (.exists (io/file \"README.md\")))" :expected "true"} {:suite "io" :expr "(do (require (quote [clojure.java.io :as io])) (instance? java.io.File (io/file \"/a/b\")))" :expected "true"} {:suite "io" :expr "(do (require (quote [clojure.java.io :as io])) (instance? java.io.File \"/a/b\"))" :expected "false"} {:suite "io" :expr "(do (require (quote [clojure.java.io :as io])) (str (type (io/file \"/a\"))))" :expected ":jolt/file"} {:suite "io" :expr "(do (require (quote [clojure.java.io :as io])) (every? (fn [f] (instance? java.io.File f)) (file-seq (io/file \"docs\"))))" :expected "true"} {:suite "io" :expr "(do (require (quote [clojure.java.io :as io])) (pos? (count (filter (fn [f] (.isFile f)) (file-seq (io/file \"docs\"))))))" :expected "true"} - {:suite "io" :expr "(do (require (quote [clojure.string :as s])) (boolean (some (fn [p] (s/ends-with? p \"project.janet\")) (file-seq \".\"))))" :expected "true"} - {:suite "io" :expr "(string? (slurp \"project.janet\"))" :expected "true"} + {:suite "io" :expr "(do (require (quote [clojure.string :as s])) (boolean (some (fn [p] (s/ends-with? p \"README.md\")) (file-seq \".\"))))" :expected "true"} + {:suite "io" :expr "(string? (slurp \"README.md\"))" :expected "true"} {:suite "io" :expr "(do (spit \"/tmp/jolt-io-test.txt\" \"hello\") (slurp \"/tmp/jolt-io-test.txt\"))" :expected "hello"} {:suite "io" :expr "(do (spit \"/tmp/jolt-io-test.txt\" \"a\") (spit \"/tmp/jolt-io-test.txt\" \"b\" :append true) (slurp \"/tmp/jolt-io-test.txt\"))" :expected "ab"} {:suite "io" :expr "(flush)" :expected ""} - {:suite "io" :expr "(do (require (quote [clojure.java.io :as io])) (string? (slurp (io/file \"project.janet\"))))" :expected "true"} + {:suite "io" :expr "(do (require (quote [clojure.java.io :as io])) (string? (slurp (io/file \"README.md\"))))" :expected "true"} {:suite "ioreader" :expr "(str (char-array \"abc\"))" :expected "(\\a \\b \\c)"} {:suite "ioreader" :expr "(.read (StringReader. (apply str (char-array \"Qz\"))))" :expected "81"} {:suite "ioreader" :expr "(do (require (quote [clojure.java.io :as io])) (.read (io/reader (char-array \"abc\"))))" :expected "97"} {:suite "ioreader" :expr "(do (require (quote [clojure.java.io :as io])) (.read (io/reader (StringReader. \"k\"))))" :expected "107"} {:suite "ioreader" :expr "(do (require (quote [clojure.java.io :as io])) (slurp (io/reader (char-array \"xyz\"))))" :expected "xyz"} - {:suite "ioreader" :expr "(do (require (quote [clojure.java.io :as io])) (string? (slurp (io/reader \"project.janet\"))))" :expected "true"} + {:suite "ioreader" :expr "(do (require (quote [clojure.java.io :as io])) (string? (slurp (io/reader \"README.md\"))))" :expected "true"} {:suite "ioreader" :expr "(do (require (quote [clojure.java.io :as io])) (.toString (.toURL (io/file \"/tmp/x\"))))" :expected "file:/tmp/x"} {:suite "ioreader" :expr "(do (require (quote [clojure.java.io :as io])) (.toURI (io/file \"/tmp/x\")))" :expected "file:/tmp/x"} {:suite "ioreader" :expr "(do (require (quote [clojure.java.io :as io])) (.getPath (.toURL (io/file \"/tmp/x\"))))" :expected "/tmp/x"} diff --git a/test/clojure-stdlib/clojure/data_test/diff.cljc b/test/clojure-stdlib/clojure/data_test/diff.cljc deleted file mode 100644 index 0b0415a..0000000 --- a/test/clojure-stdlib/clojure/data_test/diff.cljc +++ /dev/null @@ -1,149 +0,0 @@ -(ns clojure.data-test.diff - (:require [clojure.test :refer [deftest is testing]] -;; NOTE (jolt): sequential-diff expectations corrected to match real Clojure — -;; clojure.data pads only to the max differing index (e.g. (diff [1 2 3] [1 9 3]) -;; -> a=[nil 2], not [nil 2 nil]). The upstream clojurust fixtures had this wrong. - [clojure.data :refer [diff]])) - -;; ── Atoms ──────────────────────────────────────────────────────────────────── - -(deftest test-diff-equal-atoms - (testing "equal atoms" - (is (= [nil nil :a] (diff :a :a))) - (is (= [nil nil 1] (diff 1 1))) - (is (= [nil nil "hello"] (diff "hello" "hello"))) - (is (= [nil nil nil] (diff nil nil))) - (is (= [nil nil true] (diff true true))))) - -(deftest test-diff-unequal-atoms - (testing "unequal atoms" - (is (= [:a :b nil] (diff :a :b))) - (is (= [1 2 nil] (diff 1 2))) - (is (= ["a" "b" nil] (diff "a" "b"))) - (is (= [nil 1 nil] (diff nil 1))) - (is (= [true false nil] (diff true false))))) - -;; ── Maps ───────────────────────────────────────────────────────────────────── - -(deftest test-diff-equal-maps - (testing "equal maps" - (is (= [nil nil {:a 1 :b 2}] (diff {:a 1 :b 2} {:a 1 :b 2}))) - (is (= [nil nil {}] (diff {} {}))))) - -(deftest test-diff-maps-only-in-a - (testing "keys only in a" - (let [[a b both] (diff {:a 1 :b 2} {:a 1})] - (is (= {:b 2} a)) - (is (nil? b)) - (is (= {:a 1} both))))) - -(deftest test-diff-maps-only-in-b - (testing "keys only in b" - (let [[a b both] (diff {:a 1} {:a 1 :b 2})] - (is (nil? a)) - (is (= {:b 2} b)) - (is (= {:a 1} both))))) - -(deftest test-diff-maps-different-values - (testing "same keys, different values" - (let [[a b both] (diff {:a 1 :b 2} {:a 1 :b 9})] - (is (= {:b 2} a)) - (is (= {:b 9} b)) - (is (= {:a 1} both))))) - -(deftest test-diff-maps-nested - (testing "nested maps" - (let [[a b both] (diff {:a {:x 1 :y 2}} {:a {:x 1 :z 3}})] - (is (= {:a {:y 2}} a)) - (is (= {:a {:z 3}} b)) - (is (= {:a {:x 1}} both))))) - -(deftest test-diff-maps-disjoint - (testing "completely disjoint maps" - (let [[a b both] (diff {:a 1} {:b 2})] - (is (= {:a 1} a)) - (is (= {:b 2} b)) - (is (nil? both))))) - -;; ── Sets ───────────────────────────────────────────────────────────────────── - -(deftest test-diff-equal-sets - (testing "equal sets" - (is (= [nil nil #{1 2 3}] (diff #{1 2 3} #{1 2 3}))) - (is (= [nil nil #{}] (diff #{} #{}))))) - -(deftest test-diff-sets - (testing "overlapping sets" - (let [[a b both] (diff #{1 2 3} #{2 3 4})] - (is (= #{1} a)) - (is (= #{4} b)) - (is (= #{2 3} both))))) - -(deftest test-diff-disjoint-sets - (testing "disjoint sets" - (let [[a b both] (diff #{1 2} #{3 4})] - (is (= #{1 2} a)) - (is (= #{3 4} b)) - (is (nil? both))))) - -;; ── Vectors / Sequential ──────────────────────────────────────────────────── - -(deftest test-diff-equal-vectors - (testing "equal vectors" - (is (= [nil nil [1 2 3]] (diff [1 2 3] [1 2 3]))) - (is (= [nil nil []] (diff [] []))))) - -(deftest test-diff-vectors-same-length - (testing "same length, different elements" - (let [[a b both] (diff [1 2 3] [1 9 3])] - (is (= [nil 2] a)) - (is (= [nil 9] b)) - (is (= [1 nil 3] both))))) - -(deftest test-diff-vectors-different-length - (testing "different lengths" - (let [[a b both] (diff [1 2 3] [1 2])] - (is (= [nil nil 3] a)) - (is (nil? b)) - (is (= [1 2] both))) - (let [[a b both] (diff [1] [1 2 3])] - (is (nil? a)) - (is (= [nil 2 3] b)) - (is (= [1] both))))) - -(deftest test-diff-lists - (testing "lists treated as sequential" - (let [[a b both] (diff '(1 2 3) '(1 9 3))] - (is (= [nil 2] a)) - (is (= [nil 9] b)) - (is (= [1 nil 3] both))))) - -;; ── Mixed types ───────────────────────────────────────────────────────────── - -(deftest test-diff-mixed-types - (testing "different partition types treated as atoms" - (is (= [{:a 1} [1 2] nil] (diff {:a 1} [1 2]))) - (is (= [#{1} [1] nil] (diff #{1} [1]))) - (is (= [1 :a nil] (diff 1 :a))))) - -;; ── Nil handling ──────────────────────────────────────────────────────────── - -(deftest test-diff-nil - (testing "nil vs non-nil" - (is (= [nil 1 nil] (diff nil 1))) - (is (= [1 nil nil] (diff 1 nil))) - (is (= [nil {:a 1} nil] (diff nil {:a 1}))))) - -;; ── Deeply nested ─────────────────────────────────────────────────────────── - -(deftest test-diff-deeply-nested - (testing "deeply nested structures" - (let [[a b both] (diff {:a {:b {:c 1}}} {:a {:b {:c 2}}})] - (is (= {:a {:b {:c 1}}} a)) - (is (= {:a {:b {:c 2}}} b)) - (is (nil? both)))) - (testing "deeply nested with shared keys" - (let [[a b both] (diff {:a {:b 1 :c 2}} {:a {:b 1 :c 9}})] - (is (= {:a {:c 2}} a)) - (is (= {:a {:c 9}} b)) - (is (= {:a {:b 1}} both))))) diff --git a/test/clojure-stdlib/clojure/edn_test/read_string.cljc b/test/clojure-stdlib/clojure/edn_test/read_string.cljc deleted file mode 100644 index 515af5e..0000000 --- a/test/clojure-stdlib/clojure/edn_test/read_string.cljc +++ /dev/null @@ -1,107 +0,0 @@ -(ns clojure.edn-test.read-string - (:require [clojure.edn :as edn] - [clojure.test :refer [are deftest is testing]])) - -(deftest test-read-string-scalars - (testing "nil, booleans" - (is (nil? (edn/read-string "nil"))) - (is (true? (edn/read-string "true"))) - (is (false? (edn/read-string "false")))) - - (testing "integers" - (is (= 0 (edn/read-string "0"))) - (is (= 42 (edn/read-string "42"))) - (is (= -1 (edn/read-string "-1"))) - (is (= 1000000000000 (edn/read-string "1000000000000")))) - - (testing "floats" - (is (= 3.14 (edn/read-string "3.14"))) - (is (= -0.5 (edn/read-string "-0.5"))) - (is (= 1.0 (edn/read-string "1.0")))) - - (testing "bigints" - (is (= 42N (edn/read-string "42N")))) - - (testing "bigdecimals" - (is (= 3.14M (edn/read-string "3.14M")))) - - (testing "strings" - (is (= "" (edn/read-string "\"\""))) - (is (= "hello" (edn/read-string "\"hello\""))) - (is (= "line1\nline2" (edn/read-string "\"line1\\nline2\""))) - (is (= "tab\there" (edn/read-string "\"tab\\there\"")))) - - (testing "characters" - (is (= \a (edn/read-string "\\a"))) - (is (= \newline (edn/read-string "\\newline"))) - (is (= \space (edn/read-string "\\space"))) - (is (= \tab (edn/read-string "\\tab")))) - - (testing "keywords" - (is (= :foo (edn/read-string ":foo"))) - (is (= :bar/baz (edn/read-string ":bar/baz")))) - - (testing "symbols" - (is (= 'foo (edn/read-string "foo"))) - (is (= 'bar/baz (edn/read-string "bar/baz"))))) - -(deftest test-read-string-collections - (testing "vectors" - (is (= [] (edn/read-string "[]"))) - (is (= [1 2 3] (edn/read-string "[1 2 3]"))) - (is (= [1 [2 3] 4] (edn/read-string "[1 [2 3] 4]")))) - - (testing "lists" - (is (= '() (edn/read-string "()"))) - (is (= '(1 2 3) (edn/read-string "(1 2 3)"))) - (is (= '(+ 1 2) (edn/read-string "(+ 1 2)")))) - - (testing "maps" - (is (= {} (edn/read-string "{}"))) - (is (= {:a 1} (edn/read-string "{:a 1}"))) - (is (= {:a 1 :b 2} (edn/read-string "{:a 1 :b 2}"))) - (is (= {:nested {:deep true}} (edn/read-string "{:nested {:deep true}}")))) - - (testing "sets" - (is (= #{} (edn/read-string "#{}"))) - (is (= #{1 2 3} (edn/read-string "#{1 2 3}")))) - - (testing "mixed nested" - (is (= {:users [{:name "Alice" :age 30} - {:name "Bob" :age 25}]} - (edn/read-string "{:users [{:name \"Alice\" :age 30} {:name \"Bob\" :age 25}]}"))))) - -(deftest test-read-string-tagged-literals - (testing "#uuid" - (let [u (edn/read-string "#uuid \"f81d4fae-7dec-11d0-a765-00a0c91e6bf6\"")] - (is (uuid? u)) - (is (= u (edn/read-string "#uuid \"f81d4fae-7dec-11d0-a765-00a0c91e6bf6\"")))))) - -(deftest test-read-string-eof - (testing "empty string with :eof option" - (is (= :eof (edn/read-string {:eof :eof} ""))) - (is (= nil (edn/read-string {:eof nil} ""))) - (is (= 42 (edn/read-string {:eof 42} "")))) - - (testing "whitespace-only with :eof option" - (is (= :done (edn/read-string {:eof :done} " ")))) - - (testing "nil input returns nil" - (is (nil? (edn/read-string nil))))) - -(deftest test-read-string-comments - (testing "comments are skipped" - (is (= 42 (edn/read-string "; this is a comment\n42")))) - - (testing "discard reader macro" - (is (= 2 (edn/read-string "#_ 1 2"))))) - -(deftest test-read-string-only-first-form - (testing "reads only the first form" - (is (= 1 (edn/read-string "1 2 3"))) - (is (= :a (edn/read-string ":a :b :c"))))) - -(deftest test-read-string-ratios - (testing "ratios" - (is (= 1/2 (edn/read-string "1/2"))) - (is (= 3/4 (edn/read-string "3/4"))))) diff --git a/test/clojure-stdlib/clojure/walk_test/walk.cljc b/test/clojure-stdlib/clojure/walk_test/walk.cljc deleted file mode 100644 index 49a584e..0000000 --- a/test/clojure-stdlib/clojure/walk_test/walk.cljc +++ /dev/null @@ -1,101 +0,0 @@ -(ns clojure.walk-test.walk - (:require [clojure.test :refer [deftest is testing]] - [clojure.walk :as w])) - -(deftest test-walk - (testing "walk with identity" - (is (= [1 2 3] (w/walk identity identity [1 2 3]))) - (is (= '(1 2 3) (w/walk identity identity '(1 2 3)))) - (is (= #{1 2 3} (w/walk identity identity #{1 2 3})))) - - (testing "walk with inner transform" - (is (= [2 3 4] (w/walk inc identity [1 2 3]))) - (is (= [2 3 4] (w/walk inc vec [1 2 3])))) - - (testing "walk with outer transform" - (is (= [1 2 3] (w/walk identity vec '(1 2 3)))))) - -(deftest test-postwalk - (testing "postwalk with numbers" - (is (= [2 3 4] (w/postwalk #(if (number? %) (inc %) %) [1 2 3])))) - - (testing "postwalk with nested structures" - (is (= [2 [3 4] 5] - (w/postwalk #(if (number? %) (inc %) %) [1 [2 3] 4])))) - - (testing "postwalk preserves types" - (is (vector? (w/postwalk identity [1 2 3]))) - (is (list? (w/postwalk identity '(1 2 3)))) - (is (set? (w/postwalk identity #{1 2 3}))) - (is (map? (w/postwalk identity {:a 1 :b 2})))) - - (testing "postwalk on maps" - (is (= {:a 2 :b 3} - (w/postwalk #(if (number? %) (inc %) %) {:a 1 :b 2})))) - - (testing "postwalk on empty collections" - (is (= [] (w/postwalk identity []))) - (is (= {} (w/postwalk identity {}))) - (is (= #{} (w/postwalk identity #{}))) - (is (= '() (w/postwalk identity '()))))) - -(deftest test-prewalk - (testing "prewalk with numbers" - (is (= [2 3 4] (w/prewalk #(if (number? %) (inc %) %) [1 2 3])))) - - (testing "prewalk with nested structures" - (is (= [2 [3 4] 5] - (w/prewalk #(if (number? %) (inc %) %) [1 [2 3] 4])))) - - (testing "prewalk transforms before descending" - ;; prewalk applies f to the outer form first, so we can replace - ;; entire subtrees before they are walked - (is (= [:replaced] - (w/prewalk #(if (= % [1 2 3]) [:replaced] %) [1 2 3]))))) - -(deftest test-keywordize-keys - (testing "basic keywordize" - (is (= {:a 1 :b 2} (w/keywordize-keys {"a" 1 "b" 2})))) - - (testing "nested keywordize" - (is (= {:a {:b 2}} (w/keywordize-keys {"a" {"b" 2}})))) - - (testing "non-string keys unchanged" - (is (= {:a 1 42 2} (w/keywordize-keys {"a" 1 42 2})))) - - (testing "already keyword keys unchanged" - (is (= {:a 1} (w/keywordize-keys {:a 1}))))) - -(deftest test-stringify-keys - (testing "basic stringify" - (is (= {"a" 1 "b" 2} (w/stringify-keys {:a 1 :b 2})))) - - (testing "nested stringify" - (is (= {"a" {"b" 2}} (w/stringify-keys {:a {:b 2}})))) - - (testing "non-keyword keys unchanged" - (is (= {"a" 1 42 2} (w/stringify-keys {:a 1 42 2}))))) - -(deftest test-postwalk-replace - (testing "basic replacement" - (is (= [:x :y :c] (w/postwalk-replace {:a :x :b :y} [:a :b :c])))) - - (testing "nested replacement" - (is (= [:x [:y :c]] (w/postwalk-replace {:a :x :b :y} [:a [:b :c]])))) - - (testing "no matches" - (is (= [1 2 3] (w/postwalk-replace {:a :x} [1 2 3])))) - - (testing "empty smap" - (is (= [1 2 3] (w/postwalk-replace {} [1 2 3]))))) - -(deftest test-prewalk-replace - (testing "basic replacement" - (is (= [:x :y :c] (w/prewalk-replace {:a :x :b :y} [:a :b :c])))) - - (testing "nested replacement" - (is (= [:x [:y :c]] (w/prewalk-replace {:a :x :b :y} [:a [:b :c]])))) - - (testing "replaces before descending" - ;; prewalk-replace replaces the whole form first, then walks children - (is (= :replaced (w/prewalk-replace {[:a :b] :replaced} [:a :b]))))) diff --git a/test/clojure-stdlib/clojure/zip_test/zip.cljc b/test/clojure-stdlib/clojure/zip_test/zip.cljc deleted file mode 100644 index 076eb79..0000000 --- a/test/clojure-stdlib/clojure/zip_test/zip.cljc +++ /dev/null @@ -1,122 +0,0 @@ -(ns clojure.zip-test.zip - (:require [clojure.test :refer [deftest is testing run-tests]] - [clojure.zip :as zip])) - -(deftest test-vector-zip-navigation - (let [data [[1 2] [3 [4 5]]] - z (zip/vector-zip data)] - (testing "root node" - (is (= (zip/node z) [[1 2] [3 [4 5]]])) - (is (zip/branch? z))) - (testing "down" - (is (= (zip/node (zip/down z)) [1 2]))) - (testing "right" - (is (= (zip/node (zip/right (zip/down z))) [3 [4 5]]))) - (testing "down into nested" - (is (= (zip/node (zip/down (zip/right (zip/down z)))) 3))) - (testing "up returns parent" - (is (= (zip/node (zip/up (zip/down z))) [[1 2] [3 [4 5]]]))) - (testing "rights" - (is (= (zip/rights (zip/down z)) '([3 [4 5]])))) - (testing "lefts" - (is (= (zip/lefts (zip/right (zip/down z))) [[1 2]]))))) - -(deftest test-vector-zip-rightmost-leftmost - (let [z (zip/vector-zip [1 2 3])] - (testing "rightmost" - (is (= (zip/node (zip/rightmost (zip/down z))) 3))) - (testing "leftmost" - (is (= (zip/node (zip/leftmost (zip/rightmost (zip/down z)))) 1))))) - -(deftest test-seq-zip-navigation - (let [z (zip/seq-zip '(1 (2 3) 4))] - (testing "root" - (is (= (zip/node z) '(1 (2 3) 4)))) - (testing "down" - (is (= (zip/node (zip/down z)) 1))) - (testing "right" - (is (= (zip/node (zip/right (zip/down z))) '(2 3)))) - (testing "down into nested list" - (is (= (zip/node (zip/down (zip/right (zip/down z)))) 2))))) - -(deftest test-path - (let [z (zip/vector-zip [[1 2] [3 4]])] - (testing "path at root is nil" - (is (nil? (zip/path z)))) - (testing "path one level down" - (is (= (zip/path (zip/down z)) [[[1 2] [3 4]]]))) - (testing "path two levels down" - (is (= (zip/path (zip/down (zip/down z))) - [[[1 2] [3 4]] [1 2]]))))) - -(deftest test-edit - (let [z (zip/vector-zip [1 [2 3] [4 5]])] - (testing "edit a leaf" - (let [loc (-> z zip/down zip/right zip/down) - edited (zip/edit loc inc)] - (is (= (zip/root edited) [1 [3 3] [4 5]])))) - (testing "edit a branch" - (let [loc (-> z zip/down zip/right) - edited (zip/edit loc (fn [x] (vec (map inc x))))] - (is (= (zip/root edited) [1 [3 4] [4 5]])))))) - -(deftest test-replace - (let [z (zip/vector-zip '[a b c])] - (is (= (zip/root (zip/replace (zip/down z) 'x)) - '[x b c])))) - -(deftest test-insert-left-right - (let [z (zip/vector-zip [1 2 3]) - loc (-> z zip/down zip/right)] - (testing "insert-left" - (is (= (zip/root (zip/insert-left loc 'x)) [1 'x 2 3]))) - (testing "insert-right" - (is (= (zip/root (zip/insert-right loc 'y)) [1 2 'y 3]))))) - -(deftest test-insert-child-append-child - (let [z (zip/vector-zip [1 2 3])] - (testing "insert-child" - (is (= (zip/root (zip/insert-child z 0)) [0 1 2 3]))) - (testing "append-child" - (is (= (zip/root (zip/append-child z 4)) [1 2 3 4]))))) - -(deftest test-remove - (let [z (zip/vector-zip [1 2 3]) - loc (-> z zip/down zip/right)] - (is (= (zip/root (zip/remove loc)) [1 3])))) - -(deftest test-next-traversal - (let [z (zip/vector-zip [1 [2 3]])] - (testing "next enumerates depth-first" - (is (= (loop [loc z, acc []] - (if (zip/end? loc) - acc - (recur (zip/next loc) (conj acc (zip/node loc))))) - [[1 [2 3]] 1 [2 3] 2 3]))))) - -(deftest test-end? - (let [z (zip/vector-zip [1 2])] - (testing "not end at start" - (is (not (zip/end? z)))) - (testing "end after full traversal" - (is (zip/end? (-> z zip/next zip/next zip/next)))))) - -(deftest test-prev - (let [z (zip/vector-zip [1 [2 3]])] - (testing "prev from second child" - (let [loc (-> z zip/next zip/next)] - (is (= (zip/node loc) [2 3])) - (is (= (zip/node (zip/prev loc)) 1)))) - (testing "prev from leaf inside nested" - (let [loc (-> z zip/next zip/next zip/next)] - (is (= (zip/node loc) 2)) - (is (= (zip/node (zip/prev loc)) [2 3])))))) - -(deftest test-root-after-edits - (testing "root unwinds all the way after deep edits" - (let [z (zip/vector-zip [[1 2] [3 [4 5]]]) - loc (-> z zip/down zip/right zip/down zip/right zip/down) - edited (zip/edit loc inc)] - (is (= (zip/root edited) [[1 2] [3 [5 5]]]))))) - -(run-tests) diff --git a/test/conformance/certify-test.janet b/test/conformance/certify-test.janet deleted file mode 100644 index de6e171..0000000 --- a/test/conformance/certify-test.janet +++ /dev/null @@ -1,42 +0,0 @@ -# Conformance inc1 (jolt-xsfe) — gate wrapper for the JVM corpus certifier. -# -# test/conformance/certify.clj evaluates every test/chez/corpus.edn row through -# reference JVM Clojure and checks jolt's hand-written :expected against what real -# Clojure produces. Divergences are classified in test/conformance/known-divergences.edn -# (deliberate jolt-specific / host-model deltas + tracked bugs); the certifier exits -# nonzero only on a NEW (unclassified) divergence or a stale allowlist entry. -# -# This wrapper runs it in the Janet gate and skips cleanly when `clojure` (JVM) is -# not installed — same pattern as the chez tests skipping without `chez`. -# -# janet test/conformance/certify-test.janet - -(defn- have-clojure? [] - (def p (try (os/spawn ["clojure" "--version"] :p {:out :pipe :err :pipe}) ([_] nil))) - (if (nil? p) false - (do (def out (ev/read (p :out) :all)) (def err (ev/read (p :err) :all)) - (zero? (os/proc-wait p))))) - -(unless (have-clojure?) - (print "clojure (JVM) not on PATH — skipping corpus certification") - (os/exit 0)) - -(def proc (os/spawn ["clojure" "-M" "test/conformance/certify.clj"] :p {:out :pipe :err :pipe})) -(def out (string (ev/read (proc :out) :all))) -(def err (string (or (ev/read (proc :err) :all) ""))) -(def code (os/proc-wait proc)) - -# Echo the summary lines so the gate log shows the certification status. -(each line (string/split "\n" out) - (when (or (string/find "certif" line) (string/find "allowlist" line) - (string/find "NEW" line) (string/find "STALE" line) (string/find "DIVERGENT" line)) - (print line))) - -(when (not= code 0) - (eprint "corpus certification FAILED (new/stale divergence vs reference Clojure):") - (eprint out) - (unless (= "" err) (eprint err)) - (os/exit 1)) - -(print "corpus certification: OK (all divergences classified)") -(os/exit 0) diff --git a/test/fixtures/cgen-build/cgapp.clj b/test/fixtures/cgen-build/cgapp.clj deleted file mode 100644 index 0cc6a00..0000000 --- a/test/fixtures/cgen-build/cgapp.clj +++ /dev/null @@ -1,30 +0,0 @@ -;; Fixture app for the cgen single-binary build test (jolt-a7ds). -;; count-point is a numeric leaf -> compiled to native C and statically linked; -;; run/-main stay bytecode and call into it. -main prints a deterministic total. -(ns cgapp) - -(defn count-point [cr ci cap] - (loop [i 0 zr 0.0 zi 0.0] - (if (or (>= i cap) (> (+ (* zr zr) (* zi zi)) 4.0)) - i - (recur (inc i) - (+ (- (* zr zr) (* zi zi)) cr) - (+ (* 2.0 (* zr zi)) ci))))) - -(defn run [n] - (let [cap 200 - nd (* 1.0 n)] - (loop [y 0 acc 0] - (if (< y n) - (let [ci (- (/ (* 2.0 y) nd) 1.0) - row (loop [x 0 a 0] - (if (< x n) - (let [cr (- (/ (* 2.0 x) nd) 1.5)] - (recur (inc x) (+ a (count-point cr ci cap)))) - a))] - (recur (inc y) (+ acc row))) - acc)))) - -(defn -main [& args] - (let [n (if (seq args) (Integer/parseInt (first args)) 200)] - (println (run n)))) diff --git a/test/integration/aot-test.janet b/test/integration/aot-test.janet deleted file mode 100644 index 95c1588..0000000 --- a/test/integration/aot-test.janet +++ /dev/null @@ -1,43 +0,0 @@ -# AOT image round-trip: compile a namespace, marshal it to bytecode, load it into -# a FRESH context, and run the loaded functions without recompiling. -(use ../../src/jolt/api) -(use ../../src/jolt/aot) -(use ../../src/jolt/types) - -(print "AOT image round-trip...") - -(def img-path (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-aot-test.jimg")) - -# 1. Compile a namespace into ctx1: a constant, a fn over it, a fn using core -# fns, and a recursive fn. -(def ctx1 (init {:compile? true})) -(ctx-set-current-ns ctx1 "demo") -(eval-string ctx1 "(def base 100)") -(eval-string ctx1 "(defn add-base [x] (+ x base))") -(eval-string ctx1 "(defn sum-sq [xs] (reduce + (map (fn [x] (* x x)) xs)))") -(eval-string ctx1 "(defn fact [n] (if (zero? n) 1 (* n (fact (dec n)))))") - -(assert (= 107 (eval-string ctx1 "(add-base 7)")) "ctx1 add-base") -(assert (= 14 (eval-string ctx1 "(sum-sq [1 2 3])")) "ctx1 sum-sq") -(assert (= 120 (eval-string ctx1 "(fact 5)")) "ctx1 fact") - -# 2. Save an AOT image of the compiled namespace. -(save-ns ctx1 "demo" img-path) -(assert (os/stat img-path) "image written") - -# 3. Load it into a brand-new context — no recompilation of demo. -(def ctx2 (init {:compile? true})) -(load-ns-image ctx2 "demo" img-path) -(ctx-set-current-ns ctx2 "demo") - -(assert (= 107 (eval-string ctx2 "(add-base 7)")) "ctx2 add-base from image") -(assert (= 14 (eval-string ctx2 "(sum-sq [1 2 3])")) "ctx2 sum-sq from image") -(assert (= 3628800 (eval-string ctx2 "(fact 10)")) "ctx2 fact from image (new arg)") - -# 4. The loaded vars are live: redefining one is visible to callers compiled in -# ctx2 that reference it. -(eval-string ctx2 "(def base 1000)") -(assert (= 1007 (eval-string ctx2 "(add-base 7)")) "loaded var still redefinable") - -(os/rm img-path) -(print "AOT round-trip passed!") diff --git a/test/integration/api-test.janet b/test/integration/api-test.janet deleted file mode 100644 index 3029a1f..0000000 --- a/test/integration/api-test.janet +++ /dev/null @@ -1,38 +0,0 @@ -(use ../../src/jolt/api) -(use ../../src/jolt/types) - -(print "1: init creates context...") -(let [ctx (init-cached)] - (assert (ctx? ctx) "init returns context") - (let [ns (ctx-find-ns ctx "clojure.core")] - (assert (ns? ns) "clojure.core namespace exists") - (assert (ns-find ns "nil?") "nil? is interned") - (assert (ns-find ns "+") "+ is interned"))) -(print " passed") - -(print "2: eval-string basics...") -(let [ctx (init-cached)] - (assert (= 42 (eval-string ctx "42")) "eval integer") - (assert (= true (eval-string ctx "true")) "eval bool") - (assert (= 3 (eval-string ctx "(+ 1 2)")) "eval list")) -(print " passed") - -(print "3: eval-string with core fns...") -(let [ctx (init-cached)] - (assert (= true (eval-string ctx "(nil? nil)")) "nil?") - (assert (deep= [2 3 4] (normalize-pvecs (eval-string ctx "(map inc [1 2 3])"))) "map+inc") - (assert (= 6 (eval-string ctx "(reduce + [1 2 3])")) "reduce")) -(print " passed") - -(print "4: eval-string with def...") -(let [ctx (init-cached)] - (eval-string ctx "(def x 42)") - (assert (= 42 (eval-string ctx "x")) "def then resolve")) -(print " passed") - -(print "5: eval-string* with bindings...") -(let [ctx (init-cached)] - (assert (= 99 (eval-string* ctx "y" @{"y" 99})) "bound variable")) -(print " passed") - -(print "\nAll API tests passed!") diff --git a/test/integration/app-scope-wholeprogram-test.janet b/test/integration/app-scope-wholeprogram-test.janet deleted file mode 100644 index f04e28f..0000000 --- a/test/integration/app-scope-wholeprogram-test.janet +++ /dev/null @@ -1,67 +0,0 @@ -# Whole-program inference scoped to app namespaces (jolt-87e). -# -# Auto-whole-program (a -m program run under direct-link) used to defer EVERY -# loaded namespace — including every transitive dependency — into one closed- -# world fixpoint, which is prohibitive on dep-heavy apps (hundreds of dep nses; -# a ~2-minute cold start on malli). With app source roots declared (JOLT_APP_PATHS -# / jolt-deps, here :app-paths), only the app's OWN namespaces join the whole- -# program batch; dependency namespaces skip inference (they stay direct-linked -# but generically typed — the open-world default). With NO app roots declared, -# every namespace is treated as app (whole-program over everything, pre-87e). - -(use ../../src/jolt/api) - -(var failures 0) -(defn- check [label got want] - (unless (= got want) - (++ failures) - (printf "FAIL [%s] got %q want %q" label got want))) - -# Lay down an app root and a dep root under a tmp dir. -(def tmp (string (os/getenv "TMPDIR") "jolt-87e-" (os/time))) -(def app-root (string tmp "/app")) -(def dep-root (string tmp "/dep")) -(os/mkdir tmp) (os/mkdir app-root) (os/mkdir dep-root) -(spit (string dep-root "/mydep.clj") - "(ns mydep)\n(defn helper [x] (+ x 1))\n") -(spit (string app-root "/myapp.clj") - "(ns myapp (:require [mydep]))\n(defn run [x] (mydep/helper x))\n") - -(defn- with-wp [f] - (def saved (os/getenv "JOLT_WHOLE_PROGRAM")) - (os/setenv "JOLT_WHOLE_PROGRAM" "1") - (defer (os/setenv "JOLT_WHOLE_PROGRAM" saved) (f))) - -# --- app roots declared: only the app ns defers into the batch --------------- -(with-wp - (fn [] - (let [ctx (init {:compile? true :direct-linking? true - :paths [app-root dep-root] :app-paths [app-root]})] - (check "whole-program is on" (truthy? (get (ctx :env) :whole-program?)) true) - (eval-string ctx "(require '[myapp])") - (let [deferred (or (get (ctx :env) :inferred-nses) @[])] - (check "app ns deferred to batch" (truthy? (index-of "myapp" deferred)) true) - (check "dep ns NOT in batch (per-ns inferred)" - (truthy? (index-of "mydep" deferred)) false)) - # still runs correctly after the (scoped) whole-program pass - (when-let [ip (get (ctx :env) :infer-program!)] (protect (ip ctx))) - (check "scoped whole-program program still correct" - (eval-string ctx "(myapp/run 41)") 42)))) - -# --- no app roots declared: every ns defers (pre-87e whole-program) ---------- -(with-wp - (fn [] - (let [ctx (init {:compile? true :direct-linking? true - :paths [app-root dep-root]})] - (eval-string ctx "(require '[myapp])") - (let [deferred (or (get (ctx :env) :inferred-nses) @[])] - (check "no app roots: app ns deferred" (truthy? (index-of "myapp" deferred)) true) - (check "no app roots: dep ns ALSO deferred" - (truthy? (index-of "mydep" deferred)) true)) - (when-let [ip (get (ctx :env) :infer-program!)] (protect (ip ctx))) - (check "unscoped whole-program still correct" - (eval-string ctx "(myapp/run 9)") 10)))) - -(if (pos? failures) - (do (printf "app-scope-wholeprogram: %d failure(s)" failures) (os/exit 1)) - (print "app-scope-wholeprogram: all cases passed")) diff --git a/test/integration/bootstrap-fixpoint-test.janet b/test/integration/bootstrap-fixpoint-test.janet deleted file mode 100644 index cf5a510..0000000 --- a/test/integration/bootstrap-fixpoint-test.janet +++ /dev/null @@ -1,81 +0,0 @@ -# Bootstrap fixpoint (jolt-d0r). -# -# Soundness gate for self-hosting: the self-hosted compiler, rebuilt by compiling -# its OWN source through itself (stage2), must behave identically to the compiler -# built by the Janet bootstrap (stage1). We test this BEHAVIORALLY — run a corpus -# of programs through each stage and compare results — rather than by comparing -# emitted code, because emitted forms embed live setter/getter closures and the IR -# carries representation-level gensyms; behavioral parity is the property that -# actually matters and is representation-independent. -# -# stage1 = analyzer as built by the bootstrap. -# stage2 = analyzer rebuilt by compiling jolt.ir + jolt.analyzer through stage1 -# (self-host, the fractal turn) and installing the result over itself. -# stage3 = the same self-rebuild applied again, on top of stage2. -# All three must produce identical results on the corpus. - -(use ../../src/jolt/types) -(use ../../src/jolt/api) -(use ../../src/jolt/reader) -(import ../../src/jolt/backend :as be) -(import ../../src/jolt/stdlib_embed :as se) - -(defn- forms [src] - (var s src) (def fs @[]) - (while (> (length (string/trim s)) 0) - (def p (parse-next s)) (set s (p 1)) - (when (p 0) (array/push fs (p 0)))) - fs) - -# Programs exercising the compiled constructs (fn/multi-arity/recur/loop/if/let/ -# map+vector literals/closures/higher-order/protocol dispatch). Each is a single -# expression evaluated through the compile pipeline; we compare printed results. -(def corpus - ["(let [f (fn [x] (* x x))] (map f [1 2 3 4]))" - "(loop [i 0 acc 0] (if (< i 10) (recur (inc i) (+ acc i)) acc))" - "((fn fact [n] (if (zero? n) 1 (* n (fact (dec n))))) 6)" - "(reduce + 0 (filter even? (range 20)))" - "(let [[a b & r] [1 2 3 4 5]] [a b r])" - "(mapv (juxt identity inc dec) [10 20])" - "(frequencies (concat [:a :a] [:b]))" - "(group-by odd? (range 8))" - "(get-in {:a {:b {:c 42}}} [:a :b :c])" - "(first {:x 1})" - "(into {} (map (fn [k] [k (* k k)]) (range 5)))" - "((comp inc inc) 10)" - "(apply max [3 1 4 1 5 9 2 6])" - "(str (reverse \"hello\") (count [1 2 3]))" - "(let [m {:a 1}] (assoc m :b (+ (:a m) 1)))"]) - -(defn- run-corpus [ctx] - (map (fn [p] (def r (protect (eval-string ctx p))) - (if (r 0) (string/format "%j" (normalize-pvecs (r 1))) (string "ERR:" (r 1)))) - corpus)) - -# Rebuild the analyzer through the self-hosted pipeline, in place. -(defn- self-rebuild! [ctx] - (def saved (ctx-current-ns ctx)) - (each nsn ["jolt.ir" "jolt.analyzer"] - (ctx-set-current-ns ctx nsn) - (each f (forms (get se/sources nsn)) (protect (be/compile-and-eval ctx f)))) - (ctx-set-current-ns ctx saved)) - -(def ctx (init {:compile? true})) -(def r1 (run-corpus ctx)) # stage1 (bootstrap-built) -(self-rebuild! ctx) -(def r2 (run-corpus ctx)) # stage2 (self-built) -(self-rebuild! ctx) -(def r3 (run-corpus ctx)) # stage3 (self-built from stage2) - -(var failures 0) -(for i 0 (length corpus) - (unless (and (= (r1 i) (r2 i)) (= (r2 i) (r3 i))) - (++ failures) - (printf "FAIL [%s]\n stage1=%s\n stage2=%s\n stage3=%s" (corpus i) (r1 i) (r2 i) (r3 i))) - # also guard against everything silently erroring - (when (string/has-prefix? "ERR:" (r1 i)) - (++ failures) (printf "FAIL [%s] stage1 errored: %s" (corpus i) (r1 i)))) - -(if (pos? failures) - (do (printf "bootstrap-fixpoint: %d failure(s)" failures) (os/exit 1)) - (printf "bootstrap-fixpoint: stage1 == stage2 == stage3 on %d programs\n" (length corpus))) diff --git a/test/integration/cap-record-type-test.janet b/test/integration/cap-record-type-test.janet deleted file mode 100644 index f6cc729..0000000 --- a/test/integration/cap-record-type-test.janet +++ /dev/null @@ -1,60 +0,0 @@ -# A record type keeps its :type tag through depth-capping (jolt-3ko follow-up). -# cap (jolt.passes.types) truncates a deep type's field VALUES to :any so the -# inter-procedural fixpoint stays finite, but the record :type tag is identity, -# independent of field depth — so it must survive. Before this fix cap rebuilt -# the struct via mk-struct and dropped :type, degrading a record stored in a -# deep container to a plain struct: devirtualization (jolt-41m) and record? -# folding silently stopped firing on it. This drives whole-program inference -# over a vector-of-records and asserts (a) the element keeps REC identity and -# (b) a protocol call on an element devirtualizes (the inference annotates the -# call node with :devirt-type, which it can't do without the receiver's :type). -(import ../../src/jolt/api :as api) -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/types :as types) - -(print "Record :type survives capping (jolt-3ko)...") - -(def dir (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-cap-rec")) -(os/mkdir dir) -(spit (string dir "/cr.clj") - (string - "(ns cr)\n" - "(defrecord V3 [r g b])\n" # nested record -> forces a deep type - "(defprotocol Shape (area [s]))\n" - "(defrecord Box [^V3 lo ^V3 hi]\n" - " Shape\n" - " (area [s] (+ (:r (:hi s)) (:r (:lo s)))))\n" - "(defn total [coll] (reduce (fn [acc x] (+ acc (area x))) 0.0 coll))\n" - "(defn drive [n]\n" - " (let [world [(->Box (->V3 1.0 2.0 3.0) (->V3 4.0 5.0 6.0))\n" - " (->Box (->V3 0.0 0.0 0.0) (->V3 2.0 2.0 2.0))]]\n" - " (loop [i 0 acc 0.0] (if (< i n) (recur (inc i) (+ acc (total world))) acc))))\n")) - -(os/setenv "JOLT_DIRECT_LINK" "1") -(os/setenv "JOLT_WHOLE_PROGRAM" "1") -(os/setenv "JOLT_PATH" dir) -(def ctx (api/init {:compile? true})) -(api/eval-string ctx "(require '[cr])") -(def report (backend/infer-program! ctx)) - -# (a) total's collection param keeps its record element identity through cap -(def coll-t (get (get report "cr/total") 0)) -(def elem-t (and coll-t (get coll-t :vec))) -(assert (and elem-t (= "cr.Box" (get elem-t :type))) - (string "vec element keeps record :type through cap (got " (string/format "%p" elem-t) ")")) - -# (b) the protocol call on an element devirtualizes — the inference can only -# annotate :devirt-type when it knows the receiver's record :type. -(def pns (types/ctx-find-ns ctx "jolt.passes")) -(def reinfer (types/var-get (types/ns-find pns "reinfer-def"))) -(def cell (get ((types/ctx-find-ns ctx "cr") :mappings) "total")) -(def reinferred (string/format "%p" (reinfer (get cell :infer-ir) @{"coll" coll-t}))) -(assert (not (nil? (string/find ":devirt-type" reinferred))) - "protocol call on a collection-read record devirtualizes (:devirt-type present)") - -# correctness: the program still computes the right answer -(assert (= 5.0 - (api/eval-string ctx "(cr/total [(cr/->Box (cr/->V3 1.0 0 0) (cr/->V3 4.0 0 0)) (cr/->Box (cr/->V3 0 0 0) (cr/->V3 0 0 0))])")) - "devirtualized record-in-collection computes correctly") - -(print "Record :type survives capping (jolt-3ko) passed!") diff --git a/test/integration/cgen-aot-test.janet b/test/integration/cgen-aot-test.janet deleted file mode 100644 index 8037450..0000000 --- a/test/integration/cgen-aot-test.janet +++ /dev/null @@ -1,59 +0,0 @@ -# Native codegen AOT build/deploy (jolt-a7ds): compile an app's numeric-leaf fns -# into ONE native module at build time, then deploy with NO cc — load the -# prebuilt module and install the cfunctions as var roots. Proves the build-time -# path that removes the runtime-toolchain dependency. Skips where cc/janet.h are -# absent. -(import ../../src/jolt/api :as api) -(import ../../src/jolt/cgen :as cgen) - -(print "Native codegen AOT build/deploy (jolt-a7ds)...") - -(var failures 0) -(defn check [label ok] (unless ok (++ failures) (eprintf " FAIL: %s" label))) - -(def cp-src "(defn count-point [cr ci cap] (loop [i 0 zr 0.0 zi 0.0] (if (or (>= i cap) (> (+ (* zr zr) (* zi zi)) 4.0)) i (recur (inc i) (+ (- (* zr zr) (* zi zi)) cr) (+ (* 2.0 (* zr zi)) ci)))))") -(def run-src "(defn run [n] (let [cap 200 nd (* 1.0 n)] (loop [y 0 acc 0] (if (< y n) (let [ci (- (/ (* 2.0 y) nd) 1.0) row (loop [x 0 a 0] (if (< x n) (let [cr (- (/ (* 2.0 x) nd) 1.5)] (recur (inc x) (+ a (count-point cr ci cap)))) a))] (recur (inc y) (+ acc row))) acc))))") - -(if (cgen/toolchain-available?) - (do - # --- build phase: collect numeric-leaf fns, compile one module, write manifest - (def bctx (api/init-cached {:compile? true})) - (put (bctx :env) :direct-linking? true) - (put (bctx :env) :cgen-collect? true) - (api/eval-string bctx "(ns aot)") - (api/eval-string bctx cp-src) - (api/eval-string bctx run-src) - (def collected (get (bctx :env) :cgen-collected)) - (check "collected exactly the numeric-leaf fn (count-point, not run)" - (and collected (= 1 (length collected)) - (= "count-point" ((first collected) :name)))) - (def manifest-path (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-aot-test.jdn")) - (def build (cgen/aot-build collected {:dir "build/cgen-aot-test"})) - (check "aot-build produced a module" (and build (build :sopath))) - (cgen/write-manifest manifest-path build) - - # --- deploy phase: fresh ctx, load prebuilt (NO cc), install roots, run - (def dctx (api/init-cached {:compile? true})) - (put (dctx :env) :direct-linking? true) - (def prebuilt (cgen/load-aot manifest-path)) - (check "load-aot maps the qname to a cfunction" - (cfunction? (get prebuilt "aot/count-point"))) - (put (dctx :env) :cgen-prebuilt prebuilt) - (api/eval-string dctx "(ns aot)") - (api/eval-string dctx cp-src) - (api/eval-string dctx run-src) - (check "deployed count-point root is the prebuilt cfunction" - (cfunction? (api/eval-string dctx "count-point"))) - (check "deployed run stays bytecode" (not (cfunction? (api/eval-string dctx "run")))) - (check "AOT-deployed mandelbrot computes the right total" - (= 3288753 (api/eval-string dctx "(run 200)"))) - - # a fn NOT in the manifest must stay bytecode in deploy - (api/eval-string dctx "(defn sq [x] (* x x))") - (check "unlisted numeric-leaf stays bytecode in deploy (no cc)" - (not (cfunction? (api/eval-string dctx "sq"))))) - (print " (toolchain absent — skipping AOT legs)")) - -(if (= 0 failures) - (print "All tests passed.") - (do (eprintf "%d cgen-aot check(s) failed" failures) (os/exit 1))) diff --git a/test/integration/cgen-build-test.janet b/test/integration/cgen-build-test.janet deleted file mode 100644 index 09e634b..0000000 --- a/test/integration/cgen-build-test.janet +++ /dev/null @@ -1,51 +0,0 @@ -# Single-binary native build (jolt-a7ds): `jolt cgen-build` fuses an app's hot -# numeric-leaf fns (compiled to C) + the app source into ONE static executable — -# no sidecar .so, no toolchain on the target. This test builds the fixture app to -# a binary, runs it from a CLEAN dir (no src/, no cg.so) to prove it's -# self-contained, and checks the result + native fn count. Skips with no cc. -(import ../../src/jolt/cgen :as cgen) -(import ../../src/jolt/cgen_build :as cb) - -(print "Single-binary native build (jolt-a7ds)...") - -(var failures 0) -(defn check [label ok] (if ok (print " ok: " label) (do (++ failures) (eprintf " FAIL: %s" label)))) - -(def home (os/cwd)) # the repo (gate runs here) -(def fixture-root (string home "/test/fixtures/cgen-build")) - -(if (cgen/toolchain-available?) - (do - (def out (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-cgen-build-test/app")) - (def r (cb/build-app {:main "cgapp" :out out :jolt-home home - :source-roots [fixture-root]})) - (check "build reported the single native leaf (count-point)" (= 1 (r :native-count))) - (check "binary exists at :out" (os/stat out)) - - # Run from a CLEAN dir with NO src/ and NO cg.so beside it — proves the binary - # is self-contained (runtime needs neither the jolt tree nor a sidecar .so). - (def rundir (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-cgen-build-run")) - (when (os/stat rundir) (each e (os/dir rundir) (os/rm (string rundir "/" e))) (os/rmdir rundir)) - (os/mkdir rundir) - (def bin (string rundir "/app")) - (spit bin (slurp out)) - (os/chmod bin 8r755) - - (defn run-app [&opt n] - (def tmp (string rundir "/out.txt")) - (def f (file/open tmp :w)) - (def code (os/execute (if n [bin (string n)] [bin]) :px {:out f} )) - (file/close f) - {:code code :out (string/trim (slurp tmp))}) - - (def res (run-app)) - (check "exits 0" (= 0 (res :code))) - (check "self-contained binary computes the right mandelbrot total (n=200)" - (= "3288753" (res :out))) - (check "passes through command-line args (n=400)" - (= "13162060" ((run-app 400) :out)))) - (print " (toolchain absent — skipping single-binary build)")) - -(if (= 0 failures) - (print "All tests passed.") - (do (eprintf "%d cgen-build check(s) failed" failures) (os/exit 1))) diff --git a/test/integration/cgen-pipeline-test.janet b/test/integration/cgen-pipeline-test.janet deleted file mode 100644 index d16bdf1..0000000 --- a/test/integration/cgen-pipeline-test.janet +++ /dev/null @@ -1,47 +0,0 @@ -# Native codegen pipeline integration (jolt-ihdp): under :cgen?, a defn of a -# numeric-leaf fn is compiled to C and the cfunction installed as the var root, -# so direct-linked callers run native code. Pins (1) the root becomes a -# cfunction, (2) non-leaf / redefable defns stay bytecode, (3) results match. -# Skips the native legs where the C toolchain (cc + janet.h) is absent. -(import ../../src/jolt/api :as api) -(import ../../src/jolt/cgen :as cgen) - -(print "Native codegen pipeline (jolt-ihdp)...") - -(var failures 0) -(defn check [label ok] (unless ok (++ failures) (eprintf " FAIL: %s" label))) -(defn callable? [x] (or (function? x) (cfunction? x))) - -(def ctx (api/init-cached {:compile? true})) -(put (ctx :env) :direct-linking? true) -(put (ctx :env) :inline? true) -(put (ctx :env) :cgen? true) -(api/eval-string ctx "(ns cgp)") - -(if (cgen/toolchain-available?) - (do - # numeric-leaf fn -> native root - (api/eval-string ctx "(defn sq [x] (* x x))") - (check "numeric-leaf root is a cfunction" (cfunction? (api/eval-string ctx "sq"))) - (check "native sq computes correctly" (= 49 (api/eval-string ctx "(sq 7)"))) - - # non-leaf fn -> stays bytecode (NOT a cfunction) - (api/eval-string ctx "(defn g [x] (str x))") - (check "non-leaf root stays bytecode" (not (cfunction? (api/eval-string ctx "g")))) - (check "g still works" (= "5" (api/eval-string ctx "(g 5)"))) - - # ^:redef stays bytecode even though numeric-leaf - (api/eval-string ctx "(defn ^:redef rsq [x] (* x x))") - (check "redefable numeric-leaf stays bytecode" (not (cfunction? (api/eval-string ctx "rsq")))) - - # end-to-end: count-point native, run bytecode calling it; grid total matches - (api/eval-string ctx "(defn count-point [cr ci cap] (loop [i 0 zr 0.0 zi 0.0] (if (or (>= i cap) (> (+ (* zr zr) (* zi zi)) 4.0)) i (recur (inc i) (+ (- (* zr zr) (* zi zi)) cr) (+ (* 2.0 (* zr zi)) ci)))))") - (check "count-point root is native" (cfunction? (api/eval-string ctx "count-point"))) - (api/eval-string ctx "(defn run [n] (let [cap 200 nd (* 1.0 n)] (loop [y 0 acc 0] (if (< y n) (let [ci (- (/ (* 2.0 y) nd) 1.0) row (loop [x 0 a 0] (if (< x n) (let [cr (- (/ (* 2.0 x) nd) 1.5)] (recur (inc x) (+ a (count-point cr ci cap)))) a))] (recur (inc y) (+ acc row))) acc))))") - (check "run stays bytecode (calls a user fn)" (not (cfunction? (api/eval-string ctx "run")))) - (check "native count-point gives the right grid total" (= 3288753 (api/eval-string ctx "(run 200)")))) - (print " (toolchain absent — skipping native pipeline legs)")) - -(if (= 0 failures) - (print "All tests passed.") - (do (eprintf "%d cgen-pipeline check(s) failed" failures) (os/exit 1))) diff --git a/test/integration/cgen-test.janet b/test/integration/cgen-test.janet deleted file mode 100644 index 376a05b..0000000 --- a/test/integration/cgen-test.janet +++ /dev/null @@ -1,86 +0,0 @@ -# Native codegen (jolt-ihdp): IR -> C for numeric-leaf fns. Pins that the C -# translator (1) classifies candidates correctly and (2) produces a native fn -# whose results match the bytecode/interpreted fn over the mandelbrot grid. -# Skips cleanly where the C toolchain (cc + janet.h) is absent — the rest of the -# gate still runs. -(import ../../src/jolt/api :as api) -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/reader :as reader) -(import ../../src/jolt/cgen :as cgen) - -(print "Native codegen IR->C (jolt-ihdp)...") - -(def ctx (api/init-cached {:compile? true})) -(put (ctx :env) :direct-linking? true) -(put (ctx :env) :inline? true) -(api/eval-string ctx "(ns cgentest)") - -(defn ir-of [src] (backend/analyze-form ctx (reader/parse-string src))) - -(def count-point-src - "(defn count-point [cr ci cap] (loop [i 0 zr 0.0 zi 0.0] (if (or (>= i cap) (> (+ (* zr zr) (* zi zi)) 4.0)) i (recur (inc i) (+ (- (* zr zr) (* zi zi)) cr) (+ (* 2.0 (* zr zi)) ci)))))") - -(var failures 0) -(defn check [label ok] (unless ok (++ failures) (eprintf " FAIL: %s" label))) - -# --- classification --- -(check "count-point is a numeric leaf" (cgen/numeric-leaf? (ir-of count-point-src))) -(check "fn calling a non-native fn is NOT a leaf" - (not (cgen/numeric-leaf? (ir-of "(defn f [x] (str x))")))) -(check "fn building a collection is NOT a leaf" - (not (cgen/numeric-leaf? (ir-of "(defn f [x] [x x])")))) -(check "plain numeric expr fn IS a leaf" - (cgen/numeric-leaf? (ir-of "(defn sq [x] (* x x))"))) - -# --- C generation is well-formed (smoke: contains the wrapper + a loop) --- -(def c-src (cgen/gen-c-fn (ir-of count-point-src) "count_point")) -(check "emits a cfunction wrapper" (string/find "cfun_count_point" c-src)) -(check "lowers the loop to a C while" (string/find "while (" c-src)) -(check "unboxes params with janet_getnumber" (string/find "janet_getnumber" c-src)) - -# --- behavioral equivalence (only where the toolchain is present) --- -(if (cgen/toolchain-available?) - (do - # start from a clean cache dir so the content-addressed-file count is exact - (when (os/stat "build/cgen-test") - (each f (os/dir "build/cgen-test") (os/rm (string "build/cgen-test/" f)))) - (api/eval-string ctx count-point-src) - (def bc-cp (api/eval-string ctx "count-point")) # the compiled/interpreted fn - (def c-cp (cgen/compile-fn (ir-of count-point-src) - {:dir "build/cgen-test" :name "count_point_test"})) - (defn callable? [x] (or (function? x) (cfunction? x))) - (check "compile-fn returns a callable" (callable? c-cp)) - (when (callable? c-cp) - # spot points spanning escape-fast .. in-set - (var ptmatch true) - (each [cr ci] [[2.0 2.0] [0.5 0.5] [-0.5 0.6] [0.28 0.0] [-0.74 0.1] [-0.5 0.0] [0.0 0.0]] - (unless (= (c-cp cr ci 200) (bc-cp cr ci 200)) (set ptmatch false))) - (check "C count-point matches bytecode on sample points" ptmatch) - # full mandelbrot grid total - (defn grid-total [cp n] - (def cap 200) (def nd (* 1.0 n)) (var acc 0) (var y 0) - (while (< y n) - (def ci (- (/ (* 2.0 y) nd) 1.0)) (var x 0) (var a 0) - (while (< x n) - (def cr (- (/ (* 2.0 x) nd) 1.5)) (set a (+ a (cp cr ci cap))) (++ x)) - (set acc (+ acc a)) (++ y)) - acc) - (check "C and bytecode agree on the full n=80 grid total" - (= (grid-total c-cp 80) (grid-total bc-cp 80))) - - # caching: the .so is content-addressed, so a second compile of the same - # fn reuses it. Drop the generated .c (keep the .so) then recompile: a - # cache hit loads the existing .so without needing cc/source again. - (def cache-files (filter |(string/has-suffix? ".so" $) (os/dir "build/cgen-test"))) - (check "produced a content-addressed .so" (= 1 (length cache-files))) - (each f (os/dir "build/cgen-test") - (when (string/has-suffix? ".c" f) (os/rm (string "build/cgen-test/" f)))) - (def c-cp2 (cgen/compile-fn (ir-of count-point-src) - {:dir "build/cgen-test" :name "count_point_test"})) - (check "cache hit recompiles without the source .c" - (and (callable? c-cp2) (= (c-cp2 -0.5 0.0 200) 200))))) - (print " (toolchain absent — skipping behavioral equivalence)")) - -(if (= 0 failures) - (print "All tests passed.") - (do (eprintf "%d cgen check(s) failed" failures) (os/exit 1))) diff --git a/test/integration/cli-test.janet b/test/integration/cli-test.janet deleted file mode 100644 index e4404f1..0000000 --- a/test/integration/cli-test.janet +++ /dev/null @@ -1,173 +0,0 @@ -# Smoke-test the command-line flags. Prefer the built binary (baked ctx, ~20ms -# startup); from-source is ~8s cold per invocation, and with ~20 invocations this -# file dominated the (parallel) gate's wall clock. Falls back to running -# main.janet from source when there's no binary, so an unbuilt tree still works — -# the gate (`jpm build && janet run-tests.janet`) builds first, so it's fresh. -(def- jolt-cmd - (if (os/stat "build/jolt") ["build/jolt"] ["janet" "src/jolt/main.janet"])) - -(defn- run [& args] - (def p (os/spawn [;jolt-cmd ;args] :p {:out :pipe :err :pipe})) - (def out (:read (p :out) :all)) - (os/proc-wait p) - (string (or out ""))) - -(defn- run-err [& args] - (def p (os/spawn [;jolt-cmd ;args] :p {:out :pipe :err :pipe})) - (def err (:read (p :err) :all)) - (os/proc-wait p) - (string (or err ""))) - -(var fails 0) -(defn check [label got pred] - (if (pred got) (print " ok " label) - (do (++ fails) (printf " FAIL %s: got %q" label got)))) - -(defn- has [sub] (fn [s] (string/find sub s))) - -(check "--version" (run "--version") (has "jolt v")) -(check "version" (run "version") (has "jolt v")) -(check "--help" (run "--help") (has "Usage")) -(check "help lists nrepl-server" (run "help") (has "nrepl-server")) -(check "-e" (run "-e" "(+ 1 2)") (has "3")) -(check "--eval" (run "--eval" "(* 6 7)") (has "42")) - -# -m requires a namespace and calls its -main with the remaining args -(def tmp (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-cli-" (os/time))) -(os/mkdir tmp) (os/mkdir (string tmp "/app")) -(spit (string tmp "/app/core.clj") - "(ns app.core)\n(defn -main [& args] (println \"MAIN\" (count args)))\n") -(os/setenv "JOLT_PATH" tmp) -(check "-m calls -main with args" (run "-m" "app.core" "a" "b") (has "MAIN 2")) -(os/setenv "JOLT_PATH" nil) -(os/rm (string tmp "/app/core.clj")) (os/rmdir (string tmp "/app")) (os/rmdir tmp) - - - -# --- user-facing error output (jolt-2o7 rounds 1+2) -------------------------- -# Messages are Clojure-shaped; traces show the USER'S fns (compiled fn names -# carry ns/fn-name, demangled by report-error) and never jolt internals. -(check "arith error message rewritten" - (run-err "-e" `(+ 1 "a")`) - (has `Cannot add 1 and "a"`)) -# unary arithmetic (inc/dec) on a non-number: the host error has no "or :r" -# clause, which used to crash the rewriter itself — handle it (jolt audit) -(check "unary arith error does not crash the rewriter" - (run-err "-e" `(inc "x")`) - (fn [s] (and (string/find "expects numbers" s) - (nil? (string/find "could not find method" s))))) -(check "arity error names the fn" - (run-err "-e" "(defn afn [x] x) (afn 1 2)") - (has "Wrong number of args (2) passed to: user/afn")) -(check "nil-call (nil value) keeps the hint" - (run-err "-e" "(def x nil) (x 1)") - (has "Cannot call nil as a function")) -# round 3: typos die at resolve time with Clojure's message, not as nil-calls -(check "unresolved symbol named at resolve time" - (run-err "-e" "(undefined-fn 1)") - (has "Unable to resolve symbol: undefined-fn in this context")) -(check "typo inside fn body also resolves to the message" - (run-err "-e" "(defn f [] (no-such 1)) (f)") - (has "Unable to resolve symbol: no-such")) -(check "trace shows the user's call chain" - (run-err "-e" "(defn inner [x] (let [r (+ x :k)] r)) (defn outer [x] (let [v (inner x)] v)) (outer 1)") - (fn [s] (and (string/find "at user/inner" s) (string/find "at user/outer" s)))) -(check "no jolt-internal frames in user errors" - (run-err "-e" `(+ 1 "a")`) - (fn [s] (nil? (string/find "src/jolt/" s)))) -# --- round 4: load errors carry file:line + the require chain --------------- -(def r4 (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-cli-r4-" (os/time))) -(os/mkdir r4) (os/mkdir (string r4 "/app")) -(spit (string r4 "/app/broken.clj") "(ns app.broken)\n\n(def config\n (+ 1 \"boom\"))\n") -(spit (string r4 "/app/mid.clj") "(ns app.mid (:require [app.broken :as b]))\n") -(spit (string r4 "/app/top.clj") "(ns app.top (:require [app.mid :as m]))\n(defn -main [& a] nil)\n") -(os/setenv "JOLT_PATH" r4) -(def deep-err (run-err "-m" "app.top")) -(check "load error names the failing file:line" deep-err - (has "at " )) -(check "load error points into broken.clj line 3" deep-err - (has "/app/broken.clj:3")) -(check "require chain shows the loading path" deep-err - (fn [s] (and (string/find "while loading" s) (string/find "/app/mid.clj" s) (string/find "/app/top.clj" s)))) -(check "script errors name the script file" - (do (spit (string r4 "/scr.clj") "(ns scr)\n\n(+ 1 \"x\")\n") - (run-err (string r4 "/scr.clj"))) - (has "/scr.clj:3")) -(check "no synthetic position on one-liners" - (run-err "-e" `(+ 1 "a")`) - (fn [s] (nil? (string/find "" s)))) - -# --- round 5: reader errors carry file:line:col ------------------------------ -(check "unterminated string positions in -e" - (run-err "-e" `(+ 1 "abc`) - (has "Syntax error reading source at (:1:10): Unterminated string")) -(check "unterminated list names script file:line:col" - (do (spit (string r4 "/syn.clj") "(ns syn)\n\n(defn f [x]\n (+ x 1\n") - (run-err (string r4 "/syn.clj"))) - (has ":5:1): Unterminated list")) -(check "unmatched delimiter positioned" - (do (spit (string r4 "/app/synreq.clj") "(ns app.synreq)\n\n(def x ])\n") - (spit (string r4 "/app/top2.clj") "(ns app.top2 (:require [app.synreq :as q]))\n(defn -main [& a] nil)\n") - (os/setenv "JOLT_PATH" r4) - (run-err "-m" "app.top2")) - (fn [s] (and (string/find "/app/synreq.clj:3:8): Unmatched delimiter: ]" s) - (string/find "/app/top2.clj:1" s)))) -(check "bad token positioned" - (run-err "-e" "(def x ##Huh)") - (has "Invalid symbolic value: ##Huh")) - -(check "JOLT_DEBUG restores the raw trace" - (do (os/setenv "JOLT_DEBUG" "1") - (def r (run-err "-e" `(+ 1 "a")`)) - (os/setenv "JOLT_DEBUG" nil) - r) - (has "could not find method")) - -# --- success checker default-on in direct-link, off in plain builds ---------- -# A provably-wrong defn (never called, so no runtime error): the checker is the -# only thing that can flag it. Plain build = silent (no dev regression); -# direct-link build = warns by default (free piggyback on inference). -(def tcw (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-tcwarn-" (os/time) ".clj")) -(spit tcw "(ns tcw)\n\n(defn unused [s]\n (inc \"definitely-not-a-number\"))\n") -(check "plain build does not run the checker (no regression)" - (run-err tcw) - (fn [s] (nil? (string/find "type error" s)))) -(check "direct-link build warns by default (free checking)" - (do (os/setenv "JOLT_DIRECT_LINK" "1") - (def r (run-err tcw)) - (os/setenv "JOLT_DIRECT_LINK" nil) - r) - (fn [s] (and (string/find "type error" s) - (string/find "requires a number" s)))) -(check "JOLT_TYPE_CHECK=off disables it even in direct-link" - (do (os/setenv "JOLT_DIRECT_LINK" "1") - (os/setenv "JOLT_TYPE_CHECK" "off") - (def r (run-err tcw)) - (os/setenv "JOLT_DIRECT_LINK" nil) - (os/setenv "JOLT_TYPE_CHECK" nil) - r) - (fn [s] (nil? (string/find "type error" s)))) -# negative/never types (jolt-wwy): calling a non-function is reported by default -# in direct-link; wrong-arity to a user fn under the JOLT_TYPE_CHECK_USER opt-in -(def tcn (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-tcneg-" (os/time) ".clj")) -(spit tcn "(ns tcn)\n\n(defn nope []\n (let [n 5] (n 1)))\n") -(check "direct-link reports calling a number as a function" - (do (os/setenv "JOLT_DIRECT_LINK" "1") - (def r (run-err tcn)) - (os/setenv "JOLT_DIRECT_LINK" nil) - r) - (has "cannot call a number as a function")) -(def tca (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-tcarity-" (os/time) ".clj")) -(spit tca "(ns tca)\n\n(defn f [x y] (+ x y))\n(defn g [] (f 1))\n") -(check "JOLT_TYPE_CHECK_USER reports wrong arity to a user fn" - (do (os/setenv "JOLT_DIRECT_LINK" "1") - (os/setenv "JOLT_TYPE_CHECK_USER" "1") - (def r (run-err tca)) - (os/setenv "JOLT_DIRECT_LINK" nil) - (os/setenv "JOLT_TYPE_CHECK_USER" nil) - r) - (has "wrong number of args (1) passed to `f` (expected 2)")) - -(if (> fails 0) - (error (string "cli-test: " fails " failing check(s)")) - (print "\nAll CLI tests passed!")) diff --git a/test/integration/clojure-stdlib-suite-test.janet b/test/integration/clojure-stdlib-suite-test.janet deleted file mode 100644 index c98f8bc..0000000 --- a/test/integration/clojure-stdlib-suite-test.janet +++ /dev/null @@ -1,61 +0,0 @@ -# Vendored stdlib-namespace battery (jolt-0mb). -# -# clojure.test suites for stdlib namespaces beyond clojure.core, vendored from -# clojurust's clojure-test-suite fork (test/clojure-stdlib/, with corrected -# fixtures where the upstream expectations disagreed with real Clojure). Each -# file runs in the shared per-file worker; we guard a minimum pass count so a -# regression is caught and improvements (e.g. finishing clojure.edn) can raise -# the floor. - -(def files - # [relative-path min-pass must-be-clean?] - [["clojure/walk_test/walk.cljc" 34 true] - ["clojure/zip_test/zip.cljc" 33 true] - ["clojure/data_test/diff.cljc" 61 true] - # clojure.edn reads via clojure.core/read-string (opts/:eof + nil/blank) and - # constructs set/nested values. Only #uuid remains (no real uuid type) — - # jolt-b7y. Guard the passing subset. - ["clojure/edn_test/read_string.cljc" 50 false]]) - -(def root "test/clojure-stdlib") -(def per-file-timeout 6) - -(defn- run-file [path] - (def proc (os/spawn ["janet" "test/integration/suite-worker.janet" path] :p {:out :pipe})) - (def out (proc :out)) - (var data nil) - (def ok (try - (ev/with-deadline per-file-timeout - (set data (ev/read out 0x10000)) - (os/proc-wait proc) true) - ([err] false))) - (when (not ok) - (protect (os/proc-kill proc true)) - (protect (ev/with-deadline 2 (os/proc-wait proc)))) - (protect (:close out)) - (if (and ok data) (string data) nil)) - -(defn- counts [s] - (var r nil) - (each line (string/split "\n" (or s "")) - (when (string/has-prefix? "@@COUNTS " line) - (let [p (string/split " " (string/trim line))] - (when (= 4 (length p)) (set r [(scan-number (p 1)) (scan-number (p 2)) (scan-number (p 3))]))))) - r) - -(var failures 0) -(each [rel min-pass clean?] files - (def path (string root "/" rel)) - (def c (counts (run-file path))) - (if (nil? c) - (do (++ failures) (printf "FAIL %s: no result (crash/timeout)" rel)) - (let [[p f e] c] - (printf " %-34s pass=%d fail=%d err=%d" rel p f e) - (when (< p min-pass) - (++ failures) (printf "FAIL %s: pass %d < baseline %d" rel p min-pass)) - (when (and clean? (or (pos? f) (pos? e))) - (++ failures) (printf "FAIL %s: expected clean, got %d fail / %d err" rel f e))))) - -(if (pos? failures) - (do (printf "clojure-stdlib-suite: %d failure(s)" failures) (os/exit 1)) - (print "clojure-stdlib-suite: OK")) diff --git a/test/integration/clojure-test-suite-test.janet b/test/integration/clojure-test-suite-test.janet deleted file mode 100644 index 7bce4d5..0000000 --- a/test/integration/clojure-test-suite-test.janet +++ /dev/null @@ -1,163 +0,0 @@ -# clojure-test-suite conformance: runs the external, cross-dialect -# clojure-test-suite (jank-lang fork) against Jolt and asserts the number of -# passing per-function test files stays at/above a baseline. The suite is a git -# submodule at vendor/clojure-test-suite (CI checks it out via submodules: -# recursive). The test SKIPS cleanly only if the submodule isn't initialized -# (run `git submodule update --init`). -# -# Each suite file is a `clojure.test` namespace (one per clojure.core/string -# function). A minimal clojure.test + portability shim (test/support/clojure_test.clj) -# lets Jolt load them; `when-var-exists` auto-skips fns Jolt doesn't implement. -# -# Files are run in a one-shot worker subprocess (test/integration/suite-worker.janet) -# under a wall-clock deadline. A few suite tests build infinite sequences that an -# uncompilable/eager path can't truncate and so HANG rather than fail; the -# deadline contains them — a timed-out file contributes nothing, no skip-list. - -(def suite-dir "vendor/clojure-test-suite/test/clojure") - -# Baseline: assertions Jolt currently passes across the suite. Raise as Jolt -# improves so a regression (previously-passing assertion breaking) is caught. -# Lowered 3915 -> 3913 when futures landed: `realized?`/realized_qmark.cljc has a -# `(when-var-exists future ...)` block that was skipped while `future` was -# unresolved. With futures implemented the block now runs, but it depends on JVM -# `Thread/sleep` (jolt has no JVM interop) and on `future-cancel` interrupting a -# running thread (Janet OS threads can't be interrupted), so `(deref (future -# (sleep 1)))` re-raises the unresolved-`Thread/sleep` error — a documented -# platform gap, not a regression in any previously-working behavior. -# Raised 3913 -> 3916 with the staged-bootstrap kernel tier (ns-restore-on-throw -# + faithful subvec coercion), then 3916 -> 3919 moving juxt/every-pred/some-fn to -# Clojure (the canonical defs are more correct than the prior Janet ones). Raised -# 3919 -> 3926 preserving nil map values (jolt-c7h): a nil value is a present key, -# which several suite tests assert. Runs read 3927 consistently, occasionally 3926 -# when a timeout-prone test (of the 9 that can time out) doesn't finish; floor at -# the consistent-minus-one 3926. -# Raised 3971 -> 3981 with Option A full laziness (jolt-fng): transformers return -# lazy seqs, lazy interleave stops timing out, and the lazy-seq nil-element + -# non-seqable-input fixes (case/seq/reverse/empty? over nil-first lazy seqs; -# lazy-from throws on non-seqable like Clojure) recovered + extended the suite. -# clean files 45 -> 66 (Option A makes seq?/vector? results match Clojure across -# many cross-dialect files). Stable across runs. -# Raised 3981 -> 4004 migrating 7 lazy seq fns to the Clojure overlay (40-lazy -# tier): the canonical CLJ versions add coverage (e.g. distinct value-equality). -# Raised 4004 -> 4034 / clean 66 -> 67 porting partition-all + repeatedly to the -# overlay, which required fixing two leniencies (a char is not callable; take -# validates its count) — correct beyond those fns, so the suite rose broadly. -# Raised 4660 -> 4695 (observed 4703) after the seed-shrink rounds: rest/next -# over sets/maps/sorted colls fixed (they walked the wrapper table's internal -# fields), canonical halt-when/==/memfn. Margin covers rand-based suite jitter. -(def baseline-pass 4695) -# A file is "clean" when it ran with zero failures AND zero errors. -(def baseline-clean-files 88) -# Per-file wall-clock budget (seconds). Normal files finish in well under 1s, so -# this normally only fires on genuinely-infinite-sequence hangs. It's an env var -# (JOLT_SUITE_TIMEOUT) so CI — whose runners are slower than a dev machine — can -# give slow-but-finite files generous headroom without timing them out (which -# would drop total-pass below the baseline and flake CI red). Default 6 locally. -(def per-file-timeout - (let [e (os/getenv "JOLT_SUITE_TIMEOUT")] - (or (and e (scan-number e)) 6))) - -(defn- walk [dir acc] - (each e (os/dir dir) - (def p (string dir "/" e)) - (case ((os/stat p) :mode) - :directory (walk p acc) - :file (when (and (string/has-suffix? ".cljc" p) - (not (string/has-suffix? "portability.cljc" p))) - (array/push acc p)))) - acc) - -# Run one file in a worker subprocess; return its "pass fail error" stdout, or -# nil if it exceeded the deadline (hang) or crashed. -(defn- run-file [path] - (def proc (os/spawn ["janet" "test/integration/suite-worker.janet" path] :p {:out :pipe})) - (def out (proc :out)) - (var data nil) - (def ok - (try - (ev/with-deadline per-file-timeout - (set data (ev/read out 0x10000)) # workers print a single short line - (os/proc-wait proc) - true) - ([err] false))) - (when (not ok) - (protect (os/proc-kill proc true)) - (protect (ev/with-deadline 2 (os/proc-wait proc)))) - (protect (:close out)) - (if (and ok data) (string data) nil)) - -(defn- parse-counts [s] - # Find the "@@COUNTS p f e" sentinel line (a test body may have printed other - # lines to stdout, e.g. with-out-str tests). - (var result nil) - (each line (string/split "\n" s) - (when (string/has-prefix? "@@COUNTS " line) - (let [parts (string/split " " (string/trim line))] - (when (= 4 (length parts)) - (set result [(scan-number (parts 1)) (scan-number (parts 2)) (scan-number (parts 3))]))))) - result) - -(if (not (os/stat suite-dir)) - (print "clojure-test-suite: vendor/clojure-test-suite not initialized — skipped (run: git submodule update --init)") - (do - (def progress? (os/getenv "SUITE_PROGRESS")) - (def files (sort (walk suite-dir @[]))) - (var total-pass 0) - (var total-fail 0) - (var total-error 0) - (var clean-files 0) - (var ran-files 0) - (var timeouts 0) - (def worst @[]) - - # Worker pool: each file is already its own subprocess (isolation + hang - # containment), so concurrency only changes wall-clock. A token-channel - # semaphore caps the live workers; os/spawn / ev/read / os/proc-wait are - # event-loop aware so the fibers genuinely interleave. Totals are - # order-independent. Default 4 keeps per-file wall-clock deadlines honest - # on small CI runners; override with JOLT_SUITE_WORKERS. - (def nworkers - (min 8 (max 1 (or (scan-number (or (os/getenv "JOLT_SUITE_WORKERS") "")) - (os/cpu-count) 4)))) - (def sem (ev/chan nworkers)) - (def done (ev/chan (length files))) - (each path files - (ev/spawn - (ev/give sem :tok) # acquire (blocks when pool is full) - (def out (run-file path)) - (ev/take sem) # release - (ev/give done [path out]))) - (for _ 0 (length files) - (def [path out] (ev/take done)) - (def rel (string/slice path (+ 1 (length suite-dir)))) - (def counts (and out (parse-counts out))) - (when progress? - (eprintf " %s%s" rel (cond (nil? out) " TIMEOUT" (nil? counts) " (no counts)" "")) - (eflush)) - (cond - (nil? out) (++ timeouts) - (nil? counts) nil - (let [[pn fn* en] counts] - (++ ran-files) - (+= total-pass pn) - (+= total-fail fn*) - (+= total-error en) - (when (and (= 0 fn*) (= 0 en) (> pn 0)) (++ clean-files)) - (when (> (+ fn* en) 0) (array/push worst [(+ fn* en) rel pn fn* en]))))) - - (def total (+ total-pass total-fail total-error)) - (printf "\nclojure-test-suite: %d files ran (%d timed out), %d assertions — %d pass / %d fail / %d error" - ran-files timeouts total total-pass total-fail total-error) - (printf "\n clean files (0 fail/error, >0 pass): %d" clean-files) - (sort-by (fn [x] (- (x 0))) worst) - (when (> (length worst) 0) - (print " top files by fail+error:") - (each w (slice worst 0 (min 15 (length worst))) - (printf " %-40s pass=%d fail=%d err=%d" (w 1) (w 2) (w 3) (w 4)))) - - (assert (>= total-pass baseline-pass) - (string/format "regression: total-pass %d < baseline %d" total-pass baseline-pass)) - (assert (>= clean-files baseline-clean-files) - (string/format "regression: clean-files %d < baseline %d" clean-files baseline-clean-files)) - (printf "\nclojure-test-suite: OK (>= %d pass, >= %d clean files)\n" baseline-pass baseline-clean-files))) diff --git a/test/integration/compile-mode-test.janet b/test/integration/compile-mode-test.janet deleted file mode 100644 index 35cfdaf..0000000 --- a/test/integration/compile-mode-test.janet +++ /dev/null @@ -1,171 +0,0 @@ -(use ../../src/jolt/api) - -(defn ct-eval [ctx s] (normalize-pvecs (eval-string ctx s))) - -(print "Phase 6: comprehensive compile-mode tests...") -(let [ctx (init-cached {:compile? true})] - - (print " collections...") - (assert (= :a (ct-eval ctx "(nth [:a :b :c :d] 0)")) "nth") - (assert (= true (ct-eval ctx "(vector? [1 2])")) "vector?") - (assert (= true (ct-eval ctx "(map? {:a 1})")) "map?") - (assert (= true (ct-eval ctx "(fn? inc)")) "fn?") - (assert (= [1 2 3 4] (ct-eval ctx "(conj [1 2 3] 4)")) "conj") - (assert (= 1 (ct-eval ctx "(first [1 2 3])")) "first") - (assert (= [2 3] (ct-eval ctx "(rest [1 2 3])")) "rest") - (assert (= 1 (ct-eval ctx "(get {:a 1 :b 2} :a)")) "get map") - (assert (= nil (ct-eval ctx "(get {:a 1} :z)")) "get missing") - (assert (= 3 (ct-eval ctx "(count {:a 1 :b 2 :c 3})")) "count map") - (assert (= [1 2 3] (ct-eval ctx "(into [1] [2 3])")) "into") - - (print " core math...") - (assert (= 3 (ct-eval ctx "(+ 1 2)")) "+") - (assert (= 1 (ct-eval ctx "(- 3 2)")) "-") - (assert (= 6 (ct-eval ctx "(* 2 3)")) "*") - (assert (= 2 (ct-eval ctx "(/ 4 2)")) "/") - (assert (= 3 (ct-eval ctx "(inc 2)")) "inc") - (assert (= 1 (ct-eval ctx "(dec 2)")) "dec") - (assert (= 1 (ct-eval ctx "(quot 5 3)")) "quot") - (assert (= 2 (ct-eval ctx "(rem 5 3)")) "rem") - (assert (= 2 (ct-eval ctx "(mod 5 3)")) "mod") - (assert (= 3 (ct-eval ctx "(max 1 2 3)")) "max") - (assert (= 1 (ct-eval ctx "(min 1 2 3)")) "min") - - (print " predicates...") - (assert (= true (ct-eval ctx "(nil? nil)")) "nil?") - (assert (= false (ct-eval ctx "(nil? 1)")) "nil? false") - (assert (= true (ct-eval ctx "(zero? 0)")) "zero?") - (assert (= true (ct-eval ctx "(pos? 5)")) "pos?") - (assert (= true (ct-eval ctx "(neg? -1)")) "neg?") - (assert (= true (ct-eval ctx "(even? 4)")) "even?") - (assert (= true (ct-eval ctx "(odd? 3)")) "odd?") - (assert (= false (ct-eval ctx "(not true)")) "not") - (assert (= true (ct-eval ctx "(some? 1)")) "some?") - (assert (= true (ct-eval ctx "(string? \"hello\")")) "string?") - (assert (= true (ct-eval ctx "(number? 42)")) "number?") - (assert (= true (ct-eval ctx "(keyword? :foo)")) "keyword?") - (assert (= true (ct-eval ctx "(= 1 1)")) "=") - (assert (= true (ct-eval ctx "(< 1 2)")) "<") - (assert (= true (ct-eval ctx "(> 2 1)")) ">") - (assert (= true (ct-eval ctx "(<= 1 1)")) "<=") - (assert (= true (ct-eval ctx "(>= 2 2)")) ">=") - - (print " seq operations...") - (assert (= [2 3 4] (ct-eval ctx "(map inc [1 2 3])")) "map") - (assert (= [2 4] (ct-eval ctx "(filter even? [1 2 3 4])")) "filter") - (assert (= [1 3] (ct-eval ctx "(remove even? [1 2 3 4])")) "remove") - (assert (= 6 (ct-eval ctx "(reduce + [1 2 3])")) "reduce") - (assert (= [1 2 3] (ct-eval ctx "(take 3 [1 2 3 4 5])")) "take") - (assert (= [4 5] (ct-eval ctx "(drop 3 [1 2 3 4 5])")) "drop") - - (print " special forms...") - (assert (= 30 (ct-eval ctx "(let [x 10 y 20] (+ x y))")) "let") - (assert (= :a (ct-eval ctx "(if true :a :b)")) "if true") - (assert (= :b (ct-eval ctx "(if false :a :b)")) "if false") - (assert (= 3 (ct-eval ctx "(loop [x 0] (if (< x 3) (recur (inc x)) x))")) "loop") - (assert (= "caught" (ct-eval ctx "(try (throw 42) (catch Exception e \"caught\"))")) "try") - (assert (= 42 (ct-eval ctx "'42")) "quote literal") - - (print " macros...") - (ct-eval ctx "(defn add [a b] (+ a b))") - (assert (= 7 (ct-eval ctx "(add 3 4)")) "defn") - (assert (= 42 (ct-eval ctx "(when true 42)")) "when true") - (assert (= 3 (ct-eval ctx "(and 1 2 3)")) "and") - (assert (= 1 (ct-eval ctx "(or 1 2 3)")) "or") - (assert (= 49 (ct-eval ctx "((fn [x] (* x x)) 7)")) "fn macro") - (assert (= 2 (ct-eval ctx "(if-let [x 1] (inc x) 0)")) "if-let") - - (print " complex...") - (assert (= 6 (ct-eval ctx "(let [f (fn [n] (loop [i 0 acc 0] (if (< i n) (recur (inc i) (+ acc i)) acc)))] (f 4))")) "nested") - (assert (= 15 (ct-eval ctx "(reduce + (map inc [0 1 2 3 4]))")) "reduce+map") - - # Phase 1 wiring: compiled defns persist across forms (the per-context Janet - # env) and recurse correctly (named-fn self-reference). - (print " cross-form defns + recursion...") - (eval-string ctx "(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))") - (assert (= 832040 (ct-eval ctx "(fib 30)")) "recursive fib across forms") - (eval-string ctx "(defn sq [x] (* x x))") - (eval-string ctx "(defn sum-sq [a b] (+ (sq a) (sq b)))") - (assert (= 25 (ct-eval ctx "(sum-sq 3 4)")) "defn calling earlier defn") - (eval-string ctx "(def base 100)") - (assert (= 142 (ct-eval ctx "(+ base 42)")) "compiled def referenced later") - - # Phase 2: native ops are emitted directly (fast), but IFn values in call - # position (keyword/map/set) still dispatch via the runtime. - (print " native ops + IFn dispatch...") - (assert (= 10 (ct-eval ctx "(+ 1 2 3 4)")) "n-ary +") - (assert (= true (ct-eval ctx "(< 1 2 3)")) "n-ary <") - (assert (= 1 (ct-eval ctx "(:a {:a 1})")) "keyword as fn") - (assert (= 1 (ct-eval ctx "({:a 1} :a)")) "map as fn") - (assert (= 2 (ct-eval ctx "(#{1 2 3} 2)")) "set as fn") - (assert (= true (ct-eval ctx "(= [1 2] [1 2])")) "= is value equality, not core-= bypass") - - # Phase 2: hybrid fallback. Forms the compiler can't compile (destructuring, - # multi-arity, named fns) interpret instead of erroring or miscompiling. The - # result is the same — compilation is a transparent speedup. - (print " hybrid fallback (destructuring / multi-arity)...") - (assert (= 3 (ct-eval ctx "(let [[a b] [1 2]] (+ a b))")) "vector destructuring let") - (assert (= 6 (ct-eval ctx "(let [{:keys [x y z]} {:x 1 :y 2 :z 3}] (+ x y z))")) "map destructuring let") - (assert (= 3 (ct-eval ctx "((fn [[a b]] (+ a b)) [1 2])")) "destructuring fn param") - (assert (= 5 (ct-eval ctx "(let [[a & more] [1 2 3 4 5]] (+ a (count more)))")) "rest destructuring") - (ct-eval ctx "(defn arity ([a] a) ([a b] (+ a b)) ([a b & more] (apply + a b more)))") - (assert (= 5 (ct-eval ctx "(arity 5)")) "multi-arity 1") - (assert (= 7 (ct-eval ctx "(arity 3 4)")) "multi-arity 2") - (assert (= 15 (ct-eval ctx "(arity 1 2 3 4 5)")) "multi-arity variadic clause") - (assert (= 10 (ct-eval ctx "((fn self [n] (if (zero? n) 0 (+ n (self (dec n))))) 4)")) "named fn recursion") - # recur directly inside a fn (not a loop) — re-enters the fn's arity. Compiles - # to a self-call; was previously broken under compilation. - (assert (= 15 (ct-eval ctx "((fn [n acc] (if (zero? n) acc (recur (dec n) (+ acc n)))) 5 0)")) "recur in fn") - (assert (= 3 (ct-eval ctx "((fn cnt [acc & xs] (if (seq xs) (recur (inc acc) (rest xs)) acc)) 0 :a :b :c)")) "recur into variadic arity") - (assert (= 6 (ct-eval ctx "(loop [[x & xs] [1 2 3] acc 0] (if x (recur xs (+ acc x)) acc))")) "destructuring loop binding") - # A runtime error in compiled code must propagate, not silently fall back to a - # second (interpreted) evaluation. - (assert (= :threw (try (do (ct-eval ctx "(inc nil)") :no-throw) ([_] :threw))) - "runtime error in compiled code propagates")) - -# Context isolation: a def in one compiled context is invisible in another. With -# var-indirection each context has its own var cells, so in b `secret` does not -# resolve at all ('Unable to resolve symbol', jolt-2o7.3) rather than seeing a's 7. -(let [a (init-cached {:compile? true}) b (init-cached {:compile? true})] - (eval-string a "(def secret 7)") - (assert (= 7 (ct-eval a "secret")) "def visible in its own ctx") - (def r (protect (ct-eval b "secret"))) - (assert (and (not (r 0)) - (string/find "Unable to resolve symbol: secret" (string/format "%q" (r 1)))) - "def isolated to its ctx (unresolved there)")) - -# Redefinition is visible to already-compiled callers (var-indirection). -(let [c (init-cached {:compile? true})] - (eval-string c "(defn g [] 1)") - (eval-string c "(defn calls-g [] (g))") - (eval-string c "(defn g [] 2)") - (assert (= 2 (ct-eval c "(calls-g)")) "compiled caller sees redefined global")) - -# Map-literal metadata on a def'd name reads as (def (with-meta name m) v); the -# analyzer must route it to the interpreter (uncompilable), not die extracting -# the name. Regression: yogthos/config's (defonce ^{:doc "…"} env …) broke -# every load-string/uberscript path while loading fine through require. -(let [c (init-cached {:compile? true})] - (assert (= 42 (do (eval-string c `(def ^{:doc "d"} md-def 42)`) - (ct-eval c "md-def"))) - "compile-mode def with ^{:map} metadata") - (assert (= "d" (ct-eval c "(:doc (meta (var md-def)))")) - "map metadata lands on the var") - (assert (= 7 (do (eval-string c `(defonce ^{:doc "o"} md-once 7)`) - (ct-eval c "md-once"))) - "compile-mode defonce with ^{:map} metadata")) - -# (declare name) must intern a var so a compiled forward reference binds to it — -# not to a like-named Janet host builtin. Regression: selmer.parser's -# (declare parse) + a (parse …) call compiled to janet's 1-arg `parse`. -(let [c (init-cached {:compile? true})] - (eval-string c "(declare parse)") - (eval-string c "(defn callit [s] (parse s 1 2))") - (eval-string c "(defn parse [s a b] [s a b])") - (assert (deep= ["x" 1 2] (ct-eval c `(callit "x")`)) - "compiled forward ref through declare beats host fallback") - (eval-string c "(def no-init-var)") - (assert (= true (ct-eval c "(do (def no-init-var 5) (= 5 no-init-var))")) - "(def name) with no init interns; later def binds")) - -(print "\nAll Phase 6 tests passed!") diff --git a/test/integration/config-lib-test.janet b/test/integration/config-lib-test.janet deleted file mode 100644 index 30e0bba..0000000 --- a/test/integration/config-lib-test.janet +++ /dev/null @@ -1,75 +0,0 @@ -# yogthos/config acceptance: load the real library from ~/src/config and run -# its whole surface — PushbackReader over io/reader, edn/read from a reader, -# Long/parseLong + BigInteger. + Boolean/parseBoolean, System/getenv + -# System/getProperties as iterable maps, str->value, keywordize, deep-merge, -# and the defonce env built at load. SKIPS cleanly when the checkout is -# absent (CI); the shim surface itself is covered by host-interop-spec. - -(import ../../src/jolt/api :as api) -(use ../../src/jolt/reader) - -(def config-src (string (os/getenv "HOME") "/src/config/src")) - -(if (nil? (os/stat (string config-src "/config/core.clj"))) - (print "config-lib-test: ~/src/config not present, skipping") - (do - (reader-features-set! ["jolt" "clj" "default"]) - - # run from a temp project dir so config.edn/.lein-env are controlled - (def base (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-config-lib-" (os/time))) - (defn rmrf [p] - (when (os/stat p) - (if (= :directory (os/stat p :mode)) - (do (each e (os/dir p) (rmrf (string p "/" e))) (os/rmdir p)) - (os/rm p)))) - (rmrf base) - (os/mkdir base) - (spit (string base "/config.edn") - "{:db {:host \"localhost\"\n :port 5432}\n :app-name \"demo\"}\n") - (spit (string base "/.lein-env") "{:db {:port 9999}}") - (os/cd base) - (os/setenv "CONFIG_TEST_NUM" "42") - (os/setenv "CONFIG_TEST_FLAG" "true") - (os/setenv "CONFIG_TEST_EDN" "{:x 1}") - - (def ctx (api/init {:paths [config-src]})) - - (print "loading config.core (defonce env runs load-env at require)...") - (api/eval-string ctx "(require (quote [config.core :as cfg]))") - (print " ok") - - (var fails 0) - (defn check [label expr expected] - (def r (protect (api/eval-string ctx expr))) - (def got (if (r 0) (r 1) (string "ERR " (r 1)))) - (if (deep= got expected) (print " ok " label) - (do (++ fails) (printf " FAIL %s: want %q, got %q" label expected got)))) - - (print "config.edn + .lein-env deep merge...") - (check "nested value from config.edn" "(get-in cfg/env [:db :host])" "localhost") - (check ".lein-env overrides nested" "(get-in cfg/env [:db :port])" 9999) - (check "top-level value" "(:app-name cfg/env)" "demo") - (print "env vars keywordized + converted...") - (check "numeric env var is a number" "(:config-test-num cfg/env)" 42) - (check "boolean env var" "(:config-test-flag cfg/env)" true) - (check "edn env var parses" "(= {:x 1} (:config-test-edn cfg/env))" true) - (print "library fns directly...") - (check "str->value number" "(cfg/str->value \"17\")" 17) - (check "str->value bool" "(cfg/str->value \"false\")" false) - (check "str->value word" "(cfg/str->value \"hello\")" "hello") - (check "str->value edn vec" "(= [1 2] (cfg/str->value \"[1 2]\"))" true) - (check "str->value symbol stays str" "(cfg/str->value \"foo/bar\")" "foo/bar") - (check "keywordize" "(cfg/keywordize \"FOO_BAR__BAZ_QMARK_\")" :foo-bar/baz?) - (check "read-config-file" "(get-in (cfg/read-config-file \"config.edn\") [:db :port])" 5432) - (check "deep-merge-with" - "(= {:a {:b 3}} (cfg/deep-merge-with + {:a {:b 1}} {:a {:b 2}}))" true) - (print "reload-env...") - (check "reload-env returns merged map" - "(do (cfg/reload-env) (get-in cfg/env [:db :host]))" "localhost") - - (os/cd "/") - (rmrf base) - - (if (> fails 0) - (error (string "config-lib-test: " fails " failing check(s)")) - (print "\nconfig-lib-test: all passed")))) diff --git a/test/integration/conformance-test.janet b/test/integration/conformance-test.janet deleted file mode 100644 index 2dee3aa..0000000 --- a/test/integration/conformance-test.janet +++ /dev/null @@ -1,569 +0,0 @@ -# Clojure conformance harness (phase 1: extracted assertion pairs). -# -# Each case is [name expected-clj actual-clj]. The harness evaluates the -# single Clojure program (= ) inside a fresh jolt ctx -# and asserts it returns boolean true. Comparison therefore uses jolt's OWN -# `=`, which implements Clojure sequential/collection equality -- so results -# reflect real Clojure semantics rather than Janet-level identity. -# -# `actual` may be a multi-form body; wrap such cases in (do ...). -# -# Source of truth: ~/src/clojure/test/clojure/test_clojure/*.clj -# These pairs are hand-extracted from those files (and canonical idioms) -# until a minimal clojure.test lets us load the real files directly. - -(use ../../src/jolt/api) -(import ../../src/jolt/backend :as selfhost) -(use ../../src/jolt/reader) - -(def cases - [ - ### ---- CRITICAL: lazy sequences ---- - ["self-ref lazy-cat fib" - "(quote (0 1 1 2 3 5 8 13 21 34))" - "(do (def fib-seq (lazy-cat [0 1] (map + (rest fib-seq) fib-seq))) (take 10 fib-seq))"] - ["self-ref lazy-seq ones" - "(quote (1 1 1 1 1))" - "(do (def ones (lazy-seq (cons 1 ones))) (take 5 ones))"] - ["self-ref lazy-seq nats" - "(quote (0 1 2 3 4))" - "(do (def nats (lazy-cat [0] (map inc nats))) (take 5 nats))"] - - ### ---- CRITICAL: multi-collection map ---- - ["map two colls" "(quote (11 22 33))" "(map + [1 2 3] [10 20 30])"] - ["map three colls" "(quote (12 24 36))" "(map + [1 2 3] [10 20 30] [1 2 3])"] - ["map uneven (shortest)" "(quote ([1 :a] [2 :b]))" "(map vector [1 2 3] [:a :b])"] - ["map over range+vec" "(quote (1 3 5))" "(map + (range 3) [1 2 3])"] - ["map fn list arg" "(quote (2 3 4))" "(map inc (list 1 2 3))"] - - ### ---- CRITICAL: iterate / infinite seqs ---- - ["iterate" "(quote (0 1 2 3 4))" "(take 5 (iterate inc 0))"] - ["iterate double" "(quote (1 2 4 8 16))" "(take 5 (iterate (fn [x] (* 2 x)) 1))"] - ["range over inf map" "(quote (1 2 3))" "(take 3 (map inc (range)))"] - ["count of take" "100" "(count (take 100 (range)))"] - ["last of take" "5" "(last (take 5 (iterate inc 1)))"] - - ### ---- CRITICAL: collections as IFn ---- - ["vector as fn" ":b" "([:a :b :c] 1)"] - ["map as fn" "1" "({:a 1} :a)"] - ["map as fn miss" "nil" "({:a 1} :z)"] - ["map as fn default" "99" "({:a 1} :z 99)"] - ["set as fn" "2" "(#{1 2 3} 2)"] - ["set as fn miss" "nil" "(#{1 2 3} 9)"] - # set literals compile (Stage 1 Task 1): computed elements are each evaluated - # then the persistent set is built, matching the interpreter. - ["set literal computed" "true" "(= #{1 2} #{(inc 0) 2})"] - ["empty set literal" "true" "(empty? #{})"] - ["set literal count" "3" "(count #{1 2 3})"] - ["set literal in let" "true" "(let [x 5] (= #{5 6} #{x (inc x)}))"] - # set?/disj compile as plain fns now (jolt-g3h), not special forms - ["set? true" "true" "(set? #{1 2 3})"] - ["set? false" "false" "(set? [1 2])"] - ["disj one" "#{1 3}" "(disj #{1 2 3} 2)"] - ["disj many" "#{1}" "(disj #{1 2 3} 2 3)"] - ["disj absent" "#{1 2}" "(disj #{1 2} 5)"] - ["keyword as fn" "1" "(:a {:a 1})"] - ["map fn over coll" "(quote (1 3))" "(map {:a 1 :b 3} [:a :b])"] - - ### ---- CRITICAL: vec / into over lazy + maps ---- - ["vec of map-result" "[2 3 4]" "(vec (map inc [1 2 3]))"] - ["vec of range" "[0 1 2 3 4]" "(vec (range 5))"] - ["into vec" "[1 2 3 4 5 6]" "(into [1 2 3] [4 5 6])"] - ["into vec from lazy" "[2 3 4]" "(into [] (map inc [1 2 3]))"] - ["into map pairs" "{:a 1 :b 2}" "(into {} [[:a 1] [:b 2]])"] - ["into map onto map" "{:a 1 :b 2 :c 3}" "(into {:a 1} [[:b 2] [:c 3]])"] - ["into list" "(quote (3 2 1))" "(into (list) [1 2 3])"] - - ### ---- Option A: lazy transformers return seqs, not vectors ---- - # map/filter/take/take-while over a concrete vector yield a lazy seq, matching - # Clojure: (seq? (map ...)) is true, (vector? (map ...)) is false. - ["map vec is seq" "true" "(seq? (map inc [1 2 3]))"] - ["map vec not vector" "false" "(vector? (map inc [1 2 3]))"] - ["filter vec is seq" "true" "(seq? (filter odd? [1 2 3]))"] - ["take vec is seq" "true" "(seq? (take 2 [1 2 3]))"] - ["map over set" "true" "(= #{2 3 4} (set (map inc #{1 2 3})))"] - ["filter over map ev" "(quote ([:b 2]))" "(filter (fn [[k v]] (> v 1)) {:a 1 :b 2})"] - # cons of cons over a lazy tail must not leak the rest-thunk - ["cons cons lazy" "(quote (1 2 3))" "(cons 1 (cons 2 (lazy-seq (cons 3 nil))))"] - ["juxt fns in vec" "[1 3]" "((juxt first last) [1 2 3])"] - ["last of lazy take" "5" "(last (take 5 (iterate inc 1)))"] - ["next empty lazy" "nil" "(next (take 1 [1]))"] - # drop/distinct/partition/map-indexed/take-nth/interpose/keep are lazy too - ["drop vec is seq" "true" "(seq? (drop 1 [1 2 3]))"] - ["distinct vec is seq" "true" "(seq? (distinct [1 1 2]))"] - ["map-indexed is seq" "true" "(seq? (map-indexed vector [1 2]))"] - ["partition vec lazy" "(quote ((1 2) (3 4)))" "(partition 2 [1 2 3 4 5])"] - # nth over a lazy seq must not treat a false/nil element as end-of-seq - ["nth lazy false elem" "false" "(nth (map identity [false 1 2]) 0)"] - ["nth lazy past false" "2" "(nth (drop 1 (list false 1 2)) 1)"] - ["cond-> false clause" "2" "(cond-> 1 true inc false inc)"] - - ### ---- HIGH: destructuring ---- - ["destr nested seq" "[1 2 3]" "(let [[a [b c]] [1 [2 3]]] [a b c])"] - ["destr rest+as" "[1 (quote (2 3)) [1 2 3]]" "(let [[a & r :as all] [1 2 3]] [a r all])"] - ["destr map :keys" "[1 2]" "(let [{:keys [a b]} {:a 1 :b 2}] [a b])"] - ["destr map :or" "[1 99]" "(let [{:keys [a b] :or {b 99}} {:a 1}] [a b])"] - ["destr map :strs" "[1 2]" "(let [{:strs [a b]} {\"a\" 1 \"b\" 2}] [a b])"] - ["destr map :as" "[1 {:a 1}]" "(let [{:keys [a] :as m} {:a 1}] [a m])"] - ["destr nested map" "5" "(let [{{:keys [x]} :pos} {:pos {:x 5}}] x)"] - ["destr fn-param seq" "7" "((fn [[a b]] (+ a b)) [3 4])"] - ["destr fn-param map" "3" "((fn [{:keys [a b]}] (+ a b)) {:a 1 :b 2})"] - ["destr let map key" "1" "(let [{a :a} {:a 1}] a)"] - - ### ---- HIGH: update / assoc-in on map literals ---- - ["update inc" "{:a 2}" "(update {:a 1} :a inc)"] - ["update extra args" "{:a 111}" "(update {:a 1} :a + 10 100)"] - ["update-in" "{:a {:b 2}}" "(update-in {:a {:b 1}} [:a :b] inc)"] - ["assoc-in" "{:a {:b 1 :c 2}}" "(assoc-in {:a {:b 1}} [:a :c] 2)"] - ["assoc-in create" "{:a {:b 1}}" "(assoc-in {} [:a :b] 1)"] - ["update-in fnil" "{:a {:b 1}}" "(update-in {} [:a :b] (fnil inc 0))"] - ["get-in" "1" "(get-in {:a {:b {:c 1}}} [:a :b :c])"] - - ### ---- native-op parity (compile emits janet ops at guarded arities) ---- - ["native mod floored" "2" "(mod -7 3)"] - ["native rem truncated" "-1" "(rem -7 3)"] - ["native unary div" "0.5" "(/ 2)"] - ["native chained div" "1" "(/ 6 3 2)"] - ["native bit-and" "8" "(bit-and 12 10)"] - ["native bit-xor" "6" "(bit-xor 12 10)"] - ["native bit-not" "-6" "(bit-not 5)"] - ["native shifts" "[16 2]" "[(bit-shift-left 4 2) (bit-shift-right 8 2)]"] - - ### ---- multimethod preferences (jolt-heo) ---- - ["prefer-method breaks tie" ":rect" - "(do (derive :cm/sq :cm/rect) (derive :cm/sq :cm/shape) (defmulti cmf identity) (defmethod cmf :cm/rect [x] :rect) (defmethod cmf :cm/shape [x] :shape) (prefer-method cmf :cm/rect :cm/shape) (cmf :cm/sq))"] - - ### ---- HIGH: str semantics ---- - ["str nil empty" "\"\"" "(str nil)"] - ["str concat nil" "\"a1\"" "(str \"a\" 1 nil)"] - ["str keyword" "\":b\"" "(str :b)"] - ["str symbol" "\"foo\"" "(str (quote foo))"] - ["str mixed" "\"a:b1\"" "(str \"a\" :b 1)"] - ["str seq" "\"[1 2 3]\"" "(str [1 2 3])"] - - ### ---- HIGH: dispatch ---- - ["multimethod" "9" "(do (defmulti area :shape) (defmethod area :sq [s] (* (:s s) (:s s))) (area {:shape :sq :s 3}))"] - ["multimethod default" ":def" "(do (defmulti f identity) (defmethod f :default [x] :def) (f 99))"] - ["protocol on record" "16" "(do (defprotocol Sh (ar [s])) (defrecord Sq [side] Sh (ar [_] (* side side))) (ar (->Sq 4)))"] - ["reify dispatch" "42" "(do (defprotocol P (m [_])) (m (reify P (m [_] 42))))"] - # deftype with INLINE protocol methods (its expansion calls extend-type, which - # is defined AFTER deftype in 30-macros — regression for the sq-symbol - # current-ns-vs-compile-ns qualification bug, jolt-3vh) - ["deftype inline methods" "7" "(do (defprotocol Pi (mi [x])) (deftype Ti [v] Pi (mi [x] v)) (mi (->Ti 7)))"] - ["deftype two protocols" "[1 2]" "(do (defprotocol Pa (ma [x])) (defprotocol Pb (mb [x])) (deftype Tab [a b] Pa (ma [x] a) Pb (mb [x] b)) (let [t (->Tab 1 2)] [(ma t) (mb t)]))"] - - ### ---- var fns as ordinary invokes (Stage 2 tier 6) ---- - ["var-get + call" "2" "((var-get (var inc)) 1)"] - ["var? true" "true" "(var? (var map))"] - ["var? false" "false" "(var? 5)"] - ["intern + find-var" "41" "(do (intern (quote user) (quote iv) 41) (var-get (find-var (quote user/iv))))"] - ["alter-var-root rest args" "11" "(do (def avr 1) (alter-var-root (var avr) + 4 6) avr)"] - ["alter-meta! + meta" "7" "(do (def amv 1) (alter-meta! (var amv) assoc :k 7) (:k (meta (var amv))))"] - - ### ---- ns introspection fns as ordinary invokes (Stage 2 tier 6b) ---- - ["find-ns + ns-name" "(quote clojure.core)" "(ns-name (find-ns (quote clojure.core)))"] - ["find-ns absent" "nil" "(find-ns (quote no.such.ns))"] - ["create-ns + find" "true" "(do (create-ns (quote made.ns)) (some? (find-ns (quote made.ns))))"] - ["remove-ns" "nil" "(do (create-ns (quote gone.ns)) (remove-ns (quote gone.ns)) (find-ns (quote gone.ns)))"] - ["the-ns of symbol" "(quote user)" "(ns-name (the-ns (quote user)))"] - ["ns-resolve + call" "3" "((var-get (ns-resolve (quote clojure.core) (quote inc))) 2)"] - ["resolve + call" "3" "((var-get (resolve (quote inc))) 2)"] - ["resolve absent" "nil" "(resolve (quote no-such-sym-xyz))"] - - ### ---- dispatch-table ops + misc as macros/fns (Stage 2 tier 6c) ---- - ["get-method + call" "1" "(do (defmulti t6f :k) (defmethod t6f :a [x] 1) ((get-method t6f :a) {:k :a}))"] - ["remove-method" "nil" "(do (defmulti t6g :k) (defmethod t6g :b [x] 2) (remove-method t6g :b) (get (methods t6g) :b))"] - ["remove-all-methods" "nil" "(do (defmulti t6h :k) (defmethod t6h :c [x] 3) (remove-all-methods t6h) (get (methods t6h) :c))"] - # NOTE: dispatch does not yet CONSULT prefers in ambiguous isa dispatch - # prefer-method records {x -> set-of-dominated} (Clojure's {x #{y}} shape; - # jolt-heo upgraded the store from single-value and dispatch consults it). - ["prefer-method records" "true" "(do (defmulti t6p identity) (prefer-method t6p :rect :shape) (contains? (get (prefers t6p) :rect) :shape))"] - ["instance? deftype" "true" "(do (deftype T6i [a]) (instance? T6i (->T6i 1)))"] - ["instance? String" "true" "(instance? String \"s\")"] - ["locking evals body" "3" "(locking :anything (+ 1 2))"] - ["locking evals monitor" "[3 1]" "(let [a (atom 0)] [(locking (swap! a inc) 3) @a])"] - ["defonce keeps first" "5" "(do (defonce d6o 5) (defonce d6o 9) d6o)"] - ["read-string + eval" "3" "(eval (read-string \"(+ 1 2)\"))"] - - ### ---- uuid (jolt-6s2) ---- - ["random-uuid is uuid" "true" "(uuid? (random-uuid))"] - ["uuid str 36" "36" "(count (str (random-uuid)))"] - ["parse-uuid round" "\"b6883c0a-0342-4007-9966-bc2dfa6b109e\"" "(str (parse-uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\"))"] - ["parse-uuid case =" "true" "(= (parse-uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\") (parse-uuid \"B6883C0A-0342-4007-9966-BC2DFA6B109E\"))"] - ["parse-uuid bad nil" "nil" "(parse-uuid \"df0993\")"] - ["uuid as map key" ":v" "(get {(parse-uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\") :v} (parse-uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\"))"] - - ### ---- 1.11 additions + ns fns (spec 35-var batch A) ---- - ["parse-long" "42" "(parse-long \"42\")"] - ["parse-long bad" "nil" "(parse-long \"4.2\")"] - ["parse-double" "1500.0" "(parse-double \"1.5e3\")"] - ["parse-boolean" "true" "(parse-boolean \"true\")"] - ["update-keys" "{\"a\" 1}" "(update-keys {:a 1} name)"] - ["update-vals" "{:a 2}" "(update-vals {:a 1} inc)"] - ["partitionv pad" "[[1 2] [3 :p]]" "(partitionv 2 2 [:p] [1 2 3])"] - ["partition pad" "[[0 1 2 3] [4 5 6 7] [8 9 :a]]" "(partition 4 4 [:a] (range 10))"] - ["splitv-at" "[[1 2] [3 4]]" "(splitv-at 2 [1 2 3 4])"] - ["with-redefs" "[42 1]" "(do (defn cwr [] 1) [(with-redefs [cwr (fn [] 42)] (cwr)) (cwr)])"] - ["time returns value" "3" "(time (+ 1 2))"] - ["macroexpand" "true" "(= (quote if) (first (macroexpand (quote (when-not false 1)))))"] - ["require bare symbol" "\"a,b\"" "(do (require (quote clojure.string)) (clojure.string/join \",\" [\"a\" \"b\"]))"] - ["ns-publics lookup" "true" "(do (def cnp 7) (some? (get (ns-publics (quote user)) (quote cnp))))"] - - ### ---- #inst + syntax-quote literal collapse (spec 2.4/2.3) ---- - ["inst? + inst-ms" "0" "(inst-ms #inst \"1970-01-01T00:00:00Z\")"] - ["inst partial = full" "true" "(= #inst \"2020\" #inst \"2020-01-01T00:00:00Z\")"] - ["inst offset normalized" "true" "(= #inst \"2020-01-01T01:00:00+01:00\" #inst \"2020-01-01T00:00:00Z\")"] - ["sq literal collapse" "true" "(= \"meow\" ```\"meow\")"] - ["sq number collapse" "42" "``42"] - - ### ---- stage 3: proper vars replace the Janet root-env leak ---- - ["compare total order" "[-1 0 1]" "[(compare nil 1) (compare :a :a) (compare \"b\" \"a\")]"] - ["compare vectors" "-1" "(compare [1 2] [1 3])"] - ["gensym jolt symbol" "true" "(symbol? (gensym))"] - ["any? anything" "true" "(and (any? nil) (any? 1) (any? :k))"] - ["int? excludes Inf" "false" "(int? ##Inf)"] - ["macroexpand-1 when" "2" "(count (rest (macroexpand-1 (quote (when true 1)))))"] - - ### ---- HIGH: aliased namespace calls ---- - ["require :as alias" "\"1,2,3\"" "(do (require (quote [clojure.string :as s])) (s/join \",\" [1 2 3]))"] - ["ns form + alias" "\"HI\"" "(do (ns my.a (:require [clojure.string :as s])) (s/upper-case \"hi\"))"] - ["ns :use refers" "42" "(do (ns src.u) (def helper 42) (ns dst.u (:use [src.u])) helper)"] - - ### ---- MED: missing core fns ---- - ["peek vec" "3" "(peek [1 2 3])"] - ["peek list" "1" "(peek (list 1 2 3))"] - ["pop vec" "[1 2]" "(pop [1 2 3])"] - ["pop list" "(quote (2 3))" "(pop (list 1 2 3))"] - ["subvec" "[2 3]" "(subvec [1 2 3 4 5] 1 3)"] - ["subvec to-end" "[3 4 5]" "(subvec [1 2 3 4 5] 2)"] - ["reduce-kv" "{:a 2 :b 3}" "(reduce-kv (fn [m k v] (assoc m k (inc v))) {} {:a 1 :b 2})"] - ["reduce-kv vector idx" "(quote ([0 :a] [1 :b]))" "(reduce-kv (fn [a i v] (conj a [i v])) [] [:a :b])"] - - ### ---- iterating maps yields entries ---- - ["map over map" "true" "(= #{1 2} (set (map val {:a 1 :b 2})))"] - ["map keys over map" "true" "(= #{:a :b} (set (map key {:a 1 :b 2})))"] - ["first of map" "true" "(let [e (first {:a 1})] (and (= (key e) :a) (= (val e) 1)))"] - ["vec of map" "[[:a 1]]" "(vec {:a 1})"] - ["reduce over map" "6" "(reduce (fn [a [k v]] (+ a v)) 0 {:a 1 :b 2 :c 3})"] - ["into transform map" "{:a 2 :b 3}" "(into {} (map (fn [[k v]] [k (inc v)]) {:a 1 :b 2}))"] - ["filter over map" "true" "(= [[:b 2]] (filterv (fn [[k v]] (> v 1)) {:a 1 :b 2}))"] - ["doall realizes" "(quote (2 3 4))" "(doall (map inc [1 2 3]))"] - ["tree-seq" "(quote (1 2 3))" "(map (fn [x] x) (filter (complement coll?) (tree-seq coll? seq [1 [2 [3]]])))"] - ["key/val" "true" "(let [e (first {:k 9})] (and (= :k (key e)) (= 9 (val e))))"] - ["nat-int?" "true" "(and (nat-int? 0) (nat-int? 5) (not (nat-int? -1)))"] - ["list* prepend" "(quote (1 2 3 4))" "(list* 1 2 [3 4])"] - ["cycle" "(quote (1 2 3 1 2 3 1))" "(take 7 (cycle [1 2 3]))"] - ["partition-all" "(quote ((1 2) (3 4) (5)))" "(partition-all 2 [1 2 3 4 5])"] - ["reductions" "(quote (1 3 6 10))" "(reductions + [1 2 3 4])"] - ["reductions init" "(quote (0 1 3 6))" "(reductions + 0 [1 2 3])"] - ["dedupe" "(quote (1 2 3 1))" "(dedupe [1 1 2 3 3 1])"] - # partition-by with a strict pred (odd?) — guards jolt-r81: a lazy overlay fn - # whose lazy-seq leaked its expansion in compile mode passed a non-int to odd?. - ["partition-by odd?" "(quote ((1 1) (2) (3 3)))" "(partition-by odd? [1 1 2 3 3])"] - ["reductions inf" "(quote (0 1 3 6))" "(take 4 (reductions + (range)))"] - ["tree-seq strict" "10" "(reduce + 0 (filter (complement coll?) (tree-seq coll? seq [1 [2 [3 4]]])))"] - # nil/collection case-constants past the point where Option A's lazy `drop` - # made the case macro's (empty? (drop 2 cls)) hit a nil-first lazy seq. - ["case nil + default" "[:nilr :def]" "(let [f (fn [x] (case x 1 :one nil :nilr :def))] [(f nil) (f 9)])"] - ["case collection consts" "[:v :m :s]" "(let [f (fn [x] (case x [1 2] :v {:a 1} :m #{3} :s :def))] [(f [1 2]) (f {:a 1}) (f #{3})])"] - # a lazy seq whose first element is nil is non-empty (seq/empty?/reverse) - ["seq of nil-first" "true" "(boolean (seq (cons nil (list 1))))"] - ["reverse nil elem" "[2 nil 1]" "(vec (reverse (list 1 nil 2)))"] - # lazy transformer over a non-seqable scalar throws (matches Clojure) - ["map non-seqable throws" "true" "(try (doall (map inc 5)) false (catch Throwable _ true))"] - ["keep-indexed" "(quote (:b :d))" "(keep-indexed (fn [i x] (if (odd? i) x)) [:a :b :c :d])"] - ["map-indexed" "(quote ([0 :a] [1 :b]))" "(map-indexed (fn [i x] [i x]) [:a :b])"] - ["trampoline" ":done" "(do (defn a [n] (if (zero? n) :done (fn [] (a (dec n))))) (trampoline a 5))"] - ["format" "\"1-x\"" "(format \"%d-%s\" 1 \"x\")"] - ["read-string" "(quote (+ 1 2))" "(read-string \"(+ 1 2)\")"] - ["letfn mutual" "true" "(letfn [(ev? [n] (if (= n 0) true (od? (dec n)))) (od? [n] (if (= n 0) false (ev? (dec n))))] (ev? 10))"] - ["doseq side" "[1 2 3]" "(do (def a (atom [])) (doseq [x [1 2 3]] (swap! a conj x)) @a)"] - ["doseq nested" "4" "(do (def c (atom 0)) (doseq [x [1 2] y [10 20]] (swap! c inc)) @c)"] - - ### ---- MED: lazy filter / take-while over infinite seqs ---- - ["lazy filter inf" "(quote (1 3 5 7 9))" "(take 5 (filter odd? (range)))"] - ["lazy take-while inf" "(quote (0 1 2 3 4))" "(take-while (fn [x] (< x 5)) (range))"] - ["lazy remove inf" "(quote (0 2 4 6 8))" "(take 5 (remove odd? (range)))"] - ["filter finite" "(quote (2 4))" "(filter even? [1 2 3 4 5])"] - - ### ==== atoms (full support) ==== - ["swap! args" "7" "(do (def a (atom 1)) (swap! a + 2 4) @a)"] - ["reset! ret" "9" "(do (def a (atom 1)) (reset! a 9))"] - ["compare-and-set!" "true" "(do (def a (atom 1)) (compare-and-set! a 1 2))"] - ["compare-and-set! no" "false" "(do (def a (atom 1)) (compare-and-set! a 5 2))"] - ["swap-vals!" "[1 2]" "(do (def a (atom 1)) (swap-vals! a inc))"] - ["reset-vals!" "[1 9]" "(do (def a (atom 1)) (reset-vals! a 9))"] - ["atom map swap" "{:a 1 :b 2}" "(do (def a (atom {:a 1})) (swap! a assoc :b 2) @a)"] - ["add-watch" "[:k 1 2]" "(do (def lg (atom nil)) (def a (atom 1)) (add-watch a :k (fn [k r o n] (reset! lg [k o n]))) (swap! a inc) @lg)"] - ["atom validator" "5" "(do (def a (atom 1 :validator pos?)) (reset! a 5) @a)"] - ["instance? Atom" "true" "(instance? clojure.lang.Atom (atom 1))"] - - ### ==== volatiles / delays ==== - ["volatile" "2" "(do (def v (volatile! 1)) (vreset! v 2) @v)"] - ["vswap!" "2" "(do (def v (volatile! 1)) (vswap! v inc) @v)"] - ["volatile?" "true" "(volatile? (volatile! 1))"] - ["delay force" "3" "(force (delay (+ 1 2)))"] - ["delay deref once" "1" "(do (def c (atom 0)) (def d (delay (swap! c inc))) @d @d @c)"] - ["realized? delay" "true" "(do (def d (delay 1)) @d (realized? d))"] - ["realized? not" "false" "(realized? (delay 1))"] - - ### ==== numbers / math ==== - ["quot neg" "-2" "(quot -7 3)"] - ["rem neg" "-1" "(rem -7 3)"] - ["mod neg" "2" "(mod -7 3)"] - ["bit ops" "[4 14 10]" "[(bit-and 12 6) (bit-or 12 6) (bit-xor 12 6)]"] - ["bit-shift" "[8 2]" "[(bit-shift-left 1 3) (bit-shift-right 8 2)]"] - ["Math/sqrt" "3.0" "(Math/sqrt 9)"] - ["Math/pow" "8.0" "(Math/pow 2 3)"] - ["min-key" "1" "(min-key abs 1 -2 3)"] - ["max-key" "-4" "(max-key abs 1 -2 -4 3)"] - - ### ==== strings (clojure.string) ==== - ["str/trim" "\"hi\"" "(do (require (quote [clojure.string :as s])) (s/trim \" hi \"))"] - ["str/split regex" "[\"a\" \"b\" \"c\"]" "(do (require (quote [clojure.string :as s])) (s/split \"a,b,c\" #\",\"))"] - ["str/split ws" "[\"a\" \"b\" \"c\"]" "(do (require (quote [clojure.string :as s])) (s/split \"a b c\" #\"\\s+\"))"] - ["str/replace" "\"hexxo\"" "(do (require (quote [clojure.string :as s])) (s/replace \"hello\" \"ll\" \"xx\"))"] - ["str/replace regex" "\"ab\"" "(do (require (quote [clojure.string :as s])) (s/replace \"a1b2\" #\"[0-9]\" \"\"))"] - ["str/includes?" "true" "(do (require (quote [clojure.string :as s])) (s/includes? \"hello\" \"ell\"))"] - ["str/reverse" "\"cba\"" "(do (require (quote [clojure.string :as s])) (s/reverse \"abc\"))"] - ["subs" "\"ell\"" "(subs \"hello\" 1 4)"] - - ### ==== regex ==== - ["re-find" "\"123\"" "(re-find #\"[0-9]+\" \"abc123def\")"] - ["re-matches" "\"abc\"" "(re-matches #\"a.c\" \"abc\")"] - ["re-matches no" "nil" "(re-matches #\"a.c\" \"abcd\")"] - ["re-seq" "(quote (\"12\" \"34\"))" "(re-seq #\"[0-9]+\" \"a12b34\")"] - - ### ==== sequences ==== - ["split-at" "[[1 2] [3 4 5]]" "(split-at 2 [1 2 3 4 5])"] - ["split-with" "[[1 2] [3 4 1]]" "(split-with (fn [x] (< x 3)) [1 2 3 4 1])"] - ["interpose" "(quote (1 0 2 0 3))" "(interpose 0 [1 2 3])"] - ["partition step" "(quote ((1 2) (3 4)))" "(partition 2 2 [1 2 3 4 5])"] - ["not-every?" "true" "(not-every? pos? [1 -2 3])"] - ["not-any?" "true" "(not-any? neg? [1 2 3])"] - ["take-nth" "(quote (0 2 4))" "(take-nth 2 [0 1 2 3 4])"] - ["butlast" "(quote (1 2))" "(butlast [1 2 3])"] - ["filterv" "[2 4]" "(filterv even? [1 2 3 4])"] - ["mapv" "[2 3 4]" "(mapv inc [1 2 3])"] - ["reduced early" "3" "(reduce (fn [a x] (if (> a 2) (reduced a) (+ a x))) 0 [1 2 3 4 5])"] - ["sort cmp" "[3 2 1]" "(sort > [1 3 2])"] - ["frequencies" "{1 2 2 1}" "(frequencies [1 1 2])"] - ["empty" "[]" "(empty [1 2 3])"] - ["not-empty" "nil" "(not-empty [])"] - ["rseq" "(quote (3 2 1))" "(rseq [1 2 3])"] - ["replace map" "[:a :b :a]" "(replace {1 :a 2 :b} [1 2 1])"] - - ### ==== data structures ==== - ["sorted-map seq" "(quote ([:a 1] [:b 2] [:c 3]))" "(seq (sorted-map :c 3 :a 1 :b 2))"] - ["sorted-set seq" "(quote (1 2 3))" "(seq (sorted-set 3 1 2))"] - ["assoc vector" "[1 9 3]" "(assoc [1 2 3] 1 9)"] - ["update vector" "[1 3 3]" "(update [1 2 3] 1 inc)"] - ["coll? set" "true" "(coll? #{1 2})"] - ["find entry" "[:a 1]" "(find {:a 1} :a)"] - ["conj map entry" "{:a 1 :b 2}" "(conj {:a 1} [:b 2])"] - ["conj list prepend" "(quote (0 1 2))" "(conj (list 1 2) 0)"] - - ### ==== keywords / symbols ==== - ["keyword ns" ":a/b" "(keyword \"a\" \"b\")"] - ["name ns-kw" "\"b\"" "(name :a/b)"] - ["namespace" "\"a\"" "(namespace :a/b)"] - ["namespace none" "nil" "(namespace :a)"] - - ### ==== metadata / vars ==== - ["vary-meta" "{:x 2}" "(meta (vary-meta (with-meta [1] {:x 1}) update :x inc))"] - ["defonce no-redef" "1" "(do (defonce dv1 1) (defonce dv1 2) dv1)"] - ["binding dynamic" "10" "(do (def ^:dynamic *x* 1) (binding [*x* 10] *x*))"] - - ### ==== try / catch ==== - ["try catch" ":caught" "(try (throw (ex-info \"e\" {})) (catch :default e :caught))"] - ["ex-data" "{:a 1}" "(try (throw (ex-info \"m\" {:a 1})) (catch :default e (ex-data e)))"] - ["ex-message" "\"m\"" "(try (throw (ex-info \"m\" {})) (catch :default e (ex-message e)))"] - - ### ==== macros ==== - ["macroexpand-1" "true" "(do (defmacro mm [x] (list (quote inc) x)) (= (quote (inc 5)) (macroexpand-1 (quote (mm 5)))))"] - ["doto" "{:a 1}" "(deref (doto (atom {}) (swap! assoc :a 1)))"] - - ### ==== printing ==== - ["pr-str vec" "\"[1 2 3]\"" "(pr-str [1 2 3])"] - ["prn-str" "\"1\\n\"" "(prn-str 1)"] - - ### ==== characters ==== - ["char?" "true" "(char? \\a)"] - ["char not string" "false" "(= \\a \"a\")"] - ["char eq" "true" "(= \\a \\a)"] - ["int of char" "97" "(int \\a)"] - ["char of int" "true" "(= \\A (char 65))"] - ["str of chars" "\"abc\"" "(str \\a \\b \\c)"] - ["seq of string" "(quote (\\a \\b))" "(seq \"ab\")"] - ["first of string" "\\h" "(first \"hello\")"] - ["nth of string" "\\e" "(nth \"hello\" 1)"] - ["char newline" "10" "(int \\newline)"] - ["char space" "32" "(int \\space)"] - ["char unicode" "65" "(int \\u0041)"] - ["pr-str char" "\"\\\\a\"" "(pr-str \\a)"] - ["chars in vec" "[\\a \\b]" "[\\a \\b]"] - ["apply str chars" "\"hi\"" "(apply str [\\h \\i])"] - - ### ==== transducers ==== - ["transduce map" "9" "(transduce (map inc) + 0 [1 2 3])"] - ["transduce comp" "12" "(transduce (comp (map inc) (filter even?)) + 0 [1 2 3 4 5])"] - ["transduce conj" "[2 3 4]" "(transduce (map inc) conj [] [1 2 3])"] - ["into xform" "[2 3 4]" "(into [] (map inc) [1 2 3])"] - ["into comp xform" "[1 9 25]" "(into [] (comp (filter odd?) (map (fn [x] (* x x)))) [1 2 3 4 5])"] - ["into take xform" "[0 1 2]" "(into [] (take 3) (range 100))"] - ["sequence xform" "(quote (2 3 4))" "(sequence (map inc) [1 2 3])"] - ["transduce no-init" "6" "(transduce (map inc) + [0 1 2])"] - ["transduce drop" "[3 4 5]" "(into [] (drop 2) [1 2 3 4 5])"] - ["transduce remove" "[1 3 5]" "(into [] (remove even?) [1 2 3 4 5])"] - ["transduce take-while" "[1 2]" "(into [] (take-while (fn [x] (< x 3))) [1 2 3 4 1])"] - ["transduce map-indexed" "[[0 :a] [1 :b]]" "(into [] (map-indexed (fn [i x] [i x])) [:a :b])"] - ["partition-all xform" "[[1 2] [3 4] [5]]" "(into [] (partition-all 2) [1 2 3 4 5])"] - ["partition-all xform comp" "[2 2 1]" "(into [] (comp (partition-all 2) (map count)) [1 2 3 4 5])"] - ["partition-by xform" "[[1 1] [2 4] [5]]" "(into [] (partition-by odd?) [1 1 2 4 5])"] - ["partition-by xform reduced" "[[1 1] [2 4]]" "(into [] (comp (partition-by odd?) (take 2)) [1 1 2 4 5 5])"] - - ### ==== regex (capturing groups, backtracking, flags, lookahead) ==== - ["re-find groups" "[\"12-34\" \"12\" \"34\"]" "(re-find #\"(\\d+)-(\\d+)\" \"x12-34y\")"] - ["re-find no-groups" "\"123\"" "(re-find #\"\\d+\" \"ab123\")"] - ["re-matches groups" "[\"1.2\" \"1\" \"2\"]" "(re-matches #\"(\\d+)\\.(\\d+)\" \"1.2\")"] - ["re-matches no" "nil" "(re-matches #\"a.c\" \"abcd\")"] - ["re-seq" "[\"foo\" \"bar\"]" "(re-seq #\"\\w+\" \"foo bar\")"] - ["greedy backtrack" "\"xxfoo\"" "(re-find #\".*foo\" \"xxfoo\")"] - ["greedy thru group" "[\"a,b,c\" \"a,b\" \"c\"]" "(re-find #\"(.*),(.*)\" \"a,b,c\")"] - ["lazy quantifier" "[\"\" \"a\"]" "(re-find #\"<(.+?)>\" \"\")"] - ["flag case-insens" "\"CAT\"" "(re-find #\"(?i)cat\" \"a CAT\")"] - ["lookahead" "\"foo\"" "(re-find #\"foo(?=bar)\" \"foobar\")"] - ["neg-lookahead" "\"foo\"" "(re-find #\"foo(?!bar)\" \"foobaz\")"] - ["word-boundary" "\"word\"" "(re-find #\"\\bword\\b\" \"a word!\")"] - ["word-boundary no" "nil" "(re-find #\"\\bword\\b\" \"swordfish\")"] - ["optional group" "[\"1.2.3\" \"1\" \"2\" \"3\" nil]" "(re-find #\"(\\d+)\\.(\\d+)\\.(\\d+)(?:-([a-z]+))?\" \"1.2.3\")"] - ["alternation" "\"dog\"" "(re-find #\"cat|dog\" \"a dog cat\")"] - ["str/replace $1" "\"he[ll]o\"" "(do (require (quote [clojure.string :as s])) (s/replace \"hello\" #\"(l+)\" \"[$1]\"))"] - ["str/replace regex" "\"X-X\"" "(do (require (quote [clojure.string :as s])) (s/replace \"a-b\" #\"[a-z]\" \"X\"))"] - - ### ==== map literals evaluate their values ==== - ["map literal expr" "{:a 3}" "{:a (+ 1 2)}"] - ["map literal var" "{:k 5}" "(let [x 5] {:k x})"] - ["map literal nested" "{:a {:b 2}}" "(let [y 2] {:a {:b y}})"] - ["map literal keyfn" "{:x 1}" "(let [k :x] {k 1})"] - ["map literal in fn" "6" "(do (defn mk [a b] {:sum (+ a b)}) (:sum (mk 2 4)))"] - - ### ---- overlay migration (jolt-1j0): run in all 3 modes ---- - # if-let/when-let bind only in the taken branch (else sees outer scope) - ["if-let else outer scope" "5" "(let [x 5] (if-let [x nil] :then x))"] - ["if-some else outer" "5" "(let [x 5] (if-some [x nil] :then x))"] - ["when-let body multi" "14" "(when-let [x 7] (inc x) (* x 2))"] - # nthrest returns () (not nil) for an exhausted n>0 walk; coll for n<=0 - ["nthrest exhausted" "(quote ())" "(nthrest nil 100)"] - ["nthrest n=0 keeps coll" "[1 2 3]" "(nthrest [1 2 3] 0)"] - ["nthnext surprising nil" "nil" "(nthnext nil nil)"] - # distinct? compares by value - ["distinct? equal colls" "false" "(distinct? [1 2] [1 2])"] - ["not-any?" "true" "(not-any? even? [1 3 5])"] - ["take-last" "[3 4]" "(take-last 2 [1 2 3 4])"] - ["replace nil val" "[1 nil 3]" "(replace {2 nil} [1 2 3])"] - - ### ---- migratus enablement: def/defmacro/defmulti forms, assoc, try, ns ---- - # (def name docstring value): the value is the 3rd form, not the docstring - # (jolt-6ym — the analyzer used to bind the docstring as the value). - ["def 3-arg docstring" "42" "(do (def dd \"the doc\" 42) dd)"] - ["def docstring value type" "true" "(do (def ds \"doc\" [1 2]) (vector? ds))"] - # ^{:map} metadata on a def/defn name reads as a with-meta form (jolt-8w2); - # def/defn/defmacro unwrap it instead of choking. - ["def ^{:map} name" "5" "(do (def ^{:private true} mmv 5) mmv)"] - ["defn ^{:map} name" "25" "(do (defn ^{:private true} sqf [x] (* x x)) (sqf 5))"] - # defmacro arity-clause form (jolt-whp) and a leading docstring (with-store shape) - ["defmacro arity-clause" "10" "(do (defmacro m2c ([x] (list (quote *) x 2))) (m2c 5))"] - ["defmacro doc + arity" "30" "(do (defmacro m3c \"doc\" ([x] (list (quote *) x 3))) (* (m3c 5) 2))"] - # defmulti drops a leading docstring (jolt-es4 — it used to be the dispatch fn) - ["defmulti docstring" "\"A\"" "(do (defmulti gmm \"the doc\" identity) (defmethod gmm :a [_] \"A\") (gmm :a))"] - # (assoc nil k v) yields a real map (jolt-w4s); assoc-in nests real maps - ["assoc nil is a map" "1" "(count (assoc nil :a 1))"] - ["assoc-in nested is a map" "1" "(count (:a (assoc-in {} [:a :b] 1)))"] - ["assoc-in deep get" "9" "(get-in (assoc-in {} [:a :b :c] 9) [:a :b :c])"] - # try: a multi-form body and finally that runs on the SUCCESS path with a - # catch present (jolt-0z9 — body forms past the first were dropped and - # finally was skipped on success). - ["try multi-body last" "3" "(try 1 2 3 (catch :default e 0))"] - ["try finally on ok+catch" "9" "(let [a (atom 0)] (try 1 2 (catch :default e :c) (finally (reset! a 9))) @a)"] - ["try finally on throw" "9" "(let [a (atom 0)] (try (throw (ex-info \"x\" {})) (catch :default e nil) (finally (reset! a 9))) @a)"] - # current-ns is restored after a caught throw (jolt-96m): the alias/ns seen by - # code after the catch is the one at the catch site, not the thrower's. - ["ns restored after catch" "\"user\"" - "(do (ns cf.boom) (defn bz [] (throw (Exception. \"e\"))) (in-ns (quote user)) (try (cf.boom/bz) (catch :default e nil)) (str *ns*))"] - # methods sees cross-ns defmethods through a bare multifn ref in its defining - # ns (jolt-9pu — it used to see an empty table). - ["cross-ns methods visible" "[:sql]" - "(do (ns cf.mm) (defmulti ext identity) (defmethod ext :default [_] :d) (defn allk [] (vec (for [[k v] (methods ext) :when (not= k :default)] k))) (ns cf.mmi) (defmethod cf.mm/ext :sql [_] :s) (in-ns (quote user)) (cf.mm/allk))"] - - ### ---- defmacro surface + syntax-quote/ns (enabling real clojure libs) ---- - # multi-arity defmacro (clojure.tools.logging/log has 4 arities) - ["defmacro multi-arity" "[6 5 6]" - "(do (defmacro mar ([a] (list (quote +) a 1)) ([a b] (list (quote +) a b)) ([a b c] (list (quote +) a b c))) [(mar 5) (mar 2 3) (mar 1 2 3)])"] - # defmacro with docstring AND attr-map before the params (every tools.logging - # level macro is shaped this way) - ["defmacro doc + attr-map" "10" - "(do (defmacro mam \"doc\" {:arglists (quote ([x]))} [x] (list (quote inc) x)) (mam 9))"] - # syntax-quote resolves a namespace ALIAS to its target ns, so a macro's - # template resolves at the USE site (jolt-9av) - ["syntax-quote resolves alias" "\"HI\"" - "(do (ns sq.lib (:require [clojure.string :as s])) (defmacro up [x] `(s/upper-case ~x)) (in-ns (quote user)) (sq.lib/up \"hi\"))"] - # ^{:map} metadata on an ns name (jolt-8w2): the ns name is the bare symbol - ["ns name with ^{:map} meta" "5" - "(do (ns ^{:author \"a\" :doc \"d\"} nm.meta) (def q 5) (in-ns (quote user)) nm.meta/q)"] - # ~*ns* splices the live namespace object into a template (it self-evaluates) - ["unquote *ns* in template" "true" - "(do (defmacro cur-ns [] `(str ~*ns*)) (string? (cur-ns)))"] - ]) - -# Run every case under a given context factory and return the failures. The same -# cases run under both the interpreter and the compiler: results must match real -# Clojure semantics either way, so the compile path (hybrid: hot compiles, -# unsupported forms fall back to the interpreter) must not diverge. -# mode: {} interpret, {:compile? true} bootstrap compiler, {:selfhost true} the -# self-hosted pipeline (portable Clojure analyzer -> IR -> Janet back end). -(defn- run-cases [mode] - (def selfhost? (get mode :selfhost)) - (def init-opts (if selfhost? {} mode)) - (defn ev [ctx prog] - (if selfhost? (selfhost/compile-and-eval ctx (parse-string prog)) (eval-string ctx prog))) - # One expensive init per mode; every case runs on a cheap isolated fork (~2 ms) - # instead of its own init (~50 ms interpreted / ~900 ms compiled). Isolation is - # preserved — a fork shares nothing mutable with its siblings. For self-host - # mode, compile one form first so the lazily-built analyzer is in the snapshot. - (def base (init-cached init-opts)) - (when selfhost? (selfhost/compile-and-eval base (parse-string "1"))) - (def snap (snapshot base)) - (def fails @[]) - (each [name expected actual] cases - (def ctx (fork snap)) - (def prog (string "(= " expected " " actual ")")) - (def res (protect (ev ctx prog))) - (cond - (not= (res 0) true) - (array/push fails [name "ERROR" (string (res 1))]) - (= (res 1) true) - nil - (let [got (protect (ev (fork snap) actual))] - (array/push fails [name "MISMATCH" - (string "want=" expected - " got=" (if (= (got 0) true) (string/format "%q" (got 1)) (string "ERR:" (got 1))))])))) - fails) - -(defn- report [label fails] - (printf "=== CONFORMANCE (%s): %d/%d passed ===" label (- (length cases) (length fails)) (length cases)) - (unless (empty? fails) - (print "--- Failures ---") - (each [name kind detail] fails - (printf "[%s] %s: %s" kind name detail)))) - -(def interp-fails (run-cases {})) -(report "interpret" interp-fails) -(def compile-fails (run-cases {:compile? true})) -(report "compile" compile-fails) -(def selfhost-fails (run-cases {:selfhost true})) -(report "self-host" selfhost-fails) -(print) -(when (or (pos? (length interp-fails)) (pos? (length compile-fails)) - (pos? (length selfhost-fails))) - (os/exit 1)) diff --git a/test/integration/cross-ns-hints-test.janet b/test/integration/cross-ns-hints-test.janet deleted file mode 100644 index d67fa0c..0000000 --- a/test/integration/cross-ns-hints-test.janet +++ /dev/null @@ -1,72 +0,0 @@ -# Cross-namespace ^Type field hints (jolt-3ko follow-up): a record field hinted -# with a record type defined in ANOTHER namespace — referred (:refer) or aliased -# (:as) in — must resolve to that type's HOME ctor key in the record-shapes -# registry, the same as a same-namespace hint does. That resolved key is what -# lets the inference type a field read back to the foreign record type instead of -# :any (the lever for fast nested-record code across a multi-namespace program). -# Guards both the :refer and :as spellings — for record FIELD hints and for -# fn PARAM hints (which seed the inference so a record param's reads are typed -# across a namespace boundary without whole-program). Also guards that the -# reader keeps a tag's namespace qualifier (^g/Pt -> "g/Pt", not "Pt"). -(use ../../src/jolt/api) -(import ../../src/jolt/types :as ty) -(import ../../src/jolt/core :as jc) -(import ../../src/jolt/reader :as rd) - -(var failures 0) -(defn- check [label got want] - (unless (deep= got want) - (++ failures) - (printf "FAIL [%s] got %q want %q" label got want))) - -(def dir (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-xns-hints")) -(os/mkdir dir) -(os/mkdir (string dir "/geo")) -# Pt lives in geo.pt; shape records in geo.shape hint ^Pt across the boundary. -(spit (string dir "/geo/pt.clj") - "(ns geo.pt)\n(defrecord Pt [x y z])\n") -(spit (string dir "/geo/shape.clj") - (string "(ns geo.shape (:require [geo.pt :as g :refer [Pt]]))\n" - "(defrecord Seg [^Pt a ^Pt b])\n" # :refer field hint - "(defrecord Tri [^g/Pt a ^g/Pt b ^g/Pt c])\n" # :as field hint - # param hints, both spellings: ^Pt (referred), ^g/Pt (aliased) - "(defn mid [^Pt a ^g/Pt b] a)\n")) - -(def ctx (init {:compile? true :direct-linking? true})) -(array/push (get (ctx :env) :source-paths) dir) -(eval-string ctx "(require '[geo.shape])") -(def rs (get (ctx :env) :record-shapes)) - -(check ":refer ^Pt field hint resolves to home ctor key" - (get (get rs "geo.shape/->Seg") :tags) - ["geo.pt/->Pt" "geo.pt/->Pt"]) -(check ":as ^g/Pt field hint resolves to home ctor key" - (get (get rs "geo.shape/->Tri") :tags) - ["geo.pt/->Pt" "geo.pt/->Pt" "geo.pt/->Pt"]) -# the foreign type's own shape is registered under its home key -(check "home type registered" - (get (get rs "geo.pt/->Pt") :fields) - [:x :y :z]) - -# --- param hints: the arity carries [name ctor-key] for each record param, both -# the :refer (^Pt) and :as (^g/Pt) spellings resolved to the home key ---------- -(def shape-ns (ty/ctx-find-ns ctx "geo.shape")) -(def mid-ir (get (get (get shape-ns :mappings) "mid") :infer-ir)) -(def mid-arity (first (jc/vview (get (get mid-ir :init) :arities)))) -(def phints (when (get mid-arity :phints) - (map jc/vview (jc/vview (get mid-arity :phints))))) -(check "param hints resolve cross-ns (refer + as)" - phints - @[@["a" "geo.pt/->Pt"] @["b" "geo.pt/->Pt"]]) - -# --- reader keeps a tag's namespace qualifier --------------------------------- -(check "reader preserves qualified tag ^g/Pt" - (get (get (rd/parse-string "^g/Pt x") :meta) :tag) - "g/Pt") -(check "reader bare tag ^Pt unchanged" - (get (get (rd/parse-string "^Pt x") :meta) :tag) - "Pt") - -(if (= 0 failures) - (print "cross-ns-hints: all cases passed") - (do (printf "cross-ns-hints: %d FAILURES" failures) (os/exit 1))) diff --git a/test/integration/ctx-image-test.janet b/test/integration/ctx-image-test.janet deleted file mode 100644 index 67e3917..0000000 --- a/test/integration/ctx-image-test.janet +++ /dev/null @@ -1,78 +0,0 @@ -# init-cached: disk-cached AOT image of the fully-built context. -# -# init in compile mode costs ~2.4 s (tier loading, analyzer self-compile, macro -# recompilation). init-cached pays that once, marshals the built ctx to an image -# file (the same machinery as api/snapshot), and every later process unmarshals -# it instead of rebuilding. The cache key fingerprints the embedded .clj stdlib, -# the .janet seed sources, and the init opts, so any source change invalidates. -# -# The cross-process case is the one that matters (each `jpm test` file is its -# own janet process), so the warm-load checks run in a SUBPROCESS against the -# image this process bakes. -(use ../../src/jolt/api) - -(print "ctx image cache...") - -(def dir (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-img-test-" (os/getpid))) -(os/mkdir dir) -(os/setenv "JOLT_IMAGE_CACHE_DIR" dir) -# The cache is the test subject — undo an ambient opt-out (and for the subprocess). -(os/setenv "JOLT_NO_IMAGE_CACHE" nil) -(defer (do (each f (os/dir dir) (os/rm (string dir "/" f))) (os/rmdir dir)) - - # 1. Cold init: builds the ctx, writes an image, and is fully functional. - (def t0 (os/clock)) - (def ctx1 (init-cached {:compile? true})) - (def cold-s (- (os/clock) t0)) - (assert (= 3 (eval-string ctx1 "(+ 1 2)")) "cold ctx evaluates") - (def files (filter |(string/has-suffix? ".jimg" $) (os/dir dir))) - (assert (= 1 (length files)) (string "one image written, got " (length files))) - - # 2. Warm init in THIS process: loads the image, functional, and much faster. - (def t1 (os/clock)) - (def ctx2 (init-cached {:compile? true})) - (def warm-s (- (os/clock) t1)) - (assert (= 10 (eval-string ctx2 "(do (defn f [x] (* 2 x)) (f 5))")) "warm ctx compiles defns") - (assert (< warm-s (/ cold-s 4)) - (string/format "warm load (%.0f ms) at least 4x faster than cold (%.0f ms)" - (* 1000 warm-s) (* 1000 cold-s))) - - # 3. Different opts get a different image (no false sharing between modes). - (init-cached {}) - (def files2 (filter |(string/has-suffix? ".jimg" $) (os/dir dir))) - (assert (= 2 (length files2)) "interpret-mode image is keyed separately") - - # 4. Cross-process warm load: a fresh janet process loads the image this - # process baked and runs real work — compiled defns, redefinition, - # macros, lazy seqs, protocols, multimethods, stdlib require. - (def checks - ``(use ./src/jolt/api) - (def t0 (os/clock)) - (def ctx (init-cached {:compile? true})) - (def warm-ms (* 1000 (- (os/clock) t0))) - (def img-files (filter |(string/has-suffix? ".jimg" $) - (os/dir (os/getenv "JOLT_IMAGE_CACHE_DIR")))) - (assert (= 2 (length img-files)) "subprocess hit the cache (no new image)") - (assert (= 3 (eval-string ctx "(+ 1 2)")) "arith") - (assert (= 120 (eval-string ctx "(do (defn fact [n] (if (zero? n) 1 (* n (fact (dec n))))) (fact 5))")) "compiled defn") - (assert (= 7 (eval-string ctx "(do (def a 3) (def a 7) a)")) "redefinition") - (assert (= 6 (eval-string ctx "(-> 1 inc (* 3))")) "macros expand") - (assert (= 9 (eval-string ctx "(do (defmacro tw [x] `(* 3 ~x)) (tw 3))")) "defmacro works post-load") - (assert (= [2 4 6] (normalize-pvecs (eval-string ctx "(vec (map #(* 2 %) [1 2 3]))"))) "lazy/HOF") - (assert (= "a-b" (eval-string ctx "(do (require '[clojure.string :as str]) (str/join \"-\" [\"a\" \"b\"]))")) "stdlib require") - (assert (= 42 (eval-string ctx "(do (defprotocol P (pf [x])) (defrecord R [] P (pf [x] 42)) (pf (->R)))")) "protocols") - (assert (= :big (eval-string ctx "(do (defmulti m (fn [x] (if (> x 5) :big :small))) (defmethod m :big [_] :big) (m 10))")) "multimethods") - (print "subprocess warm load ok in " (math/round warm-ms) " ms")``) - (def code (os/execute ["janet" "-e" checks] :p)) - (assert (= 0 code) "cross-process warm load passes") - - # 5. A source change invalidates: poisoning the fingerprint env knob is not - # possible from here, but a corrupted image must fall back to a rebuild - # rather than crash. - (each f (os/dir dir) - (when (string/has-suffix? ".jimg" f) (spit (string dir "/" f) "garbage"))) - (def ctx3 (init-cached {:compile? true})) - (assert (= 3 (eval-string ctx3 "(+ 1 2)")) "corrupted image falls back to rebuild") - - (printf "ctx image cache passed! (cold %.0f ms, warm %.0f ms)" - (* 1000 cold-s) (* 1000 warm-s))) diff --git a/test/integration/deps-aliases-test.janet b/test/integration/deps-aliases-test.janet deleted file mode 100644 index 00b21f1..0000000 --- a/test/integration/deps-aliases-test.janet +++ /dev/null @@ -1,119 +0,0 @@ -# deps.edn aliases + user-level config merge (jolt-4go). -# -# Mirrors tools.deps semantics scoped to what jolt supports (git/:local, no -# maven): :aliases with :extra-paths / :extra-deps / :main-opts selected by -# keyword; a user deps.edn (under $JOLT_CONFIG, else $XDG_CONFIG_HOME/jolt, -# else ~/.jolt) merged UNDER the project file — :deps and :aliases merge per -# key with the project winning, :paths replaces. Local deps only: no network. - -(import ../../src/jolt/deps :as deps) - -(def base (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-deps-aliases-" (os/time))) -(defn rmrf [p] - (when (os/stat p) - (if (= :directory (os/stat p :mode)) - (do (each e (os/dir p) (rmrf (string p "/" e))) (os/rmdir p)) - (os/rm p)))) -(rmrf base) - -(defn mkdirs [p] - (def abs (string/has-prefix? "/" p)) - (var acc nil) - (each seg (filter |(not= "" $) (string/split "/" p)) - (set acc (cond (nil? acc) (if abs (string "/" seg) seg) (string acc "/" seg))) - (unless (os/stat acc) (os/mkdir acc)))) - -(each d ["proj/src" "proj/dev" "proj/test" "a/src" "c/src" "u/src" "config"] - (mkdirs (string base "/" d))) - -# project: src + dep a; :dev alias adds dev/ + dep c; :test alias adds test/ -(spit (string base "/proj/deps.edn") - `{:paths ["src"] - :deps {my/a {:local/root "../a"}} - :aliases {:dev {:extra-paths ["dev"] - :extra-deps {my/c {:local/root "../c"}}} - :test {:extra-paths ["test"] - :main-opts ["-e" "(run-tests)"]} - :bench {:main-opts ["-e" "(bench)"]}}}`) -(spit (string base "/a/deps.edn") `{:paths ["src"]}`) -(spit (string base "/c/deps.edn") `{:paths ["src"]}`) -(spit (string base "/u/deps.edn") `{:paths ["src"]}`) - -# user-level config: a :user-tool alias the project file doesn't have, plus a -# :dev alias that the PROJECT's :dev must shadow (per-key merge, project wins) -(spit (string base "/config/deps.edn") - `{:aliases {:user-tool {:extra-deps {my/u {:local/root "BASE/u"}}} - :dev {:extra-paths ["should-not-win"]}}}`) -# :local/root in the user file is relative to... nothing useful; use absolute -(spit (string base "/config/deps.edn") - (string/replace "BASE" base (slurp (string base "/config/deps.edn")))) - -(var fails 0) -(defn check [label got expected] - (if (= got expected) (print " ok " label) - (do (++ fails) (printf " FAIL %s: want %q, got %q" label expected got)))) -(defn has-suffix-root [roots suff] - (truthy? (some |(string/has-suffix? suff $) roots))) - -(os/cd (string base "/proj")) -(os/setenv "JOLT_CONFIG" (string base "/config")) -(def tree (string base "/proj/jpm_tree")) - -# --- no aliases: plain resolution, dev/test/c absent --------------------------- -(def plain (deps/resolve-deps "deps.edn" tree)) -(check "plain: project src present" (has-suffix-root plain "/proj/src") true) -(check "plain: dep a present" (has-suffix-root plain "/a/src") true) -(check "plain: alias path absent" (has-suffix-root plain "/proj/dev") false) -(check "plain: alias dep absent" (has-suffix-root plain "/c/src") false) - -# --- :dev alias: extra-paths + extra-deps -------------------------------------- -(def dev (deps/resolve-deps "deps.edn" tree [:dev])) -(check "dev: extra path present" (has-suffix-root dev "/proj/dev") true) -(check "dev: extra dep present" (has-suffix-root dev "/c/src") true) -(check "dev: base dep still present" (has-suffix-root dev "/a/src") true) -(check "dev: project :dev shadows user :dev" - (has-suffix-root dev "/proj/should-not-win") false) - -# --- multiple aliases combine --------------------------------------------------- -(def both (deps/resolve-deps "deps.edn" tree [:dev :test])) -(check "multi: both extra paths" - (and (has-suffix-root both "/proj/dev") (has-suffix-root both "/proj/test")) true) - -# --- alias from the USER deps.edn ---------------------------------------------- -(def ut (deps/resolve-deps "deps.edn" tree [:user-tool])) -(check "user alias resolves its dep" (has-suffix-root ut "/u/src") true) - -# --- main-opts: from alias, last alias wins ------------------------------------ -(check "main-opts from alias" - (deps/alias-main-opts "deps.edn" [:test]) ["-e" "(run-tests)"]) -(check "main-opts last alias wins" - (deps/alias-main-opts "deps.edn" [:test :bench]) ["-e" "(bench)"]) -(check "main-opts absent is nil" - (deps/alias-main-opts "deps.edn" [:dev]) nil) - -# --- cached resolution keys on aliases + user config ---------------------------- -(check "cache: aliased result differs from plain" - (deep= (deps/resolve-deps-cached "deps.edn" tree) - (deps/resolve-deps-cached "deps.edn" tree [:dev])) - false) -(check "cache: same key returns same roots" - (deep= (deps/resolve-deps-cached "deps.edn" tree [:dev]) - (deps/resolve-deps-cached "deps.edn" tree [:dev])) - true) - -# --- unknown alias errors -------------------------------------------------------- -(check "unknown alias errors" - (let [r (protect (deps/resolve-deps "deps.edn" tree [:nope]))] (r 0)) - false) - -# --- works without a user config (env unset) ------------------------------------ -(os/setenv "JOLT_CONFIG" (string base "/no-such-dir")) -(check "no user config still resolves" - (has-suffix-root (deps/resolve-deps "deps.edn" tree) "/a/src") true) - -(os/cd "/") -(rmrf base) - -(if (> fails 0) - (error (string "deps-aliases-test: " fails " failing check(s)")) - (print "\nAll deps-aliases tests passed!")) diff --git a/test/integration/deps-cache-args-test.janet b/test/integration/deps-cache-args-test.janet deleted file mode 100644 index 502fdf1..0000000 --- a/test/integration/deps-cache-args-test.janet +++ /dev/null @@ -1,41 +0,0 @@ -# The deps-image cache must not drop -main's command-line args under -# whole-program (jolt-4mui). A cache HIT swaps the running ctx for the saved -# image; *command-line-args* must be (re)bound from the CURRENT invocation's -# argv, not the stale value baked into the image. Drives the built binary: -# first run builds the cache (arg "first"), second run (cache hit) passes "second" -# — both must echo their own arg. Skips if build/jolt is absent. -(def repo (os/cwd)) -(def jolt (string repo "/build/jolt")) -(if-not (os/stat jolt) - (do (print "deps-cache-args: SKIP (no build/jolt)") (os/exit 0))) - -(def dir (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-dca-" (os/time))) -(os/mkdir dir) -(spit (string dir "/echoargs.clj") - "(ns echoargs)\n(defn -main [& args] (println \"GOT\" (pr-str (vec args))))\n") -# fresh per-run image cache dir so the first run is a guaranteed miss -(def imgdir (string dir "/imgcache")) (os/mkdir imgdir) - -(each [k v] [["JOLT_DIRECT_LINK" "1"] ["JOLT_WHOLE_PROGRAM" "1"] - ["JOLT_PATH" dir] ["JOLT_APP_PATHS" dir] ["JOLT_IMAGE_CACHE_DIR" imgdir]] - (os/setenv k v)) -(defn- run [arg] - (def p (os/spawn [jolt "-m" "echoargs" arg] :p {:out :pipe :err :pipe})) - (def out (:read (p :out) :all)) - (os/proc-wait p) - (string (or out ""))) - -(var fails 0) -(defn check [label got want] - (if (string/find want got) (print " ok " label) - (do (++ fails) (printf " FAIL %s: want %p in %p" label want got)))) - -(def r1 (run "first")) # cache MISS — builds + saves the image -(check "first run passes its arg" r1 `GOT ["first"]`) -(def r2 (run "second")) # cache HIT — must use the NEW arg, not the baked one -(check "second run (cache hit) passes its arg, not the baked one" r2 `GOT ["second"]`) - -(defn rmrf [p] (when (os/stat p) (if (= :directory (os/stat p :mode)) (do (each e (os/dir p) (rmrf (string p "/" e))) (os/rmdir p)) (os/rm p)))) -(rmrf dir) -(if (> fails 0) (do (printf "deps-cache-args: %d FAILED" fails) (os/exit 1)) - (print "deps-cache-args (jolt-4mui) passed!")) diff --git a/test/integration/deps-conflicts-test.janet b/test/integration/deps-conflicts-test.janet deleted file mode 100644 index dd082e4..0000000 --- a/test/integration/deps-conflicts-test.janet +++ /dev/null @@ -1,69 +0,0 @@ -# deps.edn conflict semantics (jolt-42f), tools.deps-shaped: -# a TOP-LEVEL :deps entry beats any transitive coordinate for the same lib -# (resolution is breadth-first, top level enqueued first), and when two -# DIFFERENT coordinates for one lib meet, a warning naming both goes to stderr. -# Local deps only: no network. - -(import ../../src/jolt/deps :as deps) - -(def base (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-deps-conflicts-" (os/time))) -(defn rmrf [p] - (when (os/stat p) - (if (= :directory (os/stat p :mode)) - (do (each e (os/dir p) (rmrf (string p "/" e))) (os/rmdir p)) - (os/rm p)))) -(rmrf base) -(defn mkdirs [p] - (def abs (string/has-prefix? "/" p)) - (var acc nil) - (each seg (filter |(not= "" $) (string/split "/" p)) - (set acc (cond (nil? acc) (if abs (string "/" seg) seg) (string acc "/" seg))) - (unless (os/stat acc) (os/mkdir acc)))) - -# proj depends on A and on B@b2 (top level). A depends on B@b1 (transitive). -# DFS-first-wins would pick b1; tools.deps semantics pick the top-level b2. -(each d ["proj/src" "a/src" "b1/src" "b2/src"] (mkdirs (string base "/" d))) -(spit (string base "/proj/deps.edn") - `{:paths ["src"] - :deps {my/a {:local/root "../a"} - my/b {:local/root "../b2"}}}`) -(spit (string base "/a/deps.edn") - `{:paths ["src"] :deps {my/b {:local/root "../b1"}}}`) -(spit (string base "/b1/deps.edn") `{:paths ["src"]}`) -(spit (string base "/b2/deps.edn") `{:paths ["src"]}`) - -(var fails 0) -(defn check [label got expected] - (if (= got expected) (print " ok " label) - (do (++ fails) (printf " FAIL %s: want %q, got %q" label expected got)))) -(defn has-suffix-root [roots suff] - (truthy? (some |(string/has-suffix? suff $) roots))) - -(os/cd (string base "/proj")) -(def tree (string base "/proj/jpm_tree")) - -(def warn-buf @"") -(def roots (with-dyns [:err warn-buf] (deps/resolve-deps "deps.edn" tree))) - -(check "top-level coordinate wins" (has-suffix-root roots "/b2/src") true) -(check "transitive loser not on path" (has-suffix-root roots "/b1/src") false) -(check "dep a still resolved" (has-suffix-root roots "/a/src") true) -(check "conflict warning names the lib" - (truthy? (string/find "my/b" (string warn-buf))) true) -(check "conflict warning names both coordinates" - (and (truthy? (string/find "../b1" (string warn-buf))) - (truthy? (string/find "../b2" (string warn-buf)))) true) - -# same coordinate twice from different parents: no warning -(spit (string base "/a/deps.edn") - `{:paths ["src"] :deps {my/b {:local/root "../b2"}}}`) -(def warn2 @"") -(with-dyns [:err warn2] (deps/resolve-deps "deps.edn" tree)) -(check "agreeing coordinates warn nothing" (string warn2) "") - -(os/cd "/") -(rmrf base) - -(if (> fails 0) - (error (string "deps-conflicts-test: " fails " failing check(s)")) - (print "\nAll deps-conflicts tests passed!")) diff --git a/test/integration/deps-conformance-test.janet b/test/integration/deps-conformance-test.janet deleted file mode 100644 index 90a98ac..0000000 --- a/test/integration/deps-conformance-test.janet +++ /dev/null @@ -1,59 +0,0 @@ -# Conformance pass for deps.edn-loaded libraries: resolve a few real, pure-cljc -# git libraries and check that their namespaces load and a sample call works. -# -# Network-gated: set JOLT_CONFORMANCE=1 to run (it clones from GitHub). Skipped by -# default so CI stays offline. Findings are summarized in docs/tools-deps.md. - -(use ../../src/jolt/api) -(use ../../src/jolt/types) -(import ../../src/jolt/deps :as deps) -(use ../../src/jolt/reader) -# deps are clj/cljc libraries by definition (the jolt-dw4 premise): read them -# under clj-compat features so their #?(:clj ...) branches resolve (spec -# 02-reader S18 — features are a property of the loading context). -(reader-features-set! ["jolt" "clj" "default"]) - -(unless (os/getenv "JOLT_CONFORMANCE") - (print "deps-conformance: set JOLT_CONFORMANCE=1 to run (needs network) — skipped") - (os/exit 0)) - -(def libs - [{:name "medley" :url "https://github.com/weavejester/medley" :tag "1.4.0" - :ns "medley.core" :check "(medley.core/find-first odd? [2 4 5])" :expect "5"} - {:name "cuerdas" :url "https://github.com/funcool/cuerdas" :tag "2022.06.16-403" - :ns "cuerdas.core" :check "(cuerdas.core/kebab \"helloWorld\")" :expect "hello-world"} - {:name "dependency" :url "https://github.com/stuartsierra/dependency" :tag "dependency-1.0.0" - :ns "com.stuartsierra.dependency" - :check "(boolean (com.stuartsierra.dependency/graph))" :expect "true"}]) - -(def base (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-conf-" (os/time))) -(os/mkdir base) - -(defn- try-lib [lib] - (def dir (string base "/" (lib :name))) - (os/mkdir dir) - (spit (string dir "/deps.edn") - (string "{:deps {the/lib {:git/url \"" (lib :url) "\" :git/tag \"" (lib :tag) "\"}}}")) - (def prev (os/cwd)) - (defer (os/cd prev) - (os/cd dir) - (def r (protect (deps/resolve-deps "deps.edn"))) - (if (not (r 0)) - [:resolve-failed (string (r 1))] - (let [ctx (init {:paths (r 1)})] - (ctx-set-current-ns ctx "user") - (def lr (protect (eval-string ctx (string "(require (quote [" (lib :ns) "]))")))) - (if (not (lr 0)) - [:load-failed (string (lr 1))] - (let [cr (protect (eval-string ctx (lib :check)))] - (cond - (not (cr 0)) [:check-error (string (cr 1))] - (= (string (normalize-pvecs (cr 1))) (lib :expect)) [:ok nil] - [:check-mismatch (string "got " (string (normalize-pvecs (cr 1))))]))))))) - -(print "deps conformance — pure-cljc git libs:\n") -(each lib libs - (def [status detail] (try (try-lib lib) ([err] [:crash (string err)]))) - (printf " %-12s %-16s %s" (lib :name) status (or detail ""))) -(print "") -(os/exit 0) diff --git a/test/integration/deps-loader-test.janet b/test/integration/deps-loader-test.janet deleted file mode 100644 index 96cca27..0000000 --- a/test/integration/deps-loader-test.janet +++ /dev/null @@ -1,48 +0,0 @@ -# The loader resolves namespaces against an ordered list of source roots (the -# stdlib first, then deps.edn-resolved dirs), trying .clj then .cljc. This is the -# foundation for loading Clojure libraries via deps.edn — here we point a root at -# a hand-written "library" and require it. - -(use ../../src/jolt/api) -(use ../../src/jolt/types) - -(def tmp (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-deps-test-" (os/time))) -(os/mkdir tmp) -(os/mkdir (string tmp "/mylib")) -(os/mkdir (string tmp "/other")) - -# a .cljc library with its own ns form and a require of a sibling ns -(spit (string tmp "/mylib/core.cljc") - "(ns mylib.core (:require [other.util :as u]))\n(defn double [x] (* 2 x))\n(defn doubled-inc [x] (u/inc1 (double x)))\n") -# a .clj sibling, with a dash in the name (-> underscore in the path) -(os/mkdir (string tmp "/other")) -(spit (string tmp "/other/util.clj") "(ns other.util)\n(defn inc1 [x] (+ x 1))\n") - -(def ctx (init {:paths [tmp]})) -(ctx-set-current-ns ctx "user") - -(var fails 0) -(defn check [label expr expected] - (let [r (protect (eval-string ctx expr)) - got (if (r 0) (normalize-pvecs (r 1)) (string "ERR " (r 1)))] - (if (= got expected) - (print " ok " label) - (do (++ fails) (printf " FAIL %s: want %q, got %q" label expected got))))) - -# require a .cljc lib from the added root and call it -(check "require .cljc lib" "(do (require (quote [mylib.core :as m])) (m/double 21))" 42) -# transitive require (mylib.core requires other.util) resolved from the root too -(check "transitive .clj require" "(mylib.core/doubled-inc 10)" 21) -# the stdlib still resolves from its default root -(check "stdlib still loads" "(do (require (quote [jolt.interop :as j])) (j/janet-type 1))" :number) - -# clean up -(defn rmrf [p] - (if (= :directory (os/stat p :mode)) - (do (each e (os/dir p) (rmrf (string p "/" e))) (os/rmdir p)) - (os/rm p))) -(rmrf tmp) - -(if (> fails 0) - (error (string "deps-loader-test: " fails " failing check(s)")) - (print "\nAll deps-loader tests passed!")) diff --git a/test/integration/deps-merged-cli-test.janet b/test/integration/deps-merged-cli-test.janet deleted file mode 100644 index e5acfa2..0000000 --- a/test/integration/deps-merged-cli-test.janet +++ /dev/null @@ -1,98 +0,0 @@ -# jolt-deps folded into jolt: the single `jolt` binary resolves a deps.edn into -# JOLT_PATH in-process and dispatches the deps subcommands (path/-M/run/tasks/ -# task), and auto-resolves a deps.edn for runnable commands (repl/-m/-e/FILE). -# Drives the BUILT binary (baked overlay -> cwd-independent) from a fixture -# project dir so deps.edn in cwd is picked up. :local/root deps only — no -# network. Skips cleanly if build/jolt is absent (source-only run). - -(def repo-root (os/cwd)) -(def jolt (string repo-root "/build/jolt")) - -(if-not (os/stat jolt) - (do (print "deps-merged-cli: SKIP (no build/jolt — run from source)") (os/exit 0))) - -(def base (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-merged-cli-" (os/time))) -(defn rmrf [p] - (when (os/stat p) - (if (= :directory (os/stat p :mode)) - (do (each e (os/dir p) (rmrf (string p "/" e))) (os/rmdir p)) - (os/rm p)))) -(rmrf base) -(defn mkdirs [p] - (var acc nil) - (each seg (filter |(not= "" $) (string/split "/" p)) - (set acc (if (nil? acc) (string "/" seg) (string acc "/" seg))) - (unless (os/stat acc) (os/mkdir acc)))) - -# project depends on a local lib; an alias with :main-opts; an :extra-paths -# alias; a :tasks map (shell task) -(each d ["proj/src/app" "lib/src/mylib"] (mkdirs (string base "/" d))) -(spit (string base "/proj/deps.edn") - `{:paths ["src"] - :deps {my/lib {:local/root "../lib"}} - :aliases {:run {:main-opts ["-m" "app.core"]} - :dev {:extra-paths ["dev"]}} - :tasks {greet "echo hello-task"}}`) -(spit (string base "/lib/deps.edn") `{:paths ["src"]}`) -(spit (string base "/lib/src/mylib/core.clj") "(ns mylib.core)\n(defn answer [] 42)\n") -(spit (string base "/proj/src/app/core.clj") - "(ns app.core (:require [mylib.core :as m]))\n(defn -main [& args] (println \"MAIN\" (m/answer) (count args)))\n") -(spit (string base "/proj/script.clj") - "(require '[mylib.core :as m])\n(println \"SCRIPT\" (m/answer))\n") - -# Run the built jolt from a given dir (cwd matters: deps.edn is read from cwd). -# Direct spawn (no shell) so arbitrary -e exprs need no quoting. Returns out+err. -(defn- run-in [dir & args] - (def prev (os/cwd)) - (os/cd dir) - (def p (os/spawn [jolt ;args] :p {:out :pipe :err :pipe})) - (def out (:read (p :out) :all)) - (def err (:read (p :err) :all)) - (os/proc-wait p) - (os/cd prev) - (string (or out "") (or err ""))) - -(var fails 0) -(defn check [label got pred] - (if (pred got) (print " ok " label) - (do (++ fails) (printf " FAIL %s: got %q" label got)))) -(defn- has [sub] (fn [s] (truthy? (string/find sub s)))) - -(def proj (string base "/proj")) - -# `path` prints the resolved roots: project's own src + the local dep's src -(check "path includes project src" (run-in proj "path") (has "/proj/src")) -(check "path includes local dep src" (run-in proj "path") (has "/lib/src")) - -# `-M:run` runs the alias :main-opts (-m app.core), requiring the local dep -(check "-M:run runs -main through resolved deps" (run-in proj "-M:run" "x" "y") (has "MAIN 42 2")) - -# `run FILE` resolves deps then runs the file -(check "run FILE resolves deps" (run-in proj "run" "script.clj") (has "SCRIPT 42")) - -# `tasks` lists the :tasks entries; `task NAME` runs a shell task -(check "tasks lists greet" (run-in proj "tasks") (has "greet")) -(check "task runs shell command" (run-in proj "task" "greet") (has "hello-task")) - -# auto-resolve: a plain -e in a deps.edn dir can require the local dep -(check "-e auto-resolves deps.edn in cwd" - (run-in proj "-e" "(require '[mylib.core :as m]) (println (m/answer))") - (has "42")) - -# -A:alias forces resolution (with that alias) for a runnable command -(check "-A:dev with -e resolves + runs" - (run-in proj "-A:dev" "-e" "(println (+ 1 2))") - (has "3")) - -# no deps.edn: plain run is unaffected (resolver/jpm never touched) -(mkdirs (string base "/plain")) -(check "-e in a no-deps dir works unchanged" - (run-in (string base "/plain") "-e" "(println (* 6 7))") - (has "42")) -# help/version never trigger resolution -(check "version works in a deps dir" (run-in proj "--version") (has "jolt v")) - -(rmrf base) -(if (> fails 0) - (do (printf "deps-merged-cli: %d FAILED" fails) (os/exit 1)) - (print "deps-merged-cli: all cases passed")) diff --git a/test/integration/deps-resolve-test.janet b/test/integration/deps-resolve-test.janet deleted file mode 100644 index 5a22b88..0000000 --- a/test/integration/deps-resolve-test.janet +++ /dev/null @@ -1,156 +0,0 @@ -# deps.edn resolution into source roots, then loading a library through them. -# Uses :local/root deps only so it needs no network (the git path is the same -# code, exercised manually against real repos). - -(use ../../src/jolt/api) -(use ../../src/jolt/types) -(import ../../src/jolt/deps :as deps) - -# Captured before any os/cd: subprocess tests below re-import src/jolt/deps. -(def repo-root (os/cwd)) - -(def base (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-deps-resolve-" (os/time))) -(defn rmrf [p] - (when (os/stat p) - (if (= :directory (os/stat p :mode)) - (do (each e (os/dir p) (rmrf (string p "/" e))) (os/rmdir p)) - (os/rm p)))) -(rmrf base) - -(defn mkdirs [p] - (def abs (string/has-prefix? "/" p)) - (var acc nil) - (each seg (filter |(not= "" $) (string/split "/" p)) - (set acc (cond (nil? acc) (if abs (string "/" seg) seg) (string acc "/" seg))) - (unless (os/stat acc) (os/mkdir acc)))) - -# project -> depends on lib-a (local), which depends on lib-b (local, transitive) -(each d ["proj/src" "a/src/liba" "b/src/libb"] (mkdirs (string base "/" d))) -(spit (string base "/proj/deps.edn") `{:paths ["src"] :deps {my/a {:local/root "../a"}}}`) -(spit (string base "/a/deps.edn") `{:paths ["src"] :deps {my/b {:local/root "../b"}}}`) -(spit (string base "/b/deps.edn") `{:paths ["src"]}`) -(spit (string base "/a/src/liba/core.clj") "(ns liba.core (:require [libb.core :as b]))\n(defn val [] (b/n))\n") -(spit (string base "/b/src/libb/core.clj") "(ns libb.core)\n(defn n [] 99)\n") - -(var fails 0) -(defn check [label got expected] - (if (= got expected) (print " ok " label) - (do (++ fails) (printf " FAIL %s: want %q, got %q" label expected got)))) - -(os/cd (string base "/proj")) -(def roots (deps/resolve-deps "deps.edn" (string base "/proj/jpm_tree"))) -# roots: proj/src, a/src (transitive: b/src) — at least the two dep srcs present -(check "resolves transitive local dep roots" - (truthy? (and (some |(string/has-suffix? "/a/src" $) roots) - (some |(string/has-suffix? "/b/src" $) roots))) - true) - -# load through the resolved roots: liba.core requires libb.core transitively -(def ctx (init {:paths roots})) -(ctx-set-current-ns ctx "user") -(let [r (protect (eval-string ctx "(do (require (quote [liba.core :as a])) (a/val))"))] - (check "require local lib + transitive dep" (if (r 0) (r 1) (string "ERR " (r 1))) 99)) - -# cached resolution returns the same roots without re-walking -(check "cached resolve matches" - (deep= roots (deps/resolve-deps-cached "deps.edn" (string base "/proj/jpm_tree"))) - true) - -# The cache must hit across PROCESSES: janet's (hash ...) is seeded per process, -# so a key built with it never matches a cached one and every invocation -# re-resolved (and re-fetched git deps). Detection: plant a sentinel root in the -# cache file — a fresh process that hits the cache returns it; a process that -# misses re-resolves and overwrites it. -(os/cd (string base "/proj")) -(def cache-file ".cpcache/jolt-deps.jdn") -(def cached-now (parse (slurp cache-file))) -(spit cache-file - (string/format "%j" (merge cached-now - {:roots [;(get cached-now :roots) "/SENTINEL"]}))) -(defn subprocess-roots [] - (def code - (string `(os/cd "` repo-root `") ` - `(import ./src/jolt/deps :as deps) ` - `(os/cd "` base "/proj" `") ` - `(print (string/join (deps/resolve-deps-cached "deps.edn" "` base "/proj/jpm_tree" `") ":"))`)) - (def p (os/spawn ["janet" "-e" code] :px {:out :pipe})) - (def out (ev/read (p :out) :all)) - (os/proc-wait p) - (string/trim (string out))) -(check "cache hits across processes" - (string/has-suffix? "/SENTINEL" (subprocess-roots)) - true) - -(os/cd "/") -(rmrf base) - -# Git-dep resolution must keep stdout clean: `JOLT_PATH=$(jolt-deps path)` is -# the documented capture, and git's checkout chatter ("HEAD is now at …") was -# corrupting it. Uses a file:// git dep so no network is needed. -(def gbase (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-deps-gitout-" (os/time))) -(rmrf gbase) -(each d ["lib/src/glib" "proj2"] (mkdirs (string gbase "/" d))) -(spit (string gbase "/lib/src/glib/core.clj") "(ns glib.core)\n(defn n [] 7)\n") -(spit (string gbase "/lib/deps.edn") `{:paths ["src"]}`) -(defn sh-out [args &opt cwd] - (def p (os/spawn args :px {:out :pipe :err :pipe :cd (or cwd ".")})) - (def out (ev/read (p :out) :all)) - (os/proc-wait p) - (string/trim (string out))) -(def git-ok - (truthy? - (protect - (do (sh-out ["git" "-c" "init.defaultBranch=master" "init"] (string gbase "/lib")) - (sh-out ["git" "add" "-A"] (string gbase "/lib")) - (sh-out ["git" "-c" "user.email=t@t" "-c" "user.name=t" "commit" "-m" "init" "-q"] - (string gbase "/lib")))))) -(if (not git-ok) - (print " skip git-dep stdout test (git unavailable)") - (do - (def sha (sh-out ["git" "rev-parse" "HEAD"] (string gbase "/lib"))) - (spit (string gbase "/proj2/deps.edn") - (string `{:paths ["src"] :deps {my/glib {:git/url "file://` gbase `/lib" :git/sha "` sha `"}}}`)) - (os/setenv "JOLT_GITLIBS" (string gbase "/gitlibs")) - (def code - (string `(os/cd "` repo-root `") ` - `(import ./src/jolt/deps :as deps) ` - `(os/cd "` gbase "/proj2" `") ` - `(deps/resolve-deps "deps.edn" "` gbase "/proj2/jpm_tree" `") ` - `(eprint "done")`)) - (def p (os/spawn ["janet" "-e" code] :px {:out :pipe})) - (def out (ev/read (p :out) :all)) - (os/proc-wait p) - (os/setenv "JOLT_GITLIBS" nil) - (check "git-dep resolution keeps stdout clean" (string (or out "")) "")) - ) -(rmrf gbase) - -# --- :jpm/module deps: janet libraries installed through jpm ----------------- -# Verification only (jpm owns installation): an importable module passes and -# contributes no roots; a missing one errors with the install hint. jpm/pm is -# always importable wherever jpm itself runs (CI included). -(do - (def jbase (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-deps-jpm-" (os/time))) - (mkdirs (string jbase "/src")) - (spit (string jbase "/deps.edn") - `{:paths ["src"] :deps {janet/jpm-pm {:jpm/module "jpm/pm"}}}`) - (def cwd (os/cwd)) - (os/cd jbase) - (def roots (deps/resolve-deps "deps.edn" (string jbase "/jpm_tree"))) - (os/cd cwd) - (check "jpm module dep resolves" true (not (nil? roots))) - (check "jpm module contributes no roots" 1 (length roots)) - - (spit (string jbase "/deps.edn") - `{:paths ["src"] :deps {janet/nope {:jpm/module "no/such-module-xyz"}}}`) - (os/cd jbase) - (def r (protect (deps/resolve-deps "deps.edn" (string jbase "/jpm_tree")))) - (os/cd cwd) - (check "missing jpm module errors" false (r 0)) - (check "error carries the install hint" true - (not (nil? (string/find "jpm install" (string (r 1)))))) - (rmrf jbase)) - -(if (> fails 0) - (error (string "deps-resolve-test: " fails " failing check(s)")) - (print "\nAll deps-resolve tests passed!")) diff --git a/test/integration/deps-tasks-test.janet b/test/integration/deps-tasks-test.janet deleted file mode 100644 index d45fc02..0000000 --- a/test/integration/deps-tasks-test.janet +++ /dev/null @@ -1,89 +0,0 @@ -# deps.edn :tasks (jolt-x4o) + the global gitlibs-style clone cache default -# (jolt-xkd). Tasks are the honest subset of babashka's: a STRING task is a -# shell command; a MAP task carries :main-opts (jolt args) and optional :doc. -# Local-only: no network, no jolt binary — the CLI wrappers stay thin. - -(import ../../src/jolt/deps :as deps) - -(def base (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-deps-tasks-" (os/time))) -(defn rmrf [p] - (when (os/stat p) - (if (= :directory (os/stat p :mode)) - (do (each e (os/dir p) (rmrf (string p "/" e))) (os/rmdir p)) - (os/rm p)))) -(rmrf base) -(defn mkdirs [p] - (def abs (string/has-prefix? "/" p)) - (var acc nil) - (each seg (filter |(not= "" $) (string/split "/" p)) - (set acc (cond (nil? acc) (if abs (string "/" seg) seg) (string acc "/" seg))) - (unless (os/stat acc) (os/mkdir acc)))) - -(each d ["proj/src" "config"] (mkdirs (string base "/" d))) -(spit (string base "/proj/deps.edn") - `{:paths ["src"] - :tasks {clean "rm -rf target" - test {:doc "run the suite" :main-opts ["-e" "(run-tests)"]} - fmt {:main-opts ["-e" "(fmt)"]}}}`) -# user-level task, and a project-shadowed name -(spit (string base "/config/deps.edn") - `{:tasks {lint "echo lint" clean "echo SHADOWED"}}`) - -(var fails 0) -(defn check [label got expected] - (if (= got expected) (print " ok " label) - (do (++ fails) (printf " FAIL %s: want %q, got %q" label expected got)))) - -(os/cd (string base "/proj")) -(os/setenv "JOLT_CONFIG" (string base "/config")) - -# --- task listing (merged user+project, sorted) --------------------------------- -(def listing (deps/tasks "deps.edn")) -(check "lists all task names" - (tuple ;(sort (map first listing))) ["clean" "fmt" "lint" "test"]) -(check "doc shows in listing" - (truthy? (some |(and (= (first $) "test") (= (get $ 1) "run the suite")) listing)) - true) - -# --- task lookup ------------------------------------------------------------------ -(check "string task is shell" - (deps/task-spec "deps.edn" "clean") {:type :shell :cmd "rm -rf target"}) -(check "project task shadows user task" - (get (deps/task-spec "deps.edn" "clean") :cmd) "rm -rf target") -(check "map task is jolt argv" - (deps/task-spec "deps.edn" "test") {:type :jolt :argv ["-e" "(run-tests)"]}) -(check "user-level task visible" - (deps/task-spec "deps.edn" "lint") {:type :shell :cmd "echo lint"}) -(check "unknown task is nil" - (deps/task-spec "deps.edn" "nope") nil) - -# --- tasks resolve with NO user config (regression: load-config skipped the -# name re-keying when only the project file existed) ----------------------------- -(os/setenv "JOLT_CONFIG" (string base "/no-such-dir")) -(check "task works without user config" - (deps/task-spec "deps.edn" "clean") {:type :shell :cmd "rm -rf target"}) -(check "listing works without user config" - (tuple ;(sort (map first (deps/tasks "deps.edn")))) ["clean" "fmt" "test"]) -(os/setenv "JOLT_CONFIG" (string base "/config")) - -# --- global clone-tree default (jolt-xkd) ---------------------------------------- -# resolution with :local deps never clones, but the default tree dir must come -# from $JOLT_GITLIBS (else (config-dir)/gitlibs), not ./jpm_tree -(os/setenv "JOLT_GITLIBS" (string base "/deep/nested/gitlibs")) -(deps/resolve-deps "deps.edn") -(check "JOLT_GITLIBS dir created (parents too)" - (truthy? (os/stat (string base "/deep/nested/gitlibs"))) true) -(check "no per-project jpm_tree" (os/stat (string base "/proj/jpm_tree")) nil) - -# roots cache is project-local .cpcache, not inside the clone tree -(deps/resolve-deps-cached "deps.edn") -(check "roots cache in ./.cpcache" - (truthy? (os/stat (string base "/proj/.cpcache/jolt-deps.jdn"))) true) - -(os/setenv "JOLT_GITLIBS" "") -(os/cd "/") -(rmrf base) - -(if (> fails 0) - (error (string "deps-tasks-test: " fails " failing check(s)")) - (print "\nAll deps-tasks tests passed!")) diff --git a/test/integration/devirt-test.janet b/test/integration/devirt-test.janet deleted file mode 100644 index 190a8e3..0000000 --- a/test/integration/devirt-test.janet +++ /dev/null @@ -1,43 +0,0 @@ -# Protocol-dispatch devirtualization (jolt-41m): when the inference proves a -# protocol call's receiver is a known record type, the call is compiled to a -# DIRECT method call, skipping the runtime dispatch registry. This must stay -# SOUND — same results as the dispatched path — including polymorphic dispatch -# (the right method per type), fallback when the receiver type is unknown, and -# heterogeneous collections. Runs a protocol+record program through the built -# binary (devirt needs infer-unit!, which runs on ns load, not eval-string) and -# checks the output. Skips cleanly if build/jolt is absent. -(def jolt "build/jolt") - -(defn- run [whole?] - (def dir (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-dv-test")) - (os/mkdir dir) - (spit (string dir "/dv.clj") - (string - "(ns dv)\n" - "(defprotocol Shape (area [s]) (kind [s]))\n" - "(defrecord Rect [w h] Shape (area [r] (* (:w r) (:h r))) (kind [_] :rect))\n" - "(defrecord Circ [r] Shape (area [c] (* 3 (:r c) (:r c))) (kind [_] :circ))\n" - "(defn poly [s] (area s))\n" # receiver unknown -> must fall back - "(defn -main []\n" - " (println (area (->Rect 3 4)) (area (->Circ 5))\n" # devirt: 12 75 - " (kind (->Rect 1 1)) (kind (->Circ 1))\n" # devirt: :rect :circ - " (poly (->Rect 3 4)) (poly (->Circ 5))\n" # fallback: 12 75 - " (mapv area [(->Rect 2 3) (->Circ 2)])))\n")) # heterogeneous: [6 12] - (def out (string dir "/out.txt")) - (def jbin (string (os/cwd) "/" jolt)) - # -m auto-enables whole-program under direct-linking now, so the per-ns case - # (whole? false) must explicitly opt out to test the dispatched/per-ns path. - (def cmd (string (if whole? "JOLT_WHOLE_PROGRAM=1 " "JOLT_NO_WHOLE_PROGRAM=1 ") - "JOLT_DIRECT_LINK=1 JOLT_PATH=" dir " " jbin " -m dv > " out " 2>&1")) - (os/execute ["sh" "-c" cmd] :p) - (string/trimr (slurp out))) - -(def expected "12 75 :rect :circ 12 75 [6 12]") -(if (not (os/stat jolt)) - (print "devirt: SKIP (no build/jolt — run from source)") - (let [per-ns (run false) whole (run true)] - (printf " per-ns: %s" per-ns) - (printf " whole-program: %s" whole) - (if (and (= per-ns expected) (= whole expected)) - (print "devirt: correct (dispatched == devirtualized)") - (do (printf "devirt: WRONG — expected %q" expected) (os/exit 1))))) diff --git a/test/integration/direct-linking-test.janet b/test/integration/direct-linking-test.janet deleted file mode 100644 index ba0e101..0000000 --- a/test/integration/direct-linking-test.janet +++ /dev/null @@ -1,76 +0,0 @@ -# Direct-linking / redefinition matrix (jolt-d9j, jolt-g86). -# -# Direct-linking is a per-compilation-UNIT property (Clojure model). A call -# compiles direct iff the unit has direct-linking on AND the target is not -# ^:redef/^:dynamic AND the target is an already-defined fn. Otherwise indirect -# (live var deref → redefinable). This pins the user-visible semantics: -# - default user/REPL unit (direct-linking off): redefine anything, callers see it -# - direct-linked unit: callers don't see a later redef (unless target ^:redef) -# - :aot-core? gates whether the core tiers compile direct-linked - -(use ../../src/jolt/api) - -(var failures 0) -(defn- check [label got want] - (unless (= got want) - (++ failures) - (printf "FAIL [%s] got %q want %q" label got want))) - -# 1. Default unit (direct-linking OFF): redefinition reaches compiled callers. -(let [ctx (init {:compile? true})] - (eval-string ctx "(defn add [a b] (+ a b))") - (eval-string ctx "(defn caller [] (add 1 2))") - (check "default before redef" (eval-string ctx "(caller)") 3) - (eval-string ctx "(defn add [a b] (* a b))") - (check "default sees redef (indirect)" (eval-string ctx "(caller)") 2)) - -# 2. Direct-linked unit: compiled caller keeps the original target after a redef. -(let [ctx (init {:compile? true :direct-linking? true})] - (eval-string ctx "(defn add [a b] (+ a b))") - (eval-string ctx "(defn caller [] (add 1 2))") - (check "direct before redef" (eval-string ctx "(caller)") 3) - (eval-string ctx "(defn add [a b] (* a b))") - (check "direct ignores redef (sealed)" (eval-string ctx "(caller)") 3) - # the var itself is still redefined; only the direct-linked call is frozen - (check "direct var still updated" (eval-string ctx "(add 3 4)") 12)) - -# 3. ^:redef opts a var OUT of direct-linking even in a direct-linked unit. -(let [ctx (init {:compile? true :direct-linking? true})] - (eval-string ctx "(defn ^:redef add [a b] (+ a b))") - (eval-string ctx "(defn caller [] (add 1 2))") - (check "redef-tagged before" (eval-string ctx "(caller)") 3) - (eval-string ctx "(defn ^:redef add [a b] (* a b))") - (check "redef-tagged sees redef" (eval-string ctx "(caller)") 2)) - -# 4. :aot-core? true (default): redefining a core fn (in clojure.core) is still -# seen by USER code, because user calls are indirect regardless of core being -# direct-linked internally. -(let [ctx (init {:compile? true})] - (eval-string ctx "(defn uses-last [] (last [1 2 3]))") - (check "core call before" (eval-string ctx "(uses-last)") 3) - (eval-string ctx "(in-ns (quote clojure.core))") - (eval-string ctx "(def last (fn [coll] :patched))") - (eval-string ctx "(in-ns (quote user))") - (check "user sees core redef (indirect)" (eval-string ctx "(uses-last)") :patched)) - -# 5. :aot-core? false: core compiles indirect too, so even core-internal callers -# see a redef — the whole language is redefinable. -(let [ctx (init {:compile? true :aot-core? false})] - (check "aot-core off still correct" (eval-string ctx "(last [1 2 3])") 3)) - -# 6. Redefining a record with REORDERED fields must rebind the ctor (jolt-wf4). -# deftype expands to (do (def R (make-deftype-ctor ...)) (def ->R R) ...): the -# `->R` alias references R in the SAME compiled unit. Direct-link embeds a var's -# root as a compile-time constant, but R's redefined root hasn't RUN yet when -# that unit compiles — so ->R must NOT seal to R's stale (pre-redef) ctor. -(let [ctx (init {:compile? true :direct-linking? true})] - (eval-string ctx "(defrecord R [x a])") - (eval-string ctx "(defrecord R [a x])") - (check "record field-reorder redefine: :a reads the new layout" - (eval-string ctx "(:a (->R 10 20))") 10) - (check "record field-reorder redefine: :x reads the new layout" - (eval-string ctx "(:x (->R 10 20))") 20)) - -(if (pos? failures) - (do (printf "direct-linking: %d failure(s)" failures) (os/exit 1)) - (print "direct-linking: all matrix cases passed")) diff --git a/test/integration/dispatch-cache-test.janet b/test/integration/dispatch-cache-test.janet deleted file mode 100644 index 334bd3a..0000000 --- a/test/integration/dispatch-cache-test.janet +++ /dev/null @@ -1,51 +0,0 @@ -# Protocol host-value dispatch cache (jolt-4ay). -# -# Host-value protocol dispatch used to recompute the candidate type-tag list and -# walk the registry on every call. It's now a generation-guarded cache keyed by -# (most-specific-host-tag, protocol, method); registering a protocol impl bumps -# the registry generation and invalidates it. This pins correctness: the cache -# must never hide a re-extension. - -(use ../../src/jolt/api) - -(var failures 0) -(defn- check [label got want] - (unless (= got want) - (++ failures) - (printf "FAIL [%s] got %q want %q" label got want))) - -(each mode [{:compile? true} {} {:aot-core? false}] - (def ctx (init-cached mode)) - (eval-string ctx "(defprotocol P (m [x]))") - (eval-string ctx "(extend-protocol P Number (m [x] (* x 2)))") - (check (string mode " host dispatch") (eval-string ctx "(m 5)") 10) - (check (string mode " cache hit (same class)") (eval-string ctx "(m 7)") 14) - # Re-extend: registry generation bumps, cache must invalidate. - (eval-string ctx "(extend-protocol P Number (m [x] (+ x 100)))") - (check (string mode " sees re-extension") (eval-string ctx "(m 5)") 105) - # Extending a different host class bumps gen too; number impl re-resolves. - (eval-string ctx "(extend-protocol P String (m [x] (str \"s:\" x)))") - (check (string mode " other class") (eval-string ctx "(m \"hi\")") "s:hi") - (check (string mode " number after other-class extend") (eval-string ctx "(m 3)") 103)) - -# Multimethod hierarchy-fallback cache (jolt-g8w): the isa? walk result for a -# dispatch value is cached; defmethod/remove-method must invalidate it. -(each mode [{:compile? true} {} {:aot-core? false}] - (def ctx (init-cached mode)) - (eval-string ctx "(derive ::circle ::shape)") - (eval-string ctx "(derive ::square ::shape)") - (eval-string ctx "(defmulti area identity)") - (eval-string ctx "(defmethod area ::shape [_] :generic)") - (check (string mode " mm hierarchy") (eval-string ctx "(area ::circle)") :generic) - (check (string mode " mm cache hit") (eval-string ctx "(area ::circle)") :generic) - # adding a more specific method must invalidate the cached hierarchy result - (eval-string ctx "(defmethod area ::circle [_] :specific)") - (check (string mode " mm sees new method") (eval-string ctx "(area ::circle)") :specific) - (check (string mode " mm other still hierarchy") (eval-string ctx "(area ::square)") :generic) - # removing it must re-expose the hierarchy fallback - (eval-string ctx "(remove-method area ::circle)") - (check (string mode " mm sees removal") (eval-string ctx "(area ::circle)") :generic)) - -(if (pos? failures) - (do (printf "dispatch-cache: %d failure(s)" failures) (os/exit 1)) - (print "dispatch-cache: all cases passed (compile, interpret, aot-core off)")) diff --git a/test/integration/embedded-stdlib-test.janet b/test/integration/embedded-stdlib-test.janet deleted file mode 100644 index 20ce338..0000000 --- a/test/integration/embedded-stdlib-test.janet +++ /dev/null @@ -1,33 +0,0 @@ -# The .clj stdlib (clojure.string, clojure.set, jolt.interop, …) is baked into the -# image at build time, so it loads even when the files aren't on disk. We simulate -# the shipped-binary-elsewhere case by clearing the filesystem source roots, so a -# require can only be satisfied by the embedded copy. - -(use ../../src/jolt/api) -(use ../../src/jolt/types) - -(def ctx (init-cached)) -(ctx-set-current-ns ctx "user") -(put (ctx :env) :source-paths @[]) # no FS roots — embedded fallback only - -(var fails 0) -(defn check [label expr expected] - (let [r (protect (eval-string ctx expr)) - got (if (r 0) (normalize-pvecs (r 1)) (string "ERR " (r 1)))] - (if (= got expected) (print " ok " label) - (do (++ fails) (printf " FAIL %s: want %q, got %q" label expected got))))) - -(assert (> (length (get (ctx :env) :embedded-sources)) 0) "embedded-sources should be populated") - -(check "clojure.string from embedded" - "(do (require (quote [clojure.string :as s])) (s/upper-case \"hi\"))" "HI") -(check "clojure.set from embedded" - "(do (require (quote [clojure.set :as set])) (vec (set/union #{1} #{2})))" [2 1]) -(check "clojure.walk from embedded" - "(do (require (quote [clojure.walk :as w])) (w/keywordize-keys {\"a\" 1}))" {:a 1}) -(check "jolt.interop from embedded" - "(do (require (quote [jolt.interop :as j])) (j/janet-type 1))" :number) - -(if (> fails 0) - (error (string "embedded-stdlib-test: " fails " failing check(s)")) - (print "\nAll embedded-stdlib tests passed!")) diff --git a/test/integration/fallback-zero-test.janet b/test/integration/fallback-zero-test.janet deleted file mode 100644 index bdf40b4..0000000 --- a/test/integration/fallback-zero-test.janet +++ /dev/null @@ -1,131 +0,0 @@ -# Fallback-zero verification (Stage 1 Task 3). -# -# self-host-test.janet checks observable RESULTS but not WHICH path ran — a form -# that silently fell back to the interpreter still "passes" there. This harness -# checks the path: it runs the portable analyzer (jolt.analyzer/analyze, via -# backend/analyze-form) on a corpus of NON-STATEFUL forms and asserts NONE raise -# :jolt/uncompilable — i.e. the self-hosted analyzer actually COMPILED them. -# -# As analyzer↔compiler.janet parity grows (Stage 1), move forms from the -# "intentional fallback" sanity list into the must-compile corpus. The day the -# fallback set equals the frozen intentional stateful set, the Janet bootstrap -# compiler is retireable. -# -# Mechanism: backend/analyze-form throws (a "jolt/uncompilable: …" string) for a -# punted form; (protect …) turns that into [false msg]. [true ir] == compiled. - -(import ../../src/jolt/backend :as backend) -(use ../../src/jolt/api) -(use ../../src/jolt/reader) - -(def ctx (init-cached)) - -(defn- analyzes? [s] - # true if the form COMPILES end to end (analyzer IR + back end emit), false if - # it punts to the interpreter. Checks emit-ir too, not just analyze-form: letfn - # and (def x) with no init now ANALYZE to IR, but the Janet back end punts them - # at emit time (sequential let* can't express mutual recursion; an unbound var - # is not a compiled value) — so analyze-form alone would miss the real - # compile-vs-interpret decision that compile-and-eval makes. - (def r (protect (backend/emit-ir ctx (backend/analyze-form ctx (parse-string s))))) - (and (r 0) true)) - -# --- Must compile: pure, non-stateful value production. NONE may punt. --- -(def must-compile - [# set literals (Task 1) - "#{1 2 3}" "#{}" "#{:a :b :c}" "#{(inc 0) 2}" "(conj #{1 2} 3)" - "[#{1 2} {:s #{3}}]" "(let [x 5] #{x (inc x)})" - # other literals - "[1 2 3]" "{:a 1 :b 2}" "{:k (inc 0)}" "[[1] [2 3]]" "42" ":kw" "\"str\"" - # control flow + binding - "(+ 1 2)" "(if true 1 2)" "(do 1 2 3)" "(let [a 1 b 2] (+ a b))" - "(fn [x] (* x x))" "(fn ([a] a) ([a b] (+ a b)))" - "(loop [i 0] (if (< i 3) (recur (inc i)) i))" - "(quote (a b c))" "(throw (ex-info \"x\" {}))" - "(try (inc 1) (catch :default e e))" - # def + calls into core - "(def answer 42)" "(map inc [1 2 3])" "(reduce + 0 [1 2 3])" - "(get {:a 1} :a)" "(vec (range 5))" - # set?/disj are plain fns now, not special forms (jolt-g3h) - "(set? #{1 2})" "(disj #{1 2 3} 2)" - # Stage 2 (jolt-eaa): stateful forms moved onto the compile path. (binding only - # compiles over an INTERNED var; the built-in dynamic vars aren't interned yet, - # so it's exercised end-to-end in the state spec instead.) - "(require (quote [clojure.string :as s]))" "(in-ns (quote foo.bar))" - "(ns foo.bar (:require [clojure.string :as s]))" - "(defprotocol P (m [x]))" "(extend-type Long P (m [x] x))" - "(reify P (m [this] 1))" "(var map)" - # Stage 2 tier 5: type/dispatch definitional forms compile too - "(deftype Pt [x y])" "(deftype Sq [s] P (m [this] s))" - "(defrecord Rec [a b])" "(defmulti mf :k)" "(defmethod mf :a [x] x)" - # Stage 2 tier 6: var fns are ordinary invokes now - "(var-get (var map))" "(var? (var map))" "(var-set (var map) map)" - "(alter-var-root (var map) identity)" "(find-var (quote clojure.core/map))" - "(intern (quote user) (quote tier6-sym) 42)" - "(alter-meta! (var map) assoc :k 1)" "(reset-meta! (var map) {})" - # Stage 2 tier 6b: ns-introspection fns are ordinary invokes now - "(find-ns (quote clojure.core))" "(create-ns (quote t6.created))" - "(remove-ns (quote t6.created))" "(count (all-ns))" - "(the-ns (quote clojure.core))" "(ns-interns (quote clojure.core))" - "(ns-aliases (quote user))" "(ns-imports (quote user))" - "(ns-resolve (quote clojure.core) (quote map))" "(resolve (quote map))" - "(refer (quote clojure.string))" - # Stage 2 tier 6c: dispatch-table ops + misc compile as macros/plain invokes - "(prefer-method mf :a :b)" "(remove-method mf :a)" "(remove-all-methods mf)" - # get-method/methods take the multimethod VALUE (Clojure semantics), so the - # arg must resolve — use a real multifn (print-method) rather than the - # never-defined mf the isolated analyzer can't resolve. - "(get-method print-method :default)" "(methods print-method)" - "(satisfies? P 5)" "(instance? String \"x\")" "(locking :x 1)" - "(defonce fz-once 1)" "(read-string \"[1 2]\")" - "(macroexpand-1 (quote (when true 1)))"]) - -# --- THE FROZEN PUNT SET (Stage 2 complete) --------------------------------- -# These are the ONLY heads that may reach the interpreter, exhaustively: -# defmacro — definitional host seam (the EXPANDERS are compiled; -# see backend/recompile-macros!) -# set! — host var-cell mutation special -# letfn — analyzes to a :letrec IR node now (inc 3g), but the Janet -# back end still punts it at emit: its sequential let* can't -# express the mutual recursion. The Chez back end DOES -# compile it (letrec*). Janet stays interpret until emit-let -# gains a letrec lowering. -# eval — compile-and-run entry (also loader stateful-head?) -# . / new / Foo. / — thin host-interop heads the back end doesn't model -# .method — analyzes to a :host-call IR node now (inc 3h), but the -# Janet back end punts it at emit (no interop model). The -# Chez back end DOES lower it (jolt-host-call). Same shape as -# letfn: compiles on Chez, interprets on Janet. -# .-field — field access stays punted at analyze (form-special?) -# gen-class, monitor-enter, monitor-exit — JVM-compat stubs -# Growing this list is a REGRESSION: a new punt means the compiler lost -# coverage. Shrinking it (e.g. letfn via letrec IR) is progress — move the -# form to must-compile. -(def must-punt - ["(defmacro m [x] x)" - "(set! *warn-on-reflection* true)" - "(letfn [(f [n] (g n)) (g [n] (f n))] (f 1))" - "(eval (quote (+ 1 2)))" - # .method analyzes to :host-call now; a resolvable target ("x") makes it punt - # at EMIT (the interop reason), not at analyze (an unresolved target). - "(.toUpperCase \"x\")" - "(.-field obj)" - "(new Foo 1)" - "(Foo. 1)" - "(gen-class :name X)" - "(monitor-enter x)" - "(monitor-exit x)"]) - -(var fails @[]) -(each s must-compile - (unless (analyzes? s) (array/push fails (string "FALLBACK (should compile): " s)))) -(each s must-punt - (when (analyzes? s) (array/push fails (string "COMPILED (should punt): " s)))) - -(printf "fallback-zero: %d must-compile + %d must-punt — %d failures" - (length must-compile) (length must-punt) (length fails)) -(when (> (length fails) 0) - (print "\nFailures:") - (each f fails (printf " %s" f)) - (os/exit 1)) -(print "fallback-zero: OK (analyzer compiled the full non-stateful corpus)") diff --git a/test/integration/features-test.janet b/test/integration/features-test.janet deleted file mode 100644 index 318009d..0000000 --- a/test/integration/features-test.janet +++ /dev/null @@ -1,147 +0,0 @@ -# Feature regression tests: a broad sweep of Clojure features (destructuring, -# multimethods, protocols, laziness, …). Each case asserts (= expected actual) -# evaluated inside Jolt (so comparisons use Jolt's own Clojure-semantics =). -# Run via `jpm test`. -(use ../../src/jolt/api) - -(var pass 0) -(def fails @[]) - -(defn check [label expected actual] - # evaluate (= expected actual) in a fresh ctx; expects boolean true - (def ctx (init-cached)) - (def res (protect (eval-string ctx (string "(= " expected " " actual ")")))) - (cond - (not= (res 0) true) - (array/push fails [label "ERROR" (string (res 1))]) - (= (res 1) true) - (++ pass) - (let [got (protect (eval-string (init-cached) actual))] - (array/push fails [label "NEQ" - (string "want=" expected " got=" - (if (= (got 0) true) (string/format "%q" (got 1)) (string "ERR:" (got 1))))])))) - -(def cases - [ - ### 1. Destructuring - ["destr seq" "[10 20 30]" "(let [[a b c] [10 20 30]] [a b c])"] - ["destr map :or" "[\"Alice\" 30 \"Unknown\"]" - "(let [{:keys [name age city] :or {city \"Unknown\"}} {:name \"Alice\" :age 30}] [name age city])"] - ["destr nested map" "[1.0 2.5]" "(let [{[x y] :coords} {:coords [1.0 2.5]}] [x y])"] - ["destr :as" "[1 [1 2 3]]" "(let [[a :as all] [1 2 3]] [a all])"] - ["destr & rest" "[1 (quote (2 3))]" "(let [[a & r] [1 2 3]] [a r])"] - ["destr :strs" "[1 2]" "(let [{:strs [a b]} {\"a\" 1 \"b\" 2}] [a b])"] - ["destr fn-param" "7" "((fn [{:keys [a b]}] (+ a b)) {:a 3 :b 4})"] - - ### 2. Atoms - ["atom swap! inc" "1" "(do (def a (atom 0)) (swap! a inc) @a)"] - ["atom reset!" "100" "(do (def a (atom 0)) (reset! a 100) @a)"] - ["atom CAS ok" "true" "(do (def a (atom 5)) (compare-and-set! a 5 10))"] - ["atom CAS no" "false" "(do (def a (atom 5)) (compare-and-set! a 9 10))"] - ["atom thread-first swap!" "213" "(do (def a (atom 100)) (swap! a #(-> % (* 2) (+ 3))) (swap! a #(-> % (* 1) (+ 10))) @a)"] - ["atom swap! args" "10" "(do (def a (atom 1)) (swap! a + 2 3 4) @a)"] - ["atom swap-vals!" "[1 2]" "(do (def a (atom 1)) (swap-vals! a inc))"] - ["atom watch" "[1 2]" "(do (def lg (atom nil)) (def a (atom 1)) (add-watch a :k (fn [k r o n] (reset! lg [o n]))) (swap! a inc) @lg)"] - ["atom validator" "5" "(do (def a (atom 1 :validator pos?)) (reset! a 5) @a)"] - - ### 3. Lazy sequences - ["lazy filter inf" "(quote (0 2 4 6 8 10 12 14 16 18))" "(take 10 (filter even? (iterate inc 0)))"] - ["lazy take-while sq" "(quote (0 1 4 9 16 25 36 49))" "(take-while #(< % 50) (map #(* % %) (range)))"] - ["lazy cycle" "(quote (:a :b :c :a :b :c :a :b :c :a))" "(take 10 (cycle [:a :b :c]))"] - ["lazy-seq cons self" "(quote (1 2 4 8 16 32 64 128))" - "(do (defn my-it [f x] (lazy-seq (cons x (my-it f (f x))))) (take 8 (my-it #(* 2 %) 1)))"] - ["lazy self-ref fib" "(quote (0 1 1 2 3 5 8 13 21 34))" - "(do (def fib (lazy-cat [0 1] (map + (rest fib) fib))) (take 10 fib))"] - ["repeatedly" "(quote (1 1 1))" "(repeatedly 3 (fn [] 1))"] - ["range step" "(quote (0 2 4 6 8))" "(range 0 10 2)"] - - ### 4. Transducers - ["xf comp into" "[1 3 5 7 9]" "(into [] (comp (map inc) (filter odd?)) (range 10))"] - ["xf sequence" "(quote (1 3 5 7 9))" "(sequence (comp (map inc) (filter odd?)) (range 10))"] - ["xf transduce" "25" "(transduce (comp (map inc) (filter odd?)) + 0 (range 10))"] - ["xf take" "[0 1 2]" "(into [] (take 3) (range 100))"] - ["xf remove" "[1 3 5]" "(into [] (remove even?) [1 2 3 4 5])"] - - ### 5. Protocols & Records - ["record area circle" "78" "(do (defprotocol Sh (ar [t])) (defrecord Ci [r] Sh (ar [_] (int (* 3.14159 r r)))) (int (ar (->Ci 5))))"] - ["record field" "5" "(do (defrecord Ci [r]) (:r (->Ci 5)))"] - ["record map->" "3" "(do (defrecord P [x y]) (:x (map->P {:x 3 :y 4})))"] - ["protocol 2 methods" "[16 \"sq\"]" "(do (defprotocol Sh (ar [t]) (nm [t])) (defrecord Sq [s] Sh (ar [_] (* s s)) (nm [_] \"sq\")) (let [x (->Sq 4)] [(ar x) (nm x)]))"] - ["extend-protocol" "6" "(do (defprotocol G (g [x])) (extend-protocol G java.lang.Long (g [x] (inc x))) (g 5))"] - ["reify" "42" "(do (defprotocol P (m [_])) (m (reify P (m [_] 42))))"] - ["record equality" "true" "(do (defrecord R [a]) (= (->R 1) (->R 1)))"] - - ### 6. Multimethods - ["mm dispatch circle" "\"round\"" "(do (defmulti st :kind) (defmethod st :circle [_] \"round\") (defmethod st :default [_] \"unknown\") (st {:kind :circle}))"] - ["mm default" "\"unknown\"" "(do (defmulti st :kind) (defmethod st :circle [_] \"round\") (defmethod st :default [_] \"unknown\") (st {:kind :triangle}))"] - ["mm multi-arity" "[1 3]" "(do (defmulti f (fn [& a] (first a))) (defmethod f :x ([_ y] y) ([_ y z] (+ y z))) [(f :x 1) (f :x 1 2)])"] - - ### 7. Macros - ["macro log-call" "6" "(do (defmacro lc [e] `(let [r# ~e] r#)) (lc (* 2 3)))"] - ["macro quote arg" "(quote (* 2 3))" "(do (defmacro qa [e] `(quote ~e)) (qa (* 2 3)))"] - ["macroexpand-1" "true" "(do (defmacro mm [x] (list 'inc x)) (= '(inc 5) (macroexpand-1 '(mm 5))))"] - ["gensym distinct" "false" "(= (gensym) (gensym))"] - ["syntax-quote splice" "[1 2 3]" "(let [xs [1 2 3]] `[~@xs])"] - # syntax-quote fully-qualifies resolved core symbols to clojure.core/ (jolt-265). - ["syntax-quote unquote" "(quote (clojure.core/+ 1 5))" "(let [x 5] `(+ 1 ~x))"] - - ### 8. Recursion - ["recursion fact" "120" "(do (defn fact [n] (if (<= n 1) 1 (* n (fact (dec n))))) (fact 5))"] - ["recursion loop" "120" "(loop [i 5 acc 1] (if (zero? i) acc (recur (dec i) (* acc i))))"] - ["mutual recursion" "true" "(letfn [(ev? [n] (if (zero? n) true (od? (dec n)))) (od? [n] (if (zero? n) false (ev? (dec n))))] (ev? 6))"] - ["trampoline" ":done" "(do (defn a [n] (if (zero? n) :done (fn [] (a (dec n))))) (trampoline a 8))"] - - ### 9. Higher-order functions - ["partial" "15" "((partial + 5) 10)"] - ["comp" "8" "((comp #(* 2 %) inc) 3)"] - ["juxt" "[5 6 4]" "((juxt identity inc dec) 5)"] - ["every-pred" "true" "((every-pred pos? even?) 2 4 6)"] - ["some-fn" "true" "((some-fn even? neg?) 3 4)"] - ["fnil" "1" "((fnil inc 0) nil)"] - ["complement" "true" "((complement nil?) 1)"] - - ### 10. Threading macros - ["->> pipeline" "75" "(->> (range 20) (filter odd?) (map #(* % 3)) (take 5) (reduce +))"] - ["-> sqrt long" "15" "(-> 25 Math/sqrt long (+ 10))"] - ["some->" "2" "(some-> {:a {:b 1}} :a :b inc)"] - ["some-> nil" "nil" "(some-> {:a nil} :a :b)"] - ["cond->" "4" "(cond-> 1 true inc false (* 100) true (* 2))"] - ["as->" "20" "(as-> 1 x (inc x) (* x 10))"] - - ### 11. Exception handling - ["ex catch" "\"caught\"" "(try (throw (ex-info \"x\" {})) (catch :default e \"caught\"))"] - ["ex-message" "\"broke\"" "(try (throw (ex-info \"broke\" {:code 42})) (catch :default e (ex-message e)))"] - ["ex-data" "{:code 42}" "(try (throw (ex-info \"broke\" {:code 42})) (catch :default e (ex-data e)))"] - ["try finally" "[:body :fin]" "(do (def lg (atom [])) (try (swap! lg conj :body) (finally (swap! lg conj :fin))) @lg)"] - - ### 12. For comprehension - ["for nested :when" "(quote ([0 1] [0 2] [1 0] [1 2] [2 0] [2 1]))" - "(for [x (range 3) y (range 3) :when (not= x y)] [x y])"] - ["for :let" "(quote (1 4 9))" "(for [x [1 2 3] :let [sq (* x x)]] sq)"] - ["for :while" "(quote (0 1 2))" "(for [x (range 10) :while (< x 3)] x)"] - - ### 13b. Persistent lists — O(1) conj-prepend, immutable, value semantics - ["list conj prepends" "(quote (0 1 2 3))" "(conj (list 1 2 3) 0)"] - ["list conj multi" "(quote (:c :b :a))" "(conj (quote ()) :a :b :c)"] - ["list immutable" "true" "(let [l (list 1 2 3) l2 (conj l 9)] (and (= l (quote (1 2 3))) (= l2 (quote (9 1 2 3)))))"] - ["list? after conj" "true" "(list? (conj (list 1 2) 0))"] - ["list = vector elts" "true" "(= (quote (1 2 3)) [1 2 3])"] - ["reduce conj list" "(quote (2 1 0))" "(reduce conj (list) (range 3))"] - ["cons onto list" "(quote (0 1 2 3))" "(cons 0 (list 1 2 3))"] - - ### 14. Janet interop - ["interop method" "\"v=41\"" "(. {:value 41 :describe (fn [self] (str \"v=\" (:value self)))} describe)"] - ["interop field" "41" "(.-value {:value 41})"] - # vectors are persistent vectors (Janet tables); lists are Janet arrays - ["interop janet-type" ":array" "(do (require '[jolt.interop :as j]) (j/janet-type (list 1 2 3)))"] - ]) - -(each [label expected actual] cases (check label expected actual)) - -(printf "\n=== features-test: %d/%d passed ===" pass (length cases)) -(unless (empty? fails) - (print "--- Failures ---") - (each [label kind detail] fails (printf "[%s] %s: %s" kind label detail))) -(when (pos? (length fails)) - (error (string (length fails) " feature regression(s)"))) -(print "All feature tests passed!") diff --git a/test/integration/inline-sra-test.janet b/test/integration/inline-sra-test.janet deleted file mode 100644 index b713dcd..0000000 --- a/test/integration/inline-sra-test.janet +++ /dev/null @@ -1,64 +0,0 @@ -# Inline + scalar-replacement passes (jolt-87f, Route 1 AOT escape analysis). -# When a unit opts into direct-linking (:inline?, JOLT_DIRECT_LINK=1), the IR -# pipeline inlines small direct-linked fns and then scalar-replaces the now- -# exposed non-escaping map allocations: (:r {:r a ..}) -> a. This pins the -# transform (allocations actually vanish) AND that it stays semantics-preserving. -(import ../../src/jolt/api :as api) -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/reader :as reader) - -(print "Inline + scalar replacement (jolt-87f)...") - -# A ctx with inlining ON (independent of the build-time JOLT_DIRECT_LINK). -(def ctx (api/init-cached {:compile? true})) -(put (ctx :env) :direct-linking? true) -(put (ctx :env) :inline? true) -(api/eval-string ctx "(ns rt)") -(each s ["(defn v3 [r g b] {:r r :g g :b b})" - "(defn scale [l n] {:r (* (:r l) n) :g (* (:g l) n) :b (* (:b l) n)})" - "(defn add [l r] {:r (+ (:r l) (:r r)) :g (+ (:g l) (:g r)) :b (+ (:b l) (:b r))})" - "(defn dot [l r] (+ (+ (* (:r l) (:r r)) (* (:g l) (:g r))) (* (:b l) (:b r))))" - "(defn sub [l r] {:r (- (:r l) (:r r)) :g (- (:g l) (:g r)) :b (- (:b l) (:b r))})" - "(defn reflect [v n] (sub v (scale n (* 2.0 (dot v n)))))" - # self-recursive: must NOT be inlined into callers (its body has a free - # local — the fn-name self-reference — that would dangle when spliced). - "(defn countdown [n] (if (< n 1) :done (countdown (- n 1))))"] - (api/eval-string ctx s)) - -(defn alloc-count [src] - # struct / build-map literal occurrences in the emitted Janet = surviving map - # allocations (jolt builds a struct, falling back to build-map-literal). - (def code (string/format "%p" (backend/emit-ir ctx (backend/analyze-form ctx (reader/parse-string src))))) - [(length (string/find-all "struct " code)) - (length (string/find-all "build-map" code))]) - -# A vec3 chain whose intermediates never escape collapses to ONE result map. -(let [[s b] (alloc-count "(fn [v n] (reflect v n))")] - (assert (= 1 s) (string "reflect keeps exactly one alloc, got " s " struct")) - (assert (= 1 b) (string "reflect keeps exactly one build-map fallback, got " b))) - -# A fully consumed chain (result not returned as a map) allocates NOTHING. -(let [[s b] (alloc-count "(fn [v n] (dot (reflect v n) (reflect v n)))")] - (assert (= 0 s) (string "fully-consumed chain allocates no struct, got " s)) - (assert (= 0 b) (string "fully-consumed chain has no build-map fallback, got " b))) - -# Loop bodies optimize too (recur is not a blanket escape). -(let [[s _] (alloc-count "(fn [k] (loop [i 0 acc 0.0] (if (< i k) (recur (inc i) (+ acc (dot (v3 1.0 2.0 3.0) (v3 0.1 0.2 0.3)))) acc)))")] - (assert (= 0 s) (string "loop body allocates no struct, got " s))) - -# Correctness: inlined results match the obvious computation. -(assert (= 32.0 (api/eval-string ctx "(dot (v3 1.0 2.0 3.0) (v3 4.0 5.0 6.0))")) "dot value") -(assert (= 9.0 (api/eval-string ctx "(:r (add (v3 1.0 0.0 0.0) (scale (v3 4.0 0.0 0.0) 2.0)))")) "add+scale value") -# the self-recursive fn still runs (the closed-body guard kept it un-inlined) -(assert (= :done (api/eval-string ctx "(countdown 5)")) "recursive fn still works") - -# A redefinable (^:redef) callee must NOT be inlined — it stays a live var call. -(api/eval-string ctx "(defn ^:redef wobble [x] {:v x})") -(let [[s _] (alloc-count "(fn [] (:v (wobble 1)))")] - # wobble is not inlined, so its map isn't visible to scalar replacement: the - # lookup stays a call, and the (:v ...) result is whatever wobble returns. - (assert (= 7 (do (api/eval-string ctx "(defn ^:redef wobble [x] {:v (+ x 6)})") - (api/eval-string ctx "(:v (wobble 1))"))) - "redef callee stays live (redefinition is visible)")) - -(print "Inline + scalar replacement passed!") diff --git a/test/integration/ir-passes-test.janet b/test/integration/ir-passes-test.janet deleted file mode 100644 index 11b0286..0000000 --- a/test/integration/ir-passes-test.janet +++ /dev/null @@ -1,51 +0,0 @@ -# IR pass pipeline (jolt-2om, nanopass-lite): jolt.passes/run-passes applies -# pure IR->IR rewrites between the analyzer and the back end. The first pass -# is constant folding — it computes with the ACTUAL jolt fns, so folded -# results match runtime semantics by construction. -(import ../../src/jolt/api :as api) -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/reader :as reader) - -(print "IR passes (constant folding)...") -(def ctx (api/init-cached {:compile? true})) -(defn ir [src] (backend/analyze-form ctx (reader/parse-string src))) - -(defn check-const [src want] - (def n (ir src)) - (assert (= :const (n :op)) (string src " folds to a constant")) - (assert (= want (n :val)) (string src " folds to " (string/format "%q" want)))) - -(check-const "(+ 1 2 3)" 6) -(check-const "(* 2 (+ 3 4))" 14) -(check-const "(quot 7 2)" 3) -(check-const "(mod -7 3)" 2) -(check-const "(if (< 1 2) :yes :no)" :yes) -# dead-branch elimination: the untaken branch never evaluates (it must still -# RESOLVE — unresolved symbols are analysis errors as in Clojure, jolt-2o7.3) -(check-const "(if false (throw (ex-info \"boom\" {})) 2)" 2) -# an unresolvable symbol errors even in a dead branch (analysis precedes folding) -(assert (not ((protect (ir "(if false (this-would-not-resolve) 2)")) 0)) - "unresolved symbol errors even in a dead branch") - -# non-constants stay calls; folding must be conservative. `xq` is a real var -# (defined here) so it resolves, but its VALUE must not be folded in. -(api/eval-string ctx "(def xq 1)") -(assert (= :invoke ((ir "(+ xq 2)") :op)) "var ref stays a call") -(assert (= :invoke ((ir "(mod xq 0)") :op)) "non-const args stay calls") -# a fold that would THROW is left for runtime -(assert (= :invoke ((ir "(mod 5 0)") :op)) "throwing fold left to runtime") - -# and the folded code evaluates identically (3-mode conformance covers the -# broader matrix; this pins a couple end-to-end) -(assert (= 6 (api/eval-string ctx "(+ 1 2 3)")) "folded eval") -(assert (= :yes (api/eval-string ctx "(if (< 1 2) :yes :no)")) "folded if eval") - -# Folding reaches into every op's children via map-ir-children (phase 3a) — it is -# now total, so a constant nested in a fn arity / loop / try body folds too -# (const-fold previously passed :try through unfolded). Sound: folding preserves -# runtime results regardless of position, so these eval end-to-end (3-mode -# conformance covers the broader matrix). -(assert (= 3 ((api/eval-string ctx "(fn [x] (+ 1 2))") 0)) "folded fn arity body eval") -(assert (= 10 (api/eval-string ctx "(loop [i 0] (if (< i (* 2 5)) (recur (inc i)) i))")) "folded loop eval") -(assert (= 5 (api/eval-string ctx "(try (+ 2 3) (catch Throwable e 0))")) "folded try eval") -(print "IR passes passed!") diff --git a/test/integration/ir-try-shape-test.janet b/test/integration/ir-try-shape-test.janet deleted file mode 100644 index 54c3c50..0000000 --- a/test/integration/ir-try-shape-test.janet +++ /dev/null @@ -1,43 +0,0 @@ -# IR shape hygiene for :try nodes (phase 3b, jolt-26dm). analyze-try used to -# assoc :catch-sym/:catch-body/:finally nil-when-absent, which made the node a -# phm (jolt's nil-valued-key map representation) and forced backend densification -# before every :op read. It now adds those keys only when the clause is present -# — same discipline as the arity :rest key — so a try node stays a fast struct. -# The change is behavior-invisible (the back end reads each key nil-safely and -# gates on it), so we also pin that tries still evaluate correctly. -(import ../../src/jolt/api :as api) -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/reader :as reader) - -(print "IR :try shape...") -(def ctx (api/init-cached {:compile? true})) -(defn try-node [src] (backend/analyze-form ctx (reader/parse-string src))) - -(defn check-struct [src] - (def n (try-node src)) - (assert (= :try (n :op)) (string src " is a :try node")) - # a struct (nil-free) — NOT a phm; phm nodes carry a :jolt/deftype tag - (assert (struct? n) (string src " analyzes to a struct, not a phm")) - (assert (nil? (get n :jolt/deftype)) (string src " is not a phm"))) - -# no catch, no finally — neither optional key should appear -(check-struct "(try 1)") -# finally only — :catch-sym/:catch-body must be ABSENT, not nil -(def fin (try-node "(try 1 (finally 2))")) -(assert (struct? fin) "(try .. finally) is a struct") -(assert (nil? (get fin :catch-body)) "no catch-body when there is no catch") -(assert (get fin :finally) "finally present") -# catch only -(def cat (try-node "(try 1 (catch Throwable e 2))")) -(assert (struct? cat) "(try .. catch) is a struct") -(assert (get cat :catch-sym) "catch-sym present") -(assert (nil? (get cat :finally)) "no finally when there is none") -# catch + finally -(check-struct "(try 1 (catch Throwable e 2) (finally 3))") - -# behavior unchanged across all shapes -(assert (= 1 (api/eval-string ctx "(try 1)")) "try value") -(assert (= 2 (api/eval-string ctx "(try (throw (ex-info \"x\" {})) (catch Throwable e 2))")) "catch value") -(assert (= 7 (api/eval-string ctx "(let [a (atom 0)] (try (reset! a 7) (finally nil)) @a)")) "finally runs") -(assert (= 2 (api/eval-string ctx "(try (throw (ex-info \"x\" {})) (catch Throwable e 2) (finally 9))")) "catch+finally") -(print "IR :try shape passed!") diff --git a/test/integration/jank-conformance-test.janet b/test/integration/jank-conformance-test.janet deleted file mode 100644 index 470bc80..0000000 --- a/test/integration/jank-conformance-test.janet +++ /dev/null @@ -1,54 +0,0 @@ -# jank conformance: runs the Clojure-language pass-tests from a local jank -# checkout (https://github.com/jank-lang/jank, MPL-2.0) against Jolt and asserts -# the number that pass stays at/above a baseline. This does NOT vendor jank's -# sources (license differs) — it references ~/src/jank if present and SKIPS -# cleanly when absent, so it is a local/dev regression aid. -# -# Each jank pass-test is an assertion script ending in `:success`. We load it in -# a fresh context and count it as passing when it returns :success. -(use ../../src/jolt/api) - -(def jank-dir (string (os/getenv "HOME") "/src/jank/compiler+runtime/test/jank")) - -# Baseline: the number of pass-tests Jolt currently handles. Raise this as Jolt -# gains features so regressions (a previously-passing test breaking) are caught. -(def baseline 120) - -# Tests that loop forever under Jolt's eager evaluation (skipped to avoid hangs; -# tracked as known gaps — variadic-recur arity selection and var-quote calls). -(def skip-patterns ["/cpp/" "var-quote" "fn/recur/pass-variadic-position"]) - -(defn- skip? [path] - (var s false) - (each p skip-patterns (when (string/find p path) (set s true))) - s) - -(defn- walk [dir acc] - (each e (os/dir dir) - (def p (string dir "/" e)) - (case ((os/stat p) :mode) - :directory (walk p acc) - :file (when (and (string/has-suffix? ".jank" p) - (string/find "/pass-" p) - (not (skip? p))) - (array/push acc p)))) - acc) - -(if (not (os/stat jank-dir)) - (print "jank-conformance: ~/src/jank not present — skipped") - (do - (def files (sort (walk jank-dir @[]))) - (var pass 0) - (def fails @[]) - (each f files - # A pass-test passes when no assertion throws (assert now errors on failure). - (def res (protect (load-string (init-cached) (slurp f)))) - (if (= (res 0) true) - (++ pass) - (array/push fails (string/slice f (+ 1 (length jank-dir)))))) - (printf "jank-conformance: %d/%d pass-tests pass (baseline %d)" pass (length files) baseline) - (when (< pass baseline) - (print "--- regressions (now failing, were within baseline) ---") - (each rel fails (print " " rel)) - (error (string "jank conformance dropped to " pass " (baseline " baseline ")"))) - (printf "jank conformance OK (%d known gaps)" (length fails)))) diff --git a/test/integration/lazy-infinite-test.janet b/test/integration/lazy-infinite-test.janet deleted file mode 100644 index 1e068e2..0000000 --- a/test/integration/lazy-infinite-test.janet +++ /dev/null @@ -1,125 +0,0 @@ -# Deadlined infinite-seq conformance harness (Phase 5 Step 0). -# -# Each case is [name expected-clj actual-clj]. The harness spawns a subprocess -# worker (test/support/lazy-eval.janet) that evaluates (= expected actual) and -# prints @@RESULT true/false. Workers run under a wall-clock deadline; a hang -# = a FAIL. This is the safety net that makes it safe to convert transformers -# to lazy — wrong answers hang instead of silently passing. -# -# Pattern mirrors clojure-test-suite-test.janet: os/spawn + ev/with-deadline -# + os/proc-kill on timeout. Never probe infinite cases in-process. - -(def per-case-timeout 5) - -(defn- run-case [expected actual] - (def proc (os/spawn ["janet" "test/support/lazy-eval.janet" expected actual] :p {:out :pipe})) - (def out (proc :out)) - (var data nil) - (def ok - (try - (ev/with-deadline per-case-timeout - (set data (ev/read out 0x10000)) - (os/proc-wait proc) - true) - ([err] false))) - (when (not ok) - (protect (os/proc-kill proc true)) - (protect (ev/with-deadline 2 (os/proc-wait proc)))) - (protect (:close out)) - (if (and ok data) (string data) nil)) - -(defn- parse-result [s] - (def prefix-len (length "@@RESULT ")) - (if (string/has-prefix? "@@RESULT " s) - (let [val (string/slice s prefix-len (dec (length s)))] - [:ok val]) - (if (string/has-prefix? "@@ERROR " s) - (let [msg (string/slice s (length "@@ERROR ") (dec (length s)))] - [:error msg]) - nil))) - -# ---- Cases from phase-5.md §6.2 ---- -# Expected values use Clojure quote syntax so the worker evaluates -# (= (quote ...) actual) with Clojure's = semantics. -(def cases - [ - ["nth of map inc range" "1001" "(nth (map inc (range)) 1000)"] - ["first filter even? drop range" "4" "(first (filter even? (drop 3 (range))))"] - ["take 3 remove odd? range" "(quote (0 2 4))" "(take 3 (remove odd? (range)))"] - ["take 3 drop-while <5 range" "(quote (5 6 7))" "(take 3 (drop-while (fn [x] (< x 5)) (range)))"] - ["take 4 interleave range iterate" "(quote (0 10 1 11))" "(take 4 (interleave (range) (iterate inc 10)))"] - ["take 4 reductions + range" "(quote (0 1 3 6))" "(take 4 (reductions + (range)))"] - ["take 3 tree-seq infinite" "(quote (0 0 0))" "(take 3 (tree-seq (fn [_] true) (fn [n] [n]) 0))"] - ["sequence xform lazy inf" "(quote (1 2 3))" "(take 3 (sequence (map inc) (range)))"] - ["sequence comp xform inf" "(quote (2 4 6))" "(take 3 (sequence (comp (filter odd?) (map inc)) (range)))"] - ["every? short-circuits on inf" "false" "(every? pos? (range))"] - ["not-every? short-circuits on inf" "true" "(not-every? pos? (range))"] - ["take 3 partition 2 range" "(quote ((0 1) (2 3) (4 5)))" "(take 3 (partition 2 (range)))"] - ["take 3 partition-all 2 range" "(quote ((0 1) (2 3) (4 5)))" "(take 3 (partition-all 2 (range)))"] - ["take 3 map-indexed vector range" "(quote ([0 0] [1 1] [2 2]))" "(take 3 (map-indexed vector (range)))"] - ["take 3 distinct cycle" "(quote (1 2 3))" "(take 3 (distinct (cycle [1 2 1 3 1])))"] - ["take 6 mapcat dup range" "(quote (0 0 1 1 2 2))" "(take 6 (mapcat (fn [x] [x x]) (range)))"] - ["first rest lazy" "1" "(let [[a & r] (range)] (first r))"] - ["take 3 rest lazy" "(quote (1 2 3))" "(let [[a & r] (range)] (take 3 r))"] - ["dedupe inf" "(quote (1 2 1 2 1))" "(take 5 (dedupe (cycle [1 1 2 2])))"] - ["take 3 take-nth 2 range" "(quote (0 2 4))" "(take 3 (take-nth 2 (range)))"] - ["take 3 interpose :x range" "(quote (0 :x 1))" "(take 3 (interpose :x (range)))"] - ["take 3 map vector range iterate" "(quote ([0 100] [1 101] [2 102]))" "(take 3 (map vector (range) (iterate inc 100)))"] - - # §6.3 Laziness counter tests — realize exactly the demanded prefix. Under - # Option A `take` is lazy, so the take result must be forced (dorun) to drive - # realization; reading the counter without forcing would (correctly) see 0. - ["LAZY map" "3" "(do (def c (atom 0)) (dorun (take 3 (map (fn [x] (swap! c inc) x) (range)))) @c)"] - ["LAZY filter" "6" "(do (def c (atom 0)) (dorun (take 3 (filter (fn [x] (swap! c inc) (odd? x)) (range)))) @c)"] - ["LAZY remove" "6" "(do (def c (atom 0)) (dorun (take 3 (remove (fn [x] (swap! c inc) (even? x)) (range)))) @c)"] - ["LAZY take-while" "6" "(do (def c (atom 0)) (dorun (take-while (fn [x] (swap! c inc) (< x 5)) (range))) @c)"] - ["LAZY drop-while" "6" "(do (def c (atom 0)) (dorun (take 3 (drop-while (fn [x] (swap! c inc) (< x 5)) (range)))) @c)"] - ["LAZY distinct" "4" "(do (def c (atom 0)) (dorun (take 3 (distinct (map (fn [x] (swap! c inc) x) (cycle [1 2 1 3 1]))))) @c)"] - # 5, was 7: the canonical lazy take-nth (40-lazy, jolt-ded batch 3) realizes - # only the elements the taken outputs and their drops touch. - ["LAZY take-nth" "5" "(do (def c (atom 0)) (dorun (take 3 (take-nth 2 (map (fn [x] (swap! c inc) x) (range))))) @c)"] - ["LAZY map-indexed" "3" "(do (def c (atom 0)) (dorun (take 3 (map-indexed (fn [i x] (swap! c inc) [i x]) (range)))) @c)"] - ["LAZY keep" "6" "(do (def c (atom 0)) (dorun (take 3 (keep (fn [x] (swap! c inc) (if (odd? x) x nil)) (range)))) @c)"] - ["LAZY keep-indexed" "6" "(do (def c (atom 0)) (dorun (take 3 (keep-indexed (fn [i x] (swap! c inc) (if (odd? i) x)) (range)))) @c)"] - ["LAZY interpose" "2" "(do (def c (atom 0)) (dorun (take 3 (interpose :x (map (fn [x] (swap! c inc) x) (range))))) @c)"] - ["LAZY partition" "6" "(do (def c (atom 0)) (dorun (take 3 (partition 2 (map (fn [x] (swap! c inc) x) (range))))) @c)"] - ["LAZY partition-all" "6" "(do (def c (atom 0)) (dorun (take 3 (partition-all 2 (map (fn [x] (swap! c inc) x) (range))))) @c)"] - ["LAZY mapcat" "3" "(do (def c (atom 0)) (dorun (take 6 (mapcat (fn [x] (swap! c inc) [x x]) (range)))) @c)"] - ["LAZY dedupe" "9" "(do (def c (atom 0)) (dorun (take 5 (dedupe (map (fn [x] (swap! c inc) x) (cycle [1 1 2 2]))))) @c)"] - ["LAZY repeated inc" "3" "(do (def c (atom 0)) (dorun (take 3 (map (fn [x] (swap! c inc) x) (iterate inc 0)))) @c)"] - - # Already-working cases (guard against regression) - ["take 5 iterate inc" "(quote (0 1 2 3 4))" "(take 5 (iterate inc 0))"] - ["take 3 range" "(quote (0 1 2))" "(take 3 (range))"] - ["take 3 repeat" "(quote (7 7 7))" "(take 3 (repeat 7))"] - ["take 3 cycle" "(quote (1 2 1))" "(take 3 (cycle [1 2]))"] - ["take 3 filter even? range" "(quote (0 2 4))" "(take 3 (filter even? (range)))"] - ["take 5 lazily filtered from range" "(quote (1 3 5 7 9))" "(take 5 (filter odd? (range)))"] - ]) - -# ---- Run ---- -(var fails @[]) -(var timeouts 0) -(var passed 0) - -(each [name expected expr] cases - (def out (run-case expected expr)) - (cond - (nil? out) - (do (++ timeouts) (array/push fails (string "TIMEOUT: " name))) - (let [res (parse-result out)] - (case (res 0) - :ok (if (= "true" (res 1)) - (++ passed) - (array/push fails (string "MISMATCH: " name " — expected " expected))) - :error (array/push fails (string "ERROR: " name " — " (res 1))) - (array/push fails (string "PARSE: " name " — raw: " (string/trim out))))))) - -(printf "lazy-infinite: %d cases — %d passed / %d timeouts / %d failures" - (length cases) passed timeouts (length fails)) -(when (> (length fails) 0) - (print "\nFailures:") - (each f fails (printf " %s" f))) - -(if (or (> (length fails) 0) (> timeouts 0)) - (os/exit 1)) diff --git a/test/integration/macro-expansion-test.janet b/test/integration/macro-expansion-test.janet deleted file mode 100644 index 4b4adfc..0000000 --- a/test/integration/macro-expansion-test.janet +++ /dev/null @@ -1,91 +0,0 @@ -# Compiled macro expansion in EVERY mode (jolt-tzo: the fast macro-expansion -# path that unblocks moving hot fns the 00-syntax expanders depend on). -# -# Macros are ordinary compiled fns in Clojure's model. Compile mode has had -# this since the staged bootstrap (ensure-macros-compiled! recompiles the -# early interpreted expanders once the analyzer is alive); interpret mode — -# the conformance battery's default — used to skip it, so every distinct -# (and ...) / (cond ...) / nested expansion ran an interpreted closure. -# Now interpret-mode init also builds the analyzer once at the end of the -# overlay load and compiles every stashed expander; JOLT_INTERPRET_MACROS=1 -# opts back into the pure interpreted oracle. - -(use ../../src/jolt/api) -(use ../../src/jolt/types) - -(print "compiled macro expansion...") -(os/setenv "JOLT_INTERPRET_MACROS" nil) - -(defn- macro-var [ctx nm] (ns-find (ctx-find-ns ctx "clojure.core") nm)) -(defn- user-var [ctx nm] (ns-find (ctx-find-ns ctx "user") nm)) - -(def probes - ["(= 3 (and 1 2 3))" - "(= 1 (or nil false 1))" - "(= :b (cond false :a :else :b))" - "(= 4 (when-not nil 4))" - "(= 6 (-> 1 inc (* 3)))" - "(= 15 (->> [1 2] (map inc) (reduce +) (* 3)))" - "(= 2 (if-let [x nil] 1 2))" - "(= [0 1] (vec (for [i (range 2)] i)))" - "(= 5 (case 2 1 :one 2 5 :dflt))" - "(= 10 (loop [i 0 a 0] (if (< i 5) (recur (inc i) (+ a 2)) a)))"]) - -(defn- run-probes [ctx label] - (each prog probes - (def got (protect (eval-string ctx prog))) - (assert (and (got 0) (= (got 1) true)) - (string label " probe failed: " prog " => " - (if (got 0) (string/format "%q" (got 1)) (string (got 1))))))) - -# 1. Interpret mode: expanders are COMPILED after init (the new path). -(def ictx (init {})) -(run-probes ictx "interpret") -(each m ["when" "when-not" "and" "or" "cond" "->" "->>" "if-let" "case" "doseq"] - (def v (macro-var ictx m)) - (assert v (string m " var exists")) - (assert (get v :macro-compiled) - (string m " expander is compiled in interpret mode"))) - -# 2. A USER defmacro in an interpret ctx gets a compiled expander too. -(eval-string ictx "(defmacro my-twice [x] `(* 2 ~x))") -(assert (= 10 (eval-string ictx "(my-twice 5)")) "user macro works") -(assert (get (user-var ictx "my-twice") :macro-compiled) - "user macro expander compiled in interpret mode") - -# 3. An expander whose body the analyzer can't compile (here: the `eval` -# special form) falls back to the interpreted closure and still works. -(eval-string ictx "(defmacro evalish [x] (eval `(+ ~x 1)))") -(assert (= 3 (eval-string ictx "(evalish 2)")) "uncompilable expander works") -(assert (not (get (user-var ictx "evalish") :macro-compiled)) - "uncompilable expander stays interpreted") - -# 4. Compile mode unchanged: expanders compiled (pre-existing behavior). -(def cctx (init {:compile? true})) -(run-probes cctx "compile") -(assert (get (macro-var cctx "cond") :macro-compiled) "compile-mode expanders compiled") - -# 5. JOLT_INTERPRET_MACROS=1: the pure interpreted oracle — same semantics, -# expanders NOT compiled. -(os/setenv "JOLT_INTERPRET_MACROS" "1") -(def octx (init {})) -(run-probes octx "oracle") -(assert (not (get (macro-var octx "cond") :macro-compiled)) - "oracle mode keeps interpreted expanders") -(os/setenv "JOLT_INTERPRET_MACROS" nil) - -(print "compiled macro expansion passed!") - -# 6. Early overlay DEFNS get the same staged-recompile treatment (jolt-4j3): -# 00-syntax fns (destructure, and the expander-called keys/vals/empty?) load -# interpreted pre-kernel, then compile in the same end-of-init pass. -(each nm ["destructure" "empty?" "keys" "vals"] - (def v (macro-var ictx nm)) - (assert v (string nm " var exists")) - (assert (get v :defn-compiled) - (string nm " early defn is compiled (interpret mode)"))) -(def cctx2 (init {:compile? true})) -(assert (get (macro-var cctx2 "destructure") :defn-compiled) - "early defn compiled in compile mode too") -(assert (not (get (macro-var octx "destructure") :defn-compiled)) - "oracle mode keeps early defns interpreted") diff --git a/test/integration/mutable-deftype-test.janet b/test/integration/mutable-deftype-test.janet deleted file mode 100644 index 261cee2..0000000 --- a/test/integration/mutable-deftype-test.janet +++ /dev/null @@ -1,57 +0,0 @@ -# Mutable deftype fields under shapes/direct-link (jolt-c3q). -# -# A deftype field tagged ^:unsynchronized-mutable / ^:volatile-mutable is set! at -# runtime. Immutable records are shape-recs (immutable tuples) where shapes are -# active (direct-link), so set! can't mutate them. A deftype with ANY mutable -# field opts out of the shape-rec layout and uses the mutable table form (which -# set! already mutates and field reads route through), regardless of :shapes?. -# Immutable deftypes/records keep the fast shape-rec. - -(use ../../src/jolt/api) - -(var failures 0) -(defn- check [label got want] - (unless (= got want) - (++ failures) - (printf "FAIL [%s] got %q want %q" label got want))) - -# direct-linking? true => :shapes? on (the mode where immutable records are -# tuples and this used to error "Can't set! field on non-deftype: tuple"). -(let [ctx (init {:compile? true :direct-linking? true})] - (eval-string ctx "(deftype Counter [^:unsynchronized-mutable n])") - (eval-string ctx "(def c (->Counter 0))") - (check "read initial mutable field" (eval-string ctx "(.-n c)") 0) - (eval-string ctx "(set! (.-n c) 5)") - (check "read after set!" (eval-string ctx "(.-n c)") 5) - (eval-string ctx "(set! (.-n c) (inc (.-n c)))") - (check "set! using prior value" (eval-string ctx "(.-n c)") 6) - # keyword access reads the same mutated field - (check "keyword access sees mutation" (eval-string ctx "(:n c)") 6)) - -# Mixed mutable + immutable fields: a method reads both, set! touches the mutable. -(let [ctx (init {:compile? true :direct-linking? true})] - (eval-string ctx "(deftype Cell [label ^:unsynchronized-mutable v] Object (toString [_] (str label \"=\" v)))") - (eval-string ctx "(def cell (->Cell \"x\" 1))") - (check "immutable field reads" (eval-string ctx "(.-label cell)") "x") - (check "custom toString before" (eval-string ctx "(str cell)") "x=1") - (eval-string ctx "(set! (.-v cell) 42)") - (check "mutable field after set!" (eval-string ctx "(.-v cell)") 42) - (check "custom toString after mutation" (eval-string ctx "(str cell)") "x=42") - (check "immutable field unchanged" (eval-string ctx "(.-label cell)") "x")) - -# volatile-mutable is treated the same (also a mutable field). -(let [ctx (init {:compile? true :direct-linking? true})] - (eval-string ctx "(deftype Box [^:volatile-mutable x])") - (eval-string ctx "(def b (->Box :a))") - (eval-string ctx "(set! (.-x b) :z)") - (check "volatile-mutable set!" (eval-string ctx "(.-x b)") :z)) - -# An all-immutable deftype/record is unaffected: still a shape-rec, fast reads. -(let [ctx (init {:compile? true :direct-linking? true})] - (eval-string ctx "(defrecord Pt [x y])") - (check "immutable record reads" (eval-string ctx "(:x (->Pt 3 4))") 3) - (check "immutable record reads y" (eval-string ctx "(:y (->Pt 3 4))") 4)) - -(if (pos? failures) - (do (printf "mutable-deftype: %d failure(s)" failures) (os/exit 1)) - (print "mutable-deftype: all cases passed")) diff --git a/test/integration/namespace-test.janet b/test/integration/namespace-test.janet deleted file mode 100644 index 4d05f50..0000000 --- a/test/integration/namespace-test.janet +++ /dev/null @@ -1,119 +0,0 @@ -(use ../../src/jolt/reader) -(use ../../src/jolt/types) -(use ../../src/jolt/evaluator) -(import ../../src/jolt/api :as api) - -# ns/in-ns/require/use are overlay macros + clojure.core fns now (Stage 2 jolt-eaa), -# so these interpreter tests need the full env (init loads the overlay + installs -# the stateful fns), not a bare make-ctx. -(defn- fresh-ctx [] (api/init)) - -# Helper: parse and eval in a fresh ctx -(defn eval-str [s] - (let [ctx (fresh-ctx) - form (parse-string s)] - (eval-form ctx @{} form))) - -(print "1: in-ns...") -(let [ctx (fresh-ctx)] - (def form (parse-string "(in-ns 'my.app)")) - (eval-form ctx @{} form) - (assert (= "my.app" (ctx-current-ns ctx)) "in-ns switches namespace")) -(print " passed") - -(print "2: def in different namespace...") -(let [ctx (fresh-ctx)] - (eval-form ctx @{} (parse-string "(in-ns 'my.app)")) - (eval-form ctx @{} (parse-string "(def x 42)")) - (let [ns (ctx-find-ns ctx "my.app") - v (ns-find ns "x")] - (assert (= 42 (var-get v)) "def works in new namespace"))) -(print " passed") - -(print "3: ns form...") -(let [ctx (fresh-ctx)] - (eval-form ctx @{} (parse-string "(ns my.lib)")) - (assert (= "my.lib" (ctx-current-ns ctx)) "ns sets current namespace")) -(print " passed") - -(print "4: ns with require...") -(let [ctx (fresh-ctx)] - # Set up a namespace with some vars - (let [other-ns (ctx-find-ns ctx "other.lib")] - (ns-intern other-ns "f" (fn [x] (inc x)))) - # Now ns with require - (eval-form ctx @{} (parse-string "(ns my.app (:require [other.lib :as o]))")) - # current-ns should be my.app - (assert (= "my.app" (ctx-current-ns ctx)) "ns with require sets current namespace") - # Alias should be registered - (let [ns (ctx-find-ns ctx "my.app") - aliased (ns-alias-lookup ns "o")] - (assert (= "other.lib" aliased) "alias o -> other.lib registered"))) -(print " passed") - -(print "5: require form (standalone)...") -(let [ctx (fresh-ctx)] - # Populate other.lib first — require of an unlocatable ns now throws - # (Clojure's FileNotFoundException), see namespaces-spec. - (let [other-ns (ctx-find-ns ctx "other.lib")] - (ns-intern other-ns "f" (fn [x] x))) - (eval-form ctx @{} (parse-string "(require '[other.lib :as o])")) - (let [ns (ctx-find-ns ctx "user") - aliased (ns-alias-lookup ns "o")] - (assert (= "other.lib" aliased) "standalone require registers alias"))) -(print " passed") - -(print "6: qualified symbol via alias...") -(let [ctx (fresh-ctx)] - # Set up target ns - (let [target (ctx-find-ns ctx "other.lib")] - (ns-intern target "f" (fn [x] (inc x)))) - # Register alias - (let [ns (ctx-find-ns ctx "user")] - (ns-import ns "o" "other.lib")) - # Resolve o/f and call it - (let [form (parse-string "(o/f 41)") - result (eval-form ctx @{} form)] - (assert (= 42 result) "qualified call via alias works"))) -(print " passed") - -(print "7: require then use alias...") -(let [ctx (fresh-ctx)] - # Set up target ns - (let [target (ctx-find-ns ctx "math.lib")] - (ns-intern target "add" (fn [a b] (+ a b)))) - # require + use - (eval-form ctx @{} (parse-string "(require '[math.lib :as m])")) - (let [result (eval-form ctx @{} (parse-string "(m/add 1 2)"))] - (assert (= 3 result) "require + alias + call chain works"))) -(print " passed") - -(print "8: ns form requires multiple...") -(let [ctx (fresh-ctx)] - (let [ns1 (ctx-find-ns ctx "a.lib")] - (ns-intern ns1 "f" (fn [x] (inc x)))) - (let [ns2 (ctx-find-ns ctx "b.lib")] - (ns-intern ns2 "g" (fn [x] (dec x)))) - (eval-form ctx @{} (parse-string "(ns user (:require [a.lib :as a] [b.lib :as b]))")) - (assert (= 43 (eval-form ctx @{} (parse-string "(a/f 42)"))) "alias a works") - (assert (= 41 (eval-form ctx @{} (parse-string "(b/g 42)"))) "alias b works")) -(print " passed") - -(print "\nAll namespace tests passed!") - -# An UNCAUGHT throw inside an interpreted fn body must restore the caller's -# current-ns (the body runs with current-ns rebound to the defining ns; the -# restore is a defer now). Pre-fix, the ctx was left stuck in the defining ns -# and every later alias-qualified lookup failed — the sci-bootstrap and -# clojure.edn "Unable to resolve alias/..." cascades. -(print "ns restored after uncaught throw...") -(let [ctx (fresh-ctx)] - (api/eval-string ctx "(in-ns (quote otherns))") - (api/eval-string ctx "(clojure.core/refer-clojure)") - (api/eval-string ctx "(defn boom [] (throw (ex-info \"x\" {})))") - (api/eval-string ctx "(in-ns (quote user))") - (assert (not ((protect (api/eval-string ctx "(otherns/boom)")) 0)) "boom throws") - (assert (= "user" (api/eval-string ctx "(str *ns*)")) "*ns* restored after uncaught throw") - (api/eval-string ctx "(require (quote [clojure.string :as s9]))") - (assert (= "A" (api/eval-string ctx "(s9/upper-case \"a\")")) "aliases still resolve")) -(print " ok") diff --git a/test/integration/nrepl-test.janet b/test/integration/nrepl-test.janet deleted file mode 100644 index 62ff718..0000000 --- a/test/integration/nrepl-test.janet +++ /dev/null @@ -1,109 +0,0 @@ -# Integration test: jolt.nrepl server + client over a real TCP/bencode wire. -# -# The server runs in a subprocess (`jolt nrepl PORT`) so the client (this -# process) isn't affected by the server's accept-loop fiber, which leaves the -# shared ctx's current-ns pointing at jolt.nrepl. The client uses the jolt.nrepl -# Clojure API, exercising both halves of the implementation. - -(use ../../src/jolt/api) -(use ../../src/jolt/types) - -(def port "17888") - -# Watchdog: never let a hang stall CI — bail out after 90s. -(ev/spawn (ev/sleep 90) (eprint "nrepl-test: watchdog fired (possible hang)") (os/exit 1)) - -# Prefer the built executable (its ctx is baked at build time, ~20ms start); -# source mode pays the full compile-mode init, which on a slow CI runner can -# outrun a short poll window. -(def server-cmd - (if (os/stat "build/jolt") - ["build/jolt" "nrepl" port] - ["janet" "src/jolt/main.janet" "nrepl" port])) -(print "Starting jolt.nrepl server subprocess on port " port " (" (first server-cmd) ") ...") -(def proc (os/spawn server-cmd :p {:out :pipe :err :pipe})) - -# Wait until the server accepts connections (poll up to ~60s — CI headroom). -(var ready false) -(var tries 0) -(while (and (not ready) (< tries 600)) - (let [r (protect (net/connect "127.0.0.1" port))] - (if (r 0) (do (:close (r 1)) (set ready true)) - (do (ev/sleep 0.1) (++ tries))))) -(unless ready - # Surface the server's stderr so a CI failure is diagnosable. - (eprint "server stderr: " (string (ev/read (proc :err) :all))) - (assert false "nREPL server did not start")) - -(def ctx (init-cached)) -(ctx-set-current-ns ctx "user") -(load-string ctx "(require '[jolt.nrepl])") -(load-string ctx (string "(def c (jolt.nrepl/connect {:port " port "}))")) - -(defn ev [e] (eval-string ctx e)) -(var fails 0) -(defn check [label expr expected] - (let [got (ev expr)] - (if (= got expected) - (print " ok " label) - (do (++ fails) (printf " FAIL %s: want %q, got %q" label expected got))))) - -# describe advertises ops -(check "describe has ops" - "(boolean (get (first (jolt.nrepl/request c {\"op\" \"describe\"})) \"ops\"))" true) - -# clone yields a session id -(ev "(def s (jolt.nrepl/client-clone c))") -(check "clone session is string" "(string? s)" true) - -# eval returns a value -(check "eval (+ 1 2)" "(some #(get % \"value\") (jolt.nrepl/client-eval c \"(+ 1 2)\" s))" "3") - -# a def's value renders as #'ns/name (pr-str loops on a var's cyclic ns refs) -(check "def renders as #'ns/name" - "(some #(get % \"value\") (jolt.nrepl/client-eval c \"(def yy 21)\" s))" "#'user/yy") - -# defs persist across evals in the session -(check "def then use" "(some #(get % \"value\") (jolt.nrepl/client-eval c \"(* yy 2)\" s))" "42") - -# stdout is captured and streamed as an out message -(check "println captured as out" - "(some #(get % \"out\") (jolt.nrepl/client-eval c \"(do (println \\\"hi\\\") 9)\" s))" "hi\n") - -# the response carries the current ns -(check "ns field reported" - "(some #(get % \"ns\") (jolt.nrepl/client-eval c \"(+ 1 1)\" s))" "user") - -# in-ns switches the session ns, and it persists to the next eval -(check "in-ns switches ns" - "(some #(get % \"ns\") (jolt.nrepl/client-eval c \"(in-ns (quote foo.bar))\" s))" "foo.bar") -(check "ns persists across evals" - "(some #(get % \"ns\") (jolt.nrepl/client-eval c \"(+ 2 2)\" s))" "foo.bar") -# explicit :ns on the message overrides -(ev "(jolt.nrepl/request c {\"op\" \"eval\" \"code\" \"(+ 1 1)\" \"session\" s \"ns\" \"user\"})") - -# eval error -> eval-error status, and the connection keeps working afterward -(check "eval error status" - "(boolean (some #(let [st (get % \"status\")] (and (sequential? st) (some (fn [x] (= \"eval-error\" x)) st))) (jolt.nrepl/client-eval c \"(/ 1 :z)\" s)))" - true) -(check "still alive after error" - "(some #(get % \"value\") (jolt.nrepl/client-eval c \"(+ 5 5)\" s))" "10") - -# multiple forms in one eval -> a value per form (values arrive as strings) -(check "multiple forms" - "(= [\"2\" \"4\"] (mapv #(get % \"value\") (filter #(get % \"value\") (jolt.nrepl/client-eval c \"(+ 1 1) (+ 2 2)\" s))))" - true) - -# unknown op -> error/unknown-op/done -(check "unknown op status" - "(let [st (get (first (jolt.nrepl/request c {\"op\" \"nope\"})) \"status\")] (and (some #(= \"unknown-op\" %) st) true))" - true) - -# clean up -(ev "(jolt.nrepl/client-close c)") -(os/proc-kill proc true) -(when (os/stat ".nrepl-port") (os/rm ".nrepl-port")) - -(if (> fails 0) - (do (eprint "nrepl-test: " fails " failing check(s)") (os/exit 1)) - (do (print "\nAll nREPL tests passed!") (os/exit 0))) diff --git a/test/integration/phint-propagation-test.janet b/test/integration/phint-propagation-test.janet deleted file mode 100644 index abba90b..0000000 --- a/test/integration/phint-propagation-test.janet +++ /dev/null @@ -1,77 +0,0 @@ -# Declared record param hints propagate THROUGH the whole-program fixpoint -# (jolt-3ko). A ^Record param's field reads type to the field's record type, and -# when such a field-read value is passed to a SHARED helper (no hints, inferred -# from call sites), the helper's params must pick up that record type so its own -# field reads bare-index. Before the fix, ^-hints were applied only at the final -# re-emit (reinfer-def), not during the fixpoint, so a hinted param with no -# callers stayed :any during inference and never propagated to its callees — -# exactly why the ray tracer's vec ops (called with (:origin ray) etc.) stayed -# unproven even under whole-program optimization. -(import ../../src/jolt/api :as api) -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/types :as types) - -(print "phint propagation through the fixpoint (jolt-3ko)...") - -(def dir (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-phint-prop")) -(os/mkdir dir) -(spit (string dir "/pp.clj") - (string - "(ns pp)\n" - "(defrecord Vec3 [r g b])\n" - "(defrecord Ray [^Vec3 origin ^Vec3 direction])\n" - # shared ops, NO hints — must be inferred from the call sites below. A - # `loop` makes them inline-INELIGIBLE so they stay real calls (a small fn - # would be spliced into the caller, where the caller's hint already proves - # it); the point here is propagation to a separate callee's PARAMS. - "(defn dot [a b]\n" - " (loop [i 0 s 0.0]\n" - " (if (< i 1) (recur (inc i) (+ (+ (* (:r a) (:r b)) (* (:g a) (:g b))) (* (:b a) (:b b)))) s)))\n" - "(defn add [a b]\n" - " (loop [i 0 s nil]\n" - " (if (< i 1) (recur (inc i) (->Vec3 (+ (:r a) (:r b)) (+ (:g a) (:g b)) (+ (:b a) (:b b)))) s)))\n" - # callers pass field-read Vec3s from a ^Ray param into the shared ops - "(defn use-dot [^Ray r] (dot (:origin r) (:direction r)))\n" - "(defn use-add [^Ray r] (add (:origin r) (:direction r)))\n")) - -(os/setenv "JOLT_DIRECT_LINK" "1") -(os/setenv "JOLT_WHOLE_PROGRAM" "1") -(os/setenv "JOLT_PATH" dir) -(def ctx (api/init {:compile? true})) -(api/eval-string ctx "(require '[pp])") -(def report (backend/infer-program! ctx)) - -(def pns (types/ctx-find-ns ctx "jolt.passes")) -(def reinfer (types/var-get (types/ns-find pns "reinfer-def"))) -(def ppns (types/ctx-find-ns ctx "pp")) -(defn ptmap-for [fname params] - (def pts (get report (string "pp/" fname))) - (def m @{}) (when pts (var i 0) (each p params (put m p (get pts i)) (++ i))) m) -(defn guards [fname params] - (def cell (get (ppns :mappings) fname)) - (length (string/find-all ":jolt/type" - (string/format "%p" (backend/emit-ir ctx (reinfer (get cell :infer-ir) (ptmap-for fname params))))))) - -(var fails 0) -(defn check [label got expected] - (if (= got expected) (print " ok " label) - (do (++ fails) (printf " FAIL %s: want %p got %p" label expected got)))) - -# the shared ops' params get the Vec3 record type from the field-read call args, -# so all their field reads bare-index (no :jolt/type guard) -(check "dot params typed Vec3 -> reads bare" (guards "dot" ["a" "b"]) 0) -(check "add params typed Vec3 -> reads bare" (guards "add" ["a" "b"]) 0) -# the hinted callers were already fine (re-emit applies the phint) -(check "use-dot hinted reads bare" (guards "use-dot" ["r"]) 0) - -# the report shows the shared ops' params as a Vec3 struct (has :shape / :type) -(def dot-a (get (get report "pp/dot") 0)) -(check "dot param a is a struct type" (truthy? (and dot-a (or (get dot-a :shape) (get dot-a :struct)))) true) - -# correctness: results are unchanged -(check "dot computes" (api/eval-string ctx "(pp/dot (pp/->Vec3 1 2 3) (pp/->Vec3 4 5 6))") 32) -(check "use-dot computes" - (api/eval-string ctx "(pp/use-dot (pp/->Ray (pp/->Vec3 1 2 3) (pp/->Vec3 4 5 6)))") 32) - -(if (> fails 0) (do (printf "phint-propagation: %d FAILED" fails) (os/exit 1)) - (print "phint propagation (jolt-3ko) passed!")) diff --git a/test/integration/png-test.janet b/test/integration/png-test.janet deleted file mode 100644 index 6dc5664..0000000 --- a/test/integration/png-test.janet +++ /dev/null @@ -1,46 +0,0 @@ -# jolt.png: the host PNG encoder (src/jolt/png.janet) + the overlay wrapper -# (src/jolt/jolt/png.clj), reachable as janet.png/* through eval_base's -# module-load-env. Checks the encoder emits a structurally valid PNG (signature, -# IHDR dims, IEND) and that the overlay path writes the same. -(import ../../src/jolt/png :as png) -(import ../../src/jolt/api :as api) - -(print "jolt.png encoder + overlay...") -(var failures 0) -(defn check [label ok] (if ok (print " ok: " label) (do (++ failures) (eprintf " FAIL: %s" label)))) - -(defn- u32 [b o] - (+ (* (get b o) 16777216) (* (get b (+ o 1)) 65536) (* (get b (+ o 2)) 256) (get b (+ o 3)))) - -# --- host encoder --- -(def w 5) -(def h 3) -(def rgb (buffer/new (* w h 3))) -(for i 0 (* w h 3) (buffer/push-byte rgb (% (* i 7) 256))) -(def out (png/encode w h rgb)) -(check "PNG signature" (= (string/slice out 0 8) "\x89PNG\r\n\x1a\n")) -(check "IHDR length is 13" (= 13 (u32 out 8))) -(check "IHDR type" (= "IHDR" (string/slice out 12 16))) -(check "IHDR width" (= w (u32 out 16))) -(check "IHDR height" (= h (u32 out 20))) -(check "8-bit RGB colour type" (and (= 8 (get out 24)) (= 2 (get out 25)))) -(check "ends with an IEND chunk" (string/find "IEND" (string out))) -(check "encode rejects a wrong-sized buffer" - (= false (first (protect (png/encode w h (buffer/new 4)))))) - -# --- overlay (jolt.png from Clojure) writes a valid PNG --- -(def tmp (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-png-overlay-test.png")) -(def ctx (api/init-cached {:compile? true})) -(api/eval-string ctx "(require '[jolt.png :as png])") -(api/eval-string ctx - (string "(let [img (png/image 4 2)]" - " (doseq [_ (range 8)] (png/put! img 10 20 30))" - " (png/write img 4 2 \"" tmp "\"))")) -(def wrote (slurp tmp)) -(check "overlay wrote the PNG signature" (= (string/slice wrote 0 8) "\x89PNG\r\n\x1a\n")) -(check "overlay IHDR dims" (and (= 4 (u32 wrote 16)) (= 2 (u32 wrote 20)))) -(os/rm tmp) - -(if (= 0 failures) - (print "All tests passed.") - (do (eprintf "%d png check(s) failed" failures) (os/exit 1))) diff --git a/test/integration/predicate-fold-test.janet b/test/integration/predicate-fold-test.janet deleted file mode 100644 index 61afb2f..0000000 --- a/test/integration/predicate-fold-test.janet +++ /dev/null @@ -1,61 +0,0 @@ -# Predicate folding from inference (jolt-wcw): when the collection-type -# inference PROVES the argument's type, a type predicate (number?/string?/ -# keyword?/nil?/some?/record?) folds to a compile-time boolean constant, which -# the trailing const-fold then propagates — collapsing any `if` it gates to the -# taken branch. Sound: only a provable answer folds, and only when the argument -# is side-effect-free (a local or const), so dropping its evaluation is a no-op. -# Mirrors type-infer-test.janet's harness (count a marker in the emitted IR to -# prove the optimization fired, then evaluate to prove it stayed correct). -(import ../../src/jolt/api :as api) -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/reader :as reader) - -(print "Predicate folding (jolt-wcw)...") - -(os/setenv "JOLT_DIRECT_LINK" "1") -(def ctx (api/init-cached {:compile? true})) -(api/eval-string ctx "(ns pf)") - -(defn code [src] - (string/format "%p" (backend/emit-ir ctx (backend/analyze-form ctx (reader/parse-string src))))) -(defn occurs [src needle] (length (string/find-all needle (code src)))) -(defn ev [src] (api/eval-string ctx src)) - -# --- the predicate call is gone where the type is proven -------------------- -(assert (= 0 (occurs "(fn [] (let [x (+ 1 2)] (number? x)))" "number?")) - "number? on proven :num -> folded, call eliminated") -(assert (= 0 (occurs "(fn [] (let [x \"hi\"] (string? x)))" "string?")) - "string? on proven :str -> folded") -(assert (= 0 (occurs "(fn [] (let [x :k] (keyword? x)))" "keyword?")) - "keyword? on proven :kw -> folded") -(assert (= 0 (occurs "(fn [] (let [x (+ 1 2)] (nil? x)))" "nil?")) - "nil? on a provably non-nil value -> folded") - -# --- the folded constant collapses an if it gates -------------------------- -# the dead branch's literal (200) must be gone after dead-branch removal -(assert (= 0 (occurs "(fn [] (let [x (+ 1 2)] (if (number? x) 100 200)))" "200")) - "true predicate folds the if to its then-branch (dead 200 dropped)") -(assert (= 0 (occurs "(fn [] (let [x (+ 1 2)] (if (string? x) 100 200)))" "100")) - "false predicate folds the if to its else-branch (dead 100 dropped)") - -# --- sound fallback: unknown type or impure arg keeps the call ------------- -# a param is :any (Phase 0 doesn't type it) -> no fold -(assert (= 1 (occurs "(fn [m] (number? m))" "number?")) - "unknown-type arg keeps the predicate call") -# arg type is proven :num but the arg has side effects (a call) -> must NOT -# drop its evaluation, so the predicate is left in place -(assert (>= (occurs "(fn [g] (number? (+ (g) 1)))" "number?") 1) - "impure arg (even with proven type) keeps the predicate call") - -# --- correctness: folded path evaluates to the dispatched path ------------- -(assert (= true (ev "((fn [] (let [x (+ 1 2)] (number? x))))")) "number? true value") -(assert (= false (ev "((fn [] (let [x \"hi\"] (number? x))))")) "number? false value") -(assert (= true (ev "((fn [] (let [x :k] (keyword? x))))")) "keyword? true value") -(assert (= false (ev "((fn [] (let [x 5] (nil? x))))")) "nil? false value") -(assert (= true (ev "((fn [] (let [x 5] (some? x))))")) "some? true value") -(assert (= :yes (ev "((fn [] (let [x 5] (if (number? x) :yes :no))))")) "gated if takes proven branch") -(assert (= :no (ev "((fn [] (let [x 5] (if (string? x) :yes :no))))")) "gated if drops false branch") -# impure arg still runs its side effect and returns the right answer -(assert (= 6 (ev "((fn [g] (if (number? (+ (g) 1)) (+ (g) 5) 0)) (fn [] 1))")) "impure-arg predicate stays correct") - -(print "Predicate folding (jolt-wcw) passed!") diff --git a/test/integration/record-declared-shape-test.janet b/test/integration/record-declared-shape-test.janet deleted file mode 100644 index 7d0cf30..0000000 --- a/test/integration/record-declared-shape-test.janet +++ /dev/null @@ -1,45 +0,0 @@ -# Records use declared-shape layout with fast field access (jolt-t34), by default -# in a direct-linking unit — no JOLT_SHAPE needed. The key property: a record is -# laid out in DECLARED field order, and field reads bare-index by that order, so -# fields that are NOT alphabetically sorted must still read correctly. This is -# what `sidx` reads off the :shape vector (declared order, not str-sorted). -(use ../../src/jolt/api) - -(var failures 0) -(defn- check [label got want] - (unless (= got want) - (++ failures) - (printf "FAIL [%s] got %q want %q" label got want))) - -# A direct-linking ctx: records are shape-recs, reads proven/bare-indexed. -(def dl (init {:compile? true :direct-linking? true})) - -# --- representation: a record is a shape-rec (tuple), not a table ------------- -(check "record is a shape-rec" - (tuple? (eval-string dl "(do (defrecord Sp [x y]) (->Sp 1 2))")) true) - -# --- DECLARED-ORDER field access: fields are NOT alphabetically sorted; each -# must read its own value, locally and through a fn boundary. Each case uses a -# DISTINCT record name (redefining a record with new fields is jolt-wf4). ------- -(def cases - [["decl-order local" "(do (defrecord Ra [b a c]) (let [r (->Ra 10 20 30)] (= [10 20 30] [(:b r) (:a r) (:c r)])))"] - ["decl-order via fn" "(do (defrecord Rb [b a c]) (defn rdb [r] [(:b r) (:a r) (:c r)]) (= [10 20 30] (rdb (->Rb 10 20 30))))"] - ["single field z-first" "(do (defrecord Rc [z m a]) (= 7 (:z (->Rc 7 8 9))))"] - ["protocol method body" "(do (defprotocol Sh (area [s])) (defrecord Box [w h] Sh (area [b] (* (:w b) (:h b)))) (= 12 (area (->Box 3 4))))"] - ["record? true" "(do (defrecord Rd [x y]) (record? (->Rd 1 2)))"] - ["record vs map not=" "(do (defrecord Re [x y]) (not (= (->Re 1 2) {:x 1 :y 2})))"] - ["assoc keeps type" "(do (defrecord Rf [x y]) (record? (assoc (->Rf 1 2) :x 9)))"] - ["pr declared order" "(do (defrecord Rg [b a c]) (= \"#user.Rg{:b 10, :a 20, :c 30}\" (pr-str (->Rg 10 20 30))))"] - # a record shape-rec is a Janet tuple, but a record is NOT a vector/sequential - # in Clojure — else map-destructuring it takes the kwargs coerce path and - # corrupts (reitit router crash, jolt-14k). - ["vector? record false" "(do (defrecord Rh [x y]) (not (vector? (->Rh 1 2))))"] - ["sequential? record false" "(do (defrecord Ri [x y]) (not (sequential? (->Ri 1 2))))"] - ["destructure record :or" "(do (defrecord Rj [a b c d e]) (let [{:keys [a e] :or {a 0}} (->Rj 1 2 3 4 5)] (= 6 (+ a e))))"]]) - -(each [label prog] cases - (check label (eval-string dl prog) true)) - -(if (pos? failures) - (do (printf "record-declared-shape: %d failure(s)" failures) (os/exit 1)) - (print "record-declared-shape: all cases passed")) diff --git a/test/integration/record-shape-test.janet b/test/integration/record-shape-test.janet deleted file mode 100644 index d929556..0000000 --- a/test/integration/record-shape-test.janet +++ /dev/null @@ -1,64 +0,0 @@ -# Records as shape-recs (jolt-t34 R3). A user record (defrecord/deftype) under -# JOLT_SHAPE is a shape-rec whose descriptor ALSO carries :type (the type tag), -# laid out in DECLARED field order. These build records directly via the runtime -# (make-record) and assert that every map/record operation treats them the way -# Clojure does — and crucially that type identity is preserved (a record is not -# a plain map, and two records are equal only when their types match). -(use ../../src/jolt/types) -(use ../../src/jolt/core) - -(var fails 0) -(defn check [label got want] - (if (deep= got want) (print " ok " label) - (do (++ fails) (printf " FAIL %s: got %j want %j" label got want)))) - -# (defrecord Point [x y]) instance (->Point 1 2) -(def P (make-record "my.Point" [:x :y] [1 2])) - -# --- it IS a shape-rec, and reports its type --------------------------------- -(check "shape-rec?" (shape-rec? P) true) -(check "record-tag" (record-tag P) "my.Point") -(check "map?" (core-map? P) true) - -# --- field access in declared order ------------------------------------------ -(check "get x" (core-get P :x nil) 1) -(check "get y" (core-get P :y nil) 2) -(check "get miss default" (core-get P :z :d) :d) -(check "count" (core-count P) 2) -(check "contains?" (core-contains? P :x) true) - -# --- the virtual :jolt/deftype key keeps every (get obj :jolt/deftype) site -# (record?/dispatch) working without special-casing each one ------------------ -(check "virtual deftype" (core-get P :jolt/deftype nil) "my.Point") - -# --- assoc preserves the type: in place for a declared field, and grows a -# slot Clojure-style for a new key (the result is still a record) ------------- -(def P2 (core-assoc P :x 9)) -(check "assoc field tag" (record-tag P2) "my.Point") -(check "assoc field val" (core-get P2 :x nil) 9) -(check "assoc keeps other" (core-get P2 :y nil) 2) -(def P3 (core-assoc P :z 3)) -(check "assoc new tag" (record-tag P3) "my.Point") -(check "assoc new val" (core-get P3 :z nil) 3) -(check "assoc new keeps" (core-get P3 :x nil) 1) - -# --- dissoc of a declared field demotes to a plain map (Clojure semantics) ---- -(def D (core-dissoc P :x)) -(check "dissoc demotes" (record-tag D) nil) -(check "dissoc gone" (core-get D :x :gone) :gone) -(check "dissoc keeps" (core-get D :y nil) 2) - -# --- equality is TYPE-AWARE: same type + same fields equal; a different type -# or a plain map with the same fields is NOT equal ---------------------------- -(check "= same type" (jolt-equal? P (make-record "my.Point" [:x :y] [1 2])) true) -(check "not= diff field" (jolt-equal? P (make-record "my.Point" [:x :y] [1 9])) false) -(check "not= diff type" (jolt-equal? P (make-record "my.Other" [:x :y] [1 2])) false) -(check "not= record vs map" (jolt-equal? P {:x 1 :y 2}) false) -(check "not= map vs record" (jolt-equal? {:x 1 :y 2} P) false) - -# --- printing: Clojure record syntax #ns.Type{:k v, ...}, fields in order ----- -(check "pr record" (core-pr-str1 P) "#my.Point{:x 1, :y 2}") - -(if (> fails 0) - (error (string "record-shape: " fails " failing check(s)")) - (print "\nRecord shape passed!")) diff --git a/test/integration/scalar-replace-record-test.janet b/test/integration/scalar-replace-record-test.janet deleted file mode 100644 index 977e543..0000000 --- a/test/integration/scalar-replace-record-test.janet +++ /dev/null @@ -1,61 +0,0 @@ -# Scalar-replacement of short-lived RECORD allocations (jolt-15jq). The pass -# already folds the const-key MAP-literal form ((:k {:k a ..}) -> a and drops a -# non-escaping let-bound map); this extends it to record CONSTRUCTORS. A record -# ctor (->Rec a b ..) is a positional struct whose declared field order lives in -# the record-shapes registry, so a field read on a non-escaping ctor result folds -# to the corresponding positional arg and the allocation disappears. -# -# Probe: count occurrences of the ctor var "->V3" in the analyzed IR. Folded => -# the ctor is gone (0). Mirrors type-infer-test's guard-counting harness. -(import ../../src/jolt/api :as api) -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/reader :as reader) - -(print "Scalar-replace of records (jolt-15jq)...") - -(os/setenv "JOLT_DIRECT_LINK" "1") -(def ctx (api/init-cached {:compile? true})) -(api/eval-string ctx "(ns srr)") -(api/eval-string ctx "(defrecord V3 [r g b])") - -(defn ctors [src] - (length (string/find-all "->V3" - (string/format "%p" (backend/analyze-form ctx (reader/parse-string src)))))) -(defn ev [src] (api/eval-string ctx src)) - -# --- direct form: (:field (->V3 a b c)) -> the positional arg ---------------- -(assert (= 0 (ctors "(fn [] (:r (->V3 1 2 3)))")) "direct record lookup :r -> arg, ctor gone") -(assert (= 0 (ctors "(fn [] (:g (->V3 1 2 3)))")) "direct record lookup :g -> arg, ctor gone") -(assert (= 0 (ctors "(fn [] (:b (->V3 1 2 3)))")) "direct record lookup :b -> arg, ctor gone") -# pure non-constant args fold too (each discarded sibling is pure) -(assert (= 0 (ctors "(fn [a b] (:r (->V3 (+ a 1) (* b 2) 7)))")) "direct fold with pure arith args") - -# --- let form: non-escaping let-bound record, field reads -> args ------------ -(assert (= 0 (ctors "(fn [a b c] (let [v (->V3 a b c)] (+ (:r v) (:g v) (:b v))))")) "let-bound record, all field reads folded") -(assert (= 0 (ctors "(fn [a b c] (let [v (->V3 a b c)] (:r v)))")) "let-bound record, single field read folded (siblings discarded, pure)") - -# --- sound fallbacks: keep the allocation ------------------------------------ -# escaping record (passed to a sink) must NOT be folded -(assert (>= (ctors "(fn [sink a b c] (let [v (->V3 a b c)] (sink v) (:r v)))") 1) "escaping record keeps the allocation") -# returning the record escapes it -(assert (>= (ctors "(fn [a b c] (->V3 a b c))") 1) "returned record keeps the allocation") -# a non-field key read (:jolt/deftype is a virtual key) -> not folded, keep alloc -(assert (>= (ctors "(fn [a b c] (let [v (->V3 a b c)] (:jolt/deftype v)))") 1) ":jolt/deftype lookup keeps the allocation") - -# --- correctness: folded path evaluates identically ------------------------- -(assert (= 1 (ev "((fn [] (:r (->V3 1 2 3))))")) "direct :r value") -(assert (= 2 (ev "((fn [] (:g (->V3 1 2 3))))")) "direct :g value") -(assert (= 3 (ev "((fn [] (:b (->V3 1 2 3))))")) "direct :b value") -(assert (= 6 (ev "((fn [a b c] (let [v (->V3 a b c)] (+ (:r v) (:g v) (:b v)))) 1 2 3)")) "let-bound sum value") -(assert (= 10 (ev "((fn [a b] (:r (->V3 (+ a 1) (* b 2) 7))) 9 5)")) "arith-arg direct value") -# correctness of the kept-allocation fallbacks -(assert (= 1 (ev "((fn [sink a b c] (let [v (->V3 a b c)] (sink v) (:r v))) (fn [_] nil) 1 2 3)")) "escaping record reads correctly") -(assert (= "srr.V3" (ev "((fn [a b c] (let [v (->V3 a b c)] (:jolt/deftype v))) 1 2 3)")) ":jolt/deftype reads the type tag") - -# --- nested records fold compositionally (bottom-up) ------------------------- -(api/eval-string ctx "(defrecord Ray [orig dir])") -# (:r (:orig (->Ray (->V3 a b c) d))): inner ctors both fold away -(assert (= 0 (ctors "(fn [a b c d] (:r (:orig (->Ray (->V3 a b c) d))))")) "nested record reads fold both ctors") -(assert (= 7 (ev "((fn [a b c d] (:r (:orig (->Ray (->V3 a b c) d)))) 7 8 9 0)")) "nested record fold value") - -(print "Scalar-replace of records passed!") diff --git a/test/integration/sci-bootstrap-test.janet b/test/integration/sci-bootstrap-test.janet deleted file mode 100644 index 38285af..0000000 --- a/test/integration/sci-bootstrap-test.janet +++ /dev/null @@ -1,122 +0,0 @@ -(use ../../src/jolt/evaluator) -(use ../../src/jolt/types) -(use ../../src/jolt/reader) -(use ../../src/jolt/api) -(use ../../src/jolt/reader) -# SCI is a clj/cljs-targeted library: its .cljc sources select implementation -# via #?(:clj ...) and have no :jolt branches — load it under clj-compat -# features (spec 02-reader S18: feature sets are a property of the loading -# context; the portable default is #{:jolt :default}). -(reader-features-set! ["jolt" "clj" "default"]) - -(def ctx (init-cached)) -# Best-effort loading: SCI's clj-targeted requires (borkdude.graal.locking, -# clojure.tools.reader.*) don't exist on this host; a strict require would fail -# whole ns forms and cascade. See maybe-require-ns. -(put (ctx :env) :lenient-require? true) - -(printf "Loading SCI stubs...\n") -(defn load-stubs [ctx filepath] - (var s (slurp filepath)) - (var count 0) - (while (> (length (string/trim s)) 0) - (def [form rest] (parse-next s)) - (set s rest) - (++ count) - (when (not (nil? form)) - (eval-form ctx @{} form))) - (printf " Loaded %d stub forms\n" count)) - -(load-stubs ctx "src/jolt/clojure/sci/lang_stubs.clj") -(load-stubs ctx "src/jolt/clojure/sci/io_stubs.clj") -(load-stubs ctx "src/jolt/clojure/sci/host_stubs.clj") - -# namespaces.cljc copies vars out of Jolt's own clojure.string/set/walk/edn, so -# make sure those are loaded before it runs. -(each lib ["clojure.string" "clojure.set" "clojure.walk" "clojure.edn"] - (protect (eval-form ctx @{} (first (parse-next (string "(require '[" lib "])")))))) - -(defn load-file [ctx path] - (var s (slurp path)) - (var count 0) - (var ok 0) - (var fail 0) - (var failures @[]) - (while (> (length (string/trim s)) 0) - (def [form rest] (parse-next s)) - (set s rest) - (++ count) - (if (not (nil? form)) - (do - (printf "eval form %d..." count) - (flush) - (if (try - (do (eval-form ctx @{} form) true) - ([err fib] - (printf " FAIL: %q\n" err) - (when (os/getenv "SCI_TRACE") (debug/stacktrace fib "")) - (array/push failures {:form-number count :error (string err) :form (string form)}) - false)) - (do - (printf " OK\n") - (++ ok)) - (++ fail))))) - {:ok ok :fail fail :total count :failures failures}) - -(def sci-base "vendor/sci/src/sci") - -(def load-order @[ - ["impl/macros.cljc" nil] - ["impl/protocols.cljc" nil] - ["impl/types.cljc" nil] - ["impl/unrestrict.cljc" nil] - ["impl/vars.cljc" nil] - ["lang.cljc" nil] - ["impl/utils.cljc" nil] - ["ctx_store.cljc" nil] - ["impl/deftype.cljc" nil] - ["impl/records.cljc" nil] - ["impl/core_protocols.cljc" nil] - ["impl/hierarchies.cljc" nil] - # pure-Clojure macro/expander modules (loadable from SCI's real source) - ["impl/destructure.cljc" nil] - ["impl/doseq_macro.cljc" nil] - ["impl/for_macro.cljc" nil] - ["impl/fns.cljc" nil] - ["impl/multimethods.cljc" nil] - ["impl/namespaces.cljc" nil] - ["core.cljc" nil] -]) - -(var total-ok 0) -(var total-fail 0) -(var all-failures @[]) - -(each [file expected-ns] load-order - (def path (string sci-base "/" file)) - (printf "\n=== Loading %s ===\n" file) - (def result (load-file ctx path)) - (printf " Result: %d ok, %d fail, %d total\n" (result :ok) (result :fail) (result :total)) - (+= total-ok (result :ok)) - (+= total-fail (result :fail)) - (each f (result :failures) - (array/push all-failures {:file file :form-number (f :form-number) :error (f :error) :form (f :form)}))) - -(printf "\n==============================\n") -(printf "TOTAL: %d ok, %d fail, %d total\n" total-ok total-fail (+ total-ok total-fail)) -(printf "==============================\n") - -(printf "\ncurrent ns: %s\n" (ctx-current-ns ctx)) -(printf "sci.core exists: %q\n" (not (nil? (ctx-find-ns ctx "sci.core")))) -(printf "total namespaces: %d\n" (length (keys ((ctx :env) :namespaces)))) - -(when (> (length all-failures) 0) - (printf "\n=== FAILURES ===\n") - (each f all-failures - (printf "[%s:%d] %s\n" (f :file) (f :form-number) (f :error)) - (printf " form: %s\n" (f :form)))) - -# Regression guard: every form in the loaded SCI modules must evaluate cleanly. -(assert (= 0 total-fail) - (string total-fail " SCI form(s) failed to load (see FAILURES above)")) -(print "\nAll SCI bootstrap forms loaded successfully.") diff --git a/test/integration/sci-runtime-test.janet b/test/integration/sci-runtime-test.janet deleted file mode 100644 index c647ca1..0000000 --- a/test/integration/sci-runtime-test.janet +++ /dev/null @@ -1,101 +0,0 @@ -(use ../../src/jolt/evaluator) -(use ../../src/jolt/types) -(use ../../src/jolt/reader) -(use ../../src/jolt/api) -(use ../../src/jolt/reader) -# SCI is a clj/cljs-targeted library: its .cljc sources select implementation -# via #?(:clj ...) and have no :jolt branches — load it under clj-compat -# features (spec 02-reader S18: feature sets are a property of the loading -# context; the portable default is #{:jolt :default}). -(reader-features-set! ["jolt" "clj" "default"]) - -(defn- load-stubs [ctx filepath] - (var s (slurp filepath)) - (while (> (length (string/trim s)) 0) - (def [form rest] (parse-next s)) - (set s rest) - (when (not (nil? form)) - (protect (eval-form ctx @{} form))))) - -(defn- load-file [ctx path] - (var s (slurp path)) - (while (> (length (string/trim s)) 0) - (def [form rest] (parse-next s)) - (set s rest) - (when (not (nil? form)) - # Tolerant: SCI's clojure.core registration maps reference the full - # clojure.core surface (redundant for Jolt's native core); skip forms - # that don't resolve rather than aborting the bootstrap. - (protect (eval-form ctx @{} form))))) - -# Run from project root so paths resolve -(def root (if (has-value? (dyn :syspath) 0) (first (dyn :syspath)) ".")) - -(def ctx (init-cached)) - -(load-stubs ctx (string root "/src/jolt/clojure/sci/lang_stubs.clj")) -(load-stubs ctx (string root "/src/jolt/clojure/sci/io_stubs.clj")) - -(def sci-base (string root "/vendor/sci/src/sci")) -(each file ["impl/macros.cljc" "impl/protocols.cljc" "impl/types.cljc" - "impl/unrestrict.cljc" "impl/vars.cljc" "lang.cljc" - "impl/utils.cljc" "ctx_store.cljc" "impl/deftype.cljc" - "impl/records.cljc" "impl/core_protocols.cljc" "impl/hierarchies.cljc" - "impl/namespaces.cljc" "core.cljc"] - (load-file ctx (string sci-base "/" file))) - -# ── Verify sci.lang NS and Type ───────────────────────────────── -(assert (not (nil? (ctx-find-ns ctx "sci.lang"))) - "sci.lang namespace exists") -(assert (not (nil? (ctx-find-ns ctx "sci.core"))) - "sci.core namespace exists") - -# sci.lang has Type constructor -(def sci-lang (ctx-find-ns ctx "sci.lang")) -(def type-var (ns-find sci-lang "Type")) -(assert (not (nil? type-var)) "sci.lang/Type var exists") -(def ->Type (ns-find sci-lang "->Type")) -(assert (not (nil? ->Type)) "sci.lang/->Type constructor exists") - -# Instantiate a Type and check field access -(def type-inst ((var-get type-var) {:sci.impl/type-name "user.Foo"})) -(assert (table? type-inst) "Type instance is a table") -(assert (not (nil? (get type-inst :jolt/deftype))) "Type instance has deftype tag") -(assert (= "user.Foo" (get (get type-inst :data) :sci.impl/type-name)) "Type field access via data") - -# ── Verify sci.lang/Var ───────────────────────────────────────── -(def var-ctor-var (ns-find sci-lang "Var")) -(assert (not (nil? var-ctor-var)) "sci.lang/Var constructor exists") - -(def test-var ((var-get var-ctor-var) 42 'my-var nil nil nil nil nil)) -(assert (table? test-var) "Var instance is a table") -(assert (= 42 (get test-var :root)) "Var deref") - -# var? check — SCI Var is not a Jolt var but is a table with proper fields -(assert (not (nil? test-var)) "Var instance is not nil") - -# ── Verify sci.impl.types/IBox protocol ───────────────────────── -(def types-ns (ctx-find-ns ctx "sci.impl.types")) -(def vars-ns (ctx-find-ns ctx "sci.impl.vars")) -(assert (not (nil? types-ns)) "sci.impl.types namespace exists") -(assert (not (nil? vars-ns)) "sci.impl.vars namespace exists") - -(def ibox-getVal (ns-find types-ns "getVal")) -(def ibox-setVal (ns-find types-ns "setVal")) -(assert (not (nil? ibox-getVal)) "sci.impl.types/getVal exists") -(assert (not (nil? ibox-setVal)) "sci.impl.types/setVal exists") - -# Test IBox setVal/getVal exist but skip dispatch (SCI protocol machinery not fully booted) -(assert (function? (var-get ibox-setVal)) "sci.impl.types/setVal is callable") -(assert (function? (var-get ibox-getVal)) "sci.impl.types/getVal is callable") - -# ── Verify sci.impl.vars/IVar protocol methods exist ───────────── -(def ivar-toSymbol (ns-find vars-ns "toSymbol")) -(def ivar-hasRoot (ns-find vars-ns "hasRoot")) -(assert (not (nil? ivar-toSymbol)) "sci.impl.vars/toSymbol exists") -(assert (not (nil? ivar-hasRoot)) "sci.impl.vars/hasRoot exists") - -# ── Verify SCI eval function exists ───────────────────────────── -(def sci-core (ctx-find-ns ctx "sci.core")) -(assert (not (nil? sci-core)) "sci.core namespace exists") -(printf "\nAll SCI runtime tests passed!\n") diff --git a/test/integration/self-host-test.janet b/test/integration/self-host-test.janet deleted file mode 100644 index 3e1bcc3..0000000 --- a/test/integration/self-host-test.janet +++ /dev/null @@ -1,96 +0,0 @@ -# End-to-end proof of the self-hosting pipeline: a reader form is analyzed by the -# PORTABLE Clojure analyzer (jolt.analyzer, in jolt-core) into host-neutral IR, -# then the Janet back end lowers the IR to a Janet form and evaluates it. No use -# of compiler.janet's analyzer — this is the Clojure-in-Clojure front end. -(import ../../src/jolt/backend :as backend) -(use ../../src/jolt/api) -(use ../../src/jolt/reader) -(use ../../src/jolt/types) - -(defn ce [ctx s] (normalize-pvecs (backend/compile-and-eval ctx (parse-string s)))) - -(print "self-host pipeline (Clojure analyzer -> IR -> Janet)...") -(let [ctx (init-cached)] - # primitives + control flow - (assert (= 3 (ce ctx "(+ 1 2)")) "+") - (assert (= 6 (ce ctx "(* 2 3)")) "*") - (assert (= :a (ce ctx "(if true :a :b)")) "if true") - (assert (= :b (ce ctx "(if false :a :b)")) "if false") - (assert (= 10 (ce ctx "(let [x 4 y 6] (+ x y))")) "let") - (assert (= 6 (ce ctx "(do 1 2 6)")) "do") - - # literals - (assert (= [2 3 4] (ce ctx "(map inc [1 2 3])")) "vector literal + core fn") - (assert (= 1 (ce ctx "(get {:a 1 :b 2} :a)")) "map literal") - (assert (= 42 (ce ctx "(quote 42)")) "quote literal") - - # def + global reference (name-based var resolution) - (ce ctx "(def base 100)") - (assert (= 142 (ce ctx "(+ base 42)")) "def + later ref") - - # fn / defn (defn is a macro -> expand -> def of fn*) - (ce ctx "(defn add [a b] (+ a b))") - (assert (= 7 (ce ctx "(add 3 4)")) "defn") - (assert (= 49 (ce ctx "((fn [x] (* x x)) 7)")) "anon fn") - - # recursion through the var cell (no recur needed) - (ce ctx "(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))") - (assert (= 55 (ce ctx "(fib 10)")) "recursive fib via var") - - # multi-arity + variadic - (ce ctx "(defn arity ([a] a) ([a b] (+ a b)) ([a b & more] (apply + a b more)))") - (assert (= 5 (ce ctx "(arity 5)")) "multi-arity 1") - (assert (= 7 (ce ctx "(arity 3 4)")) "multi-arity 2") - (assert (= 15 (ce ctx "(arity 1 2 3 4 5)")) "multi-arity variadic") - - # loop / recur - (assert (= 15 (ce ctx "(loop [i 0 acc 0] (if (< i 6) (recur (inc i) (+ acc i)) acc))")) "loop/recur") - # recur directly in a fixed-arity fn - (assert (= 15 (ce ctx "((fn [n acc] (if (zero? n) acc (recur (dec n) (+ acc n)))) 5 0)")) "recur in fn") - # try / catch / finally - (assert (= "caught" (ce ctx "(try (throw 42) (catch Exception e \"caught\"))")) "try/catch") - (assert (= 7 (ce ctx "(try 7 (finally 0))")) "try/finally") - - # higher-order + nesting - (assert (= 15 (ce ctx "(reduce + (map inc [0 1 2 3 4]))")) "reduce+map")) - -# eval-toplevel routing: :compile? IS the self-hosted pipeline now — the only -# compile path. Forms the analyzer can't handle (stateful / destructuring) fall -# back to the interpreter, with the same observable results. -(print "self-host via eval-toplevel routing...") -(let [ctx (init-cached {:compile? true})] - (defn ev [s] (normalize-pvecs (eval-one ctx (parse-string s)))) - (assert (= 3 (ev "(+ 1 2)")) "tl +") - (ev "(defn sq [x] (* x x))") # def via self-host - (assert (= 81 (ev "(sq 9)")) "tl defn") - (ev "(defmacro twice [x] (list (quote do) x x))") # stateful -> interp fallback - (assert (= 5 (ev "(do (twice 1) 5)")) "tl macro fallback") - (assert (= [1 2 3] (ev "(let [{:keys [a b c]} {:a 1 :b 2 :c 3}] [a b c])")) "tl destructuring fallback") - (assert (= 15 (ev "(reduce + (range 6))")) "tl reduce/range") - # Proof the self-hosted pipeline actually ran: only backend/ensure-analyzer - # populates jolt.analyzer. An interpret-only ctx never loads it. - (assert (pos? (length ((ctx-find-ns ctx "jolt.analyzer") :mappings))) "analyzer loaded under :compile?")) -# Interpret mode now loads the analyzer too — for compiled macro expansion -# (ensure-macros-compiled!, every mode). The fully-interpreted oracle is the -# :compile-macros? false ctx, which must never touch the analyzer. -(let [ctx (init-cached {})] - (eval-one ctx (parse-string "(+ 1 2)")) - (assert (pos? (length ((ctx-find-ns ctx "jolt.analyzer") :mappings))) - "analyzer loaded when interpreting (compiled expanders)")) -(let [ctx (init-cached {:compile-macros? false})] - (eval-one ctx (parse-string "(+ 1 2)")) - (assert (zero? (length ((ctx-find-ns ctx "jolt.analyzer") :mappings))) - "analyzer NOT loaded in the interpreted-macro oracle")) - -# clojure.core overlay: fns moved from core.janet to jolt-core/clojure/core.clj -# load into clojure.core at init and work the same compiled or interpreted. -(print "clojure.core overlay (Clojure-defined core fns)...") -(each opts [{:compile? true} {}] - (let [ctx (init-cached opts)] - (defn ev [s] (normalize-pvecs (eval-one ctx (parse-string s)))) - (assert (= 1 (ev "(ffirst [[1 2] [3 4]])")) "ffirst") - (assert (= [2] (ev "(nfirst [[1 2] [3 4]])")) "nfirst") - (assert (= 2 (ev "(fnext [1 2 3])")) "fnext") - (assert (= [3 4] (ev "(nnext [1 2 3 4])")) "nnext"))) - -(print "self-host pipeline passed!") diff --git a/test/integration/selmer-test.janet b/test/integration/selmer-test.janet deleted file mode 100644 index c5a646a..0000000 --- a/test/integration/selmer-test.janet +++ /dev/null @@ -1,61 +0,0 @@ -# Selmer acceptance (jolt-ea7): load the real Selmer template engine from -# ~/src/selmer and render through its full pipeline — the java.time shims -# (DateTimeFormatter/Instant/ZoneId/LocalDateTime), the java.io shims -# (StringReader/StringBuilder + char-array readers), vector :import sharing -# deftype ctors, and :refer :all. SKIPS cleanly if the checkout is absent -# (CI has no ~/src/selmer); the shim surface itself is covered by -# test/spec/host-interop-spec.janet either way. - -(import ../../src/jolt/api :as api) -(use ../../src/jolt/reader) - -(def selmer-src (string (os/getenv "HOME") "/src/selmer/src")) -(def selmer-res (string (os/getenv "HOME") "/src/selmer/resources")) - -(if (nil? (os/stat (string selmer-src "/selmer/parser.clj"))) - (print "selmer-test: ~/src/selmer not present, skipping") - (do - (reader-features-set! ["jolt" "clj" "default"]) - (def ctx (api/init {:paths [selmer-src selmer-res]})) - - (print "loading selmer.parser...") - (api/eval-string ctx "(require (quote [selmer.parser :as sp]))") - (print " ok") - - (defn render [tpl ctx-map-src] - (api/eval-string ctx (string "(sp/render " (describe tpl) " " ctx-map-src ")"))) - - (print "variable + filter...") - (assert (= "Hello WORLD!" (render "Hello {{name|upper}}!" "{:name \"world\"}"))) - (print " ok") - - (print "date filter (java.time path)...") - (def d (render "{{d|date:yyyy-MM-dd}}" "{:d #inst \"2020-03-05T10:00:00Z\"}")) - (assert (peg/match '(* :d :d :d :d "-" :d :d "-" :d :d -1) d) - (string "date filter renders a yyyy-MM-dd date, got: " d)) - (print " ok") - - (print "if / for tags...") - (assert (= "YES" (render "{% if ok %}YES{% else %}NO{% endif %}" "{:ok true}"))) - (assert (= "NO" (render "{% if ok %}YES{% else %}NO{% endif %}" "{:ok false}"))) - (assert (= "1,2,3," (render "{% for x in xs %}{{x}},{% endfor %}" "{:xs [1 2 3]}"))) - (print " ok") - - (print "nested lookup + escaping...") - (assert (= "7" (render "{{m.a.b}}" "{:m {:a {:b 7}}}"))) - (assert (= "<b>&" (render "{{x}}" "{:x \"&\"}"))) - (print " ok") - - (print "file templates (render-file + cache)...") - (def tpl-dir (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-selmer-test")) - (os/mkdir tpl-dir) - (spit (string tpl-dir "/t.html") "File says {{x|upper}}") - (api/eval-string ctx (string "(selmer.util/set-custom-resource-path! " (describe (string tpl-dir "/")) ")")) - (assert (= "File says HI" - (api/eval-string ctx "(sp/render-file \"t.html\" {:x \"hi\"})"))) - # second render goes through the template cache (last-modified check) - (assert (= "File says AGAIN" - (api/eval-string ctx "(sp/render-file \"t.html\" {:x \"again\"})"))) - (print " ok") - - (print "selmer-test: all passed"))) diff --git a/test/integration/shape-transparency-test.janet b/test/integration/shape-transparency-test.janet deleted file mode 100644 index 496803f..0000000 --- a/test/integration/shape-transparency-test.janet +++ /dev/null @@ -1,64 +0,0 @@ -# Shape-record transparency (jolt-t34 Round 1). A shape-rec is the compiler's -# cheap representation for a constant-key map literal — a Janet tuple -# [descriptor v0 v1 ...]. Every map operation must treat it EXACTLY like the -# equivalent struct map, so a shape value is transparent wherever it flows. -# These build shape-recs directly via the runtime (shape-for + tuple) and -# assert each op matches the struct map's behavior. -(use ../../src/jolt/types) -(use ../../src/jolt/core) - -(var fails 0) -(defn check [label got want] - (if (deep= got want) (print " ok " label) - (do (++ fails) (printf " FAIL %s: got %j want %j" label got want)))) - -# {:a 1 :b 2} as a shape-rec and as a struct — they must be indistinguishable -(def SH (shape-for [:a :b])) -(def r (tuple SH 1 2)) -(def s {:a 1 :b 2}) - -# --- access ------------------------------------------------------------------ -(check "get hit" (core-get r :a nil) 1) -(check "get hit 2" (core-get r :b nil) 2) -(check "get miss" (core-get r :z :d) :d) -(check "count" (core-count r) 2) -(check "contains? hit" (core-contains? r :a) true) -(check "contains? miss" (core-contains? r :z) false) -(check "map?" (core-map? r) true) - -# --- update (returns something that reads back correctly) -------------------- -(check "assoc existing" (core-get (core-assoc r :a 9) :a nil) 9) -(check "assoc new key" (core-get (core-assoc r :c 3) :c nil) 3) -(check "assoc keeps others" (core-get (core-assoc r :c 3) :b nil) 2) -(check "dissoc" (core-get (core-dissoc r :a) :a :gone) :gone) -(check "dissoc keeps" (core-get (core-dissoc r :a) :b nil) 2) - -# --- enumeration: entries via the central seq normalizer (what keys/vals/seq/ -# reduce-kv in the overlay all flow through) — order-independent --------------- -(defn entryset [m] (sorted (map |(string/format "%j" $) (realize-for-iteration m)))) -(check "entries match struct" (entryset r) (entryset s)) -(check "count of seq" (length (core-seq r)) 2) -(check "first is a 2-entry" (length (core-first r)) 2) - -# --- equality: a shape-rec equals the same struct map and vice versa --------- -(check "= shape vs struct" (jolt-equal? r s) true) -(check "= struct vs shape" (jolt-equal? s r) true) -(check "= shape vs shape" (jolt-equal? r (tuple (shape-for [:a :b]) 1 2)) true) -(check "not= diff value" (jolt-equal? r (tuple (shape-for [:a :b]) 1 9)) false) -(check "not= diff shape" (jolt-equal? r (tuple (shape-for [:a :b :c]) 1 2 3)) false) -(check "not= vs vector" (jolt-equal? r [1 2]) false) - -# --- IFn: a map is callable as a key lookup ---------------------------------- -(check "call as fn" (jolt-call r :a) 1) -(check "call as fn miss default" (jolt-call r :z :d) :d) - -# --- nil/false values are present (shape-recs store them positionally) -------- -(def rn (tuple (shape-for [:a :b]) nil false)) -(check "nil value present" (core-contains? rn :a) true) -(check "nil value get" (core-get rn :a :d) nil) -(check "false value get" (core-get rn :b :d) false) -(check "count with nils" (core-count rn) 2) - -(if (> fails 0) - (error (string "shape-transparency: " fails " failing check(s)")) - (print "\nShape transparency passed!")) diff --git a/test/integration/sorted-rbtree-test.janet b/test/integration/sorted-rbtree-test.janet deleted file mode 100644 index 6c5094f..0000000 --- a/test/integration/sorted-rbtree-test.janet +++ /dev/null @@ -1,63 +0,0 @@ -# sorted-map / sorted-set are a red-black tree (jolt-0hbr), ported from the -# ClojureScript PersistentTreeMap. assoc/dissoc are O(log n); the old sorted- -# vector rep was O(n) per op (O(n^2) to build — 55s for 2000 entries). This -# drives big shuffled insert/delete sequences (which stress rebalancing) through -# the built binary and checks ordering + a sub-quadratic build time. -(import ../../src/jolt/api :as api) - -(print "sorted-map/set red-black tree (jolt-0hbr)...") - -(os/setenv "JOLT_DIRECT_LINK" "1") -(def ctx (api/init-cached {:compile? true})) -(defn ev [s] (api/eval-string ctx s)) - -(var fails 0) -(defn check [label got expected] - (if (= got expected) (print " ok " label) - (do (++ fails) (printf " FAIL %s: want %p got %p" label expected got)))) - -# --- ordering is maintained through heavy rebalancing ----------------------- -(check "shuffled 500 keys come back sorted" - (ev "(= (vec (keys (apply sorted-map (interleave (shuffle (vec (range 500))) (range 500))))) (vec (range 500)))") - true) -(check "sorted-set of shuffled 500 is sorted" - (ev "(= (vec (apply sorted-set (shuffle (vec (range 500))))) (vec (range 500)))") - true) - -# --- delete maintains order + correctness (stresses delete rebalancing) ------ -(check "dissoc every even key, odds remain in order" - (ev "(let [m (apply sorted-map (interleave (shuffle (vec (range 200))) (range 200))) - m2 (reduce dissoc m (range 0 200 2))] - (= (vec (keys m2)) (vec (range 1 200 2))))") - true) -(check "disj down to empty then rebuild" - (ev "(let [s (apply sorted-set (range 100)) - s2 (reduce disj s (shuffle (vec (range 100))))] - (and (= 0 (count s2)) (= [1 2 3] (vec (conj s2 3 1 2 1)))))") - true) - -# --- comparator + lookup correctness ---------------------------------------- -(check "custom comparator (descending)" - (ev "(= (vec (keys (sorted-map-by > 1 :a 3 :c 2 :b))) [3 2 1])") true) -(check "get/contains go through comparator (1 vs 1.0)" - (ev "(and (contains? (sorted-set 1 2 3) 1.0) (= :a (get (sorted-map 1 :a) 1.0)))") true) -(check "first-inserted key kept on value replace" - (ev "(first (first (assoc (sorted-map 1 :a) 1.0 :b)))") 1) - -# --- count + subseq ---------------------------------------------------------- -(check "count after mixed ops" - (ev "(count (-> (apply sorted-map (interleave (range 50) (range 50))) (dissoc 10 20 30) (assoc 100 1 101 2)))") 49) -(check "subseq range" - (ev "(= (vec (map first (subseq (apply sorted-map (interleave (range 20) (range 20))) >= 5 < 9))) [5 6 7 8])") true) - -# --- complexity: building a big map must be sub-quadratic -------------------- -(def t0 (os/clock)) -(ev "(count (loop [i 0 m (sorted-map)] (if (< i 5000) (recur (inc i) (assoc m (mod (* i 7919) 10007) i)) m)))") -(def elapsed (- (os/clock) t0)) -(printf " 5000 assocs: %.2fs" elapsed) -(if (< elapsed 8.0) - (print " ok sorted assoc is sub-quadratic (< 8s)") - (do (++ fails) (printf " FAIL sorted build too slow (%.1fs) — O(n^2)?" elapsed))) - -(if (> fails 0) (do (printf "sorted-rbtree: %d FAILED" fails) (os/exit 1)) - (print "sorted-rbtree (jolt-0hbr) passed!")) diff --git a/test/integration/staged-bootstrap-test.janet b/test/integration/staged-bootstrap-test.janet deleted file mode 100644 index 7f2a54c..0000000 --- a/test/integration/staged-bootstrap-test.janet +++ /dev/null @@ -1,63 +0,0 @@ -# Staged-bootstrap soundness (jolt-vcx, under epic jolt-tzo). -# -# The self-hosted compiler's structural deps — second/peek/subvec/mapv/update — -# now come from the Clojure kernel tier (jolt-core/clojure/core/00-kernel.clj), -# bootstrap-compiled into clojure.core BEFORE the analyzer is built. This pins -# the two properties that make that safe: -# -# 1. Compile mode: the analyzer (which itself calls second/peek/subvec/mapv) -# compiles analyzer-exercising forms correctly — the exact case that broke -# when `second` was a plain overlay fn: (first {:a 1}) / (key (first ...)). -# 2. Bootstrap FIXPOINT: rebuilding the compiler (rebuild-compiler!) against the -# now Clojure-defined core still yields a correct compiler. This is the -# soundness gate for every future fractal turn (S2 -> S3). - -(use ../../src/jolt/api) -(import ../../src/jolt/backend :as backend) - -(var failures 0) - -# Each probe is a jolt boolean expression; compared with jolt's own `=`. -(def probes - ["(= 2 (second [1 2 3]))" - "(= nil (second [1]))" - "(= 3 (peek [1 2 3]))" - "(= 1 (peek (list 1 2 3)))" - "(= nil (peek []))" - "(= [2 3] (subvec [1 2 3 4 5] 1 3))" - "(= [3 4 5] (subvec [1 2 3 4 5] 2))" - "(= [2 3 4] (mapv inc [1 2 3]))" - "(= [11 22 33] (mapv + [1 2 3] [10 20 30]))" - "(= {:a 2} (update {:a 1} :a inc))" - "(= {:a 1 :b 1} (update {:a 1} :b (fnil inc 0)))" - # Regression: these run the analyzer's own second/map-pair path in compile mode. - "(= [:a 1] (first {:a 1}))" - "(= :a (key (first {:a 1})))" - "(= 1 (val (first {:a 1})))" - "(= 3 (let [[a b] [1 2]] (+ a b)))" - "(= 3 (loop [i 0 acc 0] (if (< i 3) (recur (inc i) (+ acc i)) acc)))"]) - -(defn- run-probes [ctx label] - (each prog probes - (def got (protect (eval-string ctx prog))) - (unless (and (got 0) (= (got 1) true)) - (++ failures) - (printf "FAIL [%s] %s => %s" label prog - (if (got 0) (string/format "%q" (got 1)) (string "ERR:" (got 1))))))) - -# Interpret mode: kernel tier interpreted, no analyzer involved. -(run-probes (init {}) "interpret") - -# Compile mode: kernel tier bootstrap-compiled, analyzer built against it. -(def cctx (init {:compile? true})) -(run-probes cctx "compile") - -# Fixpoint: rebuild the compiler against the current (Clojure-defined) core and -# re-run. A correct compiler recompiled on the language it just defined stays -# correct. -(backend/rebuild-compiler! cctx) -(run-probes cctx "compile+rebuilt") - -(if (pos? failures) - (do (printf "staged-bootstrap: %d failure(s)" failures) (os/exit 1)) - (print "staged-bootstrap: all probes passed (interpret, compile, compile+rebuilt)")) diff --git a/test/integration/struct-hint-test.janet b/test/integration/struct-hint-test.janet deleted file mode 100644 index 3fba4f2..0000000 --- a/test/integration/struct-hint-test.janet +++ /dev/null @@ -1,79 +0,0 @@ -# Type hints driving keyword-lookup specialization (jolt-94n). A local hinted -# ^:struct (a plain struct/record map) or ^Record (a defrecord/deftype) lets a -# constant-keyword lookup skip the :jolt/type guard and emit a bare get -# (~20ns vs ~36ns), the way Clojure type hints let the compiler specialize. -# Covers both (:k m) and (get m :k), hint propagation through inlining, the -# ^Record path, the JOLT_CHECK_HINTS dev aid, and that accurate hints preserve -# results. An inaccurate hint is a programmer error (like a wrong ^String): the -# raw get returns the wrong value, surfaced only under JOLT_CHECK_HINTS. -(import ../../src/jolt/api :as api) -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/reader :as reader) - -(print "Type hints (jolt-94n)...") - -(os/setenv "JOLT_DIRECT_LINK" "1") # inline on, so hint-through-inline is exercised -(def ctx (api/init-cached {:compile? true})) -(api/eval-string ctx "(ns sh)") -(api/eval-string ctx "(defrecord Vec3r [r g b])") -(each s ["(defn v3 [r g b] {:r r :g g :b b})" - "(defn dot [^:struct l ^:struct r] (+ (+ (* (:r l) (:r r)) (* (:g l) (:g r))) (* (:b l) (:b r))))" - "(defn sub [^:struct l ^:struct r] {:r (- (:r l) (:r r)) :g (- (:g l) (:g r)) :b (- (:b l) (:b r))})" - "(defn lensq [^:struct v] (dot v v))"] - (api/eval-string ctx s)) - -(defn guards [src] - (def code (string/format "%p" (backend/emit-ir ctx (backend/analyze-form ctx (reader/parse-string src))))) - (length (string/find-all ":jolt/type" code))) - -# --- guard removal ---------------------------------------------------------- -(assert (= 1 (guards "(fn [v] (:r v))")) "unhinted (:r v) keeps the guard") -(assert (= 0 (guards "(fn [^:struct v] (:r v))")) "^:struct (:r v) drops the guard") -(assert (= 0 (guards "(fn [^Vec3r v] (:r v))")) "^Record (:r v) drops the guard") -(assert (= 1 (guards "(fn [^String v] (:r v))")) "^String (not a record) still guards") -(assert (= 0 (guards "(fn [^:struct v] (+ (+ (:r v) (:g v)) (:b v)))")) "all three hinted lookups bare") -(assert (= 0 (guards "(fn [^:struct v] (lensq v))")) "hint survives through an inlined call") -# hints work on let bindings too, not just params (init is a plain local here, -# so the only candidate guard is the hinted (:r v)) -(assert (= 0 (guards "(fn [^:struct s] (let [^:struct v s] (:r v)))")) "^:struct on a let binding drops the guard") -(assert (= 1 (guards "(fn [s] (let [v s] (:r v)))")) "unhinted let binding keeps the guard") -# (get m :k) gets the same treatment as (:k m) -(assert (= 1 (guards "(fn [m] (get m :k))")) "unhinted (get m :k) is guarded-inline") -(assert (= 0 (guards "(fn [^:struct m] (get m :k))")) "^:struct (get m :k) drops the guard") -(assert (= 0 (guards "(fn [^Vec3r m] (get m :k 0))")) "^Record (get m :k d) drops the guard") -# a variable (non-constant) key isn't a keyword literal, so the inline doesn't -# fire — it falls through to core-get, which still indexes correctly. -(assert (= 2 (api/eval-string ctx "((fn [m kk] (get m kk)) {:a 2} :a)")) "variable-key get via core-get") -(assert (= 10 (api/eval-string ctx "((fn [m i] (get m i)) [10 20] 0)")) "variable-key get indexes a vector") - -# --- correctness (accurate hints preserve results) -------------------------- -(assert (= 32 (api/eval-string ctx "(dot (v3 1 2 3) (v3 4 5 6))")) "hinted dot value") -(assert (= 14 (api/eval-string ctx "(lensq (v3 1 2 3))")) "hinted lensq (inline-flow) value") -(assert (= 7 (api/eval-string ctx "(:r (sub (v3 9 8 7) (v3 2 0 0)))")) "hinted sub field") -(api/eval-string ctx "(defn hit [^:struct ray ^:struct c] (lensq (sub (:origin ray) c)))") -(assert (= 48 (api/eval-string ctx "(hit {:origin (v3 5 5 5) :direction (v3 0 0 0)} (v3 1 1 1))")) - "hinted value through nested inline reads correctly") -(assert (= nil (api/eval-string ctx "((fn [^:struct m] (:absent m)) (v3 1 2 3))")) "hinted struct miss -> nil") -(assert (= 9 (api/eval-string ctx "((fn [^:struct m] (get m :absent 9)) (v3 1 2 3))")) "hinted get default") -# field access on a real record instance through a ^Record hint -(api/eval-string ctx "(defn vr-x [^Vec3r v] (:r v))") -(assert (= 5 (api/eval-string ctx "(vr-x (->Vec3r 5 6 7))")) "record field via ^Record hint") -# (get m :k) on assorted reps still matches core-get semantics (unhinted path) -(assert (= 2 (api/eval-string ctx "(get {:a 2} :a)")) "get struct present") -(assert (= nil (api/eval-string ctx "(get {:a 2} :z)")) "get struct miss") -(assert (= 1 (api/eval-string ctx "(get (hash-map :a 1 :x nil) :a)")) "get phm present") -(assert (= nil (api/eval-string ctx "(get (hash-map :a 1 :x nil) :x)")) "get phm nil value") -(assert (= 7 (api/eval-string ctx "(get (sorted-map :a 7) :a)")) "get sorted present") - -# --- checked mode: a lying hint throws (separate ctx with the flag on) ------- -(os/setenv "JOLT_CHECK_HINTS" "1") -(def cctx (api/init {:compile? true})) -(api/eval-string cctx "(ns ck)") -(api/eval-string cctx "(defn rd [^:struct m] (:a m))") -(assert (= 1 (api/eval-string cctx "(rd {:a 1 :b 2})")) "checked mode: accurate hint still works") -(let [r (protect (api/eval-string cctx "(rd (hash-map :a 1 :x nil))"))] - (assert (not (r 0)) "checked mode: lying ^:struct hint throws") - (assert (string/find "type hint violated" (string (r 1))) "checked-mode error is meaningful")) -(os/setenv "JOLT_CHECK_HINTS" nil) - -(print "Type hints passed!") diff --git a/test/integration/suite-worker.janet b/test/integration/suite-worker.janet deleted file mode 100644 index 63c7a36..0000000 --- a/test/integration/suite-worker.janet +++ /dev/null @@ -1,60 +0,0 @@ -# One-file worker for the clojure-test-suite battery. Loads the clojure.test -# shim, evaluates a single suite .cljc file, runs its deftests, and prints -# "pass fail error" to stdout. Used by the discovery pass to find files that -# hang under Jolt's eager evaluation (run under an external timeout). -(use ../../src/jolt/api) -(use ../../src/jolt/reader) -(use ../../src/jolt/evaluator) -(import ../../src/jolt/backend :as selfhost) - -(defn- parse-forms [src] - (var s src) (def fs @[]) (var go true) - (while (and go (> (length (string/trim s)) 0)) - (def r (protect (parse-next s))) - (if (not (r 0)) (set go false) - (let [p (r 1)] (set s (p 1)) (when (not (nil? (p 0))) (array/push fs (p 0)))))) - fs) - -# A helper, not a standalone test: it needs a .cljc path argument. When `jpm -# test` runs it with no args, no-op cleanly so it doesn't count as a failure. -(def path (get (dyn :args) 1)) - -(when path - # JOLT_COMPILE=1 runs the suite through the compile path (hybrid: hot forms - # compile, unsupported forms fall back to the interpreter) so the whole battery - # validates compile-mode correctness against the same baseline. - (def compile? (= "1" (os/getenv "JOLT_COMPILE"))) - # JOLT_SELFHOST=1 routes each form through the self-hosted pipeline (the - # portable Clojure analyzer + Janet back end, hybrid with interpreter fallback) - # so the whole battery validates the self-hosted compiler against the baseline. - (def selfhost? (= "1" (os/getenv "JOLT_SELFHOST"))) - (def ctx (init-cached (if compile? {:compile? true} {}))) - (defn run-form [f] - (cond - selfhost? (selfhost/compile-and-eval ctx f) - compile? (eval-one ctx f) - (eval-form ctx @{} f))) - (each f (parse-forms (slurp "test/support/clojure_test.clj")) (run-form f)) - - # Pre-load the suite's own clojure.core-test.number-range helper ns if present - # (35 files require it for r/max-int, r/max-double, … — its :default branches are - # plain numeric literals Jolt can read). Its `ns` form sets the namespace; the - # test file's own `ns` form switches back afterwards. - (let [dir (string/slice path 0 (- (length path) (length (last (string/split "/" path))))) - nr (string dir "number_range.cljc")] - (when (os/stat nr) - (each f (parse-forms (slurp nr)) (protect (run-form f))))) - - (eval-string ctx "(clojure.test/reset-report!)") - (each form (parse-forms (slurp path)) (protect (run-form form))) - (protect (eval-string ctx "(clojure.test/run-registered)")) - (def p (eval-string ctx "(clojure.test/n-pass)")) - (def f (eval-string ctx "(clojure.test/n-fail)")) - (def e (eval-string ctx "(clojure.test/n-error)")) - # A "dump" 2nd arg (or SUITE_DUMP env) also prints each failure/error message - # (one DUMP line each) for triage. - (when (or (os/getenv "SUITE_DUMP") (= "dump" (get (dyn :args) 2))) - (eval-string ctx "(doseq [m (clojure.test/failures)] (println (str \"DUMP \" m)))")) - # Counts on a sentinel line so parsers find it even if a test body printed to - # stdout (e.g. with-out-str / println-str tests). - (printf "@@COUNTS %d %d %d" (if (number? p) p 0) (if (number? f) f 0) (if (number? e) e 0))) diff --git a/test/integration/systematic-coverage-test.janet b/test/integration/systematic-coverage-test.janet deleted file mode 100644 index 0644430..0000000 --- a/test/integration/systematic-coverage-test.janet +++ /dev/null @@ -1,214 +0,0 @@ -# Systematic coverage tests for Clojure language features -(use ../../src/jolt/api) -(defn ct-eval [ctx s] (normalize-pvecs (eval-string ctx s))) - -(print "Systematic Coverage Tests") - -# --- Type Predicates --- -(print "1: type predicates...") -(let [ctx (init-cached)] - (assert (= true (ct-eval ctx "(integer? 0)")) "integer? 0") - (assert (= true (ct-eval ctx "(integer? 1)")) "integer? 1") - (assert (= true (ct-eval ctx "(integer? -5)")) "integer? negative") - (assert (= false (ct-eval ctx "(integer? 1.5)")) "integer? float") - (assert (= false (ct-eval ctx "(integer? nil)")) "integer? nil") - (assert (= false (ct-eval ctx "(integer? \"abc\")")) "integer? string") - (assert (= true (ct-eval ctx "(boolean? true)")) "boolean? true") - (assert (= true (ct-eval ctx "(boolean? false)")) "boolean? false") - (assert (= false (ct-eval ctx "(boolean? 1)")) "boolean? falsy") - (assert (= false (ct-eval ctx "(boolean? nil)")) "boolean? nil") - (assert (= true (ct-eval ctx "(nil? nil)")) "nil? nil") - (assert (= false (ct-eval ctx "(nil? false)")) "nil? false") - (assert (= false (ct-eval ctx "(nil? 0)")) "nil? 0") - (assert (= false (ct-eval ctx "(nil? [])")) "nil? empty vec") - (assert (= false (ct-eval ctx "(some? nil)")) "some? nil") - (assert (= true (ct-eval ctx "(some? false)")) "some? false") - (assert (= true (ct-eval ctx "(some? 0)")) "some? 0") - (assert (= true (ct-eval ctx "(some? [])")) "some? empty vec") - (assert (= true (ct-eval ctx "(string? \"hello\")")) "string?") - (assert (= false (ct-eval ctx "(string? 42)")) "string? false") - (assert (= true (ct-eval ctx "(string? \"\")")) "string? empty") - (assert (= true (ct-eval ctx "(number? 42)")) "number? int") - (assert (= true (ct-eval ctx "(number? 3.14)")) "number? float") - (assert (= false (ct-eval ctx "(number? \"42\")")) "number? string") - (assert (= true (ct-eval ctx "(fn? inc)")) "fn? builtin") - (assert (= false (ct-eval ctx "(fn? 42)")) "fn? false") - (assert (= true (ct-eval ctx "(keyword? :foo)")) "keyword?") - (assert (= false (ct-eval ctx "(keyword? \"foo\")")) "keyword? false") - (assert (= true (ct-eval ctx "(symbol? 'abc)")) "symbol?") - (assert (= false (ct-eval ctx "(symbol? :abc)")) "symbol? false") - (assert (= true (ct-eval ctx "(map? {:a 1})")) "map?") - (assert (= false (ct-eval ctx "(map? [1 2])")) "map? false") - (assert (= true (ct-eval ctx "(set? #{1 2})")) "set?") - (assert (= false (ct-eval ctx "(set? [1 2])")) "set? false") - (assert (= true (ct-eval ctx "(seq? '(1 2))")) "seq? list") - # vectors are not ISeq in Clojure — (seq? [1 2]) is false - (assert (= false (ct-eval ctx "(seq? [1 2])")) "seq? vector is false") - (assert (= true (ct-eval ctx "(coll? [1 2])")) "coll? vec") - (assert (= true (ct-eval ctx "(coll? '(1 2))")) "coll? list") - (assert (= true (ct-eval ctx "(coll? {})")) "coll? map") - (assert (= true (ct-eval ctx "(true? true)")) "true? true") - (assert (= false (ct-eval ctx "(true? 1)")) "true? 1") - (assert (= true (ct-eval ctx "(false? false)")) "false? false") - (assert (= false (ct-eval ctx "(false? nil)")) "false? nil") - (assert (= true (ct-eval ctx "(identical? 42 42)")) "identical? same value")) -(print " ok") - -# --- Number Predicates --- -(print "2: number predicates...") -(let [ctx (init-cached)] - (assert (= true (ct-eval ctx "(zero? 0)")) "zero? 0") - (assert (= false (ct-eval ctx "(zero? 1)")) "zero? 1") - # zero?/pos?/neg? now reject non-numbers (Clojure-strict), like the JVM. - (assert (not ((protect (ct-eval ctx "(zero? nil)")) 0)) "zero? nil throws") - (assert (= true (ct-eval ctx "(pos? 1)")) "pos?") - (assert (= false (ct-eval ctx "(pos? 0)")) "pos? 0") - (assert (= false (ct-eval ctx "(pos? -1)")) "pos? -1") - (assert (= true (ct-eval ctx "(neg? -1)")) "neg?") - (assert (= false (ct-eval ctx "(neg? 0)")) "neg? 0") - (assert (= false (ct-eval ctx "(neg? 1)")) "neg? 1") - (assert (= true (ct-eval ctx "(even? 0)")) "even? 0") - (assert (= true (ct-eval ctx "(even? 2)")) "even? 2") - (assert (= false (ct-eval ctx "(even? 1)")) "even? 1") - (assert (= true (ct-eval ctx "(odd? 1)")) "odd? 1") - (assert (= true (ct-eval ctx "(odd? 3)")) "odd? 3") - (assert (= false (ct-eval ctx "(odd? 2)")) "odd? 2")) -(print " ok") - -# --- Math --- -(print "3: math operations...") -(let [ctx (init-cached)] - (assert (= 0 (ct-eval ctx "(+)")) "+ 0 args") - (assert (= 5 (ct-eval ctx "(+ 2 3)")) "+ 2 args") - (assert (= 10 (ct-eval ctx "(+ 1 2 3 4)")) "+ varargs") - (assert (= -5 (ct-eval ctx "(- 5)")) "- unary") - (assert (= 2 (ct-eval ctx "(- 5 3)")) "- binary") - (assert (= 1 (ct-eval ctx "(*)")) "* 0 args") - (assert (= 6 (ct-eval ctx "(* 2 3)")) "*") - (assert (= 0.5 (ct-eval ctx "(/ 2)")) "/ unary reciprocal") - (assert (= 2 (ct-eval ctx "(/ 4 2)")) "/ binary") - (assert (= 2 (ct-eval ctx "(quot 5 2)")) "quot") - (assert (= 1 (ct-eval ctx "(rem 5 2)")) "rem") - (assert (= 1 (ct-eval ctx "(mod 5 2)")) "mod") - (assert (= 43 (ct-eval ctx "(inc 42)")) "inc") - (assert (= 41 (ct-eval ctx "(dec 42)")) "dec") - (assert (= 3 (ct-eval ctx "(max 1 2 3)")) "max") - (assert (= 1 (ct-eval ctx "(min 1 2 3)")) "min") - (assert (= 5 (ct-eval ctx "(abs -5)")) "abs negative") - (assert (= 5 (ct-eval ctx "(abs 5)")) "abs positive") - (assert (= 0 (ct-eval ctx "(abs 0)")) "abs 0") - (assert (= 3.14 (ct-eval ctx "(abs -3.14)")) "abs float") - (assert (= true (ct-eval ctx "(< (rand) 1)")) "rand < 1") - (assert (= true (ct-eval ctx "(number? (rand-int 10))")) "rand-int type")) -(print " ok") - -# --- Comparison --- -(print "4: comparison...") -(let [ctx (init-cached)] - (assert (= true (ct-eval ctx "(= 1 1)")) "= same") - (assert (= true (ct-eval ctx "(= 1 1 1)")) "= multi same") - (assert (= false (ct-eval ctx "(= 1 2)")) "= different") - (assert (= true (ct-eval ctx "(not= 1 2)")) "not= different") - (assert (= false (ct-eval ctx "(not= 1 1)")) "not= same") - (assert (= true (ct-eval ctx "(< 1 2)")) "<") - (assert (= false (ct-eval ctx "(< 2 1)")) "< false") - (assert (= true (ct-eval ctx "(> 2 1)")) ">") - (assert (= true (ct-eval ctx "(<= 1 1)")) "<=") - (assert (= true (ct-eval ctx "(>= 2 2)")) ">=")) -(print " ok") - -# --- Boolean logic --- -(print "5: boolean logic...") -(let [ctx (init-cached)] - (assert (= true (ct-eval ctx "(and)")) "and empty") - (assert (= true (ct-eval ctx "(and true)")) "and true") - (assert (= nil (ct-eval ctx "(and nil)")) "and nil") - (assert (= false (ct-eval ctx "(and false)")) "and false") - (assert (= 3 (ct-eval ctx "(and 1 2 3)")) "and last") - (assert (= nil (ct-eval ctx "(and 1 nil 3)")) "and short-circuit") - (assert (= nil (ct-eval ctx "(or)")) "or empty") - (assert (= true (ct-eval ctx "(or true)")) "or true") - (assert (= nil (ct-eval ctx "(or nil)")) "or nil") - (assert (= false (ct-eval ctx "(or false)")) "or false") - (assert (= 1 (ct-eval ctx "(or nil false 1 2)")) "or first truthy") - (assert (= false (ct-eval ctx "(or nil false)")) "or all falsy") - (assert (= false (ct-eval ctx "(not true)")) "not true") - (assert (= true (ct-eval ctx "(not nil)")) "not nil") - (assert (= true (ct-eval ctx "(not false)")) "not false")) -(print " ok") - -# --- Collections --- -(print "6: collections...") -(let [ctx (init-cached)] - (assert (= true (ct-eval ctx "(empty? nil)")) "empty? nil") - (assert (= true (ct-eval ctx "(empty? [])")) "empty? []") - (assert (= true (ct-eval ctx "(empty? ())")) "empty? ()") - (assert (= true (ct-eval ctx "(empty? {})")) "empty? {}") - (assert (= true (ct-eval ctx "(empty? #{})")) "empty? #{}") - (assert (= true (ct-eval ctx "(empty? \"\")")) "empty? empty string") - (assert (= false (ct-eval ctx "(empty? [1])")) "empty? non-empty") - (assert (= true (ct-eval ctx "(every? even? [2 4 6])")) "every? true") - (assert (= false (ct-eval ctx "(every? even? [2 3 4])")) "every? false") - (assert (= 3 (ct-eval ctx "(count [1 2 3])")) "count vector") - (assert (= 2 (ct-eval ctx "(count {:a 1 :b 2})")) "count map") - (assert (= 3 (ct-eval ctx "(count #{1 2 3})")) "count set") - (assert (= 3 (ct-eval ctx "(count \"abc\")")) "count string")) -(print " ok") - -# --- Sequence Operations --- -(print "7: sequence operations...") -(let [ctx (init-cached)] - (assert (= 1 (ct-eval ctx "(first [1 2 3])")) "first") - (assert (= nil (ct-eval ctx "(first [])")) "first empty") - (assert (= nil (ct-eval ctx "(first nil)")) "first nil") - (assert (= :a (ct-eval ctx "(nth [:a :b :c] 0)")) "nth 0") - (assert (= :c (ct-eval ctx "(nth [:a :b :c] 2)")) "nth 2") - (assert (= :d (ct-eval ctx "(nth [:a :b :c] 3 :d)")) "nth default") - (assert (= nil (ct-eval ctx "(seq [])")) "seq empty -> nil") - (assert (= nil (ct-eval ctx "(seq nil)")) "seq nil -> nil") - (assert (= true (ct-eval ctx "(= [2 3 4] (map inc [1 2 3]))")) "map") - (assert (= true (ct-eval ctx "(= [2 4] (filter even? [1 2 3 4]))")) "filter") - (assert (= 6 (ct-eval ctx "(reduce + [1 2 3])")) "reduce") - (assert (= 10 (ct-eval ctx "(reduce + 4 [1 2 3])")) "reduce init") - (assert (= true (ct-eval ctx "(= [1 2] (take 2 [1 2 3 4]))")) "take") - (assert (= true (ct-eval ctx "(= [3 4] (drop 2 [1 2 3 4]))")) "drop") - (assert (= true (ct-eval ctx "(= [3 2 1] (reverse [1 2 3]))")) "reverse") - (assert (= true (ct-eval ctx "(= 3 (count (distinct [1 1 2 2 3 3])))")) "distinct")) -(print " ok") - -# --- Collections: conj, assoc, dissoc, get --- -(print "8: collection mutation...") -(let [ctx (init-cached)] - (assert (= true (ct-eval ctx "(= [1 2 3] (conj [1 2] 3))")) "conj vector") - (assert (= true (ct-eval ctx "(= (quote (0 1 2)) (conj (quote (1 2)) 0))")) "conj list prepend") - (assert (= true (ct-eval ctx "(= {:a 1 :b 2} (assoc {:a 1} :b 2))")) "assoc") - (assert (= true (ct-eval ctx "(= {:a 1} (dissoc {:a 1 :b 2} :b))")) "dissoc") - (assert (= 1 (ct-eval ctx "(get {:a 1} :a)")) "get") - (assert (= nil (ct-eval ctx "(get {:a 1} :z)")) "get missing") - (assert (= :d (ct-eval ctx "(get {:a 1} :z :d)")) "get default") - (assert (= true (ct-eval ctx "(contains? {:a 1} :a)")) "contains? map") - (assert (= false (ct-eval ctx "(contains? {:a 1} :z)")) "contains? missing") - (assert (= true (ct-eval ctx "(contains? [5 6 7] 1)")) "contains? vector") - (assert (= false (ct-eval ctx "(contains? [5 6 7] 3)")) "contains? vector oob")) -(print " ok") - -# --- Higher-order functions --- -(print "9: higher-order functions...") -(let [ctx (init-cached)] - (assert (= 3 (ct-eval ctx "((comp inc inc) 1)")) "comp") - (assert (= 42 (ct-eval ctx "(identity 42)")) "identity") - (assert (= 99 (ct-eval ctx "((constantly 99) :anything)")) "constantly") - (assert (= true (ct-eval ctx "(= 10 ((partial + 3 7)))")) "partial") - (assert (= true (ct-eval ctx "((every-pred even? pos?) 4)")) "every-pred true") - (assert (= false (ct-eval ctx "((every-pred even? pos?) -4)")) "every-pred false") - (assert (= false (ct-eval ctx "((complement even?) 2)")) "complement")) -(print " ok") - -# --- Destructuring --- -(print "10: destructuring...") -(let [ctx (init-cached)] - (assert (= 1 (ct-eval ctx "(let [[x] [1 2 3]] x)")) "seq destructure first") - (assert (= 2 (ct-eval ctx "(let [[_ y] [1 2 3]] y)")) "seq destructure second")) -(print " ok") - -(print "\nAll Systematic Coverage tests passed!") diff --git a/test/integration/type-check-test.janet b/test/integration/type-check-test.janet deleted file mode 100644 index 5580a24..0000000 --- a/test/integration/type-check-test.janet +++ /dev/null @@ -1,137 +0,0 @@ -# Success-type checking (RFC 0006, jolt-y3b). The structural inference of -# RFC 0005, reused as a loose checker: flag a core-fn call ONLY when an argument -# is PROVABLY the wrong type (concrete and in the op's throwing error domain). -# Ambiguous cases (:any, unions, :truthy) are accepted — no false positives. -(import ../../src/jolt/api :as api) -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/types :as types) -(import ../../src/jolt/reader :as reader) - -(print "Success-type checking (jolt-y3b)...") - -(os/setenv "JOLT_DIRECT_LINK" "1") -(reader/track-positions! true) # record form positions (jolt-fqy) -(def ctx (api/init {:compile? true})) -(def pns (types/ctx-find-ns ctx "jolt.passes")) -(def check (types/var-get (types/ns-find pns "check-form"))) - -# diagnostics (a Janet tuple of diag structs) for a source form -(defn diags [src] - (api/normalize-pvecs (check (backend/analyze-form ctx (reader/parse-string src))))) -(defn nd [src] (length (diags src))) -# strict mode (jolt-zo1): also report provably-wrong calls to user fns -(defn nds [src] - (length (api/normalize-pvecs - (check (backend/analyze-form ctx (reader/parse-string src)) true)))) - -# --- provably wrong: REPORTED ------------------------------------------------ -(assert (= 1 (nd "(inc \"x\")")) "inc on a string") -(assert (= 1 (nd "(+ 1 \"x\")")) "+ with a string arg") -(assert (= 1 (nd "(count :foo)")) "count of a keyword") -(assert (= 1 (nd "(count 5)")) "count of a number") -(assert (= 1 (nd "(first 42)")) "first of a number") -(assert (= 1 (nd "(nth :k 0)")) "nth of a keyword") -(assert (= 1 (nd "(let [n \"x\"] (inc n))")) "inc on a let-bound string") -(assert (= 1 (nd "(inc (count :k))")) "inner count of keyword reported (inc of :num is fine)") - -# --- ambiguous / lenient: ACCEPTED (no false positive) ----------------------- -(assert (= 0 (nd "(:k 5)")) "keyword lookup on a number returns nil, not an error") -(assert (= 0 (nd "(get 5 :k)")) "get on a number returns nil, not an error") -(assert (= 0 (nd "(fn [x] (inc x))")) "inc on an unknown (:any) param accepted") -(assert (= 0 (nd "(fn [c] (inc (if c 1 \"x\")))")) "inc on a {:num | :str} branch -> :any, accepted") -(assert (= 0 (nd "(count \"ab\")")) "count of a string is fine") -(assert (= 0 (nd "(count [1 2 3])")) "count of a vector is fine") -(assert (= 0 (nd "(first [1 2 3])")) "first of a vector is fine") -(assert (= 0 (nd "(inc (count [1 2 3]))")) "count of vector + inc of :num both fine") -(assert (= 0 (nd "(inc (first [1 2 3]))")) "first of vector -> :num, inc fine") - -# --- calling a non-function (jolt-wwy): :num and :str are not callable -------- -(assert (= 1 (nd "(5 1)")) "calling a number is reported") -(assert (= 1 (nd "(\"hi\" 0)")) "calling a string is reported") -(assert (= 1 (nd "((+ 1 2) :k)")) "calling an arithmetic result (a :num) is reported") -(assert (= 1 (nd "(let [n 5] (n 1))")) "calling a let-bound number is reported") -(assert (= 1 (nd "(let [s \"x\"] (s 0))")) "calling a let-bound string is reported") -# (a var holding a number, e.g. (def nn 5) (nn 1), is caught in direct-link -# mode via vtype-box; the standalone checker has no var value types) -# callable values: keyword/map/vector/set as IFn — NOT reported -(assert (= 0 (nd "(:k {:k 1})")) "keyword call is fine") -(assert (= 0 (nd "({:a 1} :a)")) "map call is fine") -(assert (= 0 (nd "([10 20] 1)")) "vector call is fine") -(assert (= 0 (nd "(#{1 2} 1)")) "set call is fine") -(assert (= 0 (nd "(fn [c] ((if c 1 :k) 0))")) "union {:num | :kw} callee accepted (:kw is callable)") -(assert (= 0 (nd "(fn [f] (f 1))")) "calling an unknown (:any) param accepted") -(assert (= 1 (nd "(fn [c] ((if c 1 \"x\") 0))")) "union {:num | :str} callee — both non-callable — reported") - -# --- bounded unions (jolt-pz5): report only when EVERY member is in the error -# domain; accept when any member is valid. Differing branches used to collapse -# to :any (accepted); now they form {:union #{...}} and are checked per-member. -(assert (= 1 (nd "(fn [c] (inc (if c \"a\" :k)))")) - "inc of {:str | :kw} — every member non-number — reported") -(assert (= 0 (nd "(fn [c] (inc (if c 1 \"x\")))")) - "inc of {:num | :str} — :num is fine — still accepted") -(assert (= 1 (nd "(fn [c] (count (if c :k 5)))")) - "count of {:kw | :num} — both non-seqable — reported") -(assert (= 0 (nd "(fn [c] (count (if c :k \"ab\")))")) - "count of {:kw | :str} — :str is seqable — accepted") -(assert (= 1 (nd "(fn [c] (inc (if c \"a\" (if c :k :j))))")) - "inc of nested all-non-number union reported") -(assert (= 0 (nd "(fn [c] (inc (if c \"a\" (if c :k 1))))")) - "inc of union with a buried :num member accepted") -# a union is opaque to structural specialization — it keeps the dynamic guard, -# exactly like :any, so a keyword lookup over it is never mis-specialized. -(assert (= 0 (nd "(fn [c] (:r (if c {:r 1} {:g 2})))")) - "keyword lookup over a struct union is accepted (no false positive)") - -# --- user-function error domains (jolt-zo1), opt-in strict mode -------------- -# A call passing a provably-wrong type to a user fn whose body requires -# otherwise is reported ONLY in strict mode; the default level never fires on -# user fns (closed-world soundness boundary). -(assert (= 0 (nd "(do (defn ufa [x] (+ x 1)) (ufa \"s\"))")) - "user-fn wrong call NOT reported at the default level") -(assert (= 1 (nds "(do (defn ufa [x] (+ x 1)) (ufa \"s\"))")) - "strict: arithmetic fn called with a string is reported") -(assert (= 0 (nds "(do (defn ufb [x] (+ x 1)) (ufb 5))")) - "strict: same fn called with a number is accepted") -(assert (= 0 (nds "(do (defn ufc [x] (:k x)) (ufc \"s\"))")) - "strict: a body that uses the param leniently is not reported") -# cross-form: a def registered by an earlier check is visible to a later call -(nds "(defn ufd [x] (count x))") -(assert (= 1 (nds "(ufd 42)")) - "strict: cross-form call to a seq-only fn with a number is reported") -(assert (= 0 (nds "(do (defn ^:redef ufe [x] (+ x 1)) (ufe \"s\"))")) - "strict: a ^:redef fn is not a stable requirement, not reported") -(assert (= 1 (nds "(do (defn ufrec [x] (ufrec (+ x 1))) (ufrec \"s\"))")) - "strict: self-recursion terminates (cycle guard) and the (+ x 1) on a string is reported once") -# wrong arity to a user fn (jolt-wwy), strict mode: the registered fixed arity -# makes a mismatched call provably throw, regardless of argument types -(assert (= 1 (nds "(do (defn uar [x y] (+ x y)) (uar 1))")) - "strict: 2-arg fn called with 1 arg is reported") -(assert (= 1 (nds "(do (defn uar2 [x] x) (uar2 1 2 3))")) - "strict: 1-arg fn called with 3 args is reported") -(assert (= 0 (nds "(do (defn uar3 [x y] (+ x y)) (uar3 1 2))")) - "strict: correct arity accepted") -(assert (= 0 (nd "(do (defn uar4 [x y] (+ x y)) (uar4 1))")) - "default level does NOT report user-fn arity (closed-world, opt-in)") -(assert (= 0 (nds "(do (defn ^:redef uar5 [x y] (+ x y)) (uar5 1))")) - "strict: ^:redef fn arity not checked (could be redefined)") - -# --- the diagnostic carries op + type + a message ---------------------------- -(def one (in (diags "(inc \"x\")") 0)) -(assert (= "inc" (get one :op)) "diagnostic names the op") -(assert (string/find "number" (get one :msg)) "message says a number is required") -# --- the diagnostic carries the offending form's source offset (jolt-fqy) ----- -(assert (= 0 (get one :pos)) "diagnostic carries :pos (offset 0 for a single form)") -(def nested (in (diags "(do 1 2 (inc :k))") 0)) -(assert (= 8 (get nested :pos)) - "the inner (inc :k) form is positioned at its own offset, not the do's") - -# --- end-to-end: strictness drives compilation (decoupled from :inline?) ----- -# error mode aborts a provably-wrong form's compilation; a correct form compiles. -(os/setenv "JOLT_TYPE_CHECK" "error") -(assert (not (first (protect (api/eval-string ctx "(count :nope)")))) - "error mode aborts a provably-wrong form") -(assert (first (protect (api/eval-string ctx "(count [1 2 3])"))) - "error mode accepts a correct form") -(os/setenv "JOLT_TYPE_CHECK" "off") - -(print "Success-type checking passed!") diff --git a/test/integration/type-infer-phase1-test.janet b/test/integration/type-infer-phase1-test.janet deleted file mode 100644 index 5d8fac7..0000000 --- a/test/integration/type-infer-phase1-test.janet +++ /dev/null @@ -1,55 +0,0 @@ -# Inter-procedural collection-type inference, Phase 1 (jolt-767): closed-world. -# A whole-unit fixpoint propagates collection types through the call graph — a -# fn's param types become the lub of its in-unit call-site arg types — so a -# param that always receives a struct map gets typed and its lookups specialize, -# with no hint. Fns whose var escapes as a value keep :any params (their callers -# aren't all visible). Sound under source distribution + whole-program compile. -(import ../../src/jolt/api :as api) -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/types :as types) -(import ../../src/jolt/reader :as reader) - -(print "Type inference Phase 1 (jolt-767)...") - -(os/setenv "JOLT_DIRECT_LINK" "1") -(def ctx (api/init-cached {:compile? true})) -(api/eval-string ctx "(ns p1)") -# closed-world unit. mk is small (inlined away). rd is RECURSIVE, so it survives -# inlining and is called via its var — exactly the shape (big/recursive fn with -# escaping-from-the-caller params) that inter-procedural inference targets. Its -# param v flows from mk's struct-map literal (after mk inlines into drv). -(each s ["(defn mk [a b] {:r a :g b})" - "(defn rd [v n] (if (< n 1) (:r v) (rd v (dec n))))" - "(defn drv [] (rd (mk 1 2) 3))" - # esc's var is used as a VALUE (passed to mapv) -> params must stay :any - "(defn esc [w] (:r w))" - "(defn use-esc [xs] (mapv esc xs))"] - (api/eval-string ctx s)) - -(def report (backend/infer-unit! ctx "p1")) - -# --- the fixpoint computed the right param types ----------------------------- -# rd's param v flows from mk's struct result (mk inlines to a struct literal in -# drv) and stays struct across the recursive self-call -> a {:struct ...} type -(defn struct-type? [t] (truthy? (get t :struct))) -(assert (struct-type? (in (get report "p1/rd") 0)) (string "rd param v: " (in (get report "p1/rd") 0))) -# esc escaped (passed to mapv) -> param stays unknown (:any / nil), NOT struct -(assert (not (struct-type? (in (get report "p1/esc") 0))) "escaping fn param not inferred struct") - -# --- the seeded re-inference drops the guard for a struct param -------------- -# (on a FRESH analysis, since infer-unit! re-stashes the already-specialized body) -(def pns (types/ctx-find-ns ctx "jolt.passes")) -(def reinfer (types/ns-find pns "reinfer-def")) -(def rd-def (backend/analyze-form ctx (reader/parse-string "(defn rdx [v n] (if (< n 1) (:r v) (rdx v (dec n))))"))) -(defn guards-seeded [ptmap] - (length (string/find-all ":jolt/type" (string/format "%p" (backend/emit-ir ctx ((types/var-get reinfer) rd-def ptmap)))))) -(assert (= 0 (guards-seeded @{"v" {:struct {}}})) "struct param -> bare lookup") -(assert (= 1 (guards-seeded @{})) "no param type -> guard kept") - -# --- correctness: recompiled unit still computes the same -------------------- -(assert (= 1 (api/eval-string ctx "(p1/drv)")) "drv correct after recompile") -(assert (= 7 (api/eval-string ctx "(p1/rd {:r 7 :g 8} 0)")) "rd correct on a struct") -(assert (= nil (api/eval-string ctx "(p1/rd (hash-map :r nil) 0)")) "rd correct on a phm (key present, nil)") -(assert (deep= [1 1] (api/normalize-pvecs (api/eval-string ctx "(p1/use-esc [{:r 1} {:r 1}])"))) "escaping fn still correct") - -(print "Type inference Phase 1 passed!") diff --git a/test/integration/type-infer-phase2-test.janet b/test/integration/type-infer-phase2-test.janet deleted file mode 100644 index 8ac347a..0000000 --- a/test/integration/type-infer-phase2-test.janet +++ /dev/null @@ -1,24 +0,0 @@ -# Vector op specialization, Phase 2 (jolt-d6u): a value the inference proved to -# be a vector ({:vec ...}) gets count -> pv-count (skip core-count's dispatch) -# and 3-arg nth -> pv-nth. 2-arg nth is NOT specialized: it errors on -# out-of-bounds where pv-nth returns nil. -(import ../../src/jolt/api :as api) -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/types :as types) -(import ../../src/jolt/reader :as reader) -(print "Type inference Phase 2 (vector ops)...") -(os/setenv "JOLT_DIRECT_LINK" "1") -(def ctx (api/init-cached {:compile? true})) -(api/eval-string ctx "(ns p2)") -(def reinfer (types/var-get (types/ns-find (types/ctx-find-ns ctx "jolt.passes") "reinfer-def"))) -(defn estr [src ptmap] - (string/format "%p" (backend/emit-ir ctx (reinfer (backend/analyze-form ctx (reader/parse-string src)) ptmap)))) -(assert (string/find "pv-count" (estr "(defn f [v] (count v))" @{"v" {:vec :any}})) "count on vector -> pv-count") -(assert (not (string/find "pv-count" (estr "(defn f [v] (count v))" @{}))) "count on unknown not specialized") -(assert (string/find "pv-nth" (estr "(defn f [v i] (nth v i 0))" @{"v" {:vec :any}})) "3-arg nth on vector -> pv-nth") -(assert (not (string/find "pv-nth" (estr "(defn f [v i] (nth v i))" @{"v" {:vec :any}}))) "2-arg nth NOT specialized") -# correctness -(assert (= 3 (api/eval-string ctx "(count [1 2 3])")) "count value") -(assert (= 2 (api/eval-string ctx "(nth [1 2 3] 1 9)")) "nth 3-arg in-bounds") -(assert (= 9 (api/eval-string ctx "(nth [1 2 3] 5 9)")) "nth 3-arg default") -(print "Type inference Phase 2 passed!") diff --git a/test/integration/type-infer-phase3-test.janet b/test/integration/type-infer-phase3-test.janet deleted file mode 100644 index 2160b04..0000000 --- a/test/integration/type-infer-phase3-test.janet +++ /dev/null @@ -1,41 +0,0 @@ -# Collection-element types + HOF awareness, Phase 3 (jolt-d6u). A vector carries -# its element type ({:vec ELEM}); a reduce/map/filter closure over it gets that -# element type on its element param. So a lookup inside a reduce closure over a -# vector-of-structs specializes — no hint — WHEN the element type is provable. -(import ../../src/jolt/api :as api) -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/types :as types) -(import ../../src/jolt/reader :as reader) - -(print "Type inference Phase 3 (jolt-d6u)...") - -(os/setenv "JOLT_DIRECT_LINK" "1") -(def ctx (api/init-cached {:compile? true})) -(api/eval-string ctx "(ns p3)") -(def pns (types/ctx-find-ns ctx "jolt.passes")) -(def reinfer (types/var-get (types/ns-find pns "reinfer-def"))) -# helper: analyze a defn, reinfer with seeded param types, count guards -(defn guards [src ptmap] - (def d (backend/analyze-form ctx (reader/parse-string src))) - (length (string/find-all ":jolt/type" (string/format "%p" (backend/emit-ir ctx (reinfer d ptmap)))))) - -# a reduce closure's element param gets the vector's element type -(def red "(defn f [coll] (reduce (fn [acc h] (+ acc (:r h))) 0 coll))") -(assert (= 0 (guards red @{"coll" {:vec {:struct {}}}})) "reduce element typed -> bare lookup in closure") -(assert (= 1 (guards red @{"coll" {:vec :any}})) "reduce over vector of unknown -> guard kept") -(assert (= 1 (guards red @{})) "untyped coll -> guard kept") - -# mapv over a vector-of-structs types the closure element too -(def mp "(defn g [coll] (mapv (fn [h] (:r h)) coll))") -(assert (= 0 (guards mp @{"coll" {:vec {:struct {}}}})) "mapv element typed -> bare lookup") -(assert (= 1 (guards mp @{"coll" {:vec :any}})) "mapv over unknown element -> guard") - -# element type is DERIVED, not just seeded: a vector literal of structs, reduced -(def derived "(defn h2 [] (reduce (fn [acc x] (+ acc (:r x))) 0 [{:r 1 :g 2} {:r 3 :g 4}]))") -(assert (= 0 (guards derived @{})) "vector literal of structs -> element struct -> bare lookup") - -# correctness: the specialized closures compute the same -(assert (= 4 (api/eval-string ctx "((fn [coll] (reduce (fn [acc h] (+ acc (:r h))) 0 coll)) [{:r 1} {:r 3}])")) "reduce value") -(assert (= 4 (api/eval-string ctx "(reduce (fn [acc x] (+ acc (:r x))) 0 [{:r 1 :g 2} {:r 3 :g 4}])")) "derived value") - -(print "Type inference Phase 3 passed!") diff --git a/test/integration/type-infer-test.janet b/test/integration/type-infer-test.janet deleted file mode 100644 index e010870..0000000 --- a/test/integration/type-infer-test.janet +++ /dev/null @@ -1,54 +0,0 @@ -# Static collection-type inference, Phase 0 (jolt-6sr): intra-procedural. -# The pass infers an expression's collection type from literals/arithmetic and -# flows it through let bindings and if-joins. Where a keyword-lookup subject is -# PROVEN to be a plain struct map it auto-drops the :jolt/type guard (the -# inference output is the same ^:struct channel as a manual hint); where the -# type is unknown it stays :any and keeps the dynamic guard (sound fallback). -# -# Note: Route 1 scalar-replacement already eliminates NON-escaping let-bound -# maps outright, so these cases force the map to ESCAPE (pass it to `sink`) to -# isolate what inference adds — typing a map that survives and is then looked up. -(import ../../src/jolt/api :as api) -(import ../../src/jolt/backend :as backend) -(import ../../src/jolt/reader :as reader) - -(print "Type inference Phase 0 (jolt-6sr)...") - -(os/setenv "JOLT_DIRECT_LINK" "1") -(def ctx (api/init-cached {:compile? true})) -(api/eval-string ctx "(ns ti)") - -(defn guards [src] - (length (string/find-all ":jolt/type" - (string/format "%p" (backend/emit-ir ctx (backend/analyze-form ctx (reader/parse-string src))))))) -(defn ev [src] (api/eval-string ctx src)) - -# --- guard auto-removal where the type is proven, no hint ------------------- -# escaping struct-map literal (scalar keys, truthy values) is proven struct -(assert (= 0 (guards "(fn [sink] (let [v {:r 1 :g 2 :b 3}] (sink v) (:r v)))")) "inferred struct-map literal -> bare lookup") -# arithmetic values are provably non-nil/non-false -> still a struct -(assert (= 0 (guards "(fn [sink a b] (let [v {:r (+ a 1) :g (* b 2) :b 7}] (sink v) (:r v)))")) "arithmetic-valued map inferred struct") -# the inferred type flows through a rebinding -(assert (= 0 (guards "(fn [sink] (let [v {:r 1 :g 2} w v] (sink w) (:r w)))")) "inferred type flows through a rebinding") -# both if-branches struct -> join is struct -(assert (= 0 (guards "(fn [sink c] (let [v (if c {:a 1} {:a 2})] (sink v) (:a v)))")) "if-join of two struct literals stays struct") - -# --- sound fallback to the guard where the type is NOT proven --------------- -# a param is unknown (Phase 1 handles params) -> guard kept, exactly as today -(assert (= 1 (guards "(fn [m] (:r m))")) "unknown param keeps the guard") -# a value that could be nil/false makes the literal maybe-phm -> :any -> guard -(assert (= 1 (guards "(fn [sink x] (let [v {:r x}] (sink v) (:r v)))")) "maybe-nil value -> not proven struct -> guard") -# join of a struct and a phm is :any -> guard -(assert (>= (guards "(fn [sink c] (let [v (if c {:a 1} (hash-map :a nil))] (sink v) (:a v)))") 1) "struct/phm join -> :any -> guard") - -# --- correctness: every shape evaluates to the same as the guarded path ----- -(def snk "(fn [_] nil)") -(assert (= 1 (ev (string "((fn [sink] (let [v {:r 1 :g 2 :b 3}] (sink v) (:r v))) " snk ")"))) "struct literal value") -(assert (= 6 (ev (string "((fn [sink a] (let [v {:r (+ a 1)}] (sink v) (:r v))) " snk " 5)"))) "arithmetic-valued struct") -(assert (= 2 (ev (string "((fn [sink] (let [v {:r 1 :g 2} w v] (sink w) (:g w))) " snk ")"))) "flowed type value") -(assert (= 1 (ev (string "((fn [sink c] (let [v (if c {:a 1} {:a 2})] (sink v) (:a v))) " snk " true)"))) "if-join value") -(assert (= nil (ev (string "((fn [sink x] (let [v {:r x}] (sink v) (:r v))) " snk " nil)"))) "maybe-nil map reads correctly (nil)") -(assert (= nil (ev (string "((fn [sink c] (let [v (if c {:a 1} (hash-map :a nil))] (sink v) (:a v))) " snk " false)"))) "phm branch reads nil correctly") -(assert (= 1 (ev (string "((fn [sink c] (let [v (if c {:a 1} (hash-map :a nil))] (sink v) (:a v))) " snk " true)"))) "struct branch reads correctly") - -(print "Type inference Phase 0 passed!") diff --git a/test/integration/uberscript-dce-test.janet b/test/integration/uberscript-dce-test.janet deleted file mode 100644 index 04a3a3b..0000000 --- a/test/integration/uberscript-dce-test.janet +++ /dev/null @@ -1,86 +0,0 @@ -# Dead-code elimination in `jolt uberscript` (jolt-atg): a bundle is closed- -# world (everything it needs is inlined, nothing is required later), so a user -# `defn` that is unreachable from the entry point's reference graph can be -# dropped. Sound + conservative: only plain defn/defn- are prunable; a defn is -# kept if its (bare or ns-qualified) name appears anywhere in a kept form, the -# closure iterates to a fixpoint, and any use of dynamic resolution -# (resolve/eval/...) keeps everything. Drives the BUILT binary (uberscript is a -# CLI command); skips cleanly if build/jolt is absent. -(def jolt "build/jolt") - -(defn- write-app [dir files] - (os/mkdir dir) - (each [name body] (partition 2 files) (spit (string dir "/" name) body))) - -(defn- uber [dir main-ns] - (def out (string dir "/out.clj")) - (def jbin (string (os/cwd) "/" jolt)) - (os/execute ["sh" "-c" (string "JOLT_PATH=" dir " " jbin " uberscript " out " -m " main-ns " 2>/dev/null")] :p) - (slurp out)) - -(defn- run-bundle [dir] - (def out2 (string dir "/run.txt")) - (def jbin (string (os/cwd) "/" jolt)) - (os/execute ["sh" "-c" (string jbin " " dir "/out.clj > " out2 " 2>&1")] :p) - (string/trimr (slurp out2))) - -(defn- has? [s needle] (not (nil? (string/find needle s)))) - -(if (not (os/stat jolt)) - (print "uberscript-dce: SKIP (no build/jolt — run from source)") - (do - # --- basic: an unreachable defn is dropped; reachable ones survive -------- - (def d1 (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-dce1")) - (write-app d1 - ["lib.clj" (string "(ns lib)\n" - "(defn used-helper [x] (* x 2))\n" - "(defn dead-never-called [x] (+ x 99999))\n" - "(defn also-used [x] (used-helper (inc x)))\n") - "app.clj" (string "(ns app (:require [lib]))\n" - "(defn -main [& _] (println \"result\" (lib/also-used 10)))\n")]) - (def b1 (uber d1 "app")) - (assert (not (has? b1 "dead-never-called")) "unreachable defn dropped from bundle") - (assert (has? b1 "used-helper") "transitively-reached defn kept") - (assert (has? b1 "also-used") "directly-reached defn kept") - (assert (= "result 22" (run-bundle d1)) "pruned bundle runs identically") - - # --- soundness: a fn reached ONLY through a macro template is kept -------- - (def d2 (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-dce2")) - (write-app d2 - ["mlib.clj" (string "(ns mlib)\n" - "(defn via-macro [x] (* x 3))\n" - "(defmacro tri [n] (list 'mlib/via-macro n))\n") - "app2.clj" (string "(ns app2 (:require [mlib]))\n" - "(defn -main [& _] (println \"m\" (mlib/tri 7)))\n")]) - (def b2 (uber d2 "app2")) - (assert (has? b2 "via-macro") "fn used only via a macro template is kept") - (assert (= "m 21" (run-bundle d2)) "macro-reached bundle runs identically") - - # --- soundness: dynamic resolution disables DCE (keeps everything) -------- - (def d3 (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-dce3")) - (write-app d3 - ["dlib.clj" (string "(ns dlib)\n" - "(defn looks-dead [x] (* x 5))\n") - "app3.clj" (string "(ns app3 (:require [dlib]))\n" - "(defn -main [& _]\n" - " (println \"d\" ((deref (resolve 'dlib/looks-dead)) 4)))\n")]) - (def b3 (uber d3 "app3")) - (assert (has? b3 "looks-dead") "resolve in bundle disables DCE (keeps all defns)") - (assert (= "d 20" (run-bundle d3)) "resolve bundle runs identically") - - # --- soundness: a fn reached only through a defmethod body is kept -------- - (def d4 (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-dce4")) - (write-app d4 - ["mmlib.clj" (string "(ns mmlib)\n" - "(defmulti shape-area :kind)\n" - "(defn rect-helper [w h] (* w h))\n" - "(defmethod shape-area :rect [s] (rect-helper (:w s) (:h s)))\n" - "(defn really-dead [x] (+ x 1))\n") - "app4.clj" (string "(ns app4 (:require [mmlib]))\n" - "(defn -main [& _] (println \"area\" (mmlib/shape-area {:kind :rect :w 3 :h 4})))\n")]) - (def b4 (uber d4 "app4")) - (assert (has? b4 "rect-helper") "fn reached only via a defmethod body is kept") - (assert (not (has? b4 "really-dead")) "truly-unreachable fn dropped alongside live multimethod code") - (assert (= "area 12" (run-bundle d4)) "multimethod bundle runs identically") - - (print "uberscript-dce: all cases passed"))) diff --git a/test/integration/uberscript-test.janet b/test/integration/uberscript-test.janet deleted file mode 100644 index 37ac08f..0000000 --- a/test/integration/uberscript-test.janet +++ /dev/null @@ -1,51 +0,0 @@ -# `jolt uberscript` bundles a namespace and everything it requires into one .clj -# that runs on a plain jolt with no JOLT_PATH / deps. Runs from source. - -(defn- run [env-jolt-path & args] - (if env-jolt-path (os/setenv "JOLT_PATH" env-jolt-path) (os/setenv "JOLT_PATH" nil)) - (def p (os/spawn ["janet" "src/jolt/main.janet" ;args] :p {:out :pipe :err :pipe})) - (def out (:read (p :out) :all)) - (os/proc-wait p) - (string (or out ""))) - -(defn- mkdirs [p] - (var acc nil) - (each seg (filter |(not= "" $) (string/split "/" p)) - (set acc (if (nil? acc) (if (string/has-prefix? "/" p) (string "/" seg) seg) (string acc "/" seg))) - (unless (os/stat acc) (os/mkdir acc)))) -(defn- rmrf [p] - (when (os/stat p) - (if (= :directory (os/stat p :mode)) - (do (each e (os/dir p) (rmrf (string p "/" e))) (os/rmdir p)) - (os/rm p)))) - -(def base (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-uber-" (os/time))) -(rmrf base) -(mkdirs (string base "/proj/src/app")) -(mkdirs (string base "/lib/src/greet")) -(spit (string base "/lib/src/greet/core.clj") - "(ns greet.core)\n(defn hello [n] (str \"Hello, \" n \"!\"))\n") -(spit (string base "/proj/src/app/core.clj") - "(ns app.core (:require [greet.core :as g]))\n(defn -main [& args] (println (g/hello (or (first args) \"world\"))))\n") - -(var fails 0) -(defn check [label got pred] - (if (pred got) (print " ok " label) - (do (++ fails) (printf " FAIL %s: got %q" label got)))) -(defn- has [s] (fn [x] (string/find s x))) - -(def roots (string base "/proj/src:" base "/lib/src")) -(def out (string base "/out.clj")) - -# build the uberscript with the dep roots on JOLT_PATH -(run roots "uberscript" out "-m" "app.core") -(check "uberscript written" (if (os/stat out) "yes" "no") (has "yes")) -(check "bundles the dep ns" (slurp out) (has "(ns greet.core)")) - -# run it standalone: no JOLT_PATH, so it only works if the dep was inlined -(check "runs standalone" (run nil out "Bob") (has "Hello, Bob!")) - -(rmrf base) -(if (> fails 0) - (error (string "uberscript-test: " fails " failing check(s)")) - (print "\nAll uberscript tests passed!")) diff --git a/test/integration/whole-program-test.janet b/test/integration/whole-program-test.janet deleted file mode 100644 index c711db8..0000000 --- a/test/integration/whole-program-test.janet +++ /dev/null @@ -1,51 +0,0 @@ -# Whole-program (Stalin) mode (jolt-t34, opt-in JOLT_WHOLE_PROGRAM): one closed- -# world inference fixpoint over ALL user namespaces, so param types propagate -# across ns boundaries (a non-inlined fn's record params get proven from its -# callers in another unit). This must be SOUND — same results as the per-ns -# pass — which is what this test guards, by running a cross-namespace record -# program both ways through the built binary and comparing output. Skips cleanly -# if build/jolt is absent (source-only test run). -(def jolt "build/jolt") - -(defn- run [env-extra] - (def dir (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-wp-test")) - (os/mkdir dir) - (spit (string dir "/wputil.clj") - (string "(ns wputil)\n" - "(defrecord V [x y z])\n" - # const-link targets (jolt-rvt): a data def and a ^:redef fn are - # indirect (cell deref) per-ns but embedded as constants under - # whole-program. Soundness => both modes must give the same answer. - "(def scale 2.0)\n" - "(defn ^:redef bump [x] (+ x 1.0))\n" - # recursive => never inlined; params proven only whole-program - "(defn dot [a b n]\n" - " (if (<= n 0) 0.0\n" - " (+ (* (:x a) (:x b)) (* (:y a) (:y b)) (* (:z a) (:z b)) (bump (* scale (dot a b (dec n)))))))\n")) - (spit (string dir "/wpmain.clj") - (string "(ns wpmain (:require [wputil :as v]))\n" - "(defn -main []\n" - " (loop [i 0 acc 0.0]\n" - " (if (< i 1000)\n" - " (let [a (v/->V (double i) 2.0 3.0) b (v/->V 1.0 (double i) 0.5)]\n" - " (recur (inc i) (+ acc (v/dot a b 2))))\n" - " (println \"sum\" acc))))\n")) - (def out (string dir "/out.txt")) - (def jbin (string (os/cwd) "/" jolt)) - (def cmd (string env-extra "JOLT_DIRECT_LINK=1 JOLT_PATH=" dir " " jbin - " -m wpmain > " out " 2>&1")) - (os/execute ["sh" "-c" cmd] :p) - (string/trimr (slurp out))) - -(if (not (os/stat jolt)) - (print "whole-program: SKIP (no build/jolt — run from source)") - # -m now auto-enables whole-program under direct-linking, so the per-ns - # baseline must explicitly opt out to exercise the per-namespace path. - (let [per-ns (run "JOLT_NO_WHOLE_PROGRAM=1 ") - whole (run "JOLT_WHOLE_PROGRAM=1 ")] - (printf " per-ns: %s" per-ns) - (printf " whole-program: %s" whole) - (if (and (= per-ns whole) (string/has-prefix? "sum" per-ns)) - (print "whole-program: results match — sound") - (do (printf "whole-program: MISMATCH per-ns=%q whole=%q" per-ns whole) - (os/exit 1))))) diff --git a/test/spec/clojure-interop-fixes-spec.janet b/test/spec/clojure-interop-fixes-spec.janet deleted file mode 100644 index 3166dd5..0000000 --- a/test/spec/clojure-interop-fixes-spec.janet +++ /dev/null @@ -1,29 +0,0 @@ -# Specification: Clojure-compat fixes that landed with HTTP-client support -# (jolt-lang/http-client). All are general language behaviours, exercised here -# across interpret + compile modes by the harness. -(use ../support/harness) - -(defspec "interop-fixes / deprecated #^ metadata reader" - ["#^ type hint on a param" "\"x\"" - "(do (defn f1 [#^String s] s) (f1 \"x\"))"] - ["#^\"[B\" array hint" "[1 2]" - "(do (defn f2 [#^\"[B\" b] b) (f2 [1 2]))"] - ["#^ is equivalent to ^" "true" - "(= (meta (with-meta [] {:tag (quote String)})) {:tag (quote String)})"]) - -(defspec "interop-fixes / (str pattern) yields raw source" - ["str of a regex" "\"abc\"" "(str #\"abc\")"] - ["compose patterns via str" "true" - "(boolean (re-matches (re-pattern (str #\"<\" \"(.*)\" \">\")) \"\"))"]) - -(defspec "interop-fixes / into onto a map" - ["merges map items" "true" "(= {:a 1 :b 2} (into {} [{:a 1} {:b 2}]))"] - ["accepts [k v] pairs" "true" "(= {:a 1} (into {} [[:a 1]]))"] - ["map item onto empty {}" "true" "(= {:x 1} (into {} (list {:x 1})))"] - ["conj a map onto {}" "true" "(= {:a 1} (conj {} {:a 1}))"]) - -(defspec "interop-fixes / a var is callable as its value" - ["call a var directly" "42" - "(do (def vf (fn [x] (inc x))) ((var vf) 41))"] - ["var bound as a client fn" "\"ok\"" - "(do (def base (fn [_] \"ok\")) (def mw (fn [client] (fn [req] (client req)))) ((mw (var base)) {}))"]) diff --git a/test/spec/control-flow-spec.janet b/test/spec/control-flow-spec.janet deleted file mode 100644 index 59e3ccf..0000000 --- a/test/spec/control-flow-spec.janet +++ /dev/null @@ -1,108 +0,0 @@ -# Specification: control flow & binding forms. -(use ../support/harness) - -(defspec "control / conditionals" - ["if true" "1" "(if true 1 2)"] - ["if false" "2" "(if false 1 2)"] - ["if nil is false" "2" "(if nil 1 2)"] - ["if no else" "nil" "(if false 1)"] - ["when true" "3" "(when true 1 2 3)"] - ["when false" "nil" "(when false 1)"] - ["when-not" "1" "(when-not false 1)"] - ["cond" ":b" "(cond false :a true :b :else :c)"] - ["cond :else" ":c" "(cond false :a false :b :else :c)"] - ["cond no match" "nil" "(cond false :a)"] - ["condp" "\"two\"" "(condp = 2 1 \"one\" 2 \"two\" \"other\")"] - ["case" ":b" "(case 2 1 :a 2 :b :default)"] - ["case default" ":d" "(case 9 1 :a 2 :b :d)"] - ["case multi" ":ab" "(case 2 (1 2) :ab 3 :c)"] - ["case symbol const" ":s" "(case 'foo foo :s :default)"] - ["case vector const" ":v" "(case [1 2] [1 2] :v :default)"] - ["case map const" ":m" "(case {:a 1} {:a 1} :m :default)"] - ["case list const" ":l" "(case '(a b) (quote (a b)) :l :default)"] - ["case keyword" ":k" "(case :x :x :k :default)"]) - -(defspec "control / logic" - ["and all true" "3" "(and 1 2 3)"] - ["and short circuits" "nil" "(and 1 nil 3)"] - ["and empty" "true" "(and)"] - ["or first truthy" "1" "(or nil 1 2)"] - ["or all false" "false" "(or nil false)"] - ["or empty" "nil" "(or)"] - ["not" "false" "(not true)"]) - -(defspec "control / let & loop" - ["let" "3" "(let [a 1 b 2] (+ a b))"] - ["let sequential" "3" "(let [a 1 b (+ a 2)] b)"] - ["let shadowing" "2" "(let [a 1] (let [a 2] a))"] - ["letfn mutual" "true" "(letfn [(ev? [n] (if (zero? n) true (od? (dec n)))) (od? [n] (if (zero? n) false (ev? (dec n))))] (ev? 10))"] - ["loop/recur" "15" "(loop [i 1 acc 0] (if (> i 5) acc (recur (inc i) (+ acc i))))"] - ["when-let" "2" "(when-let [x 1] (inc x))"] - ["when-let nil" "nil" "(when-let [x nil] (inc x))"] - ["if-let" "2" "(if-let [x 1] (inc x) :none)"] - ["if-let else" ":none" "(if-let [x nil] (inc x) :none)"] - ["if-some zero" "1" "(if-some [x 0] (inc x) :none)"] - ["when-some nil" "nil" "(when-some [x nil] x)"]) - -# Regression: if-let/when-let/if-some/when-some bind the name ONLY in the -# then/body branch. The else branch (and a falsy when-let body, which there is -# none of) must see the surrounding scope, not the binding — so the else of -# (let [x 5] (if-let [x nil] ...)) sees x=5, like Clojure. (Previously the macros -# wrapped the whole `if` in the binding's let*, leaking it into the else.) -(defspec "control / conditional-binding scope" - ["if-let else sees outer" "5" "(let [x 5] (if-let [x nil] :then x))"] - ["if-let then binds" "7" "(let [x 5] (if-let [x 7] x :else))"] - ["if-some else sees outer" "5" "(let [x 5] (if-some [x nil] :then x))"] - ["if-some binds false" "false" "(if-some [x false] x :else)"] - ["when-let else via or" "5" "(let [x 5] (or (when-let [x nil] x) x))"] - ["when-let multi-form body" "14" "(when-let [x 7] (inc x) (* x 2))"] - ["if-let in fn param" "9" "((fn [xs] (if-let [xs nil] :then xs)) 9)"] - ["when-some binds zero" "1" "(when-some [x 0] (inc x))"] - ["if-let evals test once" "1" "(let [c (atom 0)] (if-let [v (do (swap! c inc) :v)] @c :none))"]) - -# Regression: loop/recur lowering (jolt-v28u). The backend lowers tail loop/recur -# to a Janet while + state vars with a fresh per-iteration `let` rebinding of the -# loop names. The let rebinding is load-bearing: a closure created in the body -# must capture THAT iteration's value (Clojure semantics), not a shared mutable -# var — Janet closures capture vars by reference, so a naive while+var would give -# [3 3 3]. recur reads the (immutable) iteration bindings and writes the state -# vars, so cross-referencing args don't clobber (swap, fib). -(defspec "control / loop lowering (jolt-v28u)" - ["closure captures per-iter binding" "[0 1 2]" - "(mapv (fn [g] (g)) (loop [i 0 fs []] (if (< i 3) (recur (inc i) (conj fs (fn [] i))) fs)))"] - ["fib via loop" "55" "(loop [a 0 b 1 i 0] (if (= i 10) a (recur b (+ a b) (inc i))))"] - ["recur args no clobber" "[2 1]" "(loop [a 1 b 2 n 0] (if (= n 1) [a b] (recur b a (inc n))))"] - ["nested loops" "9" "(loop [i 0 s 0] (if (= i 3) s (recur (inc i) (loop [j 0 t s] (if (= j 3) t (recur (inc j) (inc t)))))))"] - ["loop sequential init" "12" "(loop [a 1 b (+ a 10)] (+ a b))"] - ["recur through let" "6" "(loop [i 0 acc 0] (let [x (* i 2)] (if (< i 3) (recur (inc i) (+ acc x)) acc)))"] - ["fn-arity recur intact" "15" "((fn f [n acc] (if (zero? n) acc (recur (dec n) (+ acc n)))) 5 0)"]) - -(defspec "control / iteration" - ["dotimes side-effect" "5" "(let [a (atom 0)] (dotimes [i 5] (swap! a inc)) @a)"] - ["while" "5" "(let [a (atom 0)] (while (< @a 5) (swap! a inc)) @a)"] - ["for" "[0 1 2]" "(for [x (range 3)] x)"] - ["for nested" "[[0 :a] [0 :b] [1 :a] [1 :b]]" "(for [x (range 2) y [:a :b]] [x y])"] - ["for :when" "[0 2 4]" "(for [x (range 6) :when (even? x)] x)"] - ["for :while" "[0 1 2]" "(for [x (range 10) :while (< x 3)] x)"] - ["for :let" "[0 1 4]" "(for [x (range 3) :let [sq (* x x)]] sq)"] - ["for :let+:when" "[4 6 8]" "(for [x (range 5) :let [y (* x 2)] :when (> y 3)] y)"] - ["for multi :when" "[[1 :a] [1 :b]]" "(for [x [0 1] :when (odd? x) y [:a :b]] [x y])"] - ["for destructure" "[3 7]" "(for [[a b] [[1 2] [3 4]]] (+ a b))"] - ["doseq side-effect" "6" "(let [a (atom 0)] (doseq [x [1 2 3]] (swap! a (fn [v] (+ v x)))) @a)"] - ["doseq nested" "4" "(let [c (atom 0)] (doseq [x [1 2] y [10 20]] (swap! c inc)) @c)"] - ["doseq :when" "[1 3]" "(let [a (atom [])] (doseq [x [1 2 3] :when (odd? x)] (swap! a conj x)) @a)"] - ["doseq :while" "6" "(let [a (atom 0)] (doseq [x (range 10) :while (< x 4)] (swap! a + x)) @a)"] - ["doseq :let" "[0 1 4]" "(let [a (atom [])] (doseq [x (range 3) :let [sq (* x x)]] (swap! a conj sq)) @a)"] - ["doseq returns nil" "nil" "(doseq [x [1 2 3]] x)"]) - -(defspec "control / threading" - ["->" "6" "(-> 1 inc (+ 4))"] - ["-> with forms" "[1 2 3]" "(-> [] (conj 1) (conj 2) (conj 3))"] - ["->>" "9" "(->> [1 2 3] (map inc) (reduce +))"] - ["as->" "2" "(as-> [0 1] x (map inc x) (reverse x) (first x))"] - ["some->" "2" "(some-> 1 inc)"] - ["some-> nil stops" "nil" "(some-> nil inc)"] - ["some->>" "[2 3]" "(some->> [1 2] (map inc))"] - ["cond->" "2" "(cond-> 1 true inc false inc)"] - ["cond->>" "[1 2]" "(cond->> [2] true (cons 1))"] - ["doto returns subject" "5" "(let [a (doto (atom 0) (reset! 5))] @a)"]) diff --git a/test/spec/core-async-spec.janet b/test/spec/core-async-spec.janet deleted file mode 100644 index dfaec9f..0000000 --- a/test/spec/core-async-spec.janet +++ /dev/null @@ -1,98 +0,0 @@ -# Specification: clojure.core.async on Janet fibers (Phase 1 — API layer). -# Each case is self-contained: it requires the ns, sets up channels/go blocks, -# and ends with a take that pumps the event loop and yields the value compared. -(use ../support/harness) - -(def REQ - "(require '[clojure.core.async :refer [go go-loop chan ! close! alts! timeout put! take! chan? buffer dropping-buffer sliding-buffer]]) ") -(defn- a [body] (string "(do " REQ body ")")) - -(defspec "core.async / go & channels" - ["go produce, ! c (+ 40 2))) ( channel closes" - "nil" (a "(! x 10)) (go (>! y 32)) (! c 1) (>! c 2) (>! c 3) (close! c)) (! c :a) (close! c)) (! to a closed channel is false" - "false" (a "(def c (chan 1)) (close! c) (>! c 1)")] - ["take from closed empty channel is nil" - "nil" (a "(def c (chan)) (close! c) (! in 1) (>! in 2) (>! in 3) (close! in)) (! mid (inc (! out (* 10 (! in 4)) (! y :v)) (! c 7)) (! c 1) (>! c 2) (>! c 3) (close! c))")] - ["filter transducer" - "[0 2 4]" (drain "(def c (chan 10 (filter even?))) (go (doseq [x (range 6)] (>! c x)) (close! c))")] - ["mapcat expands" - "[1 1 2 2]" (drain "(def c (chan 10 (mapcat (fn [x] [x x])))) (go (>! c 1) (>! c 2) (close! c))")] - ["take closes early" - "[:a :b]" (drain "(def c (chan 10 (take 2))) (go (>! c :a) (>! c :b) (>! c :c) (>! c :d) (close! c))")] - ["comp of transducers" - "[10 30 50]" (drain "(def c (chan 10 (comp (filter odd?) (map (fn [x] (* x 10)))))) (go (doseq [x (range 6)] (>! c x)) (close! c))")]) - -# Buffers: fixed (default), dropping (drops new when full), sliding (drops oldest -# when full). Filled synchronously on this fiber (dropping/sliding never park). -(defn- fill [bufexpr] - (string "(do " REQ "(def c (chan " bufexpr ")) (doseq [x [1 2 3 4 5]] (>! c x)) (close! c)" - " (Foo \"hi\")))"] - ["str uses the method" "\"hi\"" - "(do (deftype Foo [s] Object (toString [_] s)) (str (->Foo \"hi\")))"] - ["str concatenation uses it" "\"\"" - "(do (deftype Foo [s] Object (toString [_] s)) (str \"<\" (->Foo \"hi\") \">\"))"] - ["computed toString" "\"v=7\"" - "(do (deftype Boxed [v] Object (toString [_] (str \"v=\" v))) (str (->Boxed 7)))"] - # a record WITHOUT a custom toString keeps the #Type{...} repr (regression guard) - ["defrecord without toString keeps repr" "true" - "(do (defrecord Bar [x]) (boolean (re-find #\"Bar\" (str (->Bar 1)))))"] - # pr-str of a defrecord is unaffected (still the data repr) - ["pr-str of a defrecord is the repr" "true" - "(do (defrecord Baz [x]) (boolean (re-find #\"\\{\" (pr-str (->Baz 1)))))"]) diff --git a/test/spec/destructuring-spec.janet b/test/spec/destructuring-spec.janet deleted file mode 100644 index 91525dd..0000000 --- a/test/spec/destructuring-spec.janet +++ /dev/null @@ -1,79 +0,0 @@ -# Specification: destructuring (in let, fn, loop, doseq, for). -(use ../support/harness) - -(defspec "destructure / sequential" - ["basic vector" "3" "(let [[a b] [1 2]] (+ a b))"] - ["skip with _" "3" "(let [[_ b] [1 2]] (+ b 1))"] - ["rest with &" "[3 4]" "(let [[a & more] [1 3 4]] more)"] - [":as whole" "[1 2]" "(let [[a :as v] [1 2]] v)"] - ["nested" "3" "(let [[[a b]] [[1 2]]] (+ a b))"] - ["fewer values nil" "nil" "(let [[a b c] [1 2]] c)"] - ["over a list" "1" "(let [[a] (list 1 2)] a)"] - ["over a seq" "2" "(let [[a b] (rest [9 1 2])] b)"] - ["string chars" "\\a" "(let [[a] (seq \"ab\")] a)"]) - -(defspec "destructure / associative" - ["keys" "3" "(let [{:keys [a b]} {:a 1 :b 2}] (+ a b))"] - [":as map" "{:a 1}" "(let [{:as m} {:a 1}] m)"] - [":or default" "9" "(let [{:keys [a] :or {a 9}} {}] a)"] - [":or present" "1" "(let [{:keys [a] :or {a 9}} {:a 1}] a)"] - ["explicit binding" "1" "(let [{x :a} {:a 1}] x)"] - ["nested map" "2" "(let [{{b :b} :a} {:a {:b 2}}] b)"] - ["keys + as" "[1 {:a 1}]" "(let [{:keys [a] :as m} {:a 1}] [a m])"] - ["map in vector" "1" "(let [[{:keys [a]}] [{:a 1}]] a)"]) - -(defspec "destructure / in forms" - ["fn params" "3" "((fn [[a b]] (+ a b)) [1 2])"] - ["fn map param" "1" "((fn [{:keys [a]}] a) {:a 1})"] - ["defn destructure" "3" "(do (defn f [[a b]] (+ a b)) (f [1 2]))"] - ["loop destructure" "3" "(loop [[a b] [1 2]] (+ a b))"] - ["doseq destructure" "12" "(let [s (atom 0)] (doseq [[k v] {:a 4 :b 8}] (swap! s (fn [x] (+ x v)))) @s)"] - ["for destructure" "[3 7]" "(for [[a b] [[1 2] [3 4]]] (+ a b))"] - ["& rest in fn" "[2 3]" "((fn [a & more] more) 1 2 3)"]) - -(defspec "destructure / associative extras" - [":strs" "7" "(let [{:strs [a]} {\"a\" 7}] a)"] - [":syms" "8" "(let [{:syms [a]} {(quote a) 8}] a)"] - ["namespaced :keys" "3" "(let [{:keys [x/y]} {:x/y 3}] y)"] - ["namespaced :syms" "4" "(let [{:syms [p/q]} {(quote p/q) 4}] q)"] - # :keys also accepts keyword elements ({:keys [:a :b]}), binding bare locals. - ["keyword :keys" "3" "(let [{:keys [:a :b]} {:a 1 :b 2}] (+ a b))"] - ["keyword :keys ns" "3" "(let [{:keys [:x/y]} {:x/y 3}] y)"]) - -(defspec "destructure / keyword args (& {:keys})" - ["fn kwargs" "[1 2]" "(do (defn f [& {:keys [a b]}] [a b]) (f :a 1 :b 2))"] - ["fn kwargs + fixed" "[0 5]" "(do (defn g [x & {:keys [a]}] [x a]) (g 0 :a 5))"] - ["fn kwargs :or" "9" "(do (defn h [& {:keys [a] :or {a 9}}] a) (h))"] - ["fn kwargs trailing map" "7" "(do (defn k [& {:keys [a]}] a) (k {:a 7}))"]) - -(defspec "destructure / fn params & loop" - ["fn vector param" "7" "((fn [[a b]] (+ a b)) [3 4])"] - ["fn map param" "30" "((fn [{:keys [x y]}] (* x y)) {:x 5 :y 6})"] - ["fn :or param" "7" "((fn [{:keys [x] :or {x 7}}] x) {})"] - ["fn multi-arity destr" "15" "((fn ([[a]] a) ([[a] b] (+ a b))) [10] 5)"] - ["loop vector binding" "[4 2]" "(loop [[a b] [1 2] n 0] (if (< n 3) (recur [(inc a) b] (inc n)) [a b]))"] - ["loop map binding" "4" "(loop [{:keys [v]} {:v 1} n 0] (if (< n 2) (recur {:v (* v 2)} (inc n)) v))"] - ["loop init sees destr" "[1 2 3]" "(loop [[a b] [1 2] c (+ a b)] [a b c])"]) - -# fn*/let*/loop* are PRIMITIVES: their binding forms must be plain symbols, exactly -# as in Clojure ("fn params must be Symbols" / "Bad binding form, expected symbol"). -# Destructuring lives in the fn/let/loop/defn MACROS, which desugar to plain -# primitives — so the interpreter and the self-hosted analyzer agree (neither -# destructures fn*), and nothing silently falls back to a lenient interpreter path. -(defspec "destructure / primitives reject patterns (jolt-f79)" - ["fn* fixed pattern" :throws "((fn* [[a b]] a) [1 2])"] - ["fn* rest pattern" :throws "((fn* [a & [b]] b) 1 2 3)"] - ["let* pattern" :throws "(let* [[a b] [1 2]] a)"] - ["loop* pattern" :throws "(loop* [[a b] [1 2]] a)"] - # the macros still desugar the same patterns to plain primitives: - ["fn desugars" "[1 2]" "((fn [[a b]] [a b]) [1 2])"] - ["let desugars" "[1 2]" "(let [[a b] [1 2]] [a b])"]) - -(defspec "destructure / macro params" - ["macro & [a & more :as all]" - "[1 [2 3] [1 2 3]]" - "(do (defmacro m [& [a & more :as all]] (list (quote quote) [a (vec more) (vec all)])) (m 1 2 3))"] - ["macro fixed destructure" "[2 1]" - "(do (defmacro mm [[a b]] (list (quote quote) [b a])) (mm [1 2]))"] - ["macro & {:keys}" "5" - "(do (defmacro mk [& {:keys [x]}] (list (quote quote) x)) (mk :x 5))"]) diff --git a/test/spec/exceptions-spec.janet b/test/spec/exceptions-spec.janet deleted file mode 100644 index d7a3a60..0000000 --- a/test/spec/exceptions-spec.janet +++ /dev/null @@ -1,46 +0,0 @@ -# Specification: exceptions — try/catch/finally, throw, ex-info. -(use ../support/harness) - -(defspec "exceptions / try-catch" - ["catch :default" ":caught" - "(try (throw (ex-info \"boom\" {})) (catch :default e :caught))"] - ["catch by class" ":caught" - "(try (throw (ex-info \"boom\" {})) (catch Exception e :caught))"] - ["catch binds error" "\"boom\"" - "(try (throw (ex-info \"boom\" {})) (catch :default e (ex-message e)))"] - ["no throw -> body" "1" - "(try 1 (catch :default e :caught))"] - ["finally runs on ok" "2" - "(let [a (atom 0)] (try 2 (finally (reset! a 9))) )"] - ["finally runs on throw" "9" - "(let [a (atom 0)] (try (throw (ex-info \"x\" {})) (catch :default e nil) (finally (reset! a 9))) @a)"] - ["catch value of body" "5" - "(try (+ 2 3) (catch :default e 0))"] - # a malformed catch clause (binding not a symbol, or clause too short) is a - # clean error, not a silent nil or an internal crash (jolt-kg6p). - ["malformed catch: non-symbol binding" :throws "(try 1 (catch e (* e 10)))"] - ["malformed catch: literal binding" :throws "(try 1 (catch e 5))"] - ["malformed catch: too short" :throws "(try 1 (catch Exception))"]) - -(defspec "exceptions / assert" - ["assert true -> ok" ":ok" "(do (assert true) :ok)"] - ["assert expr -> ok" ":ok" "(do (assert (= 1 1)) :ok)"] - ["assert false throws" :throws "(assert false)"] - ["assert nil throws" :throws "(assert nil)"]) - -(defspec "exceptions / ex-info" - ["ex-message" "\"oops\"" "(ex-message (ex-info \"oops\" {}))"] - ["ex-data" "{:k 1}" "(ex-data (ex-info \"oops\" {:k 1}))"] - ["ex-data via catch" "{:code 42}" - "(try (throw (ex-info \"e\" {:code 42})) (catch :default e (ex-data e)))"] - ["ex-cause" "true" - "(let [c (ex-info \"root\" {})] (= c (ex-cause (ex-info \"outer\" {} c))))"] - ["propagates to outer" "\"inner\"" - "(try (try (throw (ex-info \"inner\" {})) (finally nil)) (catch :default e (ex-message e)))"] - ["catch binds thrown value" "42" - "(try (throw 42) (catch :default e e))"] - ["rethrow preserves ex" "\"inner\"" - "(try (try (throw (ex-info \"inner\" {})) (catch :default e (throw e))) (catch :default e (ex-message e)))"] - ["ex-data on non-ex" "nil" "(ex-data 42)"] - ["ex-cause on non-ex" "nil" "(ex-cause {:k 1})"] - ["ex-message of string" "nil" "(ex-message \"hi\")"]) diff --git a/test/spec/forms-spec.janet b/test/spec/forms-spec.janet deleted file mode 100644 index dab5fb8..0000000 --- a/test/spec/forms-spec.janet +++ /dev/null @@ -1,92 +0,0 @@ -# Specification: core special forms (case/fn/let/letfn/loop/if/do/def/call). -# -# Adapted from the jank test corpus (compiler+runtime/test/jank/form/**, /call) — -# we base our coverage on jank's to close gaps, but maintain our own copies since -# jank may diverge. jank-isms are translated to Jolt/Clojure: letfn* -> letfn, -# (catch jank.runtime.object_ref …) -> (catch :default …). Platform-specific cases -# (bigdecimal M, biginteger, ratios, unicode char edges) are intentionally omitted. -# -# Multi-form jank files (def + asserts, ending in :success) are wrapped in a single -# (do … :success) so they run as one expression and assert :success. -(use ../support/harness) - -(defspec "forms / case" - ["bool" ":yes" "(case true true :yes false :no :default)"] - ["keyword match" ":b" "(case :a :x :wrong :a :b :default)"] - ["number match" ":two" "(case 2 1 :one 2 :two :default)"] - ["string match" ":hit" "(case \"x\" \"y\" :miss \"x\" :hit :default)"] - ["nil match" ":nada" "(case nil nil :nada :default)"] - ["default" ":def" "(case 99 1 :one 2 :two :def)"] - ["list of consts" ":vowel" "(case \\a (\\a \\e \\i \\o \\u) :vowel :consonant)"] - ["no match no default" :throws "(case 5 1 :one)"] - ["duplicate keys" :throws "(case 1 1 :one 1 :dup :default)"] - ["duplicate in or-group" :throws "(case 2 (1 2) :a (2 3) :b :default)"]) - -(defspec "forms / fn" - ["named fn nil" "nil" "((fn* foo-bar []))"] - ["immediate call" "1" "((fn* [] 1))"] - ["args" "[:a :b]" "((fn* [a b] [a b]) :a :b)"] - ["multi-arity 0" "0" "(do (def add (fn* ([] 0) ([a] a) ([a b] (+ a b)))) (add))"] - ["multi-arity 1" "-500" "(do (def add (fn* ([] 0) ([a] a) ([a b] (+ a b)))) (add -500))"] - ["multi-arity 2" "-450" "(do (def add (fn* ([] 0) ([a] a) ([a b] (+ a b)))) (add -500 50))"] - ["variadic rest" "[3 4]" "(do (def v (fn* ([a b & args] args) ([] 0))) (v 1 2 3 4))"] - ["variadic empty" "0" "(do (def v (fn* ([a b & args] args) ([] 0))) (v))"] - ["variadic collect" "[{} nil :m]" "((fn* [a b & args] args) 'w 't {} nil :m)"] - ["closure capture" "8" "(do (def adder (fn* [n] (fn* [x] (+ x n)))) ((adder 5) 3))"] - ["recur countdown" "0" "(do (def cd (fn* [n] (if (< 0 n) (recur (+ n -1)) n))) (cd 10))"] - ["named self-recur" "120" "(do (def f (fn* fact [n] (if (= n 0) 1 (* n (fact (dec n)))))) (f 5))"] - ["no param vector" :throws "(fn* foo)"] - ["non-symbol param" :throws "(fn* [1] 1)"]) - -(defspec "forms / let" - ["literal" "1" "(let* [a 1] a)"] - ["multiple" "[1 2]" "(let* [a 1 b 2] [a b])"] - ["previous ref" ":bee" "(let* [a 1 b (if (= 1 a) :bee :uh-oh)] b)"] - ["nested let" "3" "(let* [a 5 b (let* [c -2] (+ a c))] b)"] - ["fn value bound" "\":foo\"" "(let* [kw->str (fn* [kw] (str kw))] (kw->str :foo))"] - ["shadowing" "2" "(let* [a 1 a 2] a)"]) - -(defspec "forms / letfn" - ["mutual top" "[1 2]" "(letfn [(a [] 1) (b [] 2)] [(a) (b)])"] - ["mutual recursion" ":done" "(letfn [(ev? [n] (if (= 0 n) :done (od? (dec n)))) (od? [n] (ev? n))] (ev? 4))"] - ["nested letfn" "3" "(letfn [(a [] 5) (b [] (letfn [(c [] -2)] (+ (a) (c))))] (b))"]) - -(defspec "forms / loop" - ["sum" "55" "(loop* [sum 0 cnt 10] (if (= cnt 0) sum (recur (+ cnt sum) (dec cnt))))"] - ["multi binding" "[4 2]" "(loop* [a 1 b 2 n 0] (if (< n 3) (recur (inc a) b (inc n)) [a b]))"] - ["init sees prior" "[1 2 3]" "(loop* [a 1 b (+ a 1) c (+ b 1)] [a b c])"]) - -(defspec "forms / try" - ["immediate throw caught" ":caught" "(try (throw :boom) (catch :default e :caught))"] - ["first throw wins" "\"a\"" "(try (throw (ex-info \"a\" {})) (throw (ex-info \"b\" {})) (catch :default e (ex-message e)))"] - ["catch ex-data" "7" "(try (throw (ex-info \"e\" {:v 7})) (catch :default e (:v (ex-data e))))"] - ["finally runs" "9" "(let [a (atom 0)] (try 1 (finally (reset! a 9))) @a)"] - ["body value w/ finally" "1" "(try 1 (finally 2))"] - ["catch value w/ finally" ":h" "(try (throw (ex-info \"x\" {})) (catch :default e :h) (finally :ignored))"] - ["no throw skips catch" "5" "(try 5 (catch :default e :nope))"]) - -(defspec "forms / if-do-def-call" - ["if truthy vec" ":fine" "(if [:ok] :fine :no)"] - ["if truthy str" ":fine" "(if \"good?\" :fine :no)"] - ["if nil = false" ":else" "(if nil :then :else)"] - ["if no else" "nil" "(if false 1)"] - ["do nested" "1" "(do (do (do (do 1))))"] - ["do returns last" "3" "(do 1 2 3)"] - ["def + deref var" "true" "(var? (def one 1))"] - ["def no init interns var" "true" "(var? (def no-init))"] - ["def no init keeps existing root" "7" "(do (def kept 7) (def kept) kept)"] - ["declare interns var" "true" "(do (declare fwd-declared) (var? (var fwd-declared)))"] - ["def redefine" "100" "(do (def one 1) (def one 100) one)"] - ["def in fn mutates" "[:default :meow]" "(do (def a :default) (def set-a (fn* [v] (def a v))) (let* [before a] (set-a :meow) [before a]))"] - ["call literal fn" "1" "((fn* [] 1))"] - ["call nested" "6" "(+ ((fn* [] 1)) ((fn* [] 2)) ((fn* [] 3)))"] - ["call nil" :throws "(nil)"]) - -# if takes two or three argument forms — anything else is a compile-time -# error (spec 03-special-forms X1). -(defspec "forms / if arity (X1)" - ["bare if throws" :throws "(if)"] - ["one-arg if throws" :throws "(if true)"] - ["four-arg if throws" :throws "(if true 1 2 3)"] - ["two-arg if ok" "nil" "(if false 1)"] - ["three-arg if ok" "2" "(if false 1 2)"]) diff --git a/test/spec/functions-spec.janet b/test/spec/functions-spec.janet deleted file mode 100644 index 89fb841..0000000 --- a/test/spec/functions-spec.janet +++ /dev/null @@ -1,223 +0,0 @@ -# Specification: functions & higher-order combinators. -(use ../support/harness) - -(defspec "functions / definition" - ["fn literal" "3" "((fn [a b] (+ a b)) 1 2)"] - ["fn shorthand" "3" "(#(+ %1 %2) 1 2)"] - ["fn shorthand %" "2" "(#(inc %) 1)"] - ["defn" "5" "(do (defn f [x] (+ x 2)) (f 3))"] - ["multi-arity" "[1 5]" "(do (defn f ([x] x) ([x y] (+ x y))) [(f 1) (f 2 3)])"] - ["variadic" "[1 2 3]" "(do (defn f [& xs] xs) (f 1 2 3))"] - ["variadic with fixed" "[1 [2 3]]" "(do (defn f [a & xs] [a xs]) (f 1 2 3))"] - ["closure captures" "8" "(do (defn adder [n] (fn [x] (+ x n))) ((adder 5) 3))"] - ["recursion" "120" "(do (defn fact [n] (if (< n 2) 1 (* n (fact (dec n))))) (fact 5))"] - ["named fn self-ref" "120" "((fn fact [n] (if (< n 2) 1 (* n (fact (dec n))))) 5)"] - # A param whose name collides with a Janet builtin the back end emits in - # generated code (here `in`, used to deref vars / index shape-recs) must not - # shadow it — malli's explainer binds `[value in acc]` (jolt-fjb1). - ["param named `in`" "1" "((fn [in] (first in)) [1 2 3])"] - ["param `in` via core fn" "3" "((fn [in] (count in)) [1 2 3])"] - ["local `in` in let body" "2" "(let [in [2 3]] (first in))"]) - -(defspec "functions / application" - ["apply" "6" "(apply + [1 2 3])"] - ["apply with leading" "10" "(apply + 1 2 [3 4])"] - ["apply keyword" "1" "(apply :a [{:a 1}])"] - ["partial" "7" "((partial + 5) 2)"] - ["partial multi" "10" "((partial + 1 2) 3 4)"] - ["comp" "4" "((comp inc inc) 2)"] - ["comp order" "5" "((comp inc (fn [x] (* x 2))) 2)"] - ["comp identity" "3" "((comp) 3)"] - ["complement" "true" "((complement even?) 3)"] - ["constantly" "5" "((constantly 5) 1 2 3)"] - ["identity" "7" "(identity 7)"]) - -(defspec "functions / combinators" - ["juxt" "[1 3]" "((juxt first last) [1 2 3])"] - ["fnil" "1" "((fnil inc 0) nil)"] - ["fnil passes value" "6" "((fnil inc 0) 5)"] - ["every-pred true" "true" "((every-pred pos? even?) 4)"] - ["every-pred false" "false" "((every-pred pos? even?) 3)"] - ["some-fn" "true" "((some-fn even? neg?) 3 4)"] - ["memoize" "2" "(do (def c (atom 0)) (def f (memoize (fn [x] (swap! c inc) x))) (f 1) (f 1) (f 2) @c)"] - ["trampoline" "10" "(trampoline (fn f [n acc] (if (zero? n) acc (fn [] (f (dec n) (+ acc 2))))) 5 0)"]) - -# Phase 2 leaf batch (jolt-ded): moved from the Janet seed to 20-coll.clj. -(defspec "clojure.core / leaf batch (complement fnil munge etc.)" - ["complement true" "true" "((complement pos?) -1)"] - ["complement false" "false" "((complement pos?) 1)"] - ["complement multi" "true" "((complement <) 3 2)"] - ["fnil patches nil" "1" "((fnil inc 0) nil)"] - ["fnil passes non-nil" "6" "((fnil inc 0) 5)"] - ["fnil two defaults" "8" "((fnil + 1 2) nil nil 5)"] - ["fnil only first 3" "[:a :b :c nil]" "((fnil vector :a :b :c) nil nil nil nil)"] - ["fnil in update" "{:k 1}" "(update {} :k (fnil inc 0))"] - ["clojure-version" "true" "(string? (clojure-version))"] - ["bigdec" "3" "(bigdec 3)"] - ["numerator throws" :throws "(numerator 1)"] - ["denominator throws" :throws "(denominator 1)"] - ["supers empty set" "#{}" "(supers 1)"] - ["munge dashes" "\"a_b\"" "(munge \"a-b\")"] - ["munge symbol" "(quote x_y)" "(munge (quote x-y))"] - ["test no-test" ":no-test" "(test (quote foo))"]) - -# Phase 2 leaf batch 2 (jolt-ded): canonical ports of key/val/select-keys/ -# zipmap/merge/merge-with/get-in/memoize/partial/trampoline/some?/true?/false?/ -# max/min/reverse, plus find (previously missing entirely). -(defspec "clojure.core / leaf batch 2" - ["key" "1" "(key (first {1 :a}))"] - ["val" ":a" "(val (first {1 :a}))"] - ["key non-entry throws" :throws "(key 5)"] - ["find hit" "[:a 1]" "(find {:a 1} :a)"] - ["find miss" "nil" "(find {:a 1} :b)"] - ["find nil value" "[:a nil]" "(find {:a nil} :a)"] - ["find on vector" "[0 :x]" "(find [:x :y] 0)"] - ["select-keys" "{:a 1}" "(select-keys {:a 1 :b 2} [:a])"] - ["select-keys nil val" "{:a nil}" "(select-keys {:a nil :b 2} [:a])"] - ["select-keys missing" "{}" "(select-keys {:a 1} [:z])"] - ["zipmap" "{:a 1 :b 2}" "(zipmap [:a :b] [1 2])"] - ["zipmap uneven" "{:a 1}" "(zipmap [:a :b] [1])"] - ["zipmap nil val" "{:a nil}" "(zipmap [:a] [nil])"] - ["merge" "{:a 1 :b 2}" "(merge {:a 1} {:b 2})"] - ["merge later wins" "{:a 2}" "(merge {:a 1} {:a 2})"] - ["merge nil arg" "{:a 1}" "(merge {:a 1} nil)"] - ["merge nil first" "{:a 1}" "(merge nil {:a 1})"] - ["merge all nil" "nil" "(merge nil nil)"] - ["merge empty" "nil" "(merge)"] - ["merge entry pair" "{:a 1 :b 2}" "(merge {:a 1} [:b 2])"] - ["merge-with" "{:a 3}" "(merge-with + {:a 1} {:a 2})"] - ["merge-with disjoint" "{:a 1 :b 2}" "(merge-with + {:a 1} {:b 2})"] - ["merge-with nil-val present" "{:a 1}" "(merge-with (fn [a b] (or a b)) {:a nil} {:a 1})"] - ["get-in" "1" "(get-in {:a {:b 1}} [:a :b])"] - ["get-in missing" ":nf" "(get-in {:a 1} [:z :y] :nf)"] - ["get-in nil value present" "nil" "(get-in {:a {:b nil}} [:a :b] :nf)"] - ["get-in empty path" "{:a 1}" "(get-in {:a 1} [])"] - ["memoize" "2" "(do (def c (atom 0)) (def f (memoize (fn [x] (swap! c inc) x))) (f 1) (f 1) (f 2) (deref c))"] - ["memoize caches nil" "1" "(do (def c (atom 0)) (def f (memoize (fn [x] (swap! c inc) nil))) (f 1) (f 1) (deref c))"] - ["partial" "6" "((partial + 1 2) 3)"] - ["partial no extra" "3" "((partial + 1 2))"] - ["partial many fixed" "15" "((partial + 1 2 3 4) 5)"] - ["trampoline" "10" "(trampoline (fn f [n acc] (if (zero? n) acc (fn [] (f (dec n) (+ acc 2))))) 5 0)"] - ["some? true" "true" "(some? 0)"] - ["some? false" "false" "(some? nil)"] - ["true?/false?" "[true false false]" "[(true? true) (true? 1) (false? nil)]"] - ["max" "3" "(max 1 3 2)"] - ["min" "1" "(min 3 1 2)"] - ["max single" "5" "(max 5)"] - ["max non-number throws" :throws "(max 1 :a)"] - ["reverse" "(quote (3 2 1))" "(reverse [1 2 3])"] - ["reverse empty" "()" "(reverse nil)"] - ["conj nil onto map" "{:a 1}" "(conj {:a 1} nil)"]) - -# Phase 2 leaf batch 3 (jolt-ded): empty/assoc-in/update-in (20-coll) and -# interpose/take-nth (40-lazy, with canonical transducer arities). keys/vals/ -# empty? are expander-coupled (00-syntax macros call them) and stay in the -# seed until the fast macro-expansion path lands. -(defspec "clojure.core / leaf batch 3" - ["empty vector" "[]" "(empty [1 2])"] - ["empty list" "()" "(empty (list 1))"] - ["empty map" "{}" "(empty {:a 1})"] - ["empty set" "#{}" "(empty #{1})"] - ["empty nil" "nil" "(empty nil)"] - ["empty string" "nil" "(empty \"abc\")"] - ["empty lazy is ()" "()" "(empty (map inc [1 2]))"] - ["empty sorted keeps cmp" "[3 1]" "(vec (seq (into (empty (sorted-set-by > 1 2)) [1 3])))"] - ["assoc-in" "{:a {:b 1}}" "(assoc-in {} [:a :b] 1)"] - ["assoc-in deep" "{:a {:b {:c 2}}}" "(assoc-in {:a {:b {:c 1}}} [:a :b :c] 2)"] - ["assoc-in keeps siblings" "{:a {:b 1 :c 2}}" "(assoc-in {:a {:b 1}} [:a :c] 2)"] - ["assoc-in vector idx" "[1 9]" "(assoc-in [1 2] [1] 9)"] - ["assoc-in nested vec" "[{:a 9}]" "(assoc-in [{:a 1}] [0 :a] 9)"] - ["update-in" "{:a {:b 2}}" "(update-in {:a {:b 1}} [:a :b] inc)"] - ["update-in extra args" "{:a {:b 111}}" "(update-in {:a {:b 1}} [:a :b] + 10 100)"] - ["update-in fnil" "{:a {:b 1}}" "(update-in {} [:a :b] (fnil inc 0))"] - ["update-in single key" "{:a 2}" "(update-in {:a 1} [:a] inc)"] - ["interpose" "(quote (1 :s 2 :s 3))" "(interpose :s [1 2 3])"] - ["interpose empty" "()" "(interpose :s [])"] - ["interpose one" "(quote (1))" "(interpose :s [1])"] - ["interpose is lazy" "(quote (0 :s 1))" "(take 3 (interpose :s (range)))"] - ["interpose xform" "[\"a\" \",\" \"b\"]" "(vec (sequence (interpose \",\") [\"a\" \"b\"]))"] - ["take-nth" "(quote (1 3 5))" "(take-nth 2 [1 2 3 4 5 6])"] - ["take-nth lazy" "(quote (0 3 6))" "(take 3 (take-nth 3 (range)))"] - ["take-nth xform" "[1 3 5]" "(vec (sequence (take-nth 2) [1 2 3 4 5 6]))"] - ["take-nth into" "[1 4]" "(into [] (take-nth 3) [1 2 3 4 5])"]) - -# Phase 2 leaf batch 4 (jolt-ded): sort-by (canonical: compare-defaulted, over -# the host sort seam), rand-int (canonical truncation via int), pure -# Fisher-Yates shuffle, random-uuid over parse-uuid, char tables as -# char-keyed Clojure maps. rand and sort stay: they ARE the host seams. -(defspec "clojure.core / leaf batch 4" - ["sort-by keyfn" "[[1 :b] [2 :a]]" "(sort-by first [[2 :a] [1 :b]])"] - ["sort-by string keys" "(quote (\"a\" \"bb\" \"ccc\"))" "(sort-by count [\"ccc\" \"a\" \"bb\"])"] - ["sort-by comparator" "[3 2 1]" "(sort-by identity > [1 3 2])"] - ["sort-by 3way cmp" "[3 2 1]" "(sort-by identity (fn [a b] (- b a)) [1 3 2])"] - ["sort-by mixed nil" "[nil 1 2]" "(sort-by identity [2 nil 1])"] - ["sort-by empty" "()" "(sort-by first [])"] - ["sort-by nil coll" "()" "(sort-by first nil)"] - ["rand-int range" "true" "(every? (fn [_] (let [r (rand-int 5)] (and (int? r) (<= 0 r 4)))) (range 50))"] - ["rand-int zero" "0" "(rand-int 1)"] - ["shuffle is permutation" "true" "(= (sort (shuffle [5 3 1 4 2])) [1 2 3 4 5])"] - ["shuffle returns vector" "true" "(vector? (shuffle [1 2 3]))"] - ["shuffle empty" "[]" "(shuffle [])"] - ["shuffle non-coll throws" :throws "(shuffle 5)"] - ["random-uuid is uuid" "true" "(uuid? (random-uuid))"] - ["random-uuid v4 shape" "true" "(boolean (re-matches #\"[0-9a-f]{8}-[0-9a-f]{4}-4[0-9a-f]{3}-[89ab][0-9a-f]{3}-[0-9a-f]{12}\" (str (random-uuid))))"] - ["random-uuid distinct" "true" "(not= (random-uuid) (random-uuid))"] - ["char-escape newline" "\"\\\\n\"" "(char-escape-string \\newline)"] - ["char-escape quote" "true" "(= 2 (count (char-escape-string \\\")))"] - ["char-escape none" "nil" "(char-escape-string \\a)"] - ["char-name space" "\"space\"" "(char-name-string \\space)"] - ["char-name newline" "\"newline\"" "(char-name-string \\newline)"] - ["char-name none" "nil" "(char-name-string \\a)"]) - -# recur into a VARIADIC fn arity binds the LAST recur arg directly as the -# rest seq (Clojure: recur to a variadic head takes n-fixed + 1 args, no -# re-collection). The interpreter used to re-enter through the varargs -# collector, wrapping the seq in a fresh 1-element rest list — xs never -# emptied and the loop hung (jolt-4df). -(defspec "functions / recur into variadic arity" - ["counts rest via recur" "3" - "((fn cnt [acc & xs] (if (seq xs) (recur (inc acc) (rest xs)) acc)) 0 :a :b :c)"] - ["zero-fixed variadic" "4" - "((fn f [& xs] (if (< (count xs) 4) (recur (cons :x xs)) (count xs))) :a)"] - ["rest empties to nil" "(quote (:done))" - "((fn f [& xs] (if xs (recur (next xs)) (list :done))) 1 2)"] - ["multi-arity variadic recur" "6" - "((fn ma ([a] a) ([a & xs] (if (seq xs) (recur (+ a (first xs)) (rest xs)) a))) 1 2 3)"] - ["recur passes nil rest" ":empty" - "((fn f [acc & xs] (if (seq xs) (recur acc (rest xs)) :empty)) 0 1)"] - ["fixed-arity recur untouched" "10" - "((fn f [n acc] (if (pos? n) (recur (dec n) (+ acc 2)) acc)) 5 0)"]) - -# An EMPTY rest arg binds nil, never () — Clojure semantics. (f) with [& r] -# giving a truthy () sent yogthos/config's (or (.exists f) required) down the -# wrong branch and broke its load. -(defspec "functions / empty rest arg is nil" - ["no args" ":nil" "((fn [& r] (if r :truthy :nil)))"] - ["after fixed" ":nil" "((fn [a & r] (if r :truthy :nil)) 1)"] - ["via apply" ":nil" "(apply (fn [& r] (if r :truthy :nil)) [])"] - ["defn no args" ":nil" "(do (defn er-f [& r] (if r :truthy :nil)) (er-f))"] - ["non-empty unchanged" "'(1 2)" "((fn [& r] r) 1 2)"] - ["one extra" "'(2)" "((fn [a & r] r) 1 2)"] - ["rest destructure with no args" ":nil" - "((fn [& [a]] (if a :truthy :nil)))"]) - -# Arity enforcement (jolt-6xn): fixed arities throw on any mismatch, variadic -# arities on fewer than the fixed params — Clojure's ArityException, in both -# the interpreter and the compiled path. -(defspec "functions / arity enforcement" - ["fixed extra args" :throws "((fn [x] x) 1 2)"] - ["fixed missing args" :throws "((fn [x y] x) 1)"] - ["fixed zero of one" :throws "((fn [x] x))"] - ["named defn extra" :throws "(do (defn af1 [x] x) (af1 1 2))"] - ["overlay fn extra" :throws "(identity 1 2)"] - ["through apply" :throws "(apply (fn [x] x) [1 2])"] - ["through update" :throws "(update {:k 1} :k identity 1 2 3 4)"] - ["variadic below min" :throws "((fn [x & r] x))"] - ["variadic at min" "nil" "((fn [x & r] r) 1)"] - ["variadic above min" "(quote (2 3))" "((fn [x & r] r) 1 2 3)"] - ["multi-arity no match" :throws "((fn ([x] x) ([x y] y)) 1 2 3)"] - ["multi-arity variadic below min" :throws "((fn ([x] x) ([x y & r] r)))"] - ["destructured param counts as one" "3" "((fn [[a b] c] c) [1 2] 3)"] - ["destructured extra throws" :throws "((fn [[a b]] a) [1 2] [3 4])"] - ["hof exact arity ok" "[2 4]" "(mapv (fn [x] (* 2 x)) [1 2])"] - ["zero-arity fn ok" "7" "((fn [] 7))"]) diff --git a/test/spec/futures-spec.janet b/test/spec/futures-spec.janet deleted file mode 100644 index 82e5996..0000000 --- a/test/spec/futures-spec.janet +++ /dev/null @@ -1,64 +0,0 @@ -# Specification: clojure.core futures on Janet OS threads (ev/thread). -# -# A `future` runs its body on a *real* OS thread (ev/thread), so it can use a -# second core for CPU-bound work — unlike the cooperatively-scheduled go blocks. -# Because Janet threads have separate heaps, the body and its captured state are -# MARSHALLED (copied) to the worker thread and the result is marshalled back: a -# future sees a snapshot of captured state and communicates only via its return -# value (mutations to captured atoms do NOT propagate back). `deref`/`@` blocks -# (parks) until the worker finishes; the result is cached for later derefs. -(use ../support/harness) - -(defspec "clojure.core / futures — deref" - ["future + deref" "3" "(deref (future (+ 1 2)))"] - ["@ reader macro derefs" "42" "@(future (* 6 7))"] - ["future returns collection" "[2 3 4]" "(deref (future (mapv inc [1 2 3])))"] - ["future returns a map" "{:a 1}" "(deref (future {:a 1}))"] - ["deref is cached/idempotent" "[2 2]" "(let [f (future (+ 1 1))] [(deref f) (deref f)])"] - ["timed deref of ready future" "42" "(let [f (future 42)] (deref f) (deref f 1000 :nope))"] - ["body error re-raised on deref" :throws "(deref (future (throw \"boom\")))"] - # Thread/sleep parks the WORKER's own event loop (each future thread has one), - # so a sleeping future doesn't block the parent — and timed deref can fire. - ["timed deref times out" ":timed-out" "(deref (future (do (Thread/sleep 300) :late)) 10 :timed-out)"] - ["Thread/sleep in body" ":slept" "(deref (future (do (Thread/sleep 5) :slept)))"] - ["timed-out future still completes" ":late" - "(let [f (future (do (Thread/sleep 30) :late))] (deref f 5 :early) (deref f))"]) - -(defspec "clojure.core / futures — predicates" - ["future? true" "true" "(future? (future 1))"] - ["future? false" "false" "(future? 42)"] - ["future-done? after deref" "true" "(let [f (future 1)] (deref f) (future-done? f))"] - ["realized? after deref" "true" "(let [f (future 1)] (deref f) (realized? f))"] - # Cancel marks the future done (the worker can't be interrupted, but the - # future object reflects the cancellation: deref raises, predicates flip). - ["cancel an in-flight future returns true" "true" - "(let [f (future 1)] (future-cancel f))"] - ["future-cancelled? after cancel" "true" - "(let [f (future 1)] (future-cancel f) (future-cancelled? f))"] - ["future-done? after cancel" "true" - "(let [f (future 1)] (future-cancel f) (future-done? f))"] - ["cancel an already-completed future returns false" "false" - "(let [f (future 1)] (deref f) (future-cancel f))"] - ["future-cancelled? fresh is false" "false" - "(future-cancelled? (future 1))"]) - -(defspec "clojure.core / futures — snapshot (copy) semantics" - # The worker thread swaps its *copy* of the atom; the parent's atom is untouched. - ["captured atom is snapshotted, not shared" - "0" "(let [a (atom 0)] (deref (future (swap! a inc))) @a)"] - # The future's own return value still reflects the swap on its copy. - ["future sees its own mutation" - "1" "(let [a (atom 0)] (deref (future (swap! a inc))))"]) - -# pmap/pcalls/pvalues over the real-thread futures: spawn-all-then-deref, so -# independent work overlaps; snapshot semantics (pure fns only). The wall-time -# row uses generous margins (4 x 150ms in parallel vs 600ms serial). -(defspec "clojure.core / pmap family" - ["pmap values in order" "[2 3 4]" "(vec (pmap inc [1 2 3]))"] - ["pmap multi-coll" "[5 7 9]" "(vec (pmap + [1 2 3] [4 5 6]))"] - ["pmap empty" "()" "(pmap inc [])"] - ["pmap is parallel" "true" - "(do (deref (future :warmup)) (let [t0 (System/currentTimeMillis)] (dorun (pmap (fn [_] (Thread/sleep 200)) [1 2 3 4])) (< (- (System/currentTimeMillis) t0) 700)))"] - ["pcalls" "[1 2]" "(vec (pcalls (fn [] 1) (fn [] 2)))"] - ["pvalues" "[3 7]" "(vec (pvalues (+ 1 2) (+ 3 4)))"] - ["snapshot semantics" "0" "(let [a (atom 0)] (dorun (pmap (fn [_] (swap! a inc)) [1 2])) (deref a))"]) diff --git a/test/spec/hierarchy-spec.janet b/test/spec/hierarchy-spec.janet deleted file mode 100644 index e6de89a..0000000 --- a/test/spec/hierarchy-spec.janet +++ /dev/null @@ -1,48 +0,0 @@ -# Specification: ad-hoc hierarchies (make-hierarchy/derive/underive/isa?/ -# parents/ancestors/descendants) — ported to pure Clojure (stage 3). The -# 3-arity forms are PURE (derive returns a new hierarchy); the 1/2-arity forms -# use the global hierarchy. Multi-parent derive, transitive ancestors AND -# descendants, and vector-pair isa? match Clojure (the old Janet kernel had -# single-parent :parents and direct-only descendants). -(use ../support/harness) - -(defspec "hierarchy / pure 3-arity" - ["derive returns new h" "true" - "(let [h (derive (make-hierarchy) :rect :shape)] (and (map? h) (isa? h :rect :shape)))"] - ["original unchanged" "false" - "(let [h0 (make-hierarchy) h1 (derive h0 :rect :shape)] (isa? h0 :rect :shape))"] - ["isa? self" "true" "(isa? (make-hierarchy) :a :a)"] - ["isa? transitive" "true" - "(let [h (-> (make-hierarchy) (derive :square :rect) (derive :rect :shape))] (isa? h :square :shape))"] - ["multi-parent" "[true true]" - "(let [h (-> (make-hierarchy) (derive :sq :rect) (derive :sq :rhombus))] [(isa? h :sq :rect) (isa? h :sq :rhombus)])"] - ["parents set" "true" - "(let [h (-> (make-hierarchy) (derive :sq :rect) (derive :sq :rhombus))] (= #{:rect :rhombus} (parents h :sq)))"] - ["ancestors transitive" "true" - "(let [h (-> (make-hierarchy) (derive :square :rect) (derive :rect :shape))] (= #{:rect :shape} (ancestors h :square)))"] - ["descendants transitive" "true" - "(let [h (-> (make-hierarchy) (derive :square :rect) (derive :rect :shape))] (= #{:rect :square} (descendants h :shape)))"] - ["underive removes" "false" - "(let [h (-> (make-hierarchy) (derive :a :b) (underive :a :b))] (isa? h :a :b))"] - ["vector isa?" "true" - "(let [h (-> (make-hierarchy) (derive :rect :shape))] (isa? h [:rect :rect] [:shape :shape]))"] - ["vector isa? length" "false" - "(isa? (make-hierarchy) [:a] [:a :a])"] - ["cyclic derive throws" :throws - "(-> (make-hierarchy) (derive :a :b) (derive :b :a))"] - ["duplicate derive ok" "true" - "(let [h (-> (make-hierarchy) (derive :a :b) (derive :a :b))] (isa? h :a :b))"] - ["parents nil when none" "nil" "(parents (make-hierarchy) :x)"]) - -(defspec "hierarchy / global + multimethod dispatch" - ["global derive + isa?" "true" "(do (derive :gsq :grect) (isa? :gsq :grect))"] - ["global ancestors" "true" - "(do (derive :ga :gb) (derive :gb :gc) (contains? (ancestors :ga) :gc))"] - ["global underive" "false" - "(do (derive :gu :gv) (underive :gu :gv) (isa? :gu :gv))"] - ["dispatch via hierarchy" ":is-shape" - "(do (derive :hsq :hshape) (defmulti hmm identity) (defmethod hmm :hshape [_] :is-shape) (hmm :hsq))"] - ["dispatch custom hierarchy" ":parent" - "(do (def hh (atom (derive (make-hierarchy) :c :p))) (defmulti cmm identity :hierarchy hh) (defmethod cmm :p [_] :parent) (cmm :c))"] - ["dispatch exact beats isa" ":exact" - "(do (derive :de1 :de2) (defmulti emm identity) (defmethod emm :de2 [_] :parent) (defmethod emm :de1 [_] :exact) (emm :de1))"]) diff --git a/test/spec/host-interop-spec.janet b/test/spec/host-interop-spec.janet deleted file mode 100644 index 17e1b55..0000000 --- a/test/spec/host-interop-spec.janet +++ /dev/null @@ -1,314 +0,0 @@ -# Specification: host (Janet) interop — the `.` forms and jolt.interop. -(use ../support/harness) - -(defspec "interop / dot forms" - ["method call" "\"v=41\"" - "(. {:value 41 :describe (fn [self] (str \"v=\" (:value self)))} describe)"] - ["method with args" "\"Hello Alice\"" - "(. {:greet (fn [self n] (str \"Hello \" n))} greet \"Alice\")"] - ["field access .-" "41" "(.-value {:value 41})"] - ["dot field keyword" "41" "(. {:value 41} :value)"]) - -# Both `.` arms share one dispatch-member helper (jolt-eos3). These rows lock the -# behaviors where the call form (args) and the bare form (zero-arg) diverge in -# their tails: zero-arg coll-interop vs with-arg coll-interop, and record/deftype -# zero-arg methods vs methods-with-args vs `-field` field access. -(defspec "interop / dot dispatch arms" - ["zero-arg coll-interop .count" "3" "(.count [1 2 3])"] - ["zero-arg coll-interop .seq" "[1 2]" "(.seq [1 2])"] - ["explicit dot zero-arg interop" "3" "(. [1 2 3] count)"] - ["with-arg coll-interop .nth" "2" "(.nth [1 2 3] 1)"] - ["record zero-arg method" "10" - "(do (defprotocol Pd (gm [this])) (defrecord Rd [x] Pd (gm [this] (* 2 x))) (.gm (->Rd 5)))"] - ["record method with args" "15" - "(do (defprotocol Pa (am [this y])) (defrecord Ra [x] Pa (am [this y] (+ x y))) (.am (->Ra 5) 10))"] - ["deftype method with args" "7" - "(do (defprotocol Pq (qq [this y])) (deftype Tq [x] Pq (qq [this y] (+ x y))) (.qq (Tq. 3) 4))"] - ["record -field is field access" "7" - "(do (defrecord Rf [x]) (.-x (->Rf 7)))"] - ["object-method with args .equals" "true" "(.equals \"a\" \"a\")"]) - -# The `janet` namespace segment is the explicit Janet-stdlib bridge added for -# the networking layer (and used by jolt.nrepl). `janet/` resolves a Janet -# root binding; `janet./` resolves a module binding. The boundary -# is explicit so it's visible where host semantics take over. -(defspec "interop / janet bridge" - ["root builtin janet/" "\"123\"" "(janet/string 1 2 3)"] - ["root builtin janet/type" ":string" "(janet/type \"x\")"] - ["module fn janet./" "4" "(janet.math/sqrt 16)"] - ["janet.string module fn" "\"HI\"" "(janet.string/ascii-upper \"hi\")"] - ["janet.os/clock is a number" "true" "(number? (janet.os/clock))"] - # crossing the boundary uses Janet representations: a Jolt vector is a table - ["jolt vector crosses as a janet table" ":table" "(janet/type [1 2])"] - # interop is explicit-only: an unprefixed Janet module is not auto-exposed - ["unprefixed janet module not exposed" :throws "net/server"] - ["unknown janet symbol throws" :throws "(janet.os/definitely-not-a-real-fn)"]) - -(defspec "interop / jolt.interop" - ["janet-type quoted list" ":array" "(do (require (quote [jolt.interop :as j])) (j/janet-type (quote (1 2))))"] - ["janet-type list" ":array" "(do (require (quote [jolt.interop :as j])) (j/janet-type (list 1 2)))"] - ["janet-type string" ":string" "(do (require (quote [jolt.interop :as j])) (j/janet-type \"x\"))"] - ["janet-type number" ":number" "(do (require (quote [jolt.interop :as j])) (j/janet-type 1))"] - ["janet-type keyword" ":keyword" "(do (require (quote [jolt.interop :as j])) (j/janet-type :a))"]) - -(defspec "interop / arrays (aget/aset/alength)" - ["alength" "3" "(alength (object-array [1 2 3]))"] - ["aget" "20" "(aget (object-array [10 20 30]) 1)"] - ["aset returns val" "9" "(aset (object-array [1 2 3]) 1 9)"] - ["aset mutates" "[7 2 3]" "(let [a (object-array [1 2 3])] (aset a 0 7) (vec a))"] - ["aget 2d" "4" "(aget (to-array-2d [[1 2] [3 4]]) 1 1)"]) - -# java.lang.String surface + .method sugar (clj-compat: what portable cljc -# libraries call — landed for the cuerdas acceptance run). ASCII case mapping. -(defspec "interop / String methods" - [".toLowerCase" "\"hi\"" "(.toLowerCase \"HI\")"] - [".toUpperCase" "\"HI\"" "(.toUpperCase \"hi\")"] - ["dot-form" "\"hi\"" "(. \"HI\" toLowerCase)"] - [".trim" "\"x\"" "(.trim \" x \")"] - [".length" "3" "(.length \"abc\")"] - [".isEmpty" "[true false]" "[(.isEmpty \"\") (.isEmpty \"a\")]"] - [".indexOf hit" "1" "(.indexOf \"abc\" \"b\")"] - [".indexOf miss is -1" "-1" "(.indexOf \"abc\" \"z\")"] - [".lastIndexOf" "3" "(.lastIndexOf \"abab\" \"b\")"] - [".substring" "\"bc\"" "(.substring \"abc\" 1)"] - [".substring end" "\"b\"" "(.substring \"abc\" 1 2)"] - [".startsWith" "true" "(.startsWith \"abc\" \"ab\")"] - [".endsWith" "true" "(.endsWith \"abc\" \"bc\")"] - [".contains" "true" "(.contains \"abc\" \"b\")"] - [".replace" "\"axc\"" "(.replace \"abc\" \"b\" \"x\")"] - [".charAt" "\\b" "(.charAt \"abc\" 1)"] - [".equalsIgnoreCase" "true" "(.equalsIgnoreCase \"AbC\" \"aBc\")"] - ["Long/MAX_VALUE" "true" "(pos? Long/MAX_VALUE)"] - # String/valueOf static (jolt-nkx): hiccup stringifies attribute values with it. - ["String/valueOf num" "\"42\"" "(String/valueOf 42)"] - ["String/valueOf str" "\"hi\"" "(String/valueOf \"hi\")"] - ["String/valueOf kw" "\":k\"" "(String/valueOf :k)"] - ["String/valueOf nil" "\"null\"" "(String/valueOf nil)"] - # String implements CharSequence (malli's :re gates on it, jolt-ltwk). - ["instance? CharSequence" "true" "(instance? CharSequence \"aaa\")"] - ["instance? CharSequence non-str" "false" "(instance? CharSequence 42)"] - ["unsupported method throws" :throws "(.frobnicate \"abc\")"]) - -# java.time shims (jolt-ea7): epoch-ms backed values + a DateTimeFormatter -# pattern subset — the surface Selmer's date filters drive. Formatting uses -# the HOST's local timezone, so rows assert structure, not wall-clock values. -(defspec "interop / java.time shims" - ["ofPattern formats #inst" "true" - "(string? (.format (DateTimeFormatter/ofPattern \"yyyy-MM-dd\") #inst \"2020-03-05T13:45:30Z\"))"] - ["pattern shape" "true" - "(boolean (re-matches #\"\\d{4}-\\d{2}-\\d{2}\" (.format (DateTimeFormatter/ofPattern \"yyyy-MM-dd\") #inst \"2020-03-05T13:45:30Z\")))"] - ["month name + ampm" "true" - "(boolean (re-matches #\"[A-Z][a-z]{2} \\d{1,2}, 2020 \\d{1,2}:\\d{2} [AP]M\" (.format (DateTimeFormatter/ofPattern \"MMM d, yyyy h:mm a\") #inst \"2020-03-05T13:45:30Z\")))"] - ["quoted literal" "true" - "(boolean (re-matches #\"\\d{4}-\\d{2}-\\d{2}T\\d{2}:\\d{2}:\\d{2}\" (.format DateTimeFormatter/ISO_LOCAL_DATE_TIME #inst \"2020-03-05T13:45:30Z\")))"] - ["localized style" "true" - "(string? (.format (DateTimeFormatter/ofLocalizedDate FormatStyle/MEDIUM) #inst \"2020-03-05T13:45:30Z\"))"] - ["withLocale chain" "true" - "(string? (.format (.withLocale (DateTimeFormatter/ofPattern \"yyyy\") (java.util.Locale. \"en\")) #inst \"2020-01-01T00:00:00Z\"))"] - ["fix-date chain" "true" - "(instance? LocalDateTime (-> #inst \"2020-03-05T13:45:30Z\" (.toInstant) (.atZone (ZoneId/systemDefault)) (.toLocalDateTime)))"] - ["inst is java.util.Date" "true" "(instance? java.util.Date #inst \"2020-01-01T00:00:00Z\")"] - ["Instant instance" "true" "(instance? java.time.Instant (Instant/ofEpochMilli 0))"] - ["getTime epoch ms" "0" "(.getTime #inst \"1970-01-01T00:00:00Z\")"] - ["toEpochMilli round trip" "1234" "(.toEpochMilli (Instant/ofEpochMilli 1234))"] - ["Instant/now is current" "true" "(> (.toEpochMilli (Instant/now)) 1500000000000)"] - ["sql types are not" "false" "(instance? java.sql.Timestamp #inst \"2020-01-01T00:00:00Z\")"]) - -# java.io / java.lang shims that carry Selmer's char-by-char template reader. -(defspec "interop / StringReader & StringBuilder" - ["StringReader read" "[97 98 -1]" - "(let [r (java.io.StringReader. \"ab\")] [(.read r) (.read r) (.read r)])"] - ["mark/reset" "[97 97]" - "(let [r (StringReader. \"ab\")] (.mark r 1) [(.read r) (do (.reset r) (.read r))])"] - ["StringBuilder append" "\"ab1\"" - "(.toString (-> (StringBuilder.) (.append \"a\") (.append \\b) (.append 1)))"] - ["capacity arg is not content" "\"x\"" - "(.toString (.append (StringBuilder. 16) \"x\"))"] - ["setLength truncates" "\"ab\"" - "(let [sb (StringBuilder.)] (.append sb \"abcd\") (.setLength sb 2) (.toString sb))"] - ["char-array of string" "true" - "(instance? (Class/forName \"[C\") (char-array \"ab\"))"] - ["reader over char[]" "97" - "(do (require (quote clojure.java.io)) (.read (clojure.java.io/reader (char-array \"abc\"))))"] - ["line-seq over file reader" "[\"a\" \"b\"]" - "(do (require (quote clojure.java.io)) (janet/spit \"/tmp/jolt-lineseq-spec.txt\" \"a\\nb\\n\") (vec (line-seq (clojure.java.io/reader \"/tmp/jolt-lineseq-spec.txt\"))))"] - ["with-open closes shim" "97" - "(with-open [r (StringReader. \"a\")] (.read r))"] - ["File.toURL methods read it back" "\"file:/tmp/x\"" - "(do (require (quote clojure.java.io)) (.toString (.toURL (clojure.java.io/file \"/tmp/x\"))))"] - ["vector :import shares deftype ctor" "\"hi!\"" - "(do (ns spec.nodea) (defprotocol SpecP (spec-pm [this])) (deftype SpecTN [t] SpecP (spec-pm [this] (str t \"!\"))) (ns spec.nodeb (:import [spec.nodea SpecTN])) (.spec-pm (SpecTN. \"hi\")))"]) - -# Shims for yogthos/config: PushbackReader, numeric/boolean parse statics, -# System/getenv + getProperties as iterable maps, edn/read from a reader. -(defspec "interop / PushbackReader & parse statics" - ["PushbackReader read" "[97 98]" - "(let [r (java.io.PushbackReader. (java.io.StringReader. \"ab\"))] [(.read r) (.read r)])"] - ["unread pushes back" "[97 97 98]" - "(let [r (PushbackReader. (StringReader. \"ab\")) a (.read r)] (.unread r a) [a (.read r) (.read r)])"] - ["unread accepts a char" "[120 97]" - "(let [r (PushbackReader. (StringReader. \"a\"))] (.unread r \\x) [(.read r) (.read r)])"] - ["edn/read from reader" "5432" - "(do (require (quote clojure.edn)) (clojure.edn/read (java.io.PushbackReader. (java.io.StringReader. \"{:db {:port 5432}}\\nrest\"))) (get-in (clojure.edn/read-string \"{:db {:port 5432}}\") [:db :port]))"] - ["edn/read multi-line" "true" - "(do (require (quote clojure.edn)) (= {:a 1 :b 2} (clojure.edn/read (PushbackReader. (StringReader. \"{:a 1\\n :b 2}\")))))"] - ["Long/parseLong" "42" "(Long/parseLong \"42\")"] - ["parseLong rejects non-numeric" :throws "(Long/parseLong \"4x\")"] - ["BigInteger." "123" "(BigInteger. \"123\")"] - ["Boolean/parseBoolean" "[true false false]" - "[(Boolean/parseBoolean \"true\") (Boolean/parseBoolean \"false\") (Boolean/parseBoolean \"yes\")]"] - ["System/getenv is a map" "true" - "(string? (get (System/getenv) \"HOME\"))"] - # registered, so (System/exit n) resolves; actual exit verified via subprocess - ["System/exit resolves" "true" "(fn? System/exit)"] - # NOT every? alone — it held vacuously while seq over a raw host table - # yielded nothing, hiding that read-system-env came back empty - ["getenv entries destructure (non-empty)" "true" - "(let [es (map (fn [[k v]] [k v]) (System/getenv))] (and (pos? (count es)) (every? vector? es)))"] - ["seq over a raw host table" "true" - "(pos? (count (seq (System/getenv))))"] - ["into {} from host table" "true" - "(string? (get (into {} (map (fn [[k v]] [k v]) (System/getenv))) \"HOME\"))"] - ["System/getProperties" "true" - "(string? (get (System/getProperties) \"os.name\"))"]) - -# ring-core enablement (host shims + protocol/reduce fixes): the java.net / -# java.util surface ring.util.codec needs, extend-protocol on Map and nil, -# and reduce over a reified clojure.lang.IReduceInit. -(defspec "host-interop / ring-codec surface" - ["URLEncoder www form" "\"a+b%3Dc\"" "(URLEncoder/encode \"a b=c\")"] - ["URLDecoder www form" "\"a b=c\"" "(URLDecoder/decode \"a+b%3Dc\" (Charset/forName \"UTF-8\"))"] - ["url round trip" "\"x &=%?\"" "(URLDecoder/decode (URLEncoder/encode \"x &=%?\"))"] - ["Base64 encode" "\"aGVsbG8=\"" "(String. (.encode (Base64/getEncoder) (.getBytes \"hello\")))"] - ["Base64 round trip" "\"hello\"" "(String. (.decode (Base64/getDecoder) (String. (.encode (Base64/getEncoder) (.getBytes \"hello\")))))"] - ["Integer radix + byteValue" "-1" "(.byteValue (Integer/valueOf \"ff\" 16))"] - ["Integer parseInt" "255" "(Integer/parseInt \"ff\" 16)"] - ["StringTokenizer" "[\"a=1\" \"b=2\"]" "(let [t (StringTokenizer. \"a=1&b=2\" \"&\")] [(.nextToken t) (.nextToken t)])"] - ["MapEntry key/val" "[:a 1]" "(let [e (MapEntry. :a 1)] [(key e) (val e)])"] - ["String ctor from bytes" "\"hi\"" "(String. (.getBytes \"hi\"))"] - ["extend-protocol Map" ":map" - "(do (defprotocol Pe (pe [x])) (extend-protocol Pe Map (pe [m] :map) Object (pe [o] :obj)) (pe {:a 1}))"] - ["extend-protocol nil" ":nil" - "(do (defprotocol Pn (pn [x])) (extend-protocol Pn nil (pn [n] :nil) Object (pn [o] :obj)) (pn nil))"] - ["extend-protocol Map covers sorted" ":map" - "(do (defprotocol Ps (ps [x])) (extend-protocol Ps Map (ps [m] :map) Object (ps [o] :obj)) (ps (sorted-map 1 2)))"] - ["reduce over reified IReduceInit" "42" - "(reduce + 0 (reify clojure.lang.IReduceInit (reduce [_ f init] (f (f init 40) 2))))"]) - -# ring-core enablement, part 2: class-name symbols evaluate to canonical -# class-name strings (so class-dispatch defmultis match), ctor sugar still -# constructs, type-hinted param vectors parse, slurp drains reader shims, -# str/replace takes fn replacements, and int needles are char codes. -(defspec "host-interop / class tokens & readers" - ["class name evaluates to canonical string" "\"java.lang.String\"" "String"] - ["dispatch-only class name" "\"java.io.InputStream\"" "InputStream"] - ["(class x) matches the token" "true" "(= String (class \"abc\"))"] - ["defmulti on class dispatches" ":str" - "(do (defmulti cm (fn [x] (class x))) (defmethod cm String [x] :str) (cm \"a\"))"] - ["defmethod on nil dispatch value" ":nil" - "(do (defmulti cn (fn [x] (class x))) (defmethod cn nil [x] :nil) (defmethod cn String [x] :str) (cn nil))"] - ["ctor sugar still constructs" "\"x\"" "(.toString (StringBuilder. \"x\"))"] - ["return-hinted defn parses" "7" "(do (defn- hb ^bytes [b] b) (hb 7))"] - ["hinted multi-arity parses" ":two" "((fn ([x] :one) (^String [x y] :two)) 1 2)"] - ["slurp drains a StringReader" "\"a=1\"" "(slurp (StringReader. \"a=1\"))"] - ["slurp accepts :encoding opts" "\"b\"" "(slurp (StringReader. \"b\") :encoding \"UTF-8\")"] - ["replace with fn replacement is literal" "\"$0\"" - "(do (require (quote [clojure.string :as s9])) (s9/replace \"x\" #\".\" (fn [m] \"$0\")))"] - ["replace fn gets group vector" "\"v=k\"" - "(do (require (quote [clojure.string :as s9])) (s9/replace \"k=v\" #\"(\\w+)=(\\w+)\" (fn [[_ k v]] (str v \"=\" k))))"] - ["indexOf int needle is a char code" "1" "(.indexOf \"a=b\" 61)"]) - -# JOLT_BAKE_ENV_ALLOWLIST (jolt-s3j): with the allowlist set, System/getenv -# serves only the listed names — so an image bake can't marshal the builder's -# secrets into the binary. Unset, reads are live and unfiltered. -(defspec "host-interop / bake env scrub" - ["unlisted name reads nil under the allowlist" "nil" - "(do (janet.os/setenv \"JOLT_BAKE_ENV_ALLOWLIST\" \"PATH\") (let [r (System/getenv \"HOME\")] (janet.os/setenv \"JOLT_BAKE_ENV_ALLOWLIST\" nil) r))"] - ["listed name still reads" "true" - "(do (janet.os/setenv \"JOLT_BAKE_ENV_ALLOWLIST\" \"HOME\") (let [r (System/getenv \"HOME\")] (janet.os/setenv \"JOLT_BAKE_ENV_ALLOWLIST\" nil) (string? r)))"] - ["full snapshot filtered to the allowlist" "true" - "(do (janet.os/setenv \"JOLT_BAKE_ENV_ALLOWLIST\" \"HOME\") (let [e (System/getenv)] (janet.os/setenv \"JOLT_BAKE_ENV_ALLOWLIST\" nil) (and (contains? (set (keys e)) \"HOME\") (= 1 (count (keys e))))))"] - ["no allowlist: unfiltered live reads" "true" - "(string? (System/getenv \"HOME\"))"]) - -# Host-class shim registration exposed to Clojure (reitit.Trie mirror, etc.): -# statics resolve as (Class/method ...), ctors as (Class. ...), and registered -# tag methods dispatch. Also: .getMessage on an exception/string, HashMap. -(defspec "host-interop / exception + HashMap shims" - ["getMessage on a thrown string" "\"boom\"" - "(try (throw \"boom\") (catch Throwable e (.getMessage e)))"] - ["getMessage on ex-info" "\"bad\"" - "(try (throw (ex-info \"bad\" {})) (catch Throwable e (.getMessage e)))"] - ["HashMap get" "2" - "(let [m (HashMap. {:a 1 :b 2})] (.get m :b))"] - ["HashMap put + size" "2" - "(let [m (HashMap. {})] (.put m :x 1) (.put m :y 2) (.size m))"]) - -# Reader-feature toggle exposed to Clojure (scoped clj-lib loading): a -# namespace can load a clj-targeted library under :clj without forcing the -# whole process — set features, require, restore. -(defspec "host-interop / reader-feature toggle" - ["features default to jolt+default" "true" - "(contains? (set (__reader-features)) \"jolt\")"] - ["set + read back" "true" - "(do (def prev (__reader-features)) (__reader-features-set! [\"clj\" \"jolt\" \"default\"]) (def r (contains? (set (__reader-features)) \"clj\")) (__reader-features-set! prev) r)"] - ["restore returns to default" "false" - "(do (def prev (__reader-features)) (__reader-features-set! [\"clj\"]) (__reader-features-set! prev) (contains? (set (__reader-features)) \"clj\"))"]) - -# JVM class shims migratus relies on. Exception constructors resolve as bare -# class symbols (jolt-6xk) and carry a message; Character/Thread/Long statics; -# java.sql.Timestamp is the millis number; SimpleDateFormat formats UTC. -(defspec "host-interop / migratus class shims" - ["Exception. message" "\"boom\"" - "(try (throw (Exception. \"boom\")) (catch Throwable e (.getMessage e)))"] - ["IllegalArgumentException." "\"bad\"" - "(try (throw (IllegalArgumentException. \"bad\")) (catch Exception e (.getMessage e)))"] - ["InterruptedException." "\"stop\"" - "(try (throw (InterruptedException. \"stop\")) (catch Throwable e (.getMessage e)))"] - ["Character/isUpperCase" "true" "(Character/isUpperCase \\A)"] - ["Character/isLowerCase" "true" "(Character/isLowerCase \\a)"] - ["Character/isUpperCase neg" "false" "(Character/isUpperCase \\a)"] - ["Thread/interrupted" "false" "(Thread/interrupted)"] - ["Long/valueOf" "42" "(Long/valueOf \"42\")"] - ["Timestamp is millis" "1000" "(.getTime (java.util.Date. (java.sql.Timestamp. 1000)))"] - ["SimpleDateFormat UTC" "\"19700101000000\"" - "(let [f (doto (java.text.SimpleDateFormat. \"yyyyMMddHHmmss\") (.setTimeZone (java.util.TimeZone/getTimeZone \"UTC\")))] (.format f (java.util.Date. 0)))"]) - -# java.io.File model (jolt-hjw): io/file builds a value that answers -# (instance? File _) so migratus's File-vs-jar branch takes the filesystem path; -# the method surface and a File-aware file-seq back it; str/slurp coerce to path. -(defspec "host-interop / java.io.File" - ["instance? File" "true" "(do (require '[clojure.java.io :as io]) (instance? java.io.File (io/file \"/a/b\")))"] - ["str is the path" "\"/a/b\"" "(do (require '[clojure.java.io :as io]) (str (io/file \"/a/b\")))"] - ["getName" "\"c.txt\"" "(do (require '[clojure.java.io :as io]) (.getName (io/file \"/a/b/c.txt\")))"] - ["getPath joins" "\"/a/b\"" "(do (require '[clojure.java.io :as io]) (.getPath (io/file \"/a\" \"b\")))"] - ["isDirectory of repo dir" "true" "(do (require '[clojure.java.io :as io]) (.isDirectory (io/file \"docs\")))"] - ["isFile of repo file" "true" "(do (require '[clojure.java.io :as io]) (.isFile (io/file \"project.janet\")))"] - ["exists is false off-disk" "false" "(do (require '[clojure.java.io :as io]) (.exists (io/file \"/no/such/path/xyz\")))"] - ["file-seq yields File values" "true" - "(do (require '[clojure.java.io :as io]) (every? (fn [f] (instance? java.io.File f)) (file-seq (io/file \"docs\"))))"] - ["file-seq finds files" "true" - "(do (require '[clojure.java.io :as io]) (pos? (count (filter (fn [f] (.isFile f)) (file-seq (io/file \"docs\"))))))"]) - -# Host shims that let libraries like clojure.tools.logging load: no STM (a -# transaction is never running) and a minimal clojure.pprint (used by spy). -(defspec "host-interop / logging host shims" - ["LockingTransaction/isRunning" "false" "(clojure.lang.LockingTransaction/isRunning)"] - ["pprint writes value" "\"[1 2 3]\\n\"" - "(do (require '[clojure.pprint :as pp]) (with-out-str (pp/pprint [1 2 3])))"] - ["with-pprint-dispatch runs body" "42" - "(do (require '[clojure.pprint :as pp]) (pp/with-pprint-dispatch pp/code-dispatch 42))"]) - -# Language capabilities that real-world macros like clojure.tools.logging exercise: -# multi-arity defmacro dispatch, conditional-eval macros (short-circuit like -# debug), and macros that eval+print+return (like spy). Self-contained — no -# external library needed. -(defspec "host-interop / macro dispatch & short-circuit patterns" - ["conditional-eval suppresses" "0" - "(do (def ^:dynamic *enabled* false) (defmacro when-on [& body] `(when *enabled* ~@body)) (let [a (atom 0)] (when-on (reset! a 9)) @a))"] - ["conditional-eval fires" "9" - "(do (def ^:dynamic *enabled* true) (defmacro when-on [& body] `(when *enabled* ~@body)) (let [a (atom 0)] (when-on (reset! a 9)) @a))"] - ["spy-like eval+print+return" "3" - "(do (defmacro spylog [expr] `(let [v# ~expr] (println v#) v#)) (spylog (+ 1 2)))"] - ["multi-arity 4 dispatch" "[:single :double :triple :quad]" - "(do (defmacro ml ([a] :single) ([a b] :double) ([a b c] :triple) ([a b c d] :quad)) [(ml 1) (ml 1 2) (ml 1 2 3) (ml 1 2 3 4)])"]) diff --git a/test/spec/inst-spec.janet b/test/spec/inst-spec.janet deleted file mode 100644 index 8edddd3..0000000 --- a/test/spec/inst-spec.janet +++ /dev/null @@ -1,30 +0,0 @@ -# Specification: #inst literals — instants as values (spec 02-reader S20). -# An instant is an immutable tagged struct {:jolt/type :jolt/inst :ms }: -# value equality by instant (offset-normalized), usable as map keys. -# The reader accepts RFC3339 with Clojure's partial-timestamp defaults -# (#inst "2020" == #inst "2020-01-01T00:00:00.000-00:00"). -(use ../support/harness) - -(defspec "inst / reading & identity" - ["reads to inst" "true" "(inst? #inst \"2020-01-01T00:00:00Z\")"] - ["inst? false on string" "false" "(inst? \"2020-01-01\")"] - ["epoch zero" "0" "(inst-ms #inst \"1970-01-01T00:00:00Z\")"] - ["one second" "1000" "(inst-ms #inst \"1970-01-01T00:00:01Z\")"] - ["millis" "123" "(inst-ms #inst \"1970-01-01T00:00:00.123Z\")"] - ["a real date" "1577836800000" "(inst-ms #inst \"2020-01-01T00:00:00Z\")"] - ["inst-ms throws on non-inst" :throws "(inst-ms 42)"]) - -(defspec "inst / partial timestamps & offsets" - ["year only" "true" "(= #inst \"2020\" #inst \"2020-01-01T00:00:00.000Z\")"] - ["year-month" "true" "(= #inst \"2020-03\" #inst \"2020-03-01T00:00:00Z\")"] - ["date only" "true" "(= #inst \"2020-03-15\" #inst \"2020-03-15T00:00:00Z\")"] - ["positive offset" "true" "(= #inst \"2020-01-01T01:00:00+01:00\" #inst \"2020-01-01T00:00:00Z\")"] - ["negative offset" "true" "(= #inst \"2019-12-31T23:00:00-01:00\" #inst \"2020-01-01T00:00:00Z\")"] - ["-00:00 offset" "true" "(= #inst \"2020-01-01T00:00:00-00:00\" #inst \"2020-01-01T00:00:00Z\")"] - ["bad timestamp throws" :throws "#inst \"garbage\""]) - -(defspec "inst / value semantics & printing" - ["equal by instant" "true" "(= #inst \"2020-01-01T00:00:00Z\" #inst \"2020-01-01T00:00:00.000Z\")"] - ["unequal instants" "false" "(= #inst \"2020-01-01T00:00:00Z\" #inst \"2020-01-01T00:00:01Z\")"] - ["works as map key" ":v" "(get {#inst \"2020-01-01T00:00:00Z\" :v} #inst \"2020-01-01T00:00:00.000Z\")"] - ["pr-str round-trips" "\"#inst \\\"2020-01-01T00:00:00.000-00:00\\\"\"" "(pr-str #inst \"2020-01-01T00:00:00Z\")"]) diff --git a/test/spec/io-spec.janet b/test/spec/io-spec.janet deleted file mode 100644 index 1f5e203..0000000 --- a/test/spec/io-spec.janet +++ /dev/null @@ -1,114 +0,0 @@ -# Specification: printing / output (print/println/pr/prn, *-str, format, str). -# Output is captured with with-out-str (jolt-rfw); the *-str fns return strings. -(use ../support/harness) - -(defspec "io / with-out-str captures" - ["println" "\"hi\\n\"" "(with-out-str (println \"hi\"))"] - ["print spaces" "\"a b\"" "(with-out-str (print \"a\" \"b\"))"] - ["prn quotes" "\"[1 2]\\n\"" "(with-out-str (prn [1 2]))"] - ["pr no newline" "\"5\"" "(with-out-str (pr 5))"] - ["multiple writes" "\"12\"" "(with-out-str (print 1) (print 2))"] - ["no output" "\"\"" "(with-out-str 42)"] - ["println no args" "\"\\n\"" "(with-out-str (println))"]) - -(defspec "io / *-str builders" - ["print-str" "\"a b\"" "(print-str \"a\" \"b\")"] - ["println-str" "\"x\\n\"" "(println-str \"x\")"] - ["prn-str" "\"[1 2]\\n\"" "(prn-str [1 2])"] - ["pr-str quotes" "\"\\\"s\\\"\"" "(pr-str \"s\")"] - ["pr-str keyword" "\":a\"" "(pr-str :a)"]) - -(defspec "io / str & format" - ["str concat" "\"1:ab\"" "(str 1 :a \"b\")"] - ["str nil" "\"\"" "(str nil)"] - ["str of coll" "\"[1 2]\"" "(str [1 2])"] - ["format d/s" "\"5-x\"" "(format \"%d-%s\" 5 \"x\")"] - ["format float" "\"3.14\"" "(format \"%.2f\" 3.14159)"]) - -# The *in* reader family (jolt-0d9): *in* is a dynamic var holding a reader; -# with-in-str rebinds it to a string reader over one shared buffer, so read -# (consumes exactly one form) and read-line (rest of that line) interleave -# correctly, as in Clojure. -(defspec "io / *in* + with-in-str + read-line" - ["read-line one line" "\"hello\"" "(with-in-str \"hello\" (read-line))"] - ["read-line strips nl" "\"a\"" "(with-in-str \"a\\nb\" (read-line))"] - ["read-line sequential" "[\"a\" \"b\"]" "(with-in-str \"a\\nb\" [(read-line) (read-line)])"] - ["read-line EOF nil" "nil" "(with-in-str \"\" (read-line))"] - ["read-line after last" "[\"x\" nil]" "(with-in-str \"x\" [(read-line) (read-line)])"] - ["empty line" "[\"\" \"y\"]" "(with-in-str \"\\ny\" [(read-line) (read-line)])"] - ["*in* is bound" "true" "(with-in-str \"\" (map? *in*))"]) - -(defspec "io / read" - ["read a form" "42" "(with-in-str \"42\" (read))"] - ["read a list form" "(quote (+ 1 2))" "(with-in-str \"(+ 1 2)\" (read))"] - ["read two forms" "[1 2]" "(with-in-str \"1 2\" [(read) (read)])"] - ["read then read-line" "[1 \" rest\"]" "(with-in-str \"1 rest\\nnext\" [(read) (read-line)])"] - ["read vector" "[1 2]" "(with-in-str \"[1 2]\" (read))"] - ["read nil literal" "nil" "(with-in-str \"nil\" (read))"] - ["read EOF throws" :throws "(with-in-str \"\" (read))"] - ["read EOF value" ":done" "(with-in-str \"\" (read *in* false :done))"] - ["read eval data" "3" "(with-in-str \"(+ 1 2)\" (eval (read)))"]) - -(defspec "io / line-seq" - ["line-seq" "[\"a\" \"b\" \"c\"]" "(with-in-str \"a\\nb\\nc\" (vec (line-seq *in*)))"] - ["line-seq empty" "nil" "(with-in-str \"\" (seq (line-seq *in*)))"] - ["line-seq is lazy seq" "true" "(with-in-str \"a\\nb\" (seq? (line-seq *in*)))"] - ["line-seq count" "3" "(with-in-str \"1\\n2\\n3\" (count (line-seq *in*)))"]) - -# The print family is overlay now (seed-shrink round 6), over the __write / -# __pr-str1 host seams: pr is readable, print is str semantics, *-ln appends. -(defspec "io / print family (overlay)" - ["pr-str multi-arg spacing" "\"\\\"a\\\" [1 2] :k\"" "(pr-str \"a\" [1 2] :k)"] - ["pr-str zero args" "\"\"" "(pr-str)"] - ["pr-str escapes" "\"\\\"a\\\\\\\"b\\\"\"" "(pr-str \"a\\\"b\")"] - ["print is unreadable" "\"a b\"" "(with-out-str (print \"a\" \"b\"))"] - ["println appends newline" "\"x 1\\n\"" "(with-out-str (println \"x\" 1))"] - ["prn is readable + newline" "\"[1 \\\"s\\\"]\\n\"" "(with-out-str (prn [1 \"s\"]))"] - ["pr writes no newline" "\"\\\\a\"" "(with-out-str (pr \\a))"] - ["print nil arg" "\"nil\"" "(with-out-str (print nil))"] - ["prn keyword" "\":k\\n\"" "(with-out-str (prn :k))"]) - -# print-method is a real multimethod (jolt-g1r): canonical dispatch on -# (:type meta) keyword else (type x); records print as #ns.Type{...} by -# default, and a user (defmethod print-method 'ns.Type ...) overrides record -# rendering everywhere — top level AND nested, through pr/prn/pr-str — via -# the host renderer's callback. Builtin overrides apply only on direct -# print-method calls (documented divergence; pr keeps the native fast path). -(defspec "io / print-method multimethod" - ["records print canonically" "\"#user.Pt{:x 1, :y 2}\"" - "(do (defrecord Pt [x y]) (pr-str (->Pt 1 2)))"] - ["records nested in colls" "\"[#user.Pt{:x 1, :y 2}]\"" - "(do (defrecord Pt [x y]) (pr-str [(->Pt 1 2)]))"] - ["defmethod overrides a record, top level" "\"<3,4>\"" - "(do (defrecord Pt [x y]) (defmethod print-method (quote user.Pt) [r w] (.write w (str \"<\" (:x r) \",\" (:y r) \">\"))) (pr-str (->Pt 3 4)))"] - ["defmethod fires nested in a map" "\"{:p <5,6>}\"" - "(do (defrecord Pt [x y]) (defmethod print-method (quote user.Pt) [r w] (.write w (str \"<\" (:x r) \",\" (:y r) \">\"))) (pr-str {:p (->Pt 5 6)}))"] - ["defmethod fires through prn" "\"[<1,2>]\\n\"" - "(do (defrecord Pt [x y]) (defmethod print-method (quote user.Pt) [r w] (.write w (str \"<\" (:x r) \",\" (:y r) \">\"))) (with-out-str (prn [(->Pt 1 2)])))"] - ["direct call uses :default" "\"42\"" - "(let [w (StringWriter.)] (print-method 42 w) (.toString w))"] - ["direct builtin override" "\"#42#\"" - "(do (defmethod print-method :number [n w] (.write w (str \"#\" n \"#\"))) (let [w (StringWriter.)] (print-method 42 w) (.toString w)))"] - ["print-dup routes to print-method" "\"[1 2]\"" - "(let [w (StringWriter.)] (print-dup [1 2] w) (.toString w))"] - ["StringWriter accumulates" "\"ab\"" - "(let [w (StringWriter.)] (.write w \"a\") (.append w \\b) (.toString w))"] - ["methods table inspectable" "true" - "(do (defrecord Pt [x y]) (defmethod print-method (quote user.Pt) [r w] r) (contains? (methods print-method) (quote user.Pt)))"]) - -# Cold tagged-type printing now lives in io-tier defmethods (the host -# renderer dispatches any remaining :jolt/* tagged value through the -# print-method hook). Outputs unchanged from the old host branches; any -# tagged type is now user-overridable, atoms included. -(defspec "io / cold tagged types via print-method" - ["uuid" "\"#uuid \\\"b6883c0a-0342-4007-9966-bc2dfa6b109e\\\"\"" - "(pr-str (parse-uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\"))"] - ["uuid nested" "\"[#uuid \\\"b6883c0a-0342-4007-9966-bc2dfa6b109e\\\"]\"" - "(pr-str [(parse-uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\")])"] - ["regex" "\"#\\\"a+b\\\"\"" "(pr-str #\"a+b\")"] - ["transient vector" "\"#\"" "(pr-str (transient [1]))"] - ["transient map" "\"#\"" "(pr-str (transient {:a 1}))"] - ["atom override fires nested" "\"{:a #atom[7]}\"" - "(do (defmethod print-method :jolt/atom [a w] (.write w (str \"#atom[\" (deref a) \"]\"))) (pr-str {:a (atom 7)}))"] - ["uuid through str unchanged" "\"b6883c0a-0342-4007-9966-bc2dfa6b109e\"" - "(str (parse-uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\"))"]) diff --git a/test/spec/iseq-call-spec.janet b/test/spec/iseq-call-spec.janet deleted file mode 100644 index b1aeaa4..0000000 --- a/test/spec/iseq-call-spec.janet +++ /dev/null @@ -1,19 +0,0 @@ -# Specification: a non-array ISeq (plist/lazy-seq, e.g. from cons/concat/list or -# ~@) used as a FORM is evaluated as a call, not returned as self-evaluating data -# (jolt-2rx). The interpreter only treated a reader LIST (Janet array) as a call; -# a runtime-built list (a plist/lazy-seq table) fell through to self-eval, so -# (eval (cons '+ '(1 2))) returned the list instead of 3. The analyzer already -# punts such forms to the interpreter, so the fix lives in eval-form. -(use ../support/harness) - -(defspec "ISeq call forms (jolt-2rx)" - ["eval a cons'd call" "3" "(eval (cons (quote +) (quote (1 2))))"] - ["eval a list-built call" "6" "(eval (list (quote +) 1 2 3))"] - ["eval a concat'd call" "10" "(eval (concat (list (quote +)) (list 1 2 3 4)))"] - ["nested cons'd subform" "7" "(eval (list (quote +) 3 (cons (quote +) (quote (1 3)))))"] - ["empty list self-evals" "()" "(eval (list))"] - ["macro output via cons" "3" "(do (defmacro mc [] (cons (quote +) (quote (1 2)))) (mc))"] - ["macro output via concat" "6" "(do (defmacro mk [] (concat (list (quote +)) (list 1 2 3))) (mk))"] - # regressions: vectors/quoted-data are NOT calls - ["vector value self-evals" "[1 2 3]" "(eval (vec [1 2 3]))"] - ["quoted list of data" "(quote (1 2 3))" "(quote (1 2 3))"]) diff --git a/test/spec/lazy-seqs-spec.janet b/test/spec/lazy-seqs-spec.janet deleted file mode 100644 index 0c9c99d..0000000 --- a/test/spec/lazy-seqs-spec.janet +++ /dev/null @@ -1,44 +0,0 @@ -# Specification: lazy sequences. -(use ../support/harness) - -(defspec "lazy / construction & laziness" - ["lazy-seq value" "[1 2 3]" "(take 3 (lazy-seq (cons 1 (lazy-seq (cons 2 (lazy-seq (cons 3 nil)))))))"] - ["not eagerly evaluated" "0" "(let [c (atom 0)] (lazy-seq (swap! c inc) nil) @c)"] - ["realized on demand" "1" "(let [c (atom 0) s (lazy-seq (swap! c inc) [1])] (first s) @c)"] - ["lazy-cat" "[0 1 2 3]" "(lazy-cat [0 1] [2 3])"] - ["doall forces" "[2 3 4]" "(doall (map inc [1 2 3]))"] - ["dorun returns nil" "nil" "(dorun (map inc [1 2 3]))"]) - -(defspec "lazy / infinite" - ["take from repeat" "[7 7 7]" "(take 3 (repeat 7))"] - ["take from iterate" "[1 2 4 8]" "(take 4 (iterate (fn [x] (* 2 x)) 1))"] - ["take from cycle" "[1 2 1 2]" "(take 4 (cycle [1 2]))"] - ["take from range" "[0 1 2]" "(take 3 (range))"] - ["drop then take" "[5 6 7]" "(take 3 (drop 5 (range)))"] - ["filter infinite" "[0 2 4]" "(take 3 (filter even? (range)))"] - ["map infinite" "[0 1 4]" "(take 3 (map (fn [x] (* x x)) (range)))"] - ["nth of infinite" "100" "(nth (range) 100)"]) - -(defspec "lazy / self-referential" - ["self-ref ones" "[1 1 1 1 1]" "(do (def ones (lazy-seq (cons 1 ones))) (take 5 ones))"] - ["self-ref nats" "[0 1 2 3 4]" "(do (def nats (lazy-cat [0] (map inc nats))) (take 5 nats))"] - ["self-ref fib" "[0 1 1 2 3 5 8 13 21 34]" - "(do (def fib (lazy-cat [0 1] (map + (rest fib) fib))) (take 10 fib))"]) - -(defspec "lazy / realized?" - ["unrealized" "false" "(realized? (lazy-seq (cons 1 nil)))"] - ["realized after" "true" "(let [s (lazy-seq (cons 1 nil))] (first s) (realized? s))"] - ["body runs once" "1" "(let [c (atom 0) s (lazy-seq (do (swap! c inc) [1 2 3]))] (seq s) (seq s) @c)"]) - -# Independent walks over the SAME lazy seq share realization: each node's rest -# wrapper is memoized (ls-rest-cached), so the shared rest-thunks run exactly -# once. Pre-fix, every walk after the first re-ran the thunks — duplicating -# side effects, and a doall'd seq of futures re-spawned them serially on the -# deref walk (which is how it surfaced, via pmap). -(defspec "lazy-seq / realization is shared across walks" - ["effects run once across three walks" "3" - "(let [a (atom 0) s (map (fn [x] (swap! a inc) x) [1 2 3])] (doall s) (dorun s) (vec s) (deref a))"] - ["values stable across walks" "true" - "(let [s (map inc [1 2 3])] (= (vec s) (vec s) [2 3 4]))"] - ["filter effects once" "4" - "(let [a (atom 0) s (filter (fn [x] (swap! a inc) (odd? x)) [1 2 3 4])] (dorun s) (count s) (deref a))"]) diff --git a/test/spec/lists-spec.janet b/test/spec/lists-spec.janet deleted file mode 100644 index 7a35f70..0000000 --- a/test/spec/lists-spec.janet +++ /dev/null @@ -1,28 +0,0 @@ -# Specification: lists (persistent singly-linked). -(use ../support/harness) - -(defspec "list / construct & predicate" - ["list" "[1 2 3]" "(list 1 2 3)"] - ["empty list" "[]" "(list)"] - ["quoted list" "[1 2 3]" "(quote (1 2 3))"] - ["list? true" "true" "(list? (list 1 2))"] - ["list? on conj result" "true" "(list? (conj (list 1) 0))"] - ["count" "3" "(count (list 1 2 3))"] - ["empty? true" "true" "(empty? (list))"] - ["list = vector elts" "true" "(= (list 1 2 3) [1 2 3])"]) - -(defspec "list / access & update" - ["first" "1" "(first (list 1 2 3))"] - ["rest" "[2 3]" "(rest (list 1 2 3))"] - ["peek is first" "1" "(peek (list 1 2 3))"] - ["pop drops first" "[2 3]" "(pop (list 1 2 3))"] - ["conj prepends" "[0 1 2]" "(conj (list 1 2) 0)"] - ["conj many prepends" "[4 3 1 2]" "(conj (list 1 2) 3 4)"] - ["cons prepends" "[0 1 2]" "(cons 0 (list 1 2))"] - ["nth" "20" "(nth (list 10 20 30) 1)"]) - -(defspec "list / immutability & performance" - ["conj does not mutate" "true" "(let [l (list 1 2 3) m (conj l 0)] (and (= l [1 2 3]) (= m [0 1 2 3])))"] - ["reduce conj builds" "[2 1 0]" "(reduce conj (list) (range 3))"] - ["O(1) conj at scale" "200000" "(count (reduce conj (list) (range 200000)))"] - ["scale head correct" "199999" "(first (reduce conj (list) (range 200000)))"]) diff --git a/test/spec/macros-spec.janet b/test/spec/macros-spec.janet deleted file mode 100644 index 5dd1fbd..0000000 --- a/test/spec/macros-spec.janet +++ /dev/null @@ -1,115 +0,0 @@ -# Specification: macros, quoting and syntax-quote. -(use ../support/harness) - -(defspec "macros / quoting" - ["quote symbol" "(quote a)" "(quote a)"] - ["quote list" "[1 2 3]" "(quote (1 2 3))"] - ["quote nested" "[1 [2 3]]" "(quote (1 (2 3)))"] - ["quote sugar" "'a" "'a"] - ["syntax-quote literal" "[1 2]" "`[1 2]"] - ["unquote" "[1 2 3]" "(let [x 2] `[1 ~x 3])"] - ["unquote-splicing" "[1 2 3 4]" "(let [xs [2 3]] `[1 ~@xs 4])"] - ["unquote in list" "[3]" "(let [x 3] `(~x))"] - ["syntax-quote symbol qualifies" "true" "(symbol? `foo)"]) - -(defspec "macros / defmacro" - ["simple macro" "3" - "(do (defmacro m [a b] `(+ ~a ~b)) (m 1 2))"] - ["macro unless" "1" - "(do (defmacro unless [c body] `(if ~c nil ~body)) (unless false 1))"] - ["macro with body splice" "6" - "(do (defmacro msum [& xs] `(+ ~@xs)) (msum 1 2 3))"] - ["macroexpand-1" "true" - "(do (defmacro m [x] `(inc ~x)) (list? (macroexpand-1 '(m 5))))"] - ["gensym unique" "false" - "(= (gensym) (gensym))"] - ["gensym# in template" "true" - "(do (defmacro m [] `(let [x# 1] x#)) (= 1 (m)))"] - # An #() lambda written inside a syntax-quote: its generated params must not be - # qualified to the ns (a qualified symbol is not a valid param). hiccup's - # compiler emits `(let [sb# ..] (run! #(.append sb# %) ..)) (jolt-nkx). - ["#() inside syntax-quote" "[2 4 6]" - "(do (defmacro m [] `(mapv #(* % 2) [1 2 3])) (m))"] - ["#() + auto-gensym share in template" "\"ab\"" - "(do (defmacro m [] `(let [sb# (StringBuilder.)] (mapv #(.append sb# %) [\"a\" \"b\"]) (.toString sb#))) (m))"]) - -# Core macros ported from Janet to the Clojure overlay (jolt-1j0 phase 3, -# jolt-core/clojure/core/30-macros.clj). -(defspec "macros / core-overlay" - ["if-not true branch" ":then" "(if-not false :then :else)"] - ["if-not else branch" ":else" "(if-not true :then :else)"] - ["if-not no else" "nil" "(if-not true :then)"] - ["if-not no else hit" ":then" "(if-not false :then)"] - ["comment -> nil" "nil" "(comment a b c)"] - ["comment in do" "42" "(do (comment ignored) 42)"] - ["if-let then" "6" "(if-let [x 5] (inc x) :none)"] - ["if-let else" ":none" "(if-let [x nil] (inc x) :none)"] - ["if-let else scope" "9" "(let [x 9] (if-let [x nil] :t x))"] - ["if-some zero" "1" "(if-some [x 0] (inc x) :none)"] - ["if-some nil" ":none" "(if-some [x nil] x :none)"] - ["when-some multi" "14" "(when-some [x 7] (inc x) (* x 2))"] - ["when-some nil" "nil" "(when-some [x nil] x)"] - ["while loop" "3" "(let [a (atom 0)] (while (< @a 3) (swap! a inc)) @a)"] - ["dotimes sum" "10" "(let [a (atom 0)] (dotimes [i 5] (swap! a + i)) @a)"] - ["as-> threads" "12" "(as-> 5 x (+ x 1) (* x 2))"] - ["as-> no forms" "5" "(as-> 5 x)"] - ["some-> through" "6" "(some-> {:a {:b 5}} :a :b inc)"] - ["some-> short-circuit" "nil" "(some-> {:a nil} :a :b)"] - ["some->> through" "9" "(some->> [1 2 3] (map inc) (reduce +))"] - ["some->> nil" "nil" "(some->> nil (map inc))"] - ["doto returns obj" "[1 2]" "(deref (doto (atom []) (swap! conj 1) (swap! conj 2)))"] - ["when-first" "20" "(when-first [x [10 20 30]] (* x 2))"] - ["when-first empty" "nil" "(when-first [x []] :body)"] - ["when-first nil coll" "nil" "(when-first [x nil] :body)"] - ["when-first range" "0" "(when-first [x (range 5)] x)"] - ["cond->> threads" "12" "(cond->> 5 true (+ 1) false (* 100) true (* 2))"] - ["cond->> skip" "10" "(cond->> 10 false (+ 1))"] - ["assert pass" ":ok" "(do (assert (= 1 1)) :ok)"] - ["assert throws" ":threw" "(try (assert (= 1 2)) (catch :default e :threw))"] - ["assert message" "\"nope\"" "(try (assert false \"nope\") (catch :default e (ex-message e)))"] - ["delay value" "42" "(deref (delay 42))"] - ["delay forces once" "1" "(let [c (atom 0) d (delay (swap! c inc))] @d @d @c)"] - ["future deref" "9" "(deref (future (* 3 3)))"] - ["letfn simple" "25" "(letfn [(sq [x] (* x x))] (sq 5))"] - ["letfn mutual" "true" "(letfn [(ev? [n] (if (zero? n) true (od? (dec n)))) (od? [n] (if (zero? n) false (ev? (dec n))))] (ev? 8))"] - ["condp match" ":two" "(condp = 2 1 :one 2 :two 3 :three)"] - ["condp default" ":else" "(condp = 9 1 :one 2 :two :else)"] - ["condp :>> form" "\"got 2\"" "(condp some [1 2 3] #{0 9} :>> (fn [x] (str \"got \" x)) #{2 6} :>> (fn [x] (str \"got \" x)))"] - ["condp no match" ":threw" "(try (condp = 9 1 :one) (catch :default e :threw))"] - ["binding rebinds" "99" "(do (def ^:dynamic *bx* 10) (binding [*bx* 99] *bx*))"] - ["binding restores" "10" "(do (def ^:dynamic *by* 10) (binding [*by* 99] *by*) *by*)"] - ["binding seen by fn" "7" "(do (def ^:dynamic *bz* 0) (defn rdz [] *bz*) (binding [*bz* 7] (rdz)))"]) - -# time returns the body value (the timing line goes to *out*); with-redefs -# temporarily rebinds var roots and restores on exit (even on throw); -# macroexpand expands repeatedly until the head is no longer a macro. -(defspec "macros / time, with-redefs, macroexpand" - ["time returns value" "3" "(time (+ 1 2))"] - ["with-redefs rebinds" "42" "(do (defn wr-f [] 1) (with-redefs [wr-f (fn [] 42)] (wr-f)))"] - ["with-redefs restores" "1" "(do (defn wr-g [] 1) (with-redefs [wr-g (fn [] 42)]) (wr-g))"] - ["with-redefs restores on throw" "1" - "(do (defn wr-h [] 1) (try (with-redefs [wr-h (fn [] 42)] (throw (ex-info \"x\" {}))) (catch :default e nil)) (wr-h))"] - ["with-redefs-fn" "42" "(do (defn wr-i [] 1) (with-redefs-fn {(var wr-i) (fn [] 42)} (fn [] (wr-i))))"] - ["macroexpand full" "true" "(let [e (macroexpand (quote (when-not false 1)))] (= (quote if) (first e)))"] - ["macroexpand non-macro" "[1 2]" "(macroexpand (quote [1 2]))"]) - -# defmacro accepts the arity-clause form (defmacro name ([params] body...)), a -# leading docstring, and ^{:map} metadata on the name (jolt-whp, jolt-8w2). -(defspec "macros / defmacro arity-clause & name metadata" - ["arity-clause form" "10" "(do (defmacro tw ([x] (list (quote *) x 2))) (tw 5))"] - ["docstring + arity" "15" "(do (defmacro th \"triple\" ([x] (list (quote *) x 3))) (th 5))"] - ["^{:map} name meta" "7" "(do (defmacro ^{:private true} pm [] 7) (pm))"] - ["multi-form body" "6" "(do (defmacro mb ([a b] (list (quote +) a b))) (mb 2 4))"]) - -# Multi-arity defmacro (dispatch on arg count) and the docstring + attr-map + -# params form — both needed to run real Clojure macros, e.g. -# clojure.tools.logging/log (4 arities) and its level macros (jolt-q8l, jolt-qnr). -(defspec "macros / defmacro multi-arity & attr-map" - ["multi-arity 1" "6" "(do (defmacro ma ([a] (list (quote +) a 1)) ([a b] (list (quote +) a b))) (ma 5))"] - ["multi-arity 2" "5" "(do (defmacro ma ([a] (list (quote +) a 1)) ([a b] (list (quote +) a b))) (ma 2 3))"] - ["arity delegates" "[:d nil 9]" - "(do (defmacro lg ([m] `(lg :d nil ~m)) ([l t m] (list (quote vector) l t m))) (lg 9))"] - ["doc + attr-map + params" "10" - "(do (defmacro am \"doc\" {:arglists (quote ([x]))} [x] (list (quote inc) x)) (am 9))"] - ["doc + attr-map + variadic" "6" - "(do (defmacro vg \"d\" {:arglists (quote ([& a]))} [& xs] `(+ ~@xs)) (vg 1 2 3))"]) diff --git a/test/spec/map-fastpath-spec.janet b/test/spec/map-fastpath-spec.janet deleted file mode 100644 index cc4d3f7..0000000 --- a/test/spec/map-fastpath-spec.janet +++ /dev/null @@ -1,74 +0,0 @@ -# Specification: keyword-invoke and map-literal semantics that the compiled -# fast paths (jolt-4vr: inlined keyword lookup, inlined struct construction) -# must preserve. Written BEFORE the optimization; every row passes on the -# generic jolt-call/build-map-literal paths and must keep passing on the -# inlined ones. -(use ../support/harness) - -(defspec "maps / keyword invoke" - ["hit" "1" "(:a {:a 1 :b 2})"] - ["miss" "nil" "(:z {:a 1})"] - ["miss with default" ":d" "(:z {:a 1} :d)"] - ["hit with default" "1" "(:a {:a 1} :d)"] - ["on nil" "nil" "(:a nil)"] - ["on nil with default" ":d" "(:a nil :d)"] - ["nil value is present" "nil" "(:a {:a nil} :d)"] - ["false value is present" "false" "(:a {:a false} :d)"] - ["on a vector" "nil" "(:a [1 2 3])"] - ["on a number" "nil" "(:a 42)"] - ["on a sorted map" "2" "(:b (sorted-map :a 1 :b 2))"] - ["on assoc result" "3" "(:c (assoc {:a 1} :c 3))"] - ["on a record field" "5" "(do (defrecord KFP [x]) (:x (->KFP 5)))"] - ["qualified keyword" "1" "(:n/a {:n/a 1})"] - ["nested in expr" "6" "(+ (:a {:a 1}) (:b {:b 2}) (:c {:c 3}))"] - ["evaluates map expr once" "[2 1]" - "(do (def cnt (atom 0)) (let [v (:a (do (swap! cnt inc) {:a 2}))] [v @cnt]))"]) - -(defspec "maps / literal construction" - ["basic" "{:a 1, :b 2}" "{:a 1 :b 2}"] - ["empty" "{}" "{}"] - ["computed values" "{:a 3}" "{:a (+ 1 2)}"] - ["nil value kept" "true" "(contains? {:a nil} :a)"] - ["nil value lookup" "nil" "(get {:a nil} :a :d)"] - ["string key" "1" "(get {\"k\" 1} \"k\")"] - ["number key" ":one" "(get {1 :one} 1)"] - ["collection key" ":v" "(get {[1 2] :v} [1 2])"] - ["collection value-equal key" ":v" "(get {[1 2] :v} (vector 1 2))"] - ["computed key" "1" "(get {(keyword \"a\") 1} :a)"] - # jolt-p3c: literal entries evaluate left to right in SOURCE order (the - # reader carries [k v ...] order on a struct prototype / phm field) - ["values evaluate in source order" "[1 2 3]" - "(do (def log (atom [])) {:a (swap! log conj 1) :b (swap! log conj 2) :c (swap! log conj 3)} (deref log))"] - ["keys evaluate before their values, pairwise" "[:k1 :v1 :k2 :v2]" - "(do (def log (atom [])) {(do (swap! log conj :k1) :a) (do (swap! log conj :v1) 1) (do (swap! log conj :k2) :b) (do (swap! log conj :v2) 2)} (deref log))"] - ["source order with a nil value (phm form)" "[1 2 3]" - "(do (def log (atom [])) {:a (do (swap! log conj 1) nil) :b (swap! log conj 2) :c (swap! log conj 3)} (deref log))"] - ["source order through syntax-quote" "[1 2]" - "(do (def log (atom [])) (defmacro m-p3c [] `{:a ~(list 'swap! 'log 'conj 1) :b ~(list 'swap! 'log 'conj 2)}) (m-p3c) (deref log))"] - ["count" "3" "(count {:a 1 :b 2 :c 3})"] - ["equality with phm" "true" "(= {:a 1 :b 2} (assoc {:a 1} :b 2))"] - ["keys work after assoc" "2" "(:b (assoc {:a 1 :b 2} :c 3))"] - ["literal in fn body" "12" "(do (defn mfp-mk [x] {:v (* x 2)}) (:v (mfp-mk 6)))"]) - -(defspec "clojure.math (jolt-h79)" - ["sqrt" "true" "(< 1.4142 (clojure.math/sqrt 2) 1.4143)"] - ["pow" "1024" "(long (clojure.math/pow 2 10))"] - ["tan of 0" "0" "(long (clojure.math/tan 0))"] - ["round" "3" "(clojure.math/round 2.6)"] - ["floor" "2" "(clojure.math/floor 2.9)"] - ["signum" "-1" "(clojure.math/signum -7.2)"] - ["to-radians" "true" "(< 3.14 (clojure.math/to-radians 180) 3.15)"] - ["PI" "true" "(< 3.14 clojure.math/PI 3.15)"] - ["require + alias" "5" "(do (require '[clojure.math :as m]) (long (m/hypot 3 4)))"] - ["as a value" "[1 2]" "(mapv (comp long clojure.math/sqrt) [1 4])"]) - -# jolt-507: a jolt local in janet CALL-HEAD position must not resolve as a -# janet core macro of the same name (repeat/seq/loop are janet macros). The -# emitter rebinds local callees to reserved _fp$ symbols. -(defspec "calls / locals named like janet macros" - ["local fn named repeat" "[1 1]" "(let [repeat (fn [x] [x x])] (repeat 1))"] - ["local fn named seq" ":end" "((fn seq [n] (if (pos? n) (seq (dec n)) :end)) 2)"] - ["local fn named loop2" "[2 1]" "(let [with (fn [a b] [b a])] (with 1 2))"] - ["overlay repeat self-call (regression)" "(quote (0 0 0))" "(take 3 (repeat 0))"] - ["closure param called" "42" "((fn [f] (f 41)) inc)"] - ["param holding a keyword (IFn leftover)" "1" "((fn [f] (f {:a 1})) :a)"]) diff --git a/test/spec/maps-spec.janet b/test/spec/maps-spec.janet deleted file mode 100644 index 9ebd5e2..0000000 --- a/test/spec/maps-spec.janet +++ /dev/null @@ -1,240 +0,0 @@ -# Specification: maps (associative). -(use ../support/harness) - -(defspec "map / construct & predicate" - ["literal" "{:a 1}" "{:a 1}"] - ["hash-map" "{:a 1, :b 2}" "(hash-map :a 1 :b 2)"] - ["empty" "{}" "{}"] - ["map? true" "true" "(map? {:a 1})"] - ["map? false on vector" "false" "(map? [1 2])"] - ["count" "2" "(count {:a 1 :b 2})"] - ["empty? true" "true" "(empty? {})"] - ["equality order-indep" "true" "(= {:a 1 :b 2} {:b 2 :a 1})"]) - -(defspec "map / access" - ["get" "1" "(get {:a 1} :a)"] - ["get missing nil" "nil" "(get {:a 1} :z)"] - ["get default" ":x" "(get {:a 1} :z :x)"] - ["keyword as fn" "1" "(:a {:a 1})"] - ["keyword fn default" ":x" "(:z {:a 1} :x)"] - ["map as fn" "1" "({:a 1} :a)"] - ["get-in" "2" "(get-in {:a {:b 2}} [:a :b])"] - ["get-in missing" "nil" "(get-in {:a {}} [:a :b])"] - ["contains? key" "true" "(contains? {:a 1} :a)"] - ["contains? missing" "false" "(contains? {:a 1} :z)"] - ["find returns entry" "[:a 1]" "(find {:a 1} :a)"] - ["keys" "true" "(= #{:a :b} (set (keys {:a 1 :b 2})))"] - ["vals" "true" "(= #{1 2} (set (vals {:a 1 :b 2})))"]) - -(defspec "map / update" - ["assoc adds" "{:a 1, :b 2}" "(assoc {:a 1} :b 2)"] - ["assoc overwrites" "{:a 9}" "(assoc {:a 1} :a 9)"] - ["assoc many" "{:a 1, :b 2}" "(assoc {} :a 1 :b 2)"] - ["dissoc" "{:a 1}" "(dissoc {:a 1 :b 2} :b)"] - ["dissoc many" "{:a 1}" "(dissoc {:a 1 :b 2 :c 3} :b :c)"] - ["merge" "{:a 1, :b 2}" "(merge {:a 1} {:b 2})"] - ["merge overwrites" "{:a 2}" "(merge {:a 1} {:a 2})"] - ["merge lattermost wins" "{:a 3}" "(merge {:a 1} {:a 2} {:a 3})"] - ["merge no args -> nil" "nil" "(merge)"] - ["merge all nil -> nil" "nil" "(merge nil nil)"] - ["merge nil arg no-op" "{:a 1}" "(merge {:a 1} nil)"] - ["merge nil then map" "{:a 1}" "(merge nil {:a 1})"] - ["merge empty + nil" "{}" "(merge {} nil)"] - ["merge map-entry (conj)" "{:a 1}" "(merge {} (first {:a 1}))"] - ["merge [k v] vector" "{:foo 1}" "(merge {} [:foo 1])"] - ["merge collection key" "true" "(= {[2 3] :foo} (merge {[2 3] :foo} nil {}))"] - ["merge-with" "{:a 3}" "(merge-with + {:a 1} {:a 2})"] - ["update" "{:a 2}" "(update {:a 1} :a inc)"] - ["update missing w/ fnil" "{:a 1}" "(update {} :a (fnil inc 0))"] - ["update-in" "{:a {:b 2}}" "(update-in {:a {:b 1}} [:a :b] inc)"] - ["assoc-in" "{:a {:b 1}}" "(assoc-in {} [:a :b] 1)"] - ["select-keys" "{:a 1}" "(select-keys {:a 1 :b 2} [:a])"] - ["into onto map" "{:a 1, :b 2}" "(into {:a 1} [[:b 2]])"] - ["zipmap" "{:a 1, :b 2}" "(zipmap [:a :b] [1 2])"]) - -(defspec "map / iteration & entries" - ["map over entries" "true" "(= #{1 2} (set (map val {:a 1 :b 2})))"] - ["map keys" "true" "(= #{:a :b} (set (map key {:a 1 :b 2})))"] - ["reduce over entries" "6" "(reduce (fn [a e] (+ a (val e))) 0 {:a 1 :b 2 :c 3})"] - ["reduce-kv" "6" "(reduce-kv (fn [a k v] (+ a v)) 0 {:a 1 :b 2 :c 3})"] - ["destructure entry" "true" "(= [[:a 2]] (into [] (map (fn [[k v]] [k (inc v)]) {:a 1})))"] - ["first of map is entry" "true" "(let [e (first {:a 1})] (and (= (key e) :a) (= (val e) 1)))"] - ["map-entry?" "true" "(map-entry? (first {:a 1}))"] - ["count of nil map" "0" "(count nil)"] - ["get from nil" "nil" "(get nil :a)"] - ["immutability" "true" "(let [m {:a 1} n (assoc m :b 2)] (and (= m {:a 1}) (= n {:a 1 :b 2})))"]) - -(defspec "map / collection keys (by value)" - ["vector key literal" ":v" "(get {[1 2] :v} [1 2])"] - ["map key literal" ":v" "(get {(hash-map :a 1) :v} {:a 1})"] - ["assoc vector key" ":v" "(get (assoc {} [1 2] :v) [1 2])"] - ["key across repr" ":v" "(get (assoc {} (vec [1 2]) :v) [1 2])"] - ["frequencies of maps" "2" "(get (frequencies [{:a 1} (hash-map :a 1)]) {:a 1})"] - ["group-by collection key" "1" "(count (group-by identity [{:a 1} (hash-map :a 1)]))"]) - -# A nil element/key/value INSIDE a collection used as a map key must survive key -# canonicalization — it used to be dropped, so the nil-containing collection -# collided with the nil-free one (jolt-zcm9). -(defspec "map / nil inside a collection key (jolt-zcm9)" - ["set key w/ nil distinct" "2" "(count {#{nil 1} :a, #{1} :b})"] - ["set key w/ nil neg lookup" "nil" "(get {#{nil 1} :a} #{1})"] - ["set key w/ nil pos lookup" ":a" "(get {#{nil 1} :a} #{nil 1})"] - ["set key just nil distinct" "false" "(= {#{nil} :x} {#{} :x})"] - ["map nil-value key distinct" "2" "(count {{:a nil} 1, {} 2})"] - ["map nil-value key neg" "nil" "(get {{:a nil} 1} {})"] - ["map nil-value key pos" "1" "(get {{:a nil} 1} {:a nil})"] - ["map nil-key key distinct" "2" "(count {{nil :a} 1, {} 2})"] - ["map nil-key key pos" "1" "(get {{nil :a} 1} {nil :a})"]) - -# Strictness: assoc bounds-checks vector indices; dissoc requires a map; -# count rejects scalars; numerator/denominator have no ratio type. -(defspec "map / strictness (throws like Clojure)" - ["assoc vec out of bounds" :throws "(assoc [0 1 2] 4 4)"] - ["assoc vec negative" :throws "(assoc [] -1 0)"] - ["assoc vec at count ok" "[1 2 3]" "(assoc [1 2] 2 3)"] - ["dissoc on number" :throws "(dissoc 42 :a)"] - ["dissoc on vector" :throws "(dissoc [1 2] 0)"] - ["dissoc on set" :throws "(dissoc #{:a} :a)"] - ["dissoc nil ok" "nil" "(dissoc nil :a)"] - ["count on number" :throws "(count 1)"] - ["count on keyword" :throws "(count :a)"] - ["count string ok" "3" "(count \"abc\")"] - ["numerator throws" :throws "(numerator 1)"] - ["denominator throws" :throws "(denominator 2)"] - ["subvec out of range" :throws "(subvec [0 1 2 3] 1 5)"] - ["subvec start>end" :throws "(subvec [0 1 2 3] 3 2)"] - ["subvec ok" "[1 2]" "(subvec [0 1 2 3] 1 3)"] - ["min-key empty" :throws "(apply min-key identity [])"] - ["merge empty vector" :throws "(merge {} [])"] - ["merge 1-elem vector" :throws "(merge {} [:foo])"] - ["merge atomic arg" :throws "(merge {} :foo)"] - ["merge [k v] ok" "{:foo 1}" "(merge {} [:foo 1])"] - ["merge maps ok" "{:a 1, :b 2}" "(merge {:a 1} {:b 2})"]) - -# Map entries are distinct from plain vectors (key/val/map-entry? reject a -# vector); min-key/max-key follow Clojure's NaN-aware ordering; subvec coerces -# float/NaN indices like (int ...). -(defspec "map / map-entry & key ordering" - ["key of entry" ":a" "(key (first {:a 1}))"] - ["val of entry" "1" "(val (first {:a 1}))"] - ["key rejects vector" :throws "(key [:a 1])"] - ["val rejects vector" :throws "(val [:a 1])"] - ["map-entry? entry" "true" "(map-entry? (first {:a 1}))"] - ["map-entry? vector" "false" "(map-entry? [:a 1])"] - ["min-key NaN first" "1" "(min-key identity ##NaN 1)"] - ["min-key NaN last" "true" "(NaN? (min-key identity 1 ##NaN))"] - ["min-key NaN three" "true" "(infinite? (min-key identity ##NaN ##-Inf 1))"] - ["min-key keys nonnum" :throws "(min-key identity \"x\" \"y\")"] - ["max-key picks max" "[1 2 3]" "(max-key count [1] [1 2 3] [1 2])"] - ["subvec float trunc" "[0]" "(subvec [0 1 2] 0.5 1.33)"] - ["subvec NaN start" "[0 1 2]" "(subvec [0 1 2] ##NaN 3)"] - ["subvec NaN end" "[]" "(subvec [0 1 2] 0 ##NaN)"]) - -# A nil value is a PRESENT key in Clojure (distinct from a missing key); Janet -# structs drop nil, so jolt builds these maps as a phm. Tested via literals (the -# reader path) and the construction/op surface, in every spec mode. -(defspec "map / nil values preserved" - ["literal contains" "true" "(contains? {:b nil} :b)"] - ["literal not= empty" "false" "(= {:b nil} {})"] - ["literal get nil" "nil" "(get {:b nil} :b :x)"] - ["literal keys incl nil" "true" "(= #{:a :b} (set (keys {:a nil :b 1})))"] - ["literal count" "2" "(count {:a nil :b 1})"] - ["literal vals incl nil" "2" "(count (vals {:a nil :b 1}))"] - ["eval values w/ nil" "3" "(:a {:a (+ 1 2) :b nil})"] - ["nil key present" "true" "(contains? {nil :v} nil)"] - ["assoc nil present" "true" "(contains? (assoc {:a 1} :b nil) :b)"] - ["assoc nil get" "nil" "(get (assoc {:a 1} :b nil) :b :x)"] - ["assoc overwrite nil" "nil" "(get (assoc {:a 1} :a nil) :a :x)"] - ["hash-map nil" "true" "(contains? (hash-map :b nil) :b)"] - ["merge new nil" "true" "(contains? (merge {:a 1} {:b nil}) :b)"] - ["merge overwrite nil" "nil" "(get (merge {:a 1} {:a nil}) :a :x)"] - ["merge-with present nil" "true" "(= [nil 1] (get (merge-with (fn [a b] [a b]) {:a nil} {:a 1}) :a))"] - ["into nil val" "true" "(contains? (into {} [[:a nil]]) :a)"] - ["conj map nil" "true" "(contains? (conj {:x 1} {:a nil}) :a)"] - ["zipmap nil" "true" "(contains? (zipmap [:a] [nil]) :a)"] - ["select-keys nil" "true" "(contains? (select-keys {:a nil} [:a]) :a)"] - ["get-in present nil" "nil" "(get-in {:a nil} [:a] :x)"] - ["get-in through nil" ":x" "(get-in {:a nil} [:a :b] :x)"] - ["dissoc keeps nil" "true" "(contains? (dissoc {:a nil :b 1} :b) :a)"] - ["reduce-kv sees nil" "true" "(= #{:a :b} (reduce-kv (fn [acc k v] (conj acc k)) #{} {:a nil :b 2}))"] - ["nil-free stays fast" "true" "(= {:a 1 :b 2} {:b 2 :a 1})"]) - -# Clojure 1.11 map transformers. -(defspec "map / update-keys & update-vals (1.11)" - ["update-keys" "{\"a\" 1, \"b\" 2}" "(update-keys {:a 1 :b 2} name)"] - ["update-keys empty" "{}" "(update-keys {} inc)"] - ["update-keys nil" "{}" "(update-keys nil str)"] - ["update-keys collide last wins" "1" "(count (update-keys {:a 1 :b 2} (fn [_] :k)))"] - ["update-vals" "{:a 2, :b 3}" "(update-vals {:a 1 :b 2} inc)"] - ["update-vals empty" "{}" "(update-vals {} inc)"] - ["update-vals nil" "{}" "(update-vals nil inc)"] - ["update-vals keeps keys" "[:a :b]" "(sort (keys (update-vals {:a 1 :b 2} inc)))"]) - -# keys/vals/empty? are 00-syntax overlay fns now (jolt-4j3) — expander-called, -# so they live in the first tier and get the staged defn recompile. -(defspec "maps / keys-vals-empty? as overlay fns" - ["keys" "(quote (:a))" "(keys {:a 1})"] - ["keys empty map" "nil" "(keys {})"] - ["keys nil" "nil" "(keys nil)"] - ["vals" "(quote (1))" "(vals {:a 1})"] - ["vals empty" "nil" "(vals {})"] - ["keys sorted order" "[1 2 3]" "(vec (keys (sorted-map 2 :b 1 :a 3 :c)))"] - ["vals sorted order" "[:a :b :c]" "(vec (vals (sorted-map 2 :b 1 :a 3 :c)))"] - ["keys/vals zip" "{:a 1 :b 2}" "(zipmap (keys {:a 1 :b 2}) (vals {:a 1 :b 2}))"] - ["empty? map" "true" "(empty? {})"] - ["empty? vec" "[true false]" "[(empty? []) (empty? [1])]"] - ["empty? list" "[true false]" "[(empty? ()) (empty? (list 1))]"] - ["empty? string" "[true false]" "[(empty? \"\") (empty? \"a\")]"] - ["empty? nil" "true" "(empty? nil)"] - ["empty? set" "[true false]" "[(empty? #{}) (empty? #{1})]"] - ["empty? lazy" "[true false]" "[(empty? (filter pos? [-1])) (empty? (map inc [1]))]"] - ["empty? lazy nil elem" "false" "(empty? (cons nil nil))"] - ["empty? sorted" "[true false]" "[(empty? (sorted-map)) (empty? (sorted-set 1))]"] - ["empty? number throws" :throws "(empty? 5)"]) - -# (assoc nil k v) yields a real immutable map, not a raw host table, so -# assoc-in into absent keys nests countable/seqable maps (jolt-w4s). -(defspec "map / assoc on nil" - ["assoc nil is a map" "{:a 1}" "(assoc nil :a 1)"] - ["count of assoc nil" "1" "(count (assoc nil :a 1))"] - ["assoc-in nested countable" "1" "(count (:a (assoc-in {} [:a :b] 1)))"] - ["assoc-in deep get" "9" "(get-in (assoc-in {} [:a :b :c] 9) [:a :b :c])"] - ["seq over assoc-nil map" ":a" "(ffirst (seq (assoc nil :a 1)))"] - ["keys of assoc-nil map" "[:a]" "(vec (keys (assoc nil :a 1)))"]) - -# into {} / frequencies / group-by bulk-build the HAMT in one pass from a native -# pairs/table accumulator (phm-from-pairs), instead of an assoc per element -# (jolt-5vsp collections). Cross the bin(<=16)/array-node(>=17) promotion and a -# size that grows the trie a level; check dedup (last-wins), nil keys, and that -# assoc/dissoc after a bulk build still land. The structure is identical to the -# incremental builder (validated in the PR), so reads agree. -(defspec "map / bulk build boundaries" - ["into = incr at 17" "true" "(= (into {} (map (fn [i] [i (* i 2)]) (range 17))) (reduce (fn [m p] (assoc m (first p) (second p))) {} (map (fn [i] [i (* i 2)]) (range 17))))"] - ["into = incr at 1000" "true" "(= (into {} (map (fn [i] [i (* i 2)]) (range 1000))) (reduce (fn [m p] (assoc m (first p) (second p))) {} (map (fn [i] [i (* i 2)]) (range 1000))))"] - ["into count 1000" "1000" "(count (into {} (map (fn [i] [i i]) (range 1000))))"] - ["into reads back" "999" "(get (into {} (map (fn [i] [i (* i 3)]) (range 1000))) 333)"] - ["into onto non-empty" "9" "(get (into {:a 1} [[:a 9] [:b 2]]) :a)"] - ["into dup last wins" "9" "(get (into {} [[:k 1] [:k 9]]) :k)"] - ["into nil key" ":x" "(get (into {} [[nil :x] [:a 1]]) nil)"] - ["assoc after bulk" "7" "(get (assoc (into {} (map (fn [i] [i i]) (range 100))) :new 7) :new)"] - ["dissoc after bulk" "nil" "(get (dissoc (into {} (map (fn [i] [i i]) (range 100))) 50) 50)"] - ["frequencies count" "3" "(get (frequencies [1 2 2 1 2 1]) 1)"] - ["frequencies coll-key" "2" "(get (frequencies [[1 2] [1 2] [3 4]]) [1 2])"] - # nil is a legal map key, but a Janet table drops a nil key — the transient - # map (canon-keyed table) used to silently lose the nil-key entry, so - # group-by/frequencies/assoc dropped the whole nil bucket. tbl-key routes nil - # to a sentinel; phm keeps its own has-nil slot. - ["frequencies nil key" "2" "(get (frequencies [nil nil 1]) nil)"] - ["group-by nil key" "[nil nil]" "(get (group-by identity [nil nil 1]) nil)"] - ["group-by nil count" "2" "(count (group-by identity [nil nil 1]))"] - ["transient nil key" ":x" "(let [t (transient {})] (assoc! t nil :x) (get (persistent! t) nil))"] - ["transient nil get" "true" "(let [t (transient {})] (assoc! t nil :x) (contains? t nil))"] - ["transient nil dissoc" ":gone" "(let [t (transient {})] (assoc! t nil :x) (dissoc! t nil) (get (persistent! t) nil :gone))"] - # group-by buckets are built on transient vectors (O(1) push) and frozen once, - # rather than an O(log n) persistent conj per element. Result is identical: - # bucket contents and order match the persistent build across a coarse - # grouping (few large buckets — the case bound on the per-bucket conj). - ["group-by bucket" "[1 3 5]" "(get (group-by odd? (range 1 6)) true)"] - ["group-by big bucket" "true" "(= (group-by even? (range 200)) {true (vec (filter even? (range 200))) false (vec (filter odd? (range 200)))})"] - ["group-by order" "[0 3 6 9]" "(get (group-by (fn [x] (mod x 3)) (range 10)) 0)"] - ["hash-map bulk = incr" "true" "(= (apply hash-map (mapcat (fn [i] [i i]) (range 50))) (reduce (fn [m i] (assoc m i i)) {} (range 50)))"]) diff --git a/test/spec/metadata-spec.janet b/test/spec/metadata-spec.janet deleted file mode 100644 index aa1b4b5..0000000 --- a/test/spec/metadata-spec.janet +++ /dev/null @@ -1,31 +0,0 @@ -# Specification: metadata. -(use ../support/harness) - -(defspec "metadata / with-meta & meta" - ["meta of bare value" "nil" "(meta [1 2 3])"] - ["with-meta then meta" "{:a 1}" "(meta (with-meta [1 2 3] {:a 1}))"] - ["with-meta preserves value" "true" "(= [1 2 3] (with-meta [1 2 3] {:a 1}))"] - ["with-meta on map" "{:doc \"x\"}" "(meta (with-meta {:k 1} {:doc \"x\"}))"] - ["vary-meta" "{:a 2}" "(meta (vary-meta (with-meta [1] {:a 1}) update :a inc))"] - ["vary-meta extra args" "{:a 1 :b 2}" "(meta (vary-meta (with-meta [1] {:a 1}) assoc :b 2))"] - ["meta reader ^" "{:tag :int}" "(meta ^{:tag :int} [1 2])"] - ["with-meta on fn ok" "true" "(fn? (with-meta inc {:a 1}))"] - ["with-meta nil clears" "nil" "(meta (with-meta [1 2 3] nil))"]) - -(defspec "metadata / type hints" - # ^Type / ^:kw / ^"str" on a symbol attach as metadata and are otherwise inert: - # the symbol stays a symbol so hints are transparent in every position. - ["type hint on param" "\"hi\"" "(do (defn f [^String s] s) (f \"hi\"))"] - ["type hint, extra params" "[1 2]" "(do (defn g [^String x y] [x y]) (g 1 2))"] - ["type hint in let" "6" "(let [^long x 5] (inc x))"] - ["type hint in body" "2" "(let [s \"ab\"] (count ^String s))"] - ["type hint in destructure" "3" "(let [{:keys [^long a]} {:a 3}] a)"] - ["symbol hint -> :tag" "\"String\"" "(:tag (meta (read-string \"^String x\")))"] - ["keyword hint -> true" "true" "(:foo (meta (read-string \"^:foo x\")))"]) - -(defspec "metadata / def metadata" - ["^:dynamic var binds" "9" "(do (def ^:dynamic *d* 1) (binding [*d* 9] *d*))"] - ["^:private on var" "true" "(do (def ^:private pv 1) (:private (meta (var pv))))"] - ["^Type tag on var" "\"String\"" "(do (def ^String tv \"a\") (:tag (meta (var tv))))"] - ["^{:doc} on var" "\"hi\"" "(do (def ^{:doc \"hi\"} dv 1) (:doc (meta (var dv))))"] - ["(def name doc val) doc" "\"d\"" "(do (def dd \"d\" 5) (:doc (meta (var dd))))"]) diff --git a/test/spec/missing-vars-spec.janet b/test/spec/missing-vars-spec.janet deleted file mode 100644 index 0690976..0000000 --- a/test/spec/missing-vars-spec.janet +++ /dev/null @@ -1,53 +0,0 @@ -# Specification: the last missing-portable core vars (jolt-brh): -# extenders, find-keyword, inst-ms*, read+string, with-local-vars, with-open, -# with-precision. Documented jolt divergences: find-keyword always finds (jolt -# keywords have no intern table — babashka does the same); with-precision -# evaluates its body with the precision ignored (numbers are doubles, no -# BigDecimal context); with-open closes via the value's :close fn or a host -# file (no .close interop on the Janet host). -(use ../support/harness) - -(defspec "core / find-keyword + inst-ms*" - ["find-keyword" ":a" "(find-keyword \"a\")"] - ["find-keyword 2-arity" ":n/a" "(find-keyword \"n\" \"a\")"] - ["find-keyword = keyword" "true" "(= (find-keyword \"x\") :x)"] - ["inst-ms*" "true" "(= (inst-ms* #inst \"2020-01-01T00:00:00Z\") (inst-ms #inst \"2020-01-01T00:00:00Z\"))"] - ["inst-ms* value" "0" "(inst-ms* #inst \"1970-01-01T00:00:00Z\")"]) - -(defspec "core / with-local-vars" - ["var-get initial" "1" "(with-local-vars [x 1] (var-get x))"] - ["var-set" "2" "(with-local-vars [x 1] (var-set x 2) (var-get x))"] - ["two vars" "[1 2]" "(with-local-vars [a 1 b 2] [(var-get a) (var-get b)])"] - ["vars are values" "5" "(with-local-vars [x 0] (let [bump (fn [v] (var-set v (+ 5 (var-get v))))] (bump x) (var-get x)))"] - ["init sees outer" "3" "(let [y 3] (with-local-vars [x y] (var-get x)))"] - ["body result" ":done" "(with-local-vars [x 1] :done)"]) - -(defspec "core / with-open" - ["body result" ":r" "(let [log (atom [])] (with-open [c {:close (fn [] (swap! log conj :closed))}] :r))"] - ["close runs" "[:closed]" "(let [log (atom [])] (with-open [c {:close (fn [] (swap! log conj :closed))}] :r) (deref log))"] - ["close on throw" "[:closed]" "(let [log (atom [])] (try (with-open [c {:close (fn [] (swap! log conj :closed))}] (throw (ex-info \"boom\" {}))) (catch Exception e nil)) (deref log))"] - ["nested close order" "[:inner :outer]" "(let [log (atom [])] (with-open [a {:close (fn [] (swap! log conj :outer))} b {:close (fn [] (swap! log conj :inner))}] :r) (deref log))"] - ["zero bindings" ":r" "(with-open [] :r)"] - ["binding visible" "5" "(with-open [c {:close (fn [] nil) :v 5}] (:v c))"]) - -(defspec "core / with-precision" - ["body evaluates" "3.14" "(with-precision 3 3.14)"] - ["multiple body forms" "2" "(with-precision 10 1 2)"] - ["rounding arg accepted" "1.5" "(with-precision 4 :rounding :half-up 1.5)"] - ["arithmetic" "2" "(with-precision 5 (+ 1 1))"]) - -(defspec "core / read+string" - ["form and text" "true" "(let [[v s] (with-in-str \"42 rest\" (read+string))] (and (= v 42) (string? s)))"] - ["form value" "(quote (+ 1 2))" "(first (with-in-str \"(+ 1 2)\" (read+string)))"] - ["text covers the form" "true" "(let [[v s] (with-in-str \" [1 2] tail\" (read+string))] (and (= v [1 2]) (> (count s) 3)))"] - ["advances the stream" "[1 2]" "(with-in-str \"1 2\" [(first (read+string)) (first (read+string))])"] - ["EOF throws" :throws "(with-in-str \"\" (read+string))"] - ["eof-value arity" ":done" "(first (with-in-str \"\" (read+string *in* false :done)))"]) - -(defspec "core / extenders" - ["lists extended type" "[\"user.Rx\"]" - "(do (defprotocol Px (pm [x])) (defrecord Rx [] Px (pm [x] 1)) (mapv str (extenders Px)))"] - ["nil when none" "nil" - "(do (defprotocol Py (pn [x])) (extenders Py))"] - ["seq of tags" "true" - "(do (defprotocol Pz (pz [x])) (defrecord Rz [] Pz (pz [x] 1)) (and (seq (extenders Pz)) (= 1 (count (extenders Pz)))))"]) diff --git a/test/spec/multimethods-spec.janet b/test/spec/multimethods-spec.janet deleted file mode 100644 index 1dd8acb..0000000 --- a/test/spec/multimethods-spec.janet +++ /dev/null @@ -1,70 +0,0 @@ -# Specification: multimethods & hierarchies. -(use ../support/harness) - -(defspec "multimethods / dispatch" - ["dispatch on value" "\"two\"" - "(do (defmulti f identity) (defmethod f 1 [_] \"one\") (defmethod f 2 [_] \"two\") (f 2))"] - ["dispatch on keyword fn" "\"circle\"" - "(do (defmulti area :shape) (defmethod area :circle [_] \"circle\") (area {:shape :circle}))"] - [":default method" "\"other\"" - "(do (defmulti f identity) (defmethod f 1 [_] \"one\") (defmethod f :default [_] \"other\") (f 99))"] - ["no match throws" :throws - "(do (defmulti f identity) (defmethod f 1 [_] \"one\") (f 99))"] - ["multiple args" "5" - "(do (defmulti g (fn [a b] a)) (defmethod g :add [_ b] b) (g :add 5))"] - ["get-method" "\"one\"" - "(do (defmulti f identity) (defmethod f 1 [_] \"one\") ((get-method f 1) 1))"] - ["remove-method" :throws - "(do (defmulti f identity) (defmethod f 1 [_] \"one\") (remove-method f 1) (f 1))"] - ["methods" "\"one\"" - "(do (defmulti f identity) (defmethod f 1 [_] \"one\") ((get (methods f) 1) 1))"] - ["methods count" "2" - "(do (defmulti f identity) (defmethod f 1 [_] \"one\") (defmethod f 2 [_] \"two\") (count (methods f)))"] - ["remove-all-methods" :throws - "(do (defmulti f identity) (defmethod f 1 [_] \"one\") (defmethod f 2 [_] \"two\") (remove-all-methods f) (f 1))"] - ["remove-all-methods empties the table" "0" - "(do (defmulti f identity) (defmethod f 1 [_] \"one\") (remove-all-methods f) (count (methods f)))"]) - -(defspec "multimethods / hierarchies" - ["derive + isa?" "true" "(do (derive ::child ::parent) (isa? ::child ::parent))"] - ["isa? reflexive" "true" "(isa? ::x ::x)"] - ["isa? unrelated" "false" "(do (derive ::a ::b) (isa? ::a ::c))"] - ["parents" "true" "(do (derive ::c ::p) (contains? (parents ::c) ::p))"] - ["ancestors" "true" "(do (derive ::c ::p) (derive ::p ::g) (contains? (ancestors ::c) ::g))"] - ["descendants" "true" "(do (derive ::c ::p) (contains? (descendants ::p) ::c))"] - ["dispatch via hierarchy" "\"animal\"" - "(do (derive ::dog ::animal) (defmulti speak identity) (defmethod speak ::animal [_] \"animal\") (speak ::dog))"] - ["custom :default key" ":unknown" - "(do (defmulti classify :type :default :other) (defmethod classify :a [_] :alpha) (defmethod classify :other [_] :unknown) (classify {:type :zzz}))"] - ["explicit :hierarchy" "\"a\"" - "(do (def h (derive (make-hierarchy) ::dog ::animal)) (defmulti snd identity :hierarchy h) (defmethod snd ::animal [_] \"a\") (snd ::dog))"]) - -# prefer-method breaks isa-dispatch ties; ambiguity without a preference is -# an ERROR (jolt-heo — this used to silently take an arbitrary method). -(defspec "multimethods / prefer-method" - ["preference picks the winner" ":rect" - "(do (derive :p/sq :p/rect) (derive :p/sq :p/shape) (defmulti pm1 identity) (defmethod pm1 :p/rect [x] :rect) (defmethod pm1 :p/shape [x] :shape) (prefer-method pm1 :p/rect :p/shape) (pm1 :p/sq))"] - ["reverse preference" ":shape" - "(do (derive :q/sq :q/rect) (derive :q/sq :q/shape) (defmulti pm2 identity) (defmethod pm2 :q/rect [x] :rect) (defmethod pm2 :q/shape [x] :shape) (prefer-method pm2 :q/shape :q/rect) (pm2 :q/sq))"] - ["ambiguity throws" :throws - "(do (derive :r/sq :r/rect) (derive :r/sq :r/shape) (defmulti pm3 identity) (defmethod pm3 :r/rect [x] :rect) (defmethod pm3 :r/shape [x] :shape) (pm3 :r/sq))"] - ["isa dominance needs no preference" ":child" - "(do (derive :s/c :s/p) (defmulti pm4 identity) (defmethod pm4 :s/c [x] :child) (defmethod pm4 :s/p [x] :parent) (pm4 :s/c))"] - ["prefers map shape" "true" - "(do (defmulti pm5 identity) (defmethod pm5 :a [x] 1) (defmethod pm5 :b [x] 2) (prefer-method pm5 :a :b) (contains? (get (prefers pm5) :a) :b))"] - ["exact match needs no preference" ":exact" - "(do (derive :t/sq :t/rect) (defmulti pm6 identity) (defmethod pm6 :t/sq [x] :exact) (defmethod pm6 :t/rect [x] :parent) (pm6 :t/sq))"]) - -# defmulti drops a leading docstring/attr-map (jolt-es4 — it used to be taken as -# the dispatch fn). methods/get-method take the multimethod VALUE and recover -# the table, so a bare multifn ref works even when defmethods live elsewhere -# (jolt-9pu). -(defspec "multimethods / docstring & value-based table ops" - ["defmulti docstring" "\"A\"" - "(do (defmulti gd \"the dispatcher\" identity) (defmethod gd :a [_] \"A\") (gd :a))"] - ["defmulti doc+default" "\"d\"" - "(do (defmulti gx \"doc\" identity) (defmethod gx :default [_] \"d\") (gx :anything))"] - ["methods on value" "2" - "(do (defmulti gm identity) (defmethod gm 1 [_] :one) (defmethod gm 2 [_] :two) (count (methods gm)))"] - ["get-method on value" "true" - "(do (defmulti gg identity) (defmethod gg :a [_] :x) (fn? (get-method gg :a)))"]) diff --git a/test/spec/namespaces-spec.janet b/test/spec/namespaces-spec.janet deleted file mode 100644 index 2e332d4..0000000 --- a/test/spec/namespaces-spec.janet +++ /dev/null @@ -1,80 +0,0 @@ -# Specification: namespaces, vars and require. -(use ../support/harness) - -(defspec "namespaces / def & vars" - ["def + deref" "5" "(do (def x 5) x)"] - ["def returns var" "true" "(var? (def y 1))"] - ["declare then def" "2" "(do (declare z) (def z 2) z)"] - ["var special form" "true" "(var? (var +))"] - ["var sugar #'" "true" "(var? #'+)"] - ["var-get" "5" "(do (def w 5) (var-get #'w))"] - ["defn defines fn" "3" "(do (defn f [x] (inc x)) (f 2))"] - ["def with docstring" "7" "(do (def d \"a doc\" 7) d)"] - ["dynamic var binding" "2" "(do (def ^:dynamic *x* 1) (binding [*x* 2] *x*))"] - ["binding restores" "1" "(do (def ^:dynamic *y* 1) (binding [*y* 9] nil) *y*)"] - ["var-set in binding" "5" "(do (def ^:dynamic *z* 1) (binding [*z* 0] (var-set (var *z*) 5) *z*))"]) - -(defspec "namespaces / ns operations" - ["in-ns switches" "true" "(do (in-ns 'my.ns) (symbol? 'x))"] - # ns is a macro over in-ns/require/use/import (Stage 2 jolt-eaa): the form sets - # the current ns and processes its clauses. - ["ns form + alias" "\"HI\"" "(do (ns my.app (:require [clojure.string :as s])) (s/upper-case \"hi\"))"] - ["ns :use refers all" "9" "(do (ns src.lib) (def helper 9) (ns dst.app (:use [src.lib])) helper)"] - ["standalone use" "7" "(do (ns src.l2) (def k 7) (in-ns 'dst.a2) (use '[src.l2]) k)"] - ["ns-name" "true" "(do (require (quote [clojure.string])) (= 'clojure.string (ns-name (find-ns 'clojure.string))))"] - ["find-ns existing" "true" "(some? (find-ns 'clojure.core))"] - ["find-ns missing" "nil" "(find-ns 'does.not.exist)"] - ["resolve var" "true" "(var? (resolve '+))"] - ["resolve missing" "nil" "(resolve 'totally-undefined-xyz)"]) - -(defspec "namespaces / require & refer" - ["require :as" "\"AB\"" "(do (require '[clojure.string :as s]) (s/upper-case \"ab\"))"] - ["require :refer" "true" "(do (require '[clojure.string :refer [blank?]]) (blank? \"\"))"] - ["require :as + :refer" "true" "(do (require '[clojure.string :as s :refer [blank?]]) (and (blank? \"\") (= \"X\" (s/upper-case \"x\"))))"] - ["require clojure.set" "#{1 2 3}" "(do (require '[clojure.set :as set]) (set/union #{1 2} #{3}))"] - ["require clojure.walk" "{:a 2}" "(do (require '[clojure.walk :as w]) (w/postwalk (fn [x] (if (number? x) (inc x) x)) {:a 1}))"] - ["walk keywordize-keys" "{:a 1}" "(do (require '[clojure.walk :as w]) (w/keywordize-keys {\"a\" 1}))"] - ["walk stringify-keys" "true" "(do (require '[clojure.walk :as w]) (= {\"a\" 1} (w/stringify-keys {:a 1})))"] - # Clojure throws FileNotFoundException; silently succeeding masks typos and - # missing roots until the first unresolved-symbol error far from the cause. - ["require missing lib throws" :throws "(require '[no.such.lib])"] - ["use missing lib throws" :throws "(use 'no.such.lib)"] - # …but an ns created in-session is in *loaded-libs* (the ns macro puts it - # there), so require/use of it must NOT hit the loader. - ["require of in-session ns ok" "1" "(do (ns made.here) (def x 1) (require '[made.here]) made.here/x)"]) - -(defspec "namespaces / alias, ns-unalias, ns-publics" - ["alias + use" "\"1,2\"" "(do (require (quote clojure.string)) (alias (quote st) (quote clojure.string)) (st/join \",\" [1 2]))"] - ["ns-unalias removes" "true" - "(do (require (quote clojure.string)) (alias (quote st2) (quote clojure.string)) (ns-unalias (quote user) (quote st2)) (nil? (get (ns-aliases (quote user)) (quote st2))))"] - ["ns-publics has var" "true" "(do (def npv 1) (some? (get (ns-publics (quote user)) (quote npv))))"] - ["newline returns nil" "nil" "(newline)"]) - -# A throw inside an interpreted fn body (or macro expander) must restore the -# caller's current-ns: the body runs with current-ns rebound to the fn's -# DEFINING ns, and an unwind that skipped the restore left the ctx stuck -# there — every later alias-qualified lookup in the REPL ns then failed -# ("Unable to resolve symbol: alias/...", seen via sci + clojure.edn). -(defspec "namespaces / error inside a fn must not leak its defining ns" - ["alias survives a throwing stdlib call" "\"A\"" - "(do (require (quote [clojure.string :as s9])) (try (s9/join nil nil nil) (catch Exception e nil)) (s9/upper-case \"a\"))"] - ["*ns* restored after throw" "\"user\"" - "(do (require (quote [clojure.walk :as w9])) (try (w9/postwalk nil nil nil) (catch Exception e nil)) (str *ns*))"]) - -# Alias bookkeeping is unified (jolt-ark): one string-keyed :aliases store, -# read by resolution AND ns-aliases (which presents Clojure's -# {alias-symbol -> namespace} shape); :imports holds class imports only. -(defspec "namespaces / unified alias store" - ["require :as registers the alias" "1" - "(do (require (quote [clojure.string :as st1])) (count (filter (fn [[a n]] (= (str a) \"st1\")) (ns-aliases))))"] - ["aliased call resolves" "\"A\"" - "(do (require (quote [clojure.string :as st2])) (st2/upper-case \"a\"))"] - ["alias fn registers + resolves" "\"B\"" - "(do (require (quote [clojure.string])) (alias (quote st3) (quote clojure.string)) (st3/upper-case \"b\"))"] - ["alias fn visible to ns-aliases" "true" - "(do (require (quote [clojure.string])) (alias (quote st4) (quote clojure.string)) (pos? (count (filter (fn [[a n]] (= (str a) \"st4\")) (ns-aliases)))))"] - ["ns-unalias removes both views" "[0 false]" - "(do (require (quote [clojure.string :as st5])) (ns-unalias (quote user) (quote st5)) [(count (filter (fn [[a n]] (= (str a) \"st5\")) (ns-aliases))) (boolean (resolve (quote st5/upper-case)))])"] - ["ns-resolve through alias" "true" - "(do (require (quote [clojure.string :as st6])) (var? (ns-resolve (quote user) (quote st6/upper-case))))"] - ["empty ns-aliases is a map" "true" "(map? (ns-aliases (quote clojure.core)))"]) diff --git a/test/spec/nrepl-spec.janet b/test/spec/nrepl-spec.janet deleted file mode 100644 index 2d635c0..0000000 --- a/test/spec/nrepl-spec.janet +++ /dev/null @@ -1,27 +0,0 @@ -# Specification: jolt.nrepl bencode codec (pure, no networking). -# The server/client wire behavior is covered by test/integration/nrepl-test.janet. -(use ../support/harness) - -(defn- b [body] - (string "(do (require '[jolt.nrepl :as nr]) " body ")")) -(defn- rt [body] - # round-trip a value through encode -> decode - (b (string "(nr/decode (nr/reader nil (nr/encode " body ")))"))) - -(defspec "jolt.nrepl / bencode round-trip" - ["integer" "42" (rt "42")] - ["negative" "-7" (rt "-7")] - ["string" "\"hello\"" (rt "\"hello\"")] - ["empty string" "\"\"" (rt "\"\"")] - ["list" "[\"a\" 1 \"b\"]" (rt "[\"a\" 1 \"b\"]")] - ["nested list" "[1 [2 3]]" (rt "[1 [2 3]]")] - ["dict" "{\"op\" \"eval\" \"id\" \"7\"}" (rt "{\"op\" \"eval\" \"id\" \"7\"}")] - ["dict with list" "{\"status\" [\"done\"]}" (rt "{\"status\" [\"done\"]}")] - ["nested dict" "{\"a\" {\"b\" 1}}" (rt "{\"a\" {\"b\" 1}}")]) - -(defspec "jolt.nrepl / bencode encode shape" - ["int" "\"i42e\"" (b "(nr/encode 42)")] - ["string" "\"5:hello\"" (b "(nr/encode \"hello\")")] - ["list" "\"li1ei2ee\"" (b "(nr/encode [1 2])")] - # dict keys are sorted lexicographically - ["dict sorted keys" "\"d1:ai1e1:bi2ee\"" (b "(nr/encode {\"b\" 2 \"a\" 1})")]) diff --git a/test/spec/ns-var-spec.janet b/test/spec/ns-var-spec.janet deleted file mode 100644 index aa44480..0000000 --- a/test/spec/ns-var-spec.janet +++ /dev/null @@ -1,16 +0,0 @@ -# Specification: *ns* — the current-namespace dynamic var (stage 3). -# *ns* holds the current NAMESPACE OBJECT; (str *ns*) is its name; it tracks -# in-ns at the top level and works with the ns-introspection fns. -(use ../support/harness) - -(defspec "*ns* / identity & printing" - ["str of *ns*" "\"user\"" "(str *ns*)"] - ["ns-name of *ns*" "(quote user)" "(ns-name *ns*)"] - ["*ns* is find-ns" "true" "(= (ns-name *ns*) (ns-name (find-ns (quote user))))"] - ["*ns* not a map" "false" "(map? *ns*)"] - ["tracks in-ns" "\"jolt.test-ns-a\"" "(do (in-ns (quote jolt.test-ns-a)) (str *ns*))"] - ["in-ns returns ns" "\"jolt.test-ns-b\"" "(str (in-ns (quote jolt.test-ns-b)))"] - ["usable with ns fns" "true" - "(do (require (quote clojure.string)) (alias (quote nsv) (quote clojure.string)) (some? (get (ns-aliases *ns*) (quote nsv))))"] - ["ns-unalias via *ns*" "true" - "(do (require (quote clojure.string)) (alias (quote nsw) (quote clojure.string)) (ns-unalias *ns* (quote nsw)) (nil? (get (ns-aliases *ns*) (quote nsw))))"]) diff --git a/test/spec/numbers-spec.janet b/test/spec/numbers-spec.janet deleted file mode 100644 index 8cf89b2..0000000 --- a/test/spec/numbers-spec.janet +++ /dev/null @@ -1,220 +0,0 @@ -# Specification: numbers & arithmetic. -(use ../support/harness) - -(defspec "numbers / arithmetic" - ["add" "6" "(+ 1 2 3)"] - ["add zero args" "0" "(+)"] - ["subtract" "5" "(- 10 3 2)"] - ["negate" "-5" "(- 5)"] - ["multiply" "24" "(* 2 3 4)"] - ["multiply zero args" "1" "(*)"] - ["divide" "2" "(/ 10 5)"] - ["divide to fraction" "0.5" "(/ 1 2)"] - ["inc" "6" "(inc 5)"] - ["dec" "4" "(dec 5)"] - ["quot" "3" "(quot 10 3)"] - ["rem" "1" "(rem 10 3)"] - ["mod" "2" "(mod -1 3)"] - ["rem negative" "-1" "(rem -1 3)"] - ["max" "9" "(max 3 9 1)"] - ["min" "1" "(min 3 9 1)"] - ["abs" "5" "(abs -5)"] - ["promoting + alias" "3" "(+' 1 2)"] - ["inc' alias" "6" "(inc' 5)"]) - -(defspec "numbers / comparison" - ["less than" "true" "(< 1 2 3)"] - ["less than false" "false" "(< 1 3 2)"] - ["greater than" "true" "(> 3 2 1)"] - ["<=" "true" "(<= 1 1 2)"] - [">=" "true" "(>= 3 3 2)"] - ["= numbers" "true" "(= 2 2)"] - ["= different" "false" "(= 2 3)"] - ["== numeric" "true" "(== 2 2)"] - ["not=" "true" "(not= 1 2)"] - ["compare less" "-1" "(compare 1 2)"] - ["compare equal" "0" "(compare 1 1)"] - ["compare greater" "1" "(compare 2 1)"]) - -(defspec "numbers / predicates" - ["zero?" "true" "(zero? 0)"] - ["pos?" "true" "(pos? 5)"] - ["neg?" "true" "(neg? -5)"] - ["even?" "true" "(even? 4)"] - ["odd?" "true" "(odd? 3)"] - ["number?" "true" "(number? 5)"] - ["number? false" "false" "(number? :a)"] - ["int?" "true" "(int? 5)"] - ["pos-int?" "true" "(pos-int? 5)"] - ["neg-int?" "true" "(neg-int? -5)"] - ["nat-int? zero" "true" "(nat-int? 0)"] - ["nat-int? neg" "false" "(nat-int? -1)"] - ["ratio? false" "false" "(ratio? 5)"]) - -# Symbolic float values and float/double predicates. NOTE: Janet represents -# integers and integer-valued doubles identically, so (float? 1.0) is false -# (1.0 is indistinguishable from 1) — a documented divergence. Fractional and -# non-finite values ARE recognized as floats. -(defspec "numbers / floats & symbolic values" - ["read ##Inf" "true" "(= ##Inf (/ 1.0 0.0))"] - ["read ##-Inf" "true" "(< ##-Inf 0)"] - ["##NaN not= itself" "true" "(not (== ##NaN ##NaN))"] - ["float? fractional" "true" "(float? 1.5)"] - ["double? fractional" "true" "(double? 0.25)"] - ["float? integer" "false" "(float? 3)"] - ["float? ##Inf" "true" "(float? ##Inf)"] - ["double? ##NaN" "true" "(double? ##NaN)"] - ["infinite? ##Inf" "true" "(infinite? ##Inf)"] - ["infinite? ##-Inf" "true" "(infinite? ##-Inf)"] - ["infinite? finite" "false" "(infinite? 1.5)"] - ["NaN? ##NaN" "true" "(NaN? ##NaN)"] - ["NaN? number" "false" "(NaN? 1.0)"] - ["int? ##Inf false" "false" "(int? ##Inf)"] - ["pos-int? ##Inf" "false" "(pos-int? ##Inf)"]) - -# Numeric literal syntaxes. Jolt has no true bignum/ratio/bigdec types, so the -# N (bigint) and M (bigdec) suffixes read as the plain number, ratios as the -# double quotient; radix integers (NrDDD) are parsed by base. -(defspec "numbers / literal syntax" - ["bigint suffix N" "42" "42N"] - ["bigint zero" "0" "0N"] - ["bigdec suffix M" "1.5" "1.5M"] - ["bigdec int M" "0" "0.0M"] - ["ratio -> double" "0.5" "1/2"] - ["ratio 3/4" "0.75" "3/4"] - ["neg ratio" "-0.5" "-1/2"] - ["radix binary" "10" "2r1010"] - ["radix hex-ish" "255" "16rFF"] - ["radix base36" "35" "36rZ"] - ["hex" "255" "0xFF"] - ["exponent" "1000.0" "1e3"] - ["exponent neg" "0.015" "1.5e-2"]) - -# Strictness: numeric ops reject non-numbers like Clojure; the integer -# predicates reject non-integers; quot/rem/mod reject zero/non-finite. -(defspec "numbers / strictness (throws like Clojure)" - ["odd? nil" :throws "(odd? nil)"] - ["odd? fractional" :throws "(odd? 1.5)"] - ["even? inf" :throws "(even? ##Inf)"] - ["zero? nil" :throws "(zero? nil)"] - ["pos? false" :throws "(pos? false)"] - ["neg? keyword" :throws "(neg? :a)"] - ["< nil" :throws "(< nil 1)"] - ["> with nil" :throws "(> 1 nil)"] - ["max non-number" :throws "(max 1 nil)"] - ["quot by zero" :throws "(quot 10 0)"] - ["quot inf" :throws "(quot ##Inf 1)"] - ["< arity-1 any" "true" "(< :anything)"] - ["odd? ok" "true" "(odd? 3)"] - ["< ok" "true" "(< 1 2 3)"] - ["quot ok" "3" "(quot 10 3)"]) - -(defspec "numbers / printing of inf & nan" - ["str Infinity" "\"Infinity\"" "(str ##Inf)"] - ["str -Infinity" "\"-Infinity\"" "(str ##-Inf)"] - ["str NaN" "\"NaN\"" "(str ##NaN)"] - ["pr-str Infinity" "\"Infinity\"" "(pr-str ##Inf)"] - ["inf inside coll" "\"[Infinity]\"" "(str [##Inf])"]) - -(defspec "numbers / bit-ops & math" - ["bit-and" "4" "(bit-and 12 6)"] - ["bit-or" "14" "(bit-or 12 6)"] - ["bit-xor" "10" "(bit-xor 12 6)"] - ["bit-shift-left" "8" "(bit-shift-left 1 3)"] - ["bit-shift-right" "2" "(bit-shift-right 8 2)"] - ["bit-set" "8" "(bit-set 0 3)"] - ["bit-clear" "13" "(bit-clear 15 1)"] - ["bit-test true" "true" "(bit-test 4 2)"] - ["bigint 64-bit" "\"9000000000\"" "(str (bigint 9000000000))"]) - -(defspec "numbers / random (invariants — non-deterministic)" - ["rand-int in range" "true" "(let [r (rand-int 5)] (and (integer? r) (>= r 0) (< r 5)))"] - ["rand-int zero" "0" "(rand-int 1)"] - ["rand in [0,1)" "true" "(let [r (rand)] (and (>= r 0) (< r 1)))"] - ["rand n in [0,n)" "true" "(let [r (rand 10)] (and (>= r 0) (< r 10)))"] - ["rand-nth member" "true" "(contains? #{:a :b :c} (rand-nth [:a :b :c]))"] - ["rand-nth single" ":x" "(rand-nth [:x])"]) - -# Clojure 1.11 string->scalar parsers: nil on malformed, throw on non-string. -(defspec "numbers / parse fns (1.11)" - ["parse-long" "42" "(parse-long \"42\")"] - ["parse-long negative" "-7" "(parse-long \"-7\")"] - ["parse-long plus" "7" "(parse-long \"+7\")"] - ["parse-long float nil" "nil" "(parse-long \"1.5\")"] - ["parse-long hex nil" "nil" "(parse-long \"0x10\")"] - ["parse-long empty nil" "nil" "(parse-long \"\")"] - ["parse-long junk nil" "nil" "(parse-long \"12ab\")"] - ["parse-long throws" :throws "(parse-long 42)"] - ["parse-double" "1.5" "(parse-double \"1.5\")"] - ["parse-double int" "4.0" "(parse-double \"4\")"] - ["parse-double sci" "1500.0" "(parse-double \"1.5e3\")"] - ["parse-double neg" "-0.5" "(parse-double \"-0.5\")"] - ["parse-double junk" "nil" "(parse-double \"abc\")"] - ["parse-double trail" "nil" "(parse-double \"1.5x\")"] - ["parse-double throws" :throws "(parse-double :k)"] - ["parse-boolean true" "true" "(parse-boolean \"true\")"] - ["parse-boolean false" "false" "(parse-boolean \"false\")"] - ["parse-boolean case" "nil" "(parse-boolean \"True\")"] - ["parse-boolean junk" "nil" "(parse-boolean \"yes\")"] - ["parse-boolean throws" :throws "(parse-boolean true)"]) - -# Jolt numbers don't overflow, so the auto-promoting (') and unchecked -# variants are aliases of the checked ops (overlay defs, core/20-coll.clj). -(defspec "numbers / promoting & unchecked aliases" - ["+'" "3" "(+' 1 2)"] - ["-'" "3" "(-' 5 2)"] - ["*'" "12" "(*' 3 4)"] - ["inc'" "6" "(inc' 5)"] - ["dec'" "4" "(dec' 5)"] - ["unchecked-add" "5" "(unchecked-add 2 3)"] - ["unchecked-add-int" "5" "(unchecked-add-int 2 3)"] - ["unchecked-subtract" "3" "(unchecked-subtract 5 2)"] - ["unchecked-subtract-int" "3" "(unchecked-subtract-int 5 2)"] - ["unchecked-multiply" "12" "(unchecked-multiply 3 4)"] - ["unchecked-multiply-int" "12" "(unchecked-multiply-int 3 4)"] - ["unchecked-negate" "-5" "(unchecked-negate 5)"] - ["unchecked-negate-int" "-5" "(unchecked-negate-int 5)"] - ["unchecked-inc" "2" "(unchecked-inc 1)"] - ["unchecked-inc-int" "2" "(unchecked-inc-int 1)"] - ["unchecked-dec" "0" "(unchecked-dec 1)"] - ["unchecked-dec-int" "0" "(unchecked-dec-int 1)"] - ["unchecked-divide-int" "3" "(unchecked-divide-int 7 2)"] - ["unchecked-divide-int negative truncates toward zero" "-3" "(unchecked-divide-int -7 2)"] - ["unchecked-divide-int by zero throws" :throws "(unchecked-divide-int 1 0)"] - ["unchecked-remainder-int" "1" "(unchecked-remainder-int 7 2)"] - ["unchecked-remainder-int negative" "-1" "(unchecked-remainder-int -7 2)"] - ["unchecked-int truncates" "3" "(unchecked-int 3.7)"] - ["unchecked-int negative" "-3" "(unchecked-int -3.7)"] - ["unchecked-long" "3" "(unchecked-long 3.7)"] - ["int? on integer" "true" "(int? 5)"] - ["int? on double" "false" "(int? 5.5)"] - ["int? on non-number" "false" "(int? \"5\")"] - ["num passes a number through" "5" "(num 5)"] - ["num on a double" "5.5" "(num 5.5)"] - ["num throws on non-number" :throws "(num \"x\")"]) - -# == is numeric equality: single arg is trivially true (Clojure's 1-arity -# never inspects the value); 2+ args must be numbers. -(defspec "numbers / == numeric equality" - ["== single arg" "true" "(== :a)"] - ["== equal" "true" "(== 2 2)"] - ["== unequal" "false" "(== 2 3)"] - ["== chained" "true" "(== 2 2 2)"] - ["== chained unequal" "false" "(== 2 2 3)"] - ["== int and double" "true" "(== 1 1.0)"] - ["== throws on non-number" :throws "(== 1 :a)"] - ["== throws on two keywords" :throws "(== :a :a)"]) - -# Variadic bit ops (canonical Clojure arities: binary host op folded over the -# rest). Shift/clear/set/flip/test stay 2-arg, as in Clojure. -(defspec "numbers / variadic bit ops" - ["bit-and 2" "4" "(bit-and 12 6)"] - ["bit-and 3" "4" "(bit-and 12 6 7)"] - ["bit-and 4" "0" "(bit-and 12 6 7 3)"] - ["bit-or 3" "7" "(bit-or 1 2 4)"] - ["bit-xor 3" "7" "(bit-xor 1 2 4)"] - ["bit-xor folds left" "1" "(bit-xor 5 6 2)"] - ["bit-and-not 2" "8" "(bit-and-not 12 6)"] - ["bit-and-not 3" "8" "(bit-and-not 12 6 3)"] - ["bit-and single arg throws" :throws "(bit-and 5)"] - ["bit-or keeps binary fast path" "3" "(bit-or 1 2)"]) diff --git a/test/spec/predicates-spec.janet b/test/spec/predicates-spec.janet deleted file mode 100644 index fd77d90..0000000 --- a/test/spec/predicates-spec.janet +++ /dev/null @@ -1,229 +0,0 @@ -# Specification: type & value predicates. -(use ../support/harness) - -(defspec "predicates / nil & boolean" - ["nil? true" "true" "(nil? nil)"] - ["nil? false" "false" "(nil? 0)"] - ["some? true" "true" "(some? 0)"] - ["some? on nil" "false" "(some? nil)"] - ["true?" "true" "(true? true)"] - ["false?" "true" "(false? false)"] - ["boolean? true" "true" "(boolean? false)"] - ["not nil" "true" "(not nil)"] - ["not 0 is false" "false" "(not 0)"] - ["boolean of nil" "false" "(boolean nil)"] - ["boolean of value" "true" "(boolean 5)"]) - -(defspec "predicates / types" - ["string?" "true" "(string? \"x\")"] - ["number?" "true" "(number? 1)"] - ["keyword?" "true" "(keyword? :a)"] - ["symbol?" "true" "(symbol? (quote a))"] - ["char?" "true" "(char? \\a)"] - ["fn? on fn" "true" "(fn? inc)"] - ["ifn? on keyword" "true" "(ifn? :a)"] - ["vector?" "true" "(vector? [1])"] - ["list?" "true" "(list? (list 1))"] - ["map?" "true" "(map? {:a 1})"] - ["set?" "true" "(set? #{1})"] - ["coll? vector" "true" "(coll? [1])"] - ["coll? map" "true" "(coll? {:a 1})"] - ["coll? on number" "false" "(coll? 1)"] - ["seq? list" "true" "(seq? (list 1))"] - ["seq? vector" "false" "(seq? [1])"] - ["sequential? vector" "true" "(sequential? [1])"] - ["associative? map" "true" "(associative? {:a 1})"] - ["associative? vec" "true" "(associative? [1])"] - ["associative? list" "false" "(associative? '(1 2))"] - ["associative? set" "false" "(associative? #{1})"] - ["reversible? vec" "true" "(reversible? [1 2])"] - ["reversible? list" "false" "(reversible? '(1 2))"] - ["reversible? smap" "true" "(reversible? (sorted-map :a 1))"] - ["reversible? hmap" "false" "(reversible? (hash-map :a 1))"] - ["indexed? vector" "true" "(indexed? [1])"] - ["counted? vector" "true" "(counted? [1])"]) - -(defspec "predicates / idents" - ["ident? keyword" "true" "(ident? :a)"] - ["ident? symbol" "true" "(ident? (quote a))"] - ["simple-keyword?" "true" "(simple-keyword? :a)"] - ["qualified-keyword?" "true" "(qualified-keyword? :a/b)"] - ["simple-symbol?" "true" "(simple-symbol? (quote a))"] - ["qualified-symbol?" "true" "(qualified-symbol? (quote a/b))"] - ["name of keyword" "\"a\"" "(name :a)"] - ["name of qualified" "\"b\"" "(name :a/b)"] - ["namespace" "\"a\"" "(namespace :a/b)"] - ["namespace simple" "nil" "(namespace :a)"] - ["keyword constructor" ":foo" "(keyword \"foo\")"] - ["keyword ns + name" ":a/b" "(keyword \"a\" \"b\")"] - ["symbol constructor" "(quote x)" "(symbol \"x\")"] - ["name of string" "\"s\"" "(name \"s\")"]) - -# Predicates moved from Janet to the Clojure overlay (jolt-1j0). Jolt has no -# ratio/bigdecimal types (so ratio?/decimal? are always false, rational?=int?), -# and no distinct host object/undefined types (object?/undefined? always false). -(defspec "predicates / overlay-migrated" - ["not-any? true" "true" "(not-any? even? [1 3 5])"] - ["not-any? false" "false" "(not-any? even? [1 2 3])"] - ["not-every? true" "true" "(not-every? even? [2 4 5])"] - ["not-every? false" "false" "(not-every? even? [2 4 6])"] - ["ident? number" "false" "(ident? 1)"] - ["qualified-ident?" "true" "(qualified-ident? :a/b)"] - ["qualified-ident? no" "false" "(qualified-ident? :a)"] - ["simple-ident?" "true" "(simple-ident? :a)"] - ["ratio?" "false" "(ratio? 3)"] - ["decimal?" "false" "(decimal? 3)"] - # No first-class Class objects on this host (class names are symbols handled - # in instance?/new positions), so class? is always false — like Clojure's - # class? of a symbol. Selmer's `exception` macro calls it at expansion time. - ["class? of value" "false" "(class? \"s\")"] - ["class? of symbol" "false" "(class? 'java.lang.String)"] - ["rational? int" "true" "(rational? 3)"] - ["rational? float" "false" "(rational? 3.5)"] - ["nat-int? zero" "true" "(nat-int? 0)"] - ["nat-int? neg" "false" "(nat-int? -1)"] - ["pos-int?" "true" "(pos-int? 5)"] - ["neg-int?" "true" "(neg-int? -3)"] - ["NaN? on nan" "true" "(NaN? (/ 0.0 0.0))"] - ["NaN? on number" "false" "(NaN? 5)"] - ["abs negative" "3" "(abs -3)"] - ["abs positive" "2.5" "(abs 2.5)"] - ["object?" "false" "(object? 1)"] - ["undefined?" "false" "(undefined? 1)"] - ["keyword-identical?" "true" "(keyword-identical? :a :a)"] - ["keyword-identical? no" "false" "(keyword-identical? :a :b)"]) - -# Tagged-value predicates moved to the overlay in Phase 4 (read the value's -# :jolt/type via get). The constructors stay native. -# map?/coll? are STRICT (jolt-6s2 cleanup): tagged structs (symbols, chars, -# uuids) are values, not collections; sorted maps/sets and records ARE -# collections (and sorted-map/record are map?), matching Clojure. -(defspec "predicates / map? & coll? strictness" - ["map? symbol" "false" "(map? (quote sym))"] - ["map? char" "false" "(map? \\a)"] - ["map? uuid" "false" "(map? (random-uuid))"] - ["map? literal" "true" "(map? {:a 1})"] - ["map? hash-map" "true" "(map? (hash-map :a 1))"] - ["map? sorted-map" "true" "(map? (sorted-map :a 1))"] - ["map? record" "true" "(do (defrecord Mr [a]) (map? (->Mr 1)))"] - ["map? sorted-set" "false" "(map? (sorted-set 1))"] - ["map? vector" "false" "(map? [1])"] - ["coll? symbol" "false" "(coll? (quote sym))"] - ["coll? char" "false" "(coll? \\a)"] - ["coll? uuid" "false" "(coll? (random-uuid))"] - ["coll? keyword" "false" "(coll? :k)"] - ["coll? string" "false" "(coll? \"s\")"] - ["coll? map literal" "true" "(coll? {:a 1})"] - ["coll? sorted-map" "true" "(coll? (sorted-map :a 1))"] - ["coll? sorted-set" "true" "(coll? (sorted-set 1))"] - ["coll? record" "true" "(do (defrecord Cr [a]) (coll? (->Cr 1)))"] - ["coll? vector" "true" "(coll? [1])"] - ["coll? list" "true" "(coll? (list 1))"] - ["coll? set" "true" "(coll? #{1})"] - ["coll? lazy seq" "true" "(coll? (map inc [1]))"]) - -(defspec "predicates / tagged-value (Phase 4)" - ["atom? yes" "true" "(atom? (atom 1))"] - ["atom? no" "false" "(atom? 1)"] - ["volatile? yes" "true" "(volatile? (volatile! 1))"] - ["volatile? no" "false" "(volatile? (atom 1))"] - ["record? yes" "true" "(do (defrecord Rp [a]) (record? (->Rp 1)))"] - ["record? no map" "false" "(record? {:a 1})"] - ["record? no nil" "false" "(record? nil)"] - ["tagged-literal? yes" "true" "(tagged-literal? (tagged-literal (quote inst) \"2020\"))"] - ["tagged-literal? no" "false" "(tagged-literal? 1)"] - ["reader-conditional? no" "false" "(reader-conditional? 1)"] - ["chunked-seq? always false" "false" "(chunked-seq? (seq [1 2 3]))"]) - -(defspec "predicates / equality & identity" - ["= same" "true" "(= 1 1)"] - ["= vectors" "true" "(= [1 2] [1 2])"] - ["= vector & list" "true" "(= [1 2] (list 1 2))"] - ["= maps" "true" "(= {:a 1} {:a 1})"] - ["= sets" "true" "(= #{1 2} #{2 1})"] - ["= nested" "true" "(= {:a [1 2]} {:a [1 2]})"] - ["not= differs" "true" "(not= [1 2] [1 3])"] - ["identical? same kw" "true" "(identical? :a :a)"] - ["compare strings" "-1" "(compare \"a\" \"b\")"]) - -(defspec "predicates / seqable, reduced & emptiness" - ["seqable? vector" "true" "(seqable? [1])"] - ["seqable? map" "true" "(seqable? {:a 1})"] - ["seqable? string" "true" "(seqable? \"s\")"] - ["seqable? nil" "true" "(seqable? nil)"] - ["seqable? number" "false" "(seqable? 5)"] - ["integer? int" "true" "(integer? 5)"] - ["integer? fraction" "false" "(integer? 5.5)"] - ["reduced? wrapped" "true" "(reduced? (reduced 1))"] - ["reduced? plain" "false" "(reduced? 1)"] - ["deref reduced" "9" "(deref (reduced 9))"] - ["unreduced wrapped" "9" "(unreduced (reduced 9))"] - ["unreduced plain" "9" "(unreduced 9)"] - ["not-empty full" "[1]" "(not-empty [1])"] - ["not-empty empty" "nil" "(not-empty [])"] - ["not-empty string" "nil" "(not-empty \"\")"]) - -# Stage 3 turn 2a: the implicit Janet root-env fallback is GONE — these are now -# proper interned clojure.core vars with Clojure semantics (compare's total -# order, meta-aware type, any?, gensym returning jolt symbols). -(defspec "predicates / compare, type, any? (stage 3)" - ["compare =" "0" "(compare 1 1)"] - ["compare <" "-1" "(compare 1 2)"] - ["compare nil first" "-1" "(compare nil 1)"] - ["compare nil nil" "0" "(compare nil nil)"] - ["compare strings" "-1" "(compare \"a\" \"b\")"] - ["compare keywords" "-1" "(compare :a :b)"] - ["compare symbols" "-1" "(compare (quote a) (quote b))"] - ["compare bools" "-1" "(compare false true)"] - ["compare vec length" "-1" "(compare [1 2] [1 2 3])"] - ["compare vec elems" "-1" "(compare [1 2] [1 3])"] - ["compare cross-type throws" :throws "(compare 1 \"a\")"] - ["sort with compare" "[nil 1 3]" "(sort compare [3 nil 1])"] - ["type meta override" ":custom" "(type (with-meta [1] {:type :custom}))"] - ["type of record" "true" "(do (defrecord TyR [a]) (= (symbol (str (type (->TyR 1)))) (type (->TyR 1))))"] - ["any? value" "true" "(any? 5)"] - ["any? nil" "true" "(any? nil)"] - ["gensym is symbol" "true" "(symbol? (gensym))"] - ["gensym prefix" "true" "(do (require (quote [clojure.string :as s])) (s/starts-with? (str (gensym \"p_\")) \"p_\"))"] - ["gensym distinct" "false" "(= (gensym) (gensym))"] - ["int? Inf false" "false" "(int? ##Inf)"] - ["integer? Inf false" "false" "(integer? ##Inf)"] - ["integer? NaN false" "false" "(integer? ##NaN)"]) - -# ifn? is the canonical IFn set (jolt-1vx): lists are NOT IFn. -(defspec "predicates / ifn?" - ["fn" "true" "(ifn? inc)"] - ["keyword" "true" "(ifn? :k)"] - ["symbol" "true" "(ifn? (quote s))"] - ["map" "true" "(ifn? {})"] - ["sorted map" "true" "(ifn? (sorted-map))"] - ["set" "true" "(ifn? #{1})"] - ["vector" "true" "(ifn? [1])"] - ["var" "true" "(ifn? (var first))"] - ["list NOT" "false" "(ifn? (list 1 2))"] - ["lazy NOT" "false" "(ifn? (map inc [1]))"] - ["string NOT" "false" "(ifn? \"s\")"] - ["number NOT" "false" "(ifn? 5)"] - ["nil NOT" "false" "(ifn? nil)"]) - -# zero?/pos? throw on non-numbers (Numbers.isZero/isPos), as in Clojure; -# every? short-circuits on the first falsey pred result, so an infinite seq -# with an early counterexample terminates. char? is the tagged-value check. -(defspec "predicates / numeric guards & every? (overlay moves)" - ["zero? zero" "true" "(zero? 0)"] - ["zero? nonzero" "false" "(zero? 3)"] - ["zero? throws" :throws "(zero? :a)"] - ["zero? throws on nil" :throws "(zero? nil)"] - ["pos? positive" "true" "(pos? 2)"] - ["pos? zero" "false" "(pos? 0)"] - ["pos? throws" :throws "(pos? \"x\")"] - ["neg? throws" :throws "(neg? \"x\")"] - ["every? all pass" "true" "(every? odd? [1 3 5])"] - ["every? one fails" "false" "(every? odd? [1 2 5])"] - ["every? vacuous" "true" "(every? odd? [])"] - ["every? nil coll" "true" "(every? odd? nil)"] - ["every? infinite short-circuit" "false" "(every? pos? (range))"] - ["char? char" "true" "(char? \\x)"] - ["char? string" "false" "(char? \"x\")"] - ["char? number" "false" "(char? 97)"] - ["char? nil" "false" "(char? nil)"]) diff --git a/test/spec/protocols-spec.janet b/test/spec/protocols-spec.janet deleted file mode 100644 index b14a723..0000000 --- a/test/spec/protocols-spec.janet +++ /dev/null @@ -1,64 +0,0 @@ -# Specification: protocols, types and records. -(use ../support/harness) - -(defspec "protocols / defprotocol & dispatch" - ["protocol on record" "16" - "(do (defprotocol Shape (area [s])) (defrecord Sq [side] Shape (area [_] (* side side))) (area (->Sq 4)))"] - ["protocol on deftype" "16" - "(do (defprotocol Shape (area [s])) (deftype Sq [side] Shape (area [_] (* side side))) (area (->Sq 4)))"] - ["multiple methods" "[1 2]" - "(do (defprotocol P (m [s]) (n [s])) (defrecord R [a b] P (m [_] a) (n [_] b)) [(m (->R 1 2)) (n (->R 1 2))])"] - ["multiple protocols" "[:a :b]" - "(do (defprotocol P1 (p1 [s])) (defprotocol P2 (p2 [s])) (deftype T [] P1 (p1 [_] :a) P2 (p2 [_] :b)) [(p1 (->T)) (p2 (->T))])"] - ["method args" "7" - "(do (defprotocol P (add [s x])) (defrecord R [n] P (add [_ x] (+ n x))) (add (->R 5) 2))"] - ["extend-type" "10" - "(do (defprotocol P (twice [s])) (extend-type Number P (twice [n] (* n 2))) (twice 5))"] - ["extend-protocol" "[2 4]" - "(do (defprotocol P (dbl [s])) (extend-protocol P Number (dbl [n] (* n 2))) [(dbl 1) (dbl 2)])"]) - -(defspec "protocols / records" - ["record field access" "1" - "(do (defrecord R [a b]) (:a (->R 1 2)))"] - ["record map access" "2" - "(do (defrecord R [a b]) (get (->R 1 2) :b))"] - ["record equality" "true" - "(do (defrecord R [a b]) (= (->R 1 2) (->R 1 2)))"] - ["record inequality" "false" - "(do (defrecord R [a b]) (= (->R 1 2) (->R 3 4)))"] - ["map-> factory" "1" - "(do (defrecord R [a b]) (:a (map->R {:a 1 :b 2})))"] - ["record? true" "true" - "(do (defrecord R [a]) (record? (->R 1)))"] - ["assoc on record" "9" - "(do (defrecord R [a]) (:a (assoc (->R 1) :a 9)))"]) - -(defspec "protocols / reify & satisfies" - ["reify dispatch" "42" - "(do (defprotocol P (m [_])) (m (reify P (m [_] 42))))"] - ["reify multi-method" "[1 2]" - "(do (defprotocol P (a [_]) (b [_])) (let [r (reify P (a [_] 1) (b [_] 2))] [(a r) (b r)]))"] - ["satisfies? true" "true" - "(do (defprotocol P (m [_])) (defrecord R [] P (m [_] 1)) (satisfies? P (->R)))"] - ["satisfies? false" "false" - "(do (defprotocol P (m [_])) (defrecord R []) (satisfies? P (->R)))"] - ["satisfies? reify" "true" - "(do (defprotocol P (m [_])) (satisfies? P (reify P (m [_] 1))))"] - ["satisfies? reify multi-protocol" "[true true]" - "(do (defprotocol P (m [_])) (defprotocol Q (n [_])) (let [r (reify P (m [_] 1) Q (n [_] 2))] [(satisfies? P r) (satisfies? Q r)]))"] - ["satisfies? reify other proto" "false" - "(do (defprotocol P (m [_])) (defprotocol Q (n [_])) (satisfies? Q (reify P (m [_] 1))))"] - ["instance? record" "true" - "(do (defrecord R [a]) (instance? R (->R 1)))"] - ["dot constructor" "5" - "(do (deftype P [n]) (.-n (P. 5)))"] - ["dot ctor + method" "5" - "(do (defprotocol G (val-of [_])) (deftype P [n] G (val-of [_] n)) (val-of (P. 5)))"]) - -# defprotocol accepts Clojure's optional docstring + leading keyword options -# before the signatures (honeysql: :extend-via-metadata true). -(defspec "protocols / defprotocol options" - ["docstring + option + method" ":hi" - "(do (defprotocol Pdoc \"docs\" :extend-via-metadata true (greet [x])) (extend-protocol Pdoc String (greet [s] :hi)) (greet \"x\"))"] - ["option only" "3" - "(do (defprotocol Popt :extend-via-metadata true (plus2 [x])) (extend-protocol Popt Long (plus2 [n] (+ n 2))) (plus2 1))"]) diff --git a/test/spec/reader-forms-spec.janet b/test/spec/reader-forms-spec.janet deleted file mode 100644 index 08e4d59..0000000 --- a/test/spec/reader-forms-spec.janet +++ /dev/null @@ -1,80 +0,0 @@ -# Specification: reader forms + syntax-quote + metadata. -# -# Adapted from the jank test corpus (test/jank/{syntax-quote,metadata,reader-macro, -# call}); we keep our own copies since jank may diverge. Syntax-quoted symbols are -# qualified to clojure.core (matching jank/Clojure). Platform-specific reader forms -# (#uuid, #inst, ##Inf/##NaN, bigdecimal/biginteger/ratio) are omitted. -(use ../support/harness) - -(defspec "reader / anonymous fn #()" - ["no args" "3" "(#(+ 1 2))"] - ["one arg %" "6" "(#(* % 2) 3)"] - ["positional %1 %2" "[1 2]" "(#(do [%1 %2]) 1 2)"] - ["rest %&" "[1 2 3]" "(#(do %&) 1 2 3)"] - ["fixed + rest" "[2 3]" "(#(do % %&) 1 2 3)"] - ["%2 + rest" "[3]" "(#(do %2 %&) 1 2 3)"] - ["%2 only (placeholder p1)" "20" "(#(* %2 2) 1 10)"] - ["% and %1 same" "10" "(#(+ % %1) 5)"]) - -(defspec "reader / var-quote #'" - ["var-quote = var" "true" "(= (var str) #'str)"] - ["is a var" "true" "(var? #'str)"] - ["deref var-quote" "5" "(do (def w 5) (deref #'w))"]) - -(defspec "reader / metadata ^" - ["meta on map" "true" "(:foo (meta ^:foo {}))"] - ["meta on vector" "true" "(:foo (meta ^:foo [1 2]))"] - ["meta on set" "true" "(:foo (meta ^:foo #{}))"] - ["meta map form" "1" "(:a (meta ^{:a 1} {}))"] - ["meta on quoted sym" "true" "(:foo (meta (quote ^:foo bar)))"] - ["with-meta map" "true" "(:k (meta (with-meta {} {:k true})))"] - ["with-meta vector" "true" "(:k (meta (with-meta [] {:k true})))"] - ["non-metadatable num" "nil" "(meta 100)"] - ["non-metadatable str" "nil" "(meta \"\")"] - ["non-metadatable bool" "nil" "(meta true)"]) - -(defspec "reader / syntax-quote" - ["plain literal" "[1 2 3]" "`[1 2 3]"] - ["gensym distinct" "true" "(not= `meow# `meow#)"] - ["gensym stable" "true" "(let [s `[meow# meow#]] (= (first s) (second s)))"] - ["qualifies unresolved" "(quote user/foo)" "`foo"] - # jolt-265 (fixed): resolved core symbols fully-qualify to clojure.core/. - ["qualifies core sym" "(quote clojure.core/str)" "`str"] - ["unquote value" "[1 2 3]" "(let [a [1 2 3]] `~a)"] - ["unquote in call" "(quote (clojure.core/str [1 2 3]))" "(let [a [1 2 3]] `(str ~a))"] - ["splice empty" "(quote (clojure.core/str))" "(let [e []] `(str ~@e))"] - ["splice values" "(quote (clojure.core/str 1 2 3))" "(let [a [1 2 3]] `(str ~@a))"] - ["splice in vector" "[1 2 3 0 1 2 3]" "(let [b [0] a [1 2 3] e []] `[~@e ~@a ~@b ~@a ~@e])"] - # jolt-edb (fixed): ~/~@ inside set literals. - ["splice in set" "#{0 1 2 3}" "(let [b [0] a [1 2 3] e []] `#{~@e ~@a ~@b})"] - ["unquote in set" "#{5 9}" "(let [x 5] `#{~x 9})"]) - -# Spec 02-reader S17/S19/S18/S13a/S22: discard, symbolic values, conditionals, -# var-quote identity, gensym stability (jank corpus derived). -(defspec "reader / discard, symbolic values, conditionals (spec 2.3)" - ["discard simple" "2" "(do #_1 2)"] - ["discard in vector" "[1 3]" "[1 #_2 3]"] - ["discard stacks" "3" "(do #_ #_ 1 2 3)"] - ["##Inf" "true" "(= ##Inf (/ 1.0 0.0))"] - ["##-Inf" "true" "(= ##-Inf (/ -1.0 0.0))"] - ["##NaN not self-equal" "false" "(= ##NaN ##NaN)"] - ["##NaN is NaN?" "true" "(NaN? ##NaN)"] - ["conditional :default reachable" "2" "#?(:no-such-dialect 1 :default 2)"] - ["var-quote qualified" "true" "(= (var clojure.core/str) #'clojure.core/str)"] - ["gensym stable in template" "true" "(let [syms `[meow# meow#]] (= (first syms) (second syms)))"] - ["gensym fresh across templates" "false" "(= `meow# `meow#)"]) - -# Spec 02-reader S25: syntax-quote of a self-evaluating literal is the literal -# (read-time collapse), so adjacent/nested backticks over literals are inert. -(defspec "reader / syntax-quote literal collapse (spec 2.4 S25)" - ["string once" "true" "(= \"meow\" `\"meow\")"] - ["string nested" "true" "(= \"meow\" ``\"meow\")"] - ["string triple" "true" "(= \"meow\" ```\"meow\")"] - ["number nested" "true" "(= 42 ``42)"] - ["keyword nested" "true" "(= :k ``:k)"] - ["nil nested" "true" "(nil? ``nil)"] - ["char nested" "true" "(= \\a ``\\a)"] - ["bool nested" "true" "(= true ``true)"] - # collapse must NOT apply to symbols (they qualify) or collections (templates) - ["symbol still qualifies" "true" "(= (quote clojure.core/map) `map)"] - ["vector still templates" "true" "(= [1 2] `[1 ~(inc 1)])"]) diff --git a/test/spec/reader-syntax-spec.janet b/test/spec/reader-syntax-spec.janet deleted file mode 100644 index 7e39eae..0000000 --- a/test/spec/reader-syntax-spec.janet +++ /dev/null @@ -1,72 +0,0 @@ -# Specification: reader syntax & literals. -(use ../support/harness) - -(defspec "reader / scalar literals" - ["integer" "42" "42"] - ["negative" "-7" "-7"] - ["float" "1.5" "1.5"] - ["string" "\"hi\"" "\"hi\""] - ["boolean true" "true" "true"] - ["nil" "nil" "nil"] - ["keyword" ":a" ":a"] - ["namespaced keyword" "true" "(= :a/b :a/b)"] - ["char" "\\a" "\\a"] - ["char newline" "true" "(= \\newline (first \"\\n\"))"] - # single non-symbol chars are one-char literals (\{ \( \, \% etc.) - ["char open-brace" "123" "(int \\{)"] - ["char open-paren" "40" "(int \\()"] - ["char comma" "44" "(int \\,)"] - ["char percent" "37" "(int \\%)"] - ["char unicode" "65" "(int \\u0041)"] - ["hex literal" "255" "0xff"] - ["hex uppercase" "31" "0X1F"] - ["bigint suffix N" "42" "42N"] - ["bigdec suffix M" "1.5" "1.5M"] - ["ratio -> double" "0.75" "3/4"] - ["radix integer" "255" "16rFF"] - ["exponent" "1500.0" "1.5e3"] - ["symbolic Infinity" "true" "(infinite? ##Inf)"] - ["symbolic NaN" "true" "(NaN? ##NaN)"] - ["symbol via quote" "'foo" "'foo"]) - -(defspec "reader / collection literals" - ["vector" "[1 2 3]" "[1 2 3]"] - ["list quoted" "[1 2 3]" "'(1 2 3)"] - ["map" "{:a 1}" "{:a 1}"] - ["set" "#{1 2 3}" "#{1 2 3}"] - ["nested" "{:a [1 {:b 2}]}" "{:a [1 {:b 2}]}"] - ["empty vector" "[]" "[]"] - ["empty map" "{}" "{}"] - ["empty set" "#{}" "#{}"]) - -(defspec "reader / dispatch & sugar" - ["anon fn #()" "3" "(#(+ %1 %2) 1 2)"] - ["anon fn single %" "2" "(#(inc %) 1)"] - ["anon fn %&" "[2 3]" "(#(vec %&) 2 3)"] - ["discard #_" "[1 3]" "[1 #_2 3]"] - ["regex literal" "true" "(= \"abc\" (re-find #\"abc\" \"xabcx\"))"] - # Feature set is #{:jolt :default} (spec 02-reader S18; RFC 0002) — :clj - # branches are NOT taken; matching is by clause order. - ["reader conditional" "3" "#?(:clj 1 :cljs 2 :default 3)"] - ["reader cond :jolt" "4" "#?(:clj 1 :jolt 4 :default 3)"] - ["reader cond clause order" "5" "#?(:default 5 :jolt 6)"] - ["reader cond no match" "[]" "[#?(:clj 1 :cljs 2)]"] - ["reader cond splice" "[1 2 3]" "[#?@(:jolt [1 2 3] :cljs [4 5])]"] - ["reader cond splice no match" "[]" "[#?@(:clj [1 2 3] :cljs [4 5])]"] - ["inst literal reads" "true" "(some? #inst \"2020-01-01T00:00:00Z\")"] - ["uuid literal" "\"550e8400-e29b-41d4-a716-446655440000\"" "(str #uuid \"550e8400-e29b-41d4-a716-446655440000\")"] - ["tagged literal var" "true" "(var? #'+)"] - ["deref sugar" "5" "(let [a (atom 5)] @a)"] - ["meta sugar" "{:t 1}" "(meta ^{:t 1} [])"]) - -# Comments and #_ discards in a map's VALUE slot keep the pending key -# (jolt-ou8: dropping both desynced kv pairing — Selmer's deps.edn, with a -# "; for development (REPL, etc)" comment between key and value, read its -# closing brace in value position: 'Unmatched closing brace'). -(defspec "reader / comments inside maps" - ["comment in value slot" "{:a 1}" "{:a ; note\n 1}"] - ["comment before key" "{:a 1}" "{; lead\n :a 1}"] - ["comment between entries" "{:a 1 :b 2}" "{:a 1 ; mid\n :b 2}"] - ["discard in value slot" "{:a 1}" "{:a #_9 1}"] - ["comment with parens" "{:a {:b 1}}" "{:a ; dev (REPL, etc)\n {:b 1}}"] - ["nested with comments" "{:x {:y 2}}" "{:x ; outer\n {:y ; inner\n 2}}"]) diff --git a/test/spec/regex-spec.janet b/test/spec/regex-spec.janet deleted file mode 100644 index 78de377..0000000 --- a/test/spec/regex-spec.janet +++ /dev/null @@ -1,83 +0,0 @@ -# Specification: regular expressions — #"…" literals and the re-* fns. -# (Whole area previously unspecced; some cases adapted from jank reader-macro/regex.) -(use ../support/harness) - -(defspec "regex / literals & predicate" - ["regex? literal" "true" "(regex? #\"\\d+\")"] - ["regex? non-regex" "false" "(regex? \"\\d+\")"] - ["escaped digits" "\"42\"" "(re-find #\"\\d+\" \"x42y\")"] - ["escaped ws/non-ws" "\"x a\"" "(re-find #\"\\S\\s\\S\" \"x a b y\")"]) - -(defspec "regex / re-find" - ["match" "\"123\"" "(re-find #\"\\d+\" \"abc123def\")"] - ["no match nil" "nil" "(re-find #\"\\d+\" \"abc\")"] - ["with groups" "[\"a1\" \"a\" \"1\"]" "(re-find #\"([a-z])(\\d)\" \"--a1--\")"] - ["first match only" "\"1\"" "(re-find #\"\\d\" \"1 2 3\")"]) - -(defspec "regex / re-matches" - ["full match" "\"123\"" "(re-matches #\"\\d+\" \"123\")"] - ["partial = nil" "nil" "(re-matches #\"\\d+\" \"123abc\")"] - ["groups" "[\"12\" \"1\" \"2\"]" "(re-matches #\"(\\d)(\\d)\" \"12\")"] - ["no match nil" "nil" "(re-matches #\"x+\" \"yyy\")"]) - -(defspec "regex / re-seq" - ["all matches" "(quote (\"1\" \"22\" \"333\"))" "(re-seq #\"\\d+\" \"a1b22c333\")"] - ["empty when none" "nil" "(seq (re-seq #\"z\" \"abc\"))"] - ["words" "(quote (\"foo\" \"bar\"))" "(re-seq #\"\\w+\" \"foo bar\")"]) - -(defspec "regex / re-pattern & string ops" - ["re-pattern build" "\"hi\"" "(re-find (re-pattern \"\\\\w+\") \"hi!\")"] - ["re-pattern is regex?" "true" "(regex? (re-pattern \"a\"))"] - ["split on regex" "[\"a\" \"b\" \"c\"]" "(do (require '[clojure.string :as s]) (s/split \"a1b2c\" #\"\\d\"))"] - ["replace regex" "\"X-X\"" "(do (require '[clojure.string :as s]) (s/replace \"a-b\" #\"[a-z]\" \"X\"))"] - ["replace $1" "\"[a][b]\"" "(do (require '[clojure.string :as s]) (s/replace \"ab\" #\"([a-z])\" \"[$1]\"))"]) - -# Unicode property classes (jolt-xlp), byte-PEG approximation: ASCII exact, -# any high byte (inside a UTF-8 sequence) counts as a LETTER for \p{L}. -# Acceptance target was cuerdas (kebab/snake/capital now pass conformance). -(defspec "regex / \\p property classes" - ["p{L} ascii" "\"hello\"" `(re-matches #"^\p{L}+$" "hello")`] - ["p{L} utf-8" "true" `(boolean (re-matches #"^\p{L}+$" "héllo"))`] - ["p{L} rejects digits" "false" `(boolean (re-matches #"^\p{L}+$" "ab1"))`] - ["p{N}" "(quote (\"12\" \"345\"))" `(re-seq #"\p{N}+" "a12b345")`] - ["P{N} negation" "\"abc\"" `(re-matches #"^\P{N}+$" "abc")`] - ["inside class" "\"a-1_b\"" `(re-matches #"^[\p{N}\p{L}_-]+$" "a-1_b")`] - ["p{Lu}/p{Ll}" "\"aB\"" `(re-matches #"^\p{Ll}\p{Lu}$" "aB")`] - ["p{Z} space" "\" \"" `(re-matches #"(?u)^[\s\p{Z}]+$" " ")`] - ["p{Ps}/p{Pe}" "\"(x)\"" `(re-matches #"^\p{Ps}x\p{Pe}$" "(x)")`] - ["(?u) accepted" "\"hi\"" `(re-matches #"(?u)^hi$" "hi")`] - ["unknown class throws" :throws `(re-pattern "\p{Greek}")`]) - -# java.util.regex.Pattern statics (jolt-47b): compile returns jolt's native -# regex value (so .split / str-ops accept it), MULTILINE maps to (?m), quote -# escapes metachars. Plus the regex String methods migratus uses. -(defspec "regex / Pattern statics & String regex methods" - ["Pattern/compile is a regex" "true" "(regex? (Pattern/compile \"a.c\"))"] - ["compiled .split" "[\"a\" \"b\" \"c\"]" "(.split (Pattern/compile \",\") \"a,b,c\")"] - ["str/replace w/ Pattern" "\"ab\"" "(do (require '[clojure.string :as s]) (s/replace \"a1b2\" (Pattern/compile \"[0-9]\") \"\"))"] - ["Pattern/MULTILINE ^" "true" "(boolean (re-find (Pattern/compile \"^x\" Pattern/MULTILINE) \"y\\nx\"))"] - ["Pattern/quote literal" "true" "(boolean (re-find (re-pattern (Pattern/quote \"a.c\")) \"za.cy\"))"] - ["Pattern/quote not meta" "false" "(boolean (re-find (re-pattern (Pattern/quote \"a.c\")) \"zabcy\"))"] - [".matches whole string" "true" "(.matches \"abc\" \"a.c\")"] - [".matches partial -> false" "false" "(.matches \"abcd\" \"a.c\")"] - [".replaceAll regex" "\"a-b-c\"" "(.replaceAll \"a_b_c\" \"_\" \"-\")"] - [".replaceFirst regex" "\"a-b_c\"" "(.replaceFirst \"a_b_c\" \"_\" \"-\")"]) - -(defspec "regex / bounded quantifiers (jolt-3xur)" - ["exact {n}" "\"aaa\"" "(re-matches #\"a{3}\" \"aaa\")"] - ["range {n,m} max" "\"aaaa\"" "(re-find #\"a{2,4}\" \"aaaaa\")"] - ["zero lower {0,n}" "\"aa\"" "(re-find #\"a{0,3}\" \"aa\")"] - ["{n,} unbounded" "\"aaaa\"" "(re-find #\"a{2,}\" \"aaaa\")"] - # nested bounded quantifiers must not blow up the PEG compiler — this used to - # expand to ~2^61 nodes and hang at compile time. - ["nested bounds compile" "true" - "(boolean (re-matches #\"[a-z](?:[a-z]{0,61}[a-z])?(?:-[a-z]{0,61}[a-z])*\" \"abc-def\"))"]) - -(defspec "regex / backreferences (jolt-xtss)" - ["repeated char" "true" "(boolean (re-find #\"(.)\\1\" \"abba\"))"] - ["no repeat = nil" "nil" "(re-find #\"(.)\\1\" \"abc\")"] - ["thematic-break run" "true" "(boolean (re-matches #\"([-*_])\\1\\1\" \"---\"))"] - ["mismatched run" "nil" "(re-matches #\"([-*_])\\1\\1\" \"-*_\")"] - ["repeated word" "[\"the the\" \"the\"]" "(re-find #\"(\\w+) \\1\" \"say the the word\")"] - ["group still captures" "[\"x=x\" \"x\"]" "(re-matches #\"(\\w+)=\\1\" \"x=x\")"] - ["html tag pair" "true" "(boolean (re-matches #\"<(\\w+)>.*\" \"hi\"))"]) diff --git a/test/spec/sequences-spec.janet b/test/spec/sequences-spec.janet deleted file mode 100644 index 93d9428..0000000 --- a/test/spec/sequences-spec.janet +++ /dev/null @@ -1,310 +0,0 @@ -# Specification: the sequence abstraction (clojure.core). -# Sequential expecteds use vector literals — Jolt's `=` treats vectors and lists -# with the same elements as equal, so [2 3 4] matches a (2 3 4) seq result. -(use ../support/harness) - -(defspec "seq / access" - ["first of vector" "1" "(first [1 2 3])"] - ["first of list" "1" "(first (list 1 2 3))"] - ["first of empty is nil" "nil" "(first [])"] - ["first of nil is nil" "nil" "(first nil)"] - ["second" "2" "(second [1 2 3])"] - ["last" "3" "(last [1 2 3])"] - ["rest of vector" "[2 3]" "(rest [1 2 3])"] - ["rest of single" "[]" "(rest [1])"] - ["rest of empty" "[]" "(rest [])"] - ["next of single is nil" "nil" "(next [1])"] - ["next of empty is nil" "nil" "(next [])"] - ["nth" "30" "(nth [10 20 30] 2)"] - ["nth with default" "99" "(nth [10] 5 99)"] - ["nth out of range" :throws "(nth [10] 5)"] - ["ffirst" "1" "(ffirst [[1 2] [3 4]])"] - ["fnext" "2" "(fnext [1 2 3])"] - ["nnext" "[3 4]" "(nnext [1 2 3 4])"]) - -(defspec "seq / construction" - ["cons onto list" "[0 1 2]" "(cons 0 (list 1 2))"] - ["cons onto vector" "[0 1 2]" "(cons 0 [1 2])"] - ["cons onto nil" "[0]" "(cons 0 nil)"] - ["conj vector appends" "[1 2 3]" "(conj [1 2] 3)"] - ["conj list prepends" "[0 1 2]" "(conj (list 1 2) 0)"] - ["conj multiple on vec" "[1 2 3 4]" "(conj [1 2] 3 4)"] - ["conj multiple on list" "[4 3 1 2]" "(conj (list 1 2) 3 4)"] - ["seq of empty is nil" "nil" "(seq [])"] - ["seq of nil is nil" "nil" "(seq nil)"] - ["seq of string" "[\\a \\b]" "(seq \"ab\")"] - ["empty?" "true" "(empty? [])"] - ["not empty?" "false" "(empty? [1])"] - ["count" "3" "(count [1 2 3])"] - ["count of nil" "0" "(count nil)"] - ["count of string" "3" "(count \"abc\")"]) - -(defspec "seq / map filter reduce" - ["map" "[2 3 4]" "(map inc [1 2 3])"] - ["map two colls" "[5 7 9]" "(map + [1 2 3] [4 5 6])"] - ["map stops at shortest" "[5 7]" "(map + [1 2] [4 5 6])"] - # nil elements are values, not end-of-seq: multi-coll map must not truncate. - ["map keeps nil elements" "[[1 :a] [nil :b] [3 nil]]" "(map vector [1 nil 3] [:a :b nil])"] - ["map 3 colls" "[12 15 18]" "(map + [1 2 3] [4 5 6] [7 8 9])"] - ["map 3 colls shortest" "[12 15]" "(map + [1 2] [4 5 6] [7 8 9])"] - ["map 4 colls" "[16 20]" "(map + [1 2] [3 4] [5 6] [7 8])"] - ["map 3 colls nils" "[[1 :a 10] [nil :b 20] [3 nil 30]]" "(map vector [1 nil 3] [:a :b nil] [10 20 30])"] - ["map empty coll" "()" "(map + [] [1 2 3] [4 5 6])"] - ["map lazy+concrete" "[11 22 33]" "(map + (map identity [1 2 3]) [10 20 30])"] - ["map-indexed" "[[0 :a] [1 :b]]" "(map-indexed vector [:a :b])"] - ["mapv" "[2 3 4]" "(mapv inc [1 2 3])"] - ["filter" "[2 4]" "(filter even? [1 2 3 4])"] - ["filterv" "[2 4]" "(filterv even? [1 2 3 4])"] - ["remove" "[1 3]" "(remove even? [1 2 3 4])"] - ["reduce" "10" "(reduce + [1 2 3 4])"] - ["reduce with init" "20" "(reduce + 10 [1 2 3 4])"] - ["reduce empty with init" "0" "(reduce + 0 [])"] - ["reduce single no init" "5" "(reduce + [5])"] - ["reduced short-circuits" "3" "(reduce (fn [a x] (if (> a 2) (reduced a) (+ a x))) 0 [1 2 3 4 5])"] - ["reduce-kv" "6" "(reduce-kv (fn [a k v] (+ a v)) 0 {:a 1 :b 2 :c 3})"] - ["reduce-kv on vector" "[[0 :a] [1 :b]]" "(reduce-kv (fn [a i v] (conj a [i v])) [] [:a :b])"] - ["reduce-kv honors reduced" "[:a]" "(reduce-kv (fn [a i v] (if (= i 1) (reduced a) (conj a v))) [] [:a :b :c])"] - ["reduce-kv on nil" "0" "(reduce-kv (fn [a k v] (+ a v)) 0 nil)"] - ["reductions" "[1 3 6]" "(reductions + [1 2 3])"] - ["mapcat" "[1 1 2 2]" "(mapcat (fn [x] [x x]) [1 2])"] - ["mapcat two colls" "[1 3 2 4]" "(mapcat vector [1 2] [3 4])"] - ["mapcat three colls" "[1 2 3]" "(mapcat vector [1] [2] [3])"] - ["mapcat empty coll" "()" "(mapcat vector [] [1 2] [3 4])"] - ["mapcat seqs" "[1 2 3 4]" "(mapcat identity [[1 2] [3 4]])"] - ["keep" "[1 3]" "(keep (fn [x] (if (odd? x) x nil)) [1 2 3 4])"] - ["some truthy" "true" "(some even? [1 2 3])"] - ["some nil" "nil" "(some even? [1 3 5])"] - ["every? true" "true" "(every? pos? [1 2 3])"] - ["every? false" "false" "(every? pos? [1 -2 3])"]) - -(defspec "seq / take drop slice" - ["take" "[1 2 3]" "(take 3 [1 2 3 4 5])"] - ["take more than size" "[1 2]" "(take 5 [1 2])"] - ["drop" "[4 5]" "(drop 3 [1 2 3 4 5])"] - ["take-while" "[1 2]" "(take-while (fn [x] (< x 3)) [1 2 3 1])"] - ["drop-while" "[3 1]" "(drop-while (fn [x] (< x 3)) [1 2 3 1])"] - ["take-last" "[4 5]" "(take-last 2 [1 2 3 4 5])"] - ["drop-last" "[1 2 3]" "(drop-last [1 2 3 4])"] - ["take-nth" "[1 3 5]" "(take-nth 2 [1 2 3 4 5])"] - ["partition" "[[1 2] [3 4]]" "(partition 2 [1 2 3 4 5])"] - ["partition-all" "[[1 2] [3]]" "(partition-all 2 [1 2 3])"] - ["split-at" "[[1 2] [3 4]]" "(split-at 2 [1 2 3 4])"]) - -(defspec "seq / transform" - ["reverse" "[3 2 1]" "(reverse [1 2 3])"] - ["sort" "[1 2 3]" "(sort [3 1 2])"] - ["sort with comparator" "[3 2 1]" "(sort > [1 3 2])"] - ["sort-by" "[[1] [2 2]]" "(sort-by count [[2 2] [1]])"] - ["distinct" "[1 2 3]" "(distinct [1 1 2 3 3])"] - ["dedupe" "[1 2 1]" "(dedupe [1 1 2 1])"] - ["interpose" "[1 0 2 0 3]" "(interpose 0 [1 2 3])"] - ["interleave" "[1 :a 2 :b]" "(interleave [1 2] [:a :b])"] - ["flatten" "[1 2 3 4]" "(flatten [1 [2 [3 [4]]]])"] - ["concat" "[1 2 3 4]" "(concat [1 2] [3 4])"] - ["into vector" "[1 2 3 4]" "(into [1 2] [3 4])"] - ["into list" "[3 2 1]" "(into (list) [1 2 3])"] - ["frequencies" "{1 2, 2 1}" "(frequencies [1 1 2])"] - ["group-by" "{false [1 3], true [2 4]}" "(group-by even? [1 2 3 4])"] - ["zipmap" "{:a 1, :b 2}" "(zipmap [:a :b] [1 2])"] - ["mapcat seqs" "[1 2 3 4]" "(mapcat identity [[1 2] [3 4]])"]) - -(defspec "seq / generators" - ["range n" "[0 1 2 3]" "(range 4)"] - ["range from to" "[2 3 4]" "(range 2 5)"] - ["range with step" "[0 2 4]" "(range 0 6 2)"] - ["take repeat" "[:x :x :x]" "(take 3 (repeat :x))"] - ["repeat n" "[5 5]" "(repeat 2 5)"] - ["take iterate" "[1 2 4 8]" "(take 4 (iterate (fn [x] (* x 2)) 1))"] - ["take cycle" "[1 2 1 2 1]" "(take 5 (cycle [1 2]))"] - ["take repeatedly" "3" "(count (take 3 (repeatedly (fn [] 1))))"] - ["take-last of range" "[8 9]" "(take-last 2 (range 10))"]) - -# Clojure IFn values used as the function arg to higher-order fns: a keyword or -# symbol looks up a key, a set tests membership, a map looks up a key. -(defspec "seq / IFn values as functions" - ["map keyword" "[1 2 3]" "(map :a [{:a 1} {:a 2} {:a 3}])"] - ["filter keyword" "[{:ok true}]" "(filter :ok [{:ok true} {:ok false}])"] - ["remove keyword" "[{:ok false}]" "(remove :ok [{:ok true} {:ok false}])"] - ["sort-by keyword" "[{:a 1} {:a 2} {:a 3}]" "(sort-by :a [{:a 3} {:a 1} {:a 2}])"] - ["sort-by key + cmp" "[{:a 3} {:a 2} {:a 1}]" "(sort-by :a > [{:a 3} {:a 1} {:a 2}])"] - ["filter set" "[2 4]" "(filter #{2 4} [1 2 3 4 5])"] - ["remove set" "[1 3 5]" "(remove #{2 4} [1 2 3 4 5])"] - ["group-by keyword" "{1 [{:n 1}], 2 [{:n 2}]}" "(group-by :n [{:n 1} {:n 2}])"] - ["map a map" "[1 nil 2]" "(map {:a 1 :b 2} [:a :z :b])"] - ["take-nth transducer" "[0 2 4 6 8]" "(into [] (take-nth 2) (range 10))"] - ["interpose transducer" "[1 :x 2]" "(into [] (interpose :x) [1 2])"]) - -# conj edge cases: 0-arg, conj onto nil (builds a list), conj a map into a map. -(defspec "seq / conj edge cases" - ["conj no args" "[]" "(conj)"] - ["conj nil one" "[3]" "(conj nil 3)"] - ["conj nil many" "[2 1]" "(conj nil 1 2)"] - ["conj vector" "[1 2 3]" "(conj [1 2] 3)"] - ["conj list prepend" "[0 1 2]" "(conj '(1 2) 0)"] - ["conj map + map" "{:a 0, :b 1}" "(conj {:a 0} {:b 1})"] - ["conj map + pair" "{:a 0, :b 1}" "(conj {:a 0} [:b 1])"] - ["conj map merge wins" "{:a 2}" "(conj {:a 0} {:a 1} {:a 2})"]) - -# Strictness: these reject malformed arguments like Clojure. -(defspec "seq / strictness (throws like Clojure)" - ["cons non-seqable num" :throws "(cons 1 42)"] - ["cons non-seqable kw" :throws "(cons 1 :k)"] - ["cons onto nil ok" "[1]" "(cons 1 nil)"] - ["cons onto seq ok" "[0 1 2]" "(cons 0 [1 2])"] - ["num non-number" :throws "(num \"x\")"] - ["num ok" "5" "(num 5)"] - ["realized? on number" :throws "(realized? 1)"] - ["realized? on nil" :throws "(realized? nil)"] - ["symbol from nil" :throws "(symbol nil)"] - ["symbol bad 2-arg" :throws "(symbol :a \"b\")"] - ["symbol from keyword" "\"x\"" "(name (symbol :x))"] - ["keyword bad 2-arg" :throws "(keyword \"abc\" nil)"] - ["keyword from symbol" "\"x\"" "(name (keyword 'x))"]) - -# Stack/accessor strictness: peek/pop are stack-only; vec needs a seqable; -# key/val need a map entry. -(defspec "seq / accessor strictness" - ["peek vector" "3" "(peek [1 2 3])"] - ["peek list" "1" "(peek '(1 2 3))"] - ["peek empty vec" "nil" "(peek [])"] - ["peek on set" :throws "(peek #{1 2})"] - ["peek on number" :throws "(peek 42)"] - ["pop empty vec" :throws "(pop [])"] - ["pop on number" :throws "(pop 0)"] - ["pop vector" "[1 2]" "(pop [1 2 3])"] - ["vec on number" :throws "(vec 42)"] - ["vec on keyword" :throws "(vec :a)"] - ["vec ok" "[1 2]" "(vec '(1 2))"] - ["key on nil" :throws "(key nil)"] - ["key on map" :throws "(key {})"] - ["val on number" :throws "(val 0)"] - ["key of entry" ":a" "(key (first {:a 1}))"] - ["val of entry" "1" "(val (first {:a 1}))"]) - -# More strictness: first/rseq on the right shapes, assoc even-arg requirement. -(defspec "seq / more strictness" - ["first on number" :throws "(first 42)"] - ["first on keyword" :throws "(first :a)"] - ["first ok vec" "1" "(first [1 2])"] - ["first ok nil" "nil" "(first nil)"] - ["rseq vector" "[3 2 1]" "(rseq [1 2 3])"] - ["rseq on string" :throws "(rseq \"ab\")"] - ["rseq on map" :throws "(rseq {:a 1})"] - ["rseq on number" :throws "(rseq 0)"] - ["assoc odd args" :throws "(assoc {:a 1} :b)"] - ["assoc on number" :throws "(assoc 5 :a 1)"] - ["assoc on set" :throws "(assoc #{} :a 1)"]) - -# Strictness on more core fns: seq/shuffle need seqables, NaN? needs a number, -# nthrest/nthnext need a numeric count (and clamp negatives / accept nil coll). -(defspec "seq / strictness round 3" - ["seq on number" :throws "(seq 1)"] - ["seq on fn" :throws "(seq (fn [] 1))"] - ["seq vector ok" "[1 2]" "(seq [1 2])"] - ["NaN? on nil" :throws "(NaN? nil)"] - ["NaN? on number ok" "false" "(NaN? 1.0)"] - ["shuffle on number" :throws "(shuffle 1)"] - ["shuffle on string" :throws "(shuffle \"abc\")"] - ["shuffle vec ok" "3" "(count (shuffle [1 2 3]))"] - ["nthrest nil count" :throws "(nthrest [0 1 2] nil)"] - ["nthrest negative" "[0 1 2]" "(nthrest [0 1 2] -1)"] - ["nthrest nil coll" "nil" "(nthrest nil 0)"] - ["nthnext nil count" :throws "(nthnext [0 1 2] nil)"] - ["update vec oob" :throws "(update [] 1 identity)"] - ["update vec kw key" :throws "(update [1 2 3] :k identity)"]) - -# Regression cases for clojure.core fns moved from Janet to the Clojure overlay -# (jolt-1j0), plus two bugs fixed in the process: nthrest returns () (not nil) -# for an exhausted n>0 walk, and distinct? compares by VALUE (equal collections -# are not distinct). -(defspec "seq / overlay-migrated fns" - ["nthrest exhausted -> ()" "()" "(nthrest nil 100)"] - ["nthrest vec exhausted" "()" "(nthrest [1 2 3] 100)"] - ["nthrest n<=0 keeps coll" "[1 2 3]" "(nthrest [1 2 3] 0)"] - ["nthrest drops n" "[3 4 5]" "(nthrest [1 2 3 4 5] 2)"] - ["nthnext exhausted -> nil" "nil" "(nthnext [1 2] 5)"] - ["nthnext surprising nil" "nil" "(nthnext nil nil)"] - ["nthnext drops n" "[3 4]" "(nthnext [1 2 3 4] 2)"] - ["distinct? distinct" "true" "(distinct? 1 2 3)"] - ["distinct? dup" "false" "(distinct? 1 2 1)"] - ["distinct? equal colls" "false" "(distinct? [1 2] [1 2])"] - ["distinct? single" "true" "(distinct? 5)"] - ["replace maps elements" "[:a 2 :c 2]" "(replace {1 :a 3 :c} [1 2 3 2])"] - ["replace preserves nil val" "[1 nil 3]" "(replace {2 nil} [1 2 3])"] - ["take-last" "[3 4]" "(take-last 2 [1 2 3 4])"] - ["take-last empty -> nil" "nil" "(take-last 2 [])"] - ["take-last n>len" "[1 2]" "(take-last 9 [1 2])"] - ["drop-last default 1" "[1 2]" "(drop-last [1 2 3])"] - ["drop-last n" "[1 2]" "(drop-last 2 [1 2 3 4])"] - ["split-with" "[[2 4] [5 6]]" "(split-with even? [2 4 5 6])"] - ["replicate" "[:x :x :x]" "(replicate 3 :x)"] - ["bounded-count" "5" "(bounded-count 3 [1 2 3 4 5])"] - ["bounded-count uncounted" "3" "(bounded-count 3 (filter odd? (range 100)))"] - ["run! side effects" "6" "(let [a (atom 0)] (run! (fn [x] (swap! a + x)) [1 2 3]) @a)"] - ["completing wraps rf" "3" "((completing +) 1 2)"] - ["comparator <" "[1 2 3]" "(sort (comparator <) [3 1 2])"] - ["comparator >" "[3 2 1]" "(sort (comparator >) [3 1 2])"] - ["reductions" "[1 3 6 10]" "(reductions + [1 2 3 4])"] - ["reductions with init" "[10 11 13 16]" "(reductions + 10 [1 2 3])"] - ["reductions empty calls f" "[0]" "(reductions + [])"] - ["reductions empty + init" "[5]" "(reductions + 5 [])"] - ["tree-seq pre-order" "[[1 [2] 3] 1 [2] 2 3]" "(tree-seq sequential? seq [1 [2] 3])"] - ["some found" "true" "(some even? [1 3 4])"] - ["some none -> nil" "nil" "(some even? [1 3 5])"] - ["some keyword pred" "7" "(some :a [{:b 1} {:a 7}])"] - ["some returns value" "4" "(some (fn [x] (when (even? x) x)) [1 3 4 5])"] - ["flatten nested" "[1 2 3 4 5]" "(flatten [1 [2 [3 4]] 5])"] - ["flatten lists too" "[1 2 3]" "(flatten [1 (list 2 3)])"] - ["flatten scalar -> empty" "[]" "(flatten 5)"] - ["interleave" "[1 :a 2 :b]" "(interleave [1 2 3] [:a :b])"] - ["interleave empty" "[]" "(interleave)"] - ["rationalize identity" "5" "(rationalize 5)"] - ["dedupe consecutive" "[1 2 3 1]" "(dedupe [1 1 2 2 3 1 1])"] - ["dedupe empty" "[]" "(dedupe [])"] - ["dedupe no dups" "[1 2 3]" "(dedupe [1 2 3])"]) - -# Clojure 1.11 vector-returning partition/split variants. -(defspec "seq / partitionv & splitv-at (1.11)" - ["partitionv" "[[1 2] [3 4]]" "(partitionv 2 [1 2 3 4 5])"] - ["partitionv elems are vectors" "true" "(every? vector? (partitionv 2 [1 2 3 4]))"] - ["partitionv step" "[[1 2] [3 4]]" "(partitionv 2 2 [1 2 3 4 5])"] - ["partitionv pad" "[[1 2] [3 :p]]" "(partitionv 2 2 [:p] [1 2 3])"] - ["partitionv-all" "[[1 2] [3]]" "(partitionv-all 2 [1 2 3])"] - ["partitionv-all vectors" "true" "(every? vector? (partitionv-all 2 [1 2 3]))"] - ["splitv-at" "[[1 2] [3 4]]" "(splitv-at 2 [1 2 3 4])"] - ["splitv-at first is vector" "true" "(vector? (first (splitv-at 2 [1 2 3])))"] - ["splitv-at past end" "[[1 2] []]" "(splitv-at 5 [1 2])"]) - -# Linear seq walks (flatiron review find): cell chains over concrete -# collections walk by INDEX. Slicing the remainder per step made every full -# walk O(n^2) — mapv over 40k elements took ten seconds, a 20k first/rest -# loop took two. rest/next of an indexed collection is an O(1) lazy view — -# and therefore a SEQ, as in Clojure (it was a vector-typed slice). -(defspec "sequences / linear walks over concrete collections" - ["rest of vector is a seq" "true" "(seq? (rest [1 2 3]))"] - ["rest of vector not vector" "false" "(vector? (rest [1 2 3]))"] - ["rest values" "(quote (2 3))" "(rest [1 2 3])"] - ["next of vector" "(quote (2 3))" "(next [1 2 3])"] - ["next exhausts to nil" "nil" "(next [1])"] - ["rest exhausts to ()" "()" "(rest [1])"] - ["rest-loop scales (20k linear)" "20000" - "(loop [xs (seq (vec (range 20000))) n 0] (if xs (recur (next xs) (inc n)) n))"] - ["mapv scales (50k linear)" "50000" "(count (mapv inc (vec (range 50000))))"] - ["nested walk" "[2 3]" "(vec (rest (mapv inc [0 1 2])))"]) - -# rest/next over sets, maps, and sorted colls used to fall into the indexed -# fall-through and walk the wrapper table's internal fields ((next #{1 2}) -# was (nil nil)) — exposed when the canonical every? started seq-walking. -(defspec "sequences / rest & next over set-like colls" - ["next of set" "true" "(let [n (next #{1 2})] (and (= 1 (count n)) (contains? #{1 2} (first n))))"] - ["rest of set count" "1" "(count (rest #{1 2}))"] - ["next of singleton set" "nil" "(next #{1})"] - ["rest of empty set" "0" "(count (rest #{}))"] - ["next of map" "true" "(let [n (next {:a 1 :b 2})] (and (= 1 (count n)) (map-entry? (first n))))"] - ["next of singleton map" "nil" "(next {:a 1})"] - ["rest of sorted-set" "(quote (2 3))" "(rest (sorted-set 3 1 2))"] - ["next of sorted-map" "(quote ([2 :b]))" "(next (sorted-map 1 :a 2 :b))"] - ["every? over set" "true" "(every? pos? #{1 2 3})"] - ["every? over set false" "false" "(every? odd? #{1 2})"] - ["every? over sorted-set" "true" "(every? pos? (sorted-set 1 2 3))"] - ["every? over map entries" "true" "(every? map-entry? (seq {:a 1 :b 2}))"]) diff --git a/test/spec/sets-spec.janet b/test/spec/sets-spec.janet deleted file mode 100644 index e041010..0000000 --- a/test/spec/sets-spec.janet +++ /dev/null @@ -1,94 +0,0 @@ -# Specification: sets, including clojure.set. -(use ../support/harness) - -(defspec "set / construct & predicate" - ["literal" "#{1 2 3}" "#{1 2 3}"] - ["hash-set" "#{1 2 3}" "(hash-set 1 2 3)"] - ["set from vector" "#{1 2 3}" "(set [1 2 3 1])"] - ["empty" "#{}" "#{}"] - ["set? true" "true" "(set? #{1})"] - ["set? false on vector" "false" "(set? [1])"] - ["count dedups" "3" "(count (set [1 1 2 3]))"] - ["equality order-indep" "true" "(= #{1 2 3} #{3 2 1})"] - # jolt-h86: into-conj had no set branch and returned the set unchanged - ["into set" "#{:a :b}" "(into #{} [:a :b])"] - ["into non-empty set" "#{1 2 3}" "(into #{1} [2 3 2])"]) - -(defspec "set / operations" - ["conj adds" "#{1 2 3}" "(conj #{1 2} 3)"] - ["conj dup no-op" "#{1 2}" "(conj #{1 2} 1)"] - ["disj removes" "#{1 2}" "(disj #{1 2 3} 3)"] - ["disj missing no-op" "#{1 2}" "(disj #{1 2} 9)"] - ["contains?" "true" "(contains? #{1 2} 1)"] - ["contains? missing" "false" "(contains? #{1 2} 9)"] - ["get present" "1" "(get #{1 2} 1)"] - ["get missing nil" "nil" "(get #{1 2} 9)"] - ["set as fn present" "2" "(#{1 2 3} 2)"] - ["set as fn missing" "nil" "(#{1 2 3} 9)"]) - -(defspec "set / literals & value elements" - ["literal evaluates elements" "#{2 4}" "#{(inc 1) (* 2 2)}"] - ["map elements by value" "true" "(= #{{:a 1}} #{(hash-map :a 1)})"] - ["contains? map by value" "true" "(contains? #{(hash-map :x 1)} {:x 1})"] - ["dedup equal maps" "1" "(count (set [{:a 1} (hash-map :a 1)]))"] - ["vector elements" "true" "(contains? #{[1 2]} (vec [1 2]))"]) - -(defspec "set / nil element (jolt-bn2p)" - # canon-key returns nil for nil and Janet tables drop a nil key, so a nil - # member used to be silently lost while count/contains? disagreed. - ["set keeps nil" "2" "(count (set [nil 1 nil]))"] - ["contains? nil true" "true" "(contains? (set [nil 1]) nil)"] - ["contains? nil false" "false" "(contains? #{1} nil)"] - ["seq includes nil" "true" "(some nil? (seq (set [nil 1])))"] - ["disj nil" "#{1}" "(disj (set [nil 1]) nil)"] - ["disj nil count" "1" "(count (disj (set [nil 1]) nil))"] - ["conj nil count" "2" "(count (conj #{1} nil))"] - ["conj nil contains?" "true" "(contains? (conj #{1} nil) nil)"] - ["into #{} keeps nil" "2" "(count (into #{} [nil 1]))"] - ["into #{} contains? nil" "true" "(contains? (into #{} [nil 1]) nil)"] - ["into keeps existing nil" "true" "(contains? (into #{nil} [1]) nil)"] - # transient set path: tr-conj!/persistent!/disj!/contains? - ["transient conj! nil" "2" "(count (persistent! (conj! (transient #{}) nil 1)))"] - ["transient contains? nil" "true" "(contains? (persistent! (conj! (transient #{}) nil 1)) nil)"] - ["transient disj! nil cnt" "1" "(count (persistent! (disj! (conj! (transient #{}) nil 1) nil)))"] - ["transient disj! removes" "false" "(contains? (persistent! (disj! (conj! (transient #{}) nil 1) nil)) nil)"] - ["transient of set w/ nil" "true" "(contains? (persistent! (transient (set [nil 1]))) nil)"]) - -(defspec "clojure.set" - ["union" "#{1 2 3 4}" "(do (require (quote [clojure.set :as s])) (s/union #{1 2} #{3 4}))"] - ["intersection" "#{2}" "(do (require (quote [clojure.set :as s])) (s/intersection #{1 2} #{2 3}))"] - ["difference" "#{1}" "(do (require (quote [clojure.set :as s])) (s/difference #{1 2} #{2 3}))"] - ["subset? true" "true" "(do (require (quote [clojure.set :as s])) (s/subset? #{1} #{1 2}))"] - ["superset? true" "true" "(do (require (quote [clojure.set :as s])) (s/superset? #{1 2} #{1}))"] - ["select" "#{2 4}" "(do (require (quote [clojure.set :as s])) (s/select even? #{1 2 3 4}))"] - ["join" "#{{:a 1, :b 2, :c 3}}" "(do (require (quote [clojure.set :as s])) (s/join #{{:a 1 :b 2}} #{{:b 2 :c 3}}))"] - ["map-invert" "{1 :a}" "(do (require (quote [clojure.set :as s])) (s/map-invert {:a 1}))"] - ["rename-keys" "{:b 1}" "(do (require (quote [clojure.set :as s])) (s/rename-keys {:a 1} {:a :b}))"]) - -# set? recognizes every set representation (jolt-dpn: sorted sets are tagged -# tables the host set? predicate missed). -(defspec "set / set? across representations" - ["literal" "true" "(set? #{1})"] - ["empty literal" "true" "(set? #{})"] - ["sorted-set" "true" "(set? (sorted-set 1 2))"] - ["sorted-set-by" "true" "(set? (sorted-set-by > 1 2))"] - ["empty sorted" "true" "(set? (sorted-set))"] - ["map is not" "false" "(set? {})"] - ["vector is not" "false" "(set? [1])"] - ["coll? still true" "true" "(coll? (sorted-set 1))"] - ["ifn? sorted-set" "true" "(ifn? (sorted-set 1))"]) - -# set / into #{} bulk-build the backing HAMT in one pass (phs-from-seq), instead -# of a phs-conj per element (jolt-5vsp collections). Cross the promotion -# boundary, check dedup, collection members, and conj after a bulk build. -(defspec "set / bulk build boundaries" - ["set dedup count" "3" "(count (set [1 1 2 3 3 2]))"] - ["set big count" "1000" "(count (set (range 1000)))"] - ["into #{} count" "500" "(count (into #{} (range 500)))"] - ["into #{} onto base" "3" "(count (into #{:a} [:a :b :c]))"] - ["set contains" "true" "(contains? (set (range 1000)) 777)"] - ["set missing" "false" "(contains? (set (range 1000)) 5000)"] - ["set coll members" "true" "(contains? (set [[1 2] [3 4]]) [1 2])"] - ["conj after bulk" "true" "(contains? (conj (set (range 100)) :x) :x)"] - ["disj after bulk" "false" "(contains? (disj (set (range 100)) 50) 50)"] - ["set = literal" "true" "(= #{0 1 2} (set (range 3)))"]) diff --git a/test/spec/sorted-spec.janet b/test/spec/sorted-spec.janet deleted file mode 100644 index d7fdc6d..0000000 --- a/test/spec/sorted-spec.janet +++ /dev/null @@ -1,120 +0,0 @@ -# Specification: sorted collections (sorted-map / sorted-set, subseq/rsubseq). -# -# Sorted collections are pure Clojure (stage 3, jolt-0lj): the entries live in -# a comparator-ordered vector, all ops are overlay Clojure attached to the -# value, and the Janet seed only dispatches to them. Semantics match Clojure: -# lookup/membership go through the COMPARATOR ((contains? (sorted-set 1) 1.0) -# is true), equality is representation-agnostic ((= (sorted-map :a 1) {:a 1})), -# empty?/empty see the collection (not the host wrapper) and (empty sc) keeps -# the comparator. (vec coerces a seq to a vector so expecteds are vector -# literals, not quoted lists.) -(use ../support/harness) - -(defspec "sorted / construction & ordering" - ["sorted-set orders" "[1 2 3]" "(vec (seq (sorted-set 3 1 2)))"] - ["sorted-set dedupes" "[1 2 3]" "(vec (seq (sorted-set 3 1 2 1 3)))"] - ["sorted-set numeric" "[1 2 10]" "(vec (seq (sorted-set 10 1 2)))"] - ["sorted-map ordered entries" "[[:a 1] [:b 2] [:c 3]]" "(vec (seq (sorted-map :c 3 :a 1 :b 2)))"] - ["first is min" "1" "(first (sorted-set 5 3 9 1))"]) - -(defspec "sorted / sorted?" - ["sorted-set" "true" "(sorted? (sorted-set 1))"] - ["sorted-map" "true" "(sorted? (sorted-map :a 1))"] - ["plain set" "false" "(sorted? #{1})"] - ["plain map" "false" "(sorted? {:a 1})"] - ["vector" "false" "(sorted? [1 2])"]) - -(defspec "sorted / map ops" - ["get hit" "2" "(get (sorted-map :a 1 :b 2) :b)"] - ["get miss default" ":none" "(get (sorted-map :a 1) :z :none)"] - ["contains? yes" "true" "(contains? (sorted-map :a 1) :a)"] - ["contains? no" "false" "(contains? (sorted-map :a 1) :z)"] - ["assoc keeps order" "[[:a 1] [:b 2] [:c 3]]" "(vec (seq (assoc (sorted-map :c 3 :a 1) :b 2)))"] - ["dissoc" "[[:a 1] [:c 3]]" "(vec (seq (dissoc (sorted-map :a 1 :b 2 :c 3) :b)))"] - ["conj entry" "[[:a 1] [:z 9]]" "(vec (seq (conj (sorted-map :a 1) [:z 9])))"] - ["keys sorted" "[:a :b :c]" "(vec (keys (sorted-map :c 3 :a 1 :b 2)))"] - ["vals by key" "[1 2 3]" "(vec (vals (sorted-map :c 3 :a 1 :b 2)))"] - ["map as fn" "2" "((sorted-map :a 1 :b 2) :b)"] - ["map as fn miss" ":d" "((sorted-map :a 1) :z :d)"]) - -(defspec "sorted / set ops" - ["get present" "2" "(get (sorted-set 1 2 3) 2)"] - ["get absent" ":none" "(get (sorted-set 1 2 3) 9 :none)"] - ["contains? yes" "true" "(contains? (sorted-set 1 2 3) 2)"] - ["contains? no" "false" "(contains? (sorted-set 1 2 3) 9)"] - ["conj keeps order" "[0 1 2 3 5]" "(vec (seq (conj (sorted-set 1 2 3) 5 0)))"] - ["disj" "[1 3]" "(vec (seq (disj (sorted-set 1 2 3) 2)))"] - ["set as fn" "3" "((sorted-set 1 2 3) 3)"] - ["set as fn miss" "nil" "((sorted-set 1 2 3) 9)"]) - -(defspec "sorted / by comparator" - ["sorted-set-by desc" "[10 3 2 1]" "(vec (seq (sorted-set-by > 1 3 2 10)))"] - ["sorted-map-by desc" "[[3 :c] [2 :b] [1 :a]]" "(vec (seq (sorted-map-by > 1 :a 3 :c 2 :b)))"] - ["conj keeps comparator" "[5 3 2 1 0]" "(vec (seq (conj (sorted-set-by > 1 3 2) 5 0)))"] - ["assoc keeps comparator" "[3 2 1]" "(vec (keys (assoc (sorted-map-by > 1 :a 3 :c) 2 :b)))"] - ["disj keeps comparator" "[3 1]" "(vec (seq (disj (sorted-set-by > 1 2 3) 2)))"] - ["by-comparator is sorted?" "true" "(sorted? (sorted-set-by > 1 2))"]) - -(defspec "sorted / subseq & rsubseq" - ["subseq >=" "[3 4 5]" "(vec (subseq (sorted-set 1 2 3 4 5) >= 3))"] - ["subseq <" "[1 2]" "(vec (subseq (sorted-set 1 2 3 4 5) < 3))"] - ["subseq range" "[2 3 4]" "(vec (subseq (sorted-set 1 2 3 4 5) > 1 < 5))"] - ["rsubseq <=" "[3 2 1]" "(vec (rsubseq (sorted-set 1 2 3 4 5) <= 3))"] - ["subseq on map" "[[2 :b] [3 :c]]" "(vec (subseq (sorted-map 1 :a 2 :b 3 :c) > 1))"] - ["subseq empty result" "nil" "(subseq (sorted-set 1 2) > 5)"] - ["rsubseq on map" "[[2 :b] [1 :a]]" "(vec (rsubseq (sorted-map 1 :a 2 :b 3 :c) < 3))"]) - -(defspec "sorted / predicates" - ["sorted-map? true" "true" "(sorted-map? (sorted-map 1 :a))"] - ["sorted-map? false" "false" "(sorted-map? {:a 1})"] - ["sorted-set? true" "true" "(sorted-set? (sorted-set 1))"] - ["sorted-set? false" "false" "(sorted-set? #{1})"] - ["map? sorted-map" "true" "(map? (sorted-map 1 :a))"] - ["coll? sorted-set" "true" "(coll? (sorted-set 1))"]) - -(defspec "sorted / lookup + membership use the comparator" - ["get cross-numeric" ":a" "(get (sorted-map 1 :a) 1.0)"] - ["contains? cross-numeric" "true" "(contains? (sorted-set 1) 1.0)"] - ["conj equal elem no-op" "1" "(count (conj (sorted-set 1) 1.0))"] - ["assoc equal key replaces" "[[1 :z]]" "(vec (seq (assoc (sorted-map 1 :a) 1.0 :z)))"] - ["first sorted-map" "[1 :a]" "(first (sorted-map 2 :b 1 :a))"] - ["dissoc missing no-op" "2" "(count (dissoc (sorted-map 1 :a 2 :b) 9))"] - ["conj map merges" "3" "(count (conj (sorted-map 1 :a) {2 :b 3 :c}))"] - ["conj nil no-op" "1" "(count (conj (sorted-map 1 :a) nil))"] - ["into sorted-map" "[[1 :a] [2 :b]]" "(vec (seq (into (sorted-map) [[2 :b] [1 :a]])))"] - ["source unchanged" "[1 2]" "(let [s (sorted-set 1 2)] (conj s 9) (vec (seq s)))"] - ["sorted-map odd kvs throws" :throws "(sorted-map 1 :a 2)"]) - -(defspec "sorted / equality is representation-agnostic" - ["sorted-map = literal" "true" "(= (sorted-map :a 1 :b 2) {:a 1 :b 2})"] - ["literal = sorted-map" "true" "(= {:a 1 :b 2} (sorted-map :a 1 :b 2))"] - ["sorted-map = hash-map" "true" "(= (sorted-map :a 1) (hash-map :a 1))"] - ["sorted-map != more keys" "false" "(= (sorted-map :a 1) {:a 1 :b 2})"] - ["sorted-set = literal" "true" "(= (sorted-set 1 2) #{1 2})"] - ["literal = sorted-set" "true" "(= #{1 2} (sorted-set 2 1))"] - ["sorted-set != diff" "false" "(= (sorted-set 1 2) #{1 3})"] - ["two sorted-maps" "true" "(= (sorted-map 1 :a 2 :b) (sorted-map 2 :b 1 :a))"] - ["cmp irrelevant to =" "true" "(= (sorted-map-by > 1 :a 2 :b) (sorted-map 1 :a 2 :b))"] - ["sorted-map as map key" ":hit" "(get {(sorted-map :a 1) :hit} {:a 1})"] - ["sorted-set as map key" ":hit" "(get {(sorted-set 1 2) :hit} #{2 1})"]) - -(defspec "sorted / empty + empty? + rseq + printing" - ["empty? empty map" "true" "(empty? (sorted-map))"] - ["empty? non-empty" "false" "(empty? (sorted-map 1 :a))"] - ["empty? empty set" "true" "(empty? (sorted-set))"] - ["empty keeps sortedness" "true" "(sorted? (empty (sorted-map 1 :a)))"] - ["empty keeps cmp" "[3 1]" "(vec (seq (into (empty (sorted-set-by > 1 2)) [1 3])))"] - ["empty set kind" "true" "(sorted-set? (empty (sorted-set 1)))"] - ["rseq map" "[[2 :b] [1 :a]]" "(vec (rseq (sorted-map 1 :a 2 :b)))"] - ["rseq set" "[3 2 1]" "(vec (rseq (sorted-set 1 2 3)))"] - ["pr-str sorted-map" "\"{1 :a, 2 :b}\"" "(pr-str (sorted-map 2 :b 1 :a))"] - ["pr-str sorted-set" "\"#{1 2 3}\"" "(pr-str (sorted-set 3 1 2))"]) - -(defspec "sorted / seq fn interop" - ["map over sorted-map" "[1 2 3]" "(vec (map first (sorted-map 2 :b 1 :a 3 :c)))"] - ["map over sorted-set" "[2 3 4]" "(vec (map inc (sorted-set 3 1 2)))"] - ["filter entries" "[[2 :b]]" "(vec (filter (fn [[k v]] (even? k)) (sorted-map 1 :a 2 :b)))"] - ["reduce over set" "6" "(reduce + (sorted-set 1 2 3))"] - ["vec of sorted-set" "[1 2 3]" "(vec (sorted-set 3 1 2))"] - ["into vec" "[[1 :a] [2 :b]]" "(into [] (sorted-map 2 :b 1 :a))"] - ["sorted-map-by 3way cmp" "[3 2 1]" "(vec (keys (sorted-map-by (fn [a b] (- b a)) 1 :a 2 :b 3 :c)))"]) diff --git a/test/spec/stage3-io-ns-spec.janet b/test/spec/stage3-io-ns-spec.janet deleted file mode 100644 index 386ce64..0000000 --- a/test/spec/stage3-io-ns-spec.janet +++ /dev/null @@ -1,52 +0,0 @@ -# Specification: Stage 3 turn 2b — host-classified IO fns, ns introspection, -# the thread-binding family, and load-string/eval as values. These were -# previously either missing or silently leaked from Janet's root environment. -(use ../support/harness) - -(defspec "io / slurp, spit, printf, flush (host-classified)" - ["slurp returns string" "true" "(string? (slurp \"project.janet\"))"] - ["slurp content" "true" "(do (require (quote [clojure.string :as s])) (s/includes? (slurp \"project.janet\") \"jolt\"))"] - ["spit + slurp round" "\"hello\"" "(do (spit \"/tmp/jolt-spit-test.txt\" \"hello\") (slurp \"/tmp/jolt-spit-test.txt\"))"] - ["spit append" "\"ab\"" "(do (spit \"/tmp/jolt-spit-test.txt\" \"a\") (spit \"/tmp/jolt-spit-test.txt\" \"b\" :append true) (slurp \"/tmp/jolt-spit-test.txt\"))"] - ["printf formats" "\"x=1 y=a\"" "(with-out-str (printf \"x=%d y=%s\" 1 \"a\"))"] - ["printf no newline" "false" "(do (require (quote [clojure.string :as s])) (s/includes? (with-out-str (printf \"%d\" 1)) \"\\n\"))"] - ["flush returns nil" "nil" "(flush)"] - ["file-seq finds files" "true" "(do (require (quote [clojure.string :as s])) (boolean (some (fn [p] (s/ends-with? p \"project.janet\")) (file-seq \".\"))))"]) - -(defspec "ns / ns-map, ns-unmap, ns-refers" - ["ns-map has var" "true" "(do (def nmv 1) (some? (get (ns-map (quote user)) (quote nmv))))"] - ["ns-unmap removes" "nil" "(do (def nuv 1) (ns-unmap (quote user) (quote nuv)) (resolve (quote nuv)))"] - ["ns-refers sees refer" "true" "(do (require (quote clojure.string)) (refer (quote clojure.string)) (some? (get (ns-refers (quote user)) (quote join))))"]) - -(defspec "vars / thread-binding family" - ["bound? on def" "true" "(do (def bvv 1) (bound? (var bvv)))"] - ["with-bindings* binds" "5" - "(do (def ^:dynamic dynv 1) (with-bindings* (array-map (var dynv) 5) (fn [] dynv)))"] - ["with-bindings* restores" "1" - "(do (def ^:dynamic dynw 1) (with-bindings* (array-map (var dynw) 5) (fn [] nil)) dynw)"] - ["with-bindings macro" "7" - "(do (def ^:dynamic dynx 1) (with-bindings (array-map (var dynx) 7) dynx))"] - ["thread-bound? inside" "[true false]" - "(do (def ^:dynamic dyny 1) [(with-bindings* (array-map (var dyny) 2) (fn [] (thread-bound? (var dyny)))) (thread-bound? (var dyny))])"] - ["bound-fn* conveys" "9" - "(do (def ^:dynamic dynz 1) (def f (with-bindings* (array-map (var dynz) 9) (fn [] (bound-fn* (fn [] dynz))))) (f))"] - ["get-thread-bindings" "3" - "(do (def ^:dynamic dyng 1) (with-bindings* (array-map (var dyng) 3) (fn [] (get (get-thread-bindings) (var dyng)))))"]) - -(defspec "eval & load-string as values" - ["load-string evals all" "3" "(load-string \"(def lsv 1) (+ lsv 2)\")"] - ["eval as value" "[2 3]" "(mapv eval [(quote (+ 1 1)) (quote (+ 1 2))])"] - ["eval special still works" "3" "(eval (quote (+ 1 2)))"]) - -# clojure.edn is complete (jolt-b7y / jolt-0mb): sets, #uuid/#inst, :eof, -# and the :readers / :default opts (tag normalized from the reader's :#name -# keyword to the symbol Clojure keys :readers with). -(defspec "clojure.edn / opts" - ["set literal" "#{1 2}" "(do (require (quote [clojure.edn :as e0])) (e0/read-string \"#{1 2}\"))"] - ["uuid tag" "true" "(do (require (quote [clojure.edn :as e0])) (uuid? (e0/read-string \"#uuid \\\"550e8400-e29b-41d4-a716-446655440000\\\"\")))"] - ["inst tag" "true" "(do (require (quote [clojure.edn :as e0])) (inst? (e0/read-string \"#inst \\\"2020-01-01T00:00:00Z\\\"\")))"] - [":eof on empty" ":end" "(do (require (quote [clojure.edn :as e0])) (e0/read-string {:eof :end} \"\"))"] - [":readers custom tag" "[:custom 5]" "(do (require (quote [clojure.edn :as e0])) (e0/read-string {:readers {(quote custom) (fn [v] [:custom v])}} \"#custom 5\"))"] - [":readers nested" "[6 8]" "(do (require (quote [clojure.edn :as e0])) (e0/read-string {:readers {(quote w) (fn [v] (* 2 v))}} \"[#w 3 #w 4]\"))"] - [":default fn" "[:dflt 7]" "(do (require (quote [clojure.edn :as e0])) (e0/read-string {:default (fn [t v] [:dflt v])} \"#unknown 7\"))"] - ["unknown tag throws" :throws "(do (require (quote [clojure.edn :as e0])) (e0/read-string \"#nope 1\"))"]) diff --git a/test/spec/state-spec.janet b/test/spec/state-spec.janet deleted file mode 100644 index b35944c..0000000 --- a/test/spec/state-spec.janet +++ /dev/null @@ -1,48 +0,0 @@ -# Specification: stateful reference types (atoms, volatiles, delays, promises). -(use ../support/harness) - -(defspec "state / atoms" - ["deref @" "0" "(let [a (atom 0)] @a)"] - ["deref fn" "0" "(deref (atom 0))"] - ["reset!" "5" "(let [a (atom 0)] (reset! a 5) @a)"] - ["reset! returns new" "5" "(let [a (atom 0)] (reset! a 5))"] - ["swap!" "1" "(let [a (atom 0)] (swap! a inc) @a)"] - ["swap! with args" "10" "(let [a (atom 1)] (swap! a + 2 3 4) @a)"] - ["swap! returns new" "1" "(let [a (atom 0)] (swap! a inc))"] - ["swap-vals!" "[0 1]" "(let [a (atom 0)] (swap-vals! a inc))"] - ["reset-vals!" "[0 9]" "(let [a (atom 0)] (reset-vals! a 9))"] - ["compare-and-set! ok" "true" "(let [a (atom 0)] (compare-and-set! a 0 1))"] - ["compare-and-set! no" "false" "(let [a (atom 0)] (compare-and-set! a 9 1))"] - ["atom?" "true" "(do (require (quote [clojure.core])) (instance? clojure.lang.Atom (atom 0)))"] - ["atom? predicate" "true" "(atom? (atom 0))"] - ["atom? on non-atom" "false" "(atom? 5)"]) - -(defspec "state / watches & validators" - ["add-watch fires" "1" "(let [a (atom 0) seen (atom 0)] (add-watch a :k (fn [k r o n] (reset! seen 1))) (reset! a 5) @seen)"] - ["remove-watch" "0" "(let [a (atom 0) seen (atom 0)] (add-watch a :k (fn [k r o n] (swap! seen inc))) (remove-watch a :k) (reset! a 5) @seen)"] - ["set-validator! ok" "5" "(let [a (atom 0)] (set-validator! a number?) (reset! a 5) @a)"] - ["set-validator! rejects" :throws "(let [a (atom 0)] (set-validator! a pos?) (reset! a -1))"] - ["get-validator" "true" "(let [a (atom 0)] (set-validator! a number?) (fn? (get-validator a)))"]) - -(defspec "state / volatiles & delays" - ["volatile! deref" "0" "(let [v (volatile! 0)] @v)"] - ["vreset!" "5" "(let [v (volatile! 0)] (vreset! v 5) @v)"] - ["vswap!" "1" "(let [v (volatile! 0)] (vswap! v inc) @v)"] - ["delay not forced" "0" "(let [c (atom 0) d (delay (swap! c inc))] @c)"] - ["delay force once" "1" "(let [c (atom 0) d (delay (swap! c inc))] (force d) (force d) @c)"] - ["delay value" "5" "(let [d (delay 5)] @d)"] - ["realized? before" "false" "(let [d (delay 5)] (realized? d))"] - ["realized? after" "true" "(let [d (delay 5)] (force d) (realized? d))"]) - -(defspec "state / promises" - ["promise deliver" "5" "(let [p (promise)] (deliver p 5) @p)"] - ["promise undelivered" "nil" "(let [p (promise)] @p)"]) - -# Minimal synchronous agent shim (jolt has no thread pool/STM) — enough for -# libraries that hold an agent without depending on async dispatch. -(defspec "state / agents (synchronous shim)" - ["agent deref" "0" "(deref (agent 0))"] - ["agent with opts" "0" "(deref (agent 0 :error-mode :continue))"] - ["send-off applies" "5" "(let [a (agent 0)] (send-off a + 5) (deref a))"] - ["send applies" "7" "(let [a (agent 1)] (send a + 6) (deref a))"] - ["agent-error nil" "nil" "(agent-error (agent 0))"]) diff --git a/test/spec/strings-spec.janet b/test/spec/strings-spec.janet deleted file mode 100644 index 731734c..0000000 --- a/test/spec/strings-spec.janet +++ /dev/null @@ -1,88 +0,0 @@ -# Specification: strings (str + clojure.string). -(use ../support/harness) - -(defspec "string / str & basics" - ["str concat" "\"abc\"" "(str \"a\" \"b\" \"c\")"] - ["str of numbers" "\"12\"" "(str 1 2)"] - ["str nil is empty" "\"\"" "(str nil)"] - ["str mixed" "\"a1:b\"" "(str \"a\" 1 :b)"] - ["str of coll" "\"[1 2]\"" "(str [1 2])"] - ["count" "3" "(count \"abc\")"] - ["subs from" "\"bc\"" "(subs \"abc\" 1)"] - ["subs range" "\"b\"" "(subs \"abc\" 1 2)"] - ["string? true" "true" "(string? \"x\")"] - ["pr-str vector" "\"[1 2 3]\"" "(pr-str [1 2 3])"] - ["pr-str quotes str" "\"\\\"hi\\\"\"" "(pr-str \"hi\")"] - # a var's :meta/:ns refs are cyclic — pr-str/str render it as #'ns/name - # rather than recursing into (and looping on) the var's fields. - ["pr-str of a var" "\"#'user/vv\"" "(pr-str (def vv 1))"] - ["str of a var" "\"#'user/ww\"" "(str (def ww 2))"] - ["pr-str of a defn" "\"#'user/gg\"" "(pr-str (defn gg [x] x))"] - ["seq of string" "[\\a \\b]" "(seq \"ab\")"]) - -(defspec "string as a seqable of chars (jolt-dl4s)" - ["vec of string" "[\\a \\b]" "(vec \"ab\")"] - ["into [] of string" "[\\a \\b]" "(into [] \"ab\")"] - ["set of string" "true" "(= #{\\a \\b} (set \"ab\"))"] - ["into #{} of string" "true" "(= #{\\a \\b} (into #{} \"ab\"))"] - ["set dedups chars" "2" "(count (set \"aab\"))"] - ["mapv over string" "[\\a \\b]" "(mapv identity \"ab\")"]) - -(defspec "clojure.string / split limit (jolt-ik3a)" - ["neg keeps trailing" "[\"a\" \"\" \"\"]" "(do (require (quote [clojure.string :as s])) (s/split \"a,,\" #\",\" -1))"] - ["zero trims trailing" "[\"a\"]" "(do (require (quote [clojure.string :as s])) (s/split \"a,,\" #\",\" 0))"] - ["omitted trims" "[\"a\"]" "(do (require (quote [clojure.string :as s])) (s/split \"a,,\" #\",\"))"] - ["positive caps parts" "[\"a\" \"b,c\"]" "(do (require (quote [clojure.string :as s])) (s/split \"a,b,c\" #\",\" 2))"] - ["empty string" "[\"\"]" "(do (require (quote [clojure.string :as s])) (s/split \"\" #\",\"))"] - ["interior empties kept" "[\"a\" \"\" \"b\"]" "(do (require (quote [clojure.string :as s])) (s/split \"a,,b\" #\",\"))"]) - -(defspec "clojure.string" - ["join" "\"a,b,c\"" "(do (require (quote [clojure.string :as s])) (s/join \",\" [\"a\" \"b\" \"c\"]))"] - ["join no sep" "\"abc\"" "(do (require (quote [clojure.string :as s])) (s/join [\"a\" \"b\" \"c\"]))"] - ["split" "[\"a\" \"b\"]" "(do (require (quote [clojure.string :as s])) (s/split \"a,b\" #\",\"))"] - ["split-lines" "[\"a\" \"b\"]" "(do (require (quote [clojure.string :as s])) (s/split-lines \"a\\nb\"))"] - ["upper-case" "\"ABC\"" "(do (require (quote [clojure.string :as s])) (s/upper-case \"abc\"))"] - ["lower-case" "\"abc\"" "(do (require (quote [clojure.string :as s])) (s/lower-case \"ABC\"))"] - ["capitalize" "\"Abc\"" "(do (require (quote [clojure.string :as s])) (s/capitalize \"abc\"))"] - ["trim" "\"x\"" "(do (require (quote [clojure.string :as s])) (s/trim \" x \"))"] - ["triml" "\"x \"" "(do (require (quote [clojure.string :as s])) (s/triml \" x \"))"] - ["blank? true" "true" "(do (require (quote [clojure.string :as s])) (s/blank? \" \"))"] - ["blank? false" "false" "(do (require (quote [clojure.string :as s])) (s/blank? \"x\"))"] - ["includes?" "true" "(do (require (quote [clojure.string :as s])) (s/includes? \"hello\" \"ell\"))"] - ["starts-with?" "true" "(do (require (quote [clojure.string :as s])) (s/starts-with? \"hello\" \"he\"))"] - ["ends-with?" "true" "(do (require (quote [clojure.string :as s])) (s/ends-with? \"hello\" \"lo\"))"] - ["replace" "\"hexxo\"" "(do (require (quote [clojure.string :as s])) (s/replace \"hello\" \"l\" \"x\"))"] - ["reverse" "\"cba\"" "(do (require (quote [clojure.string :as s])) (s/reverse \"abc\"))"] - ["index-of" "2" "(do (require (quote [clojure.string :as s])) (s/index-of \"hello\" \"l\"))"]) - -# subs validates bounds like Clojure (no Janet from-end/clamping). -(defspec "string / subs strictness" - ["subs basic" "\"bcd\"" "(subs \"abcde\" 1 4)"] - ["subs to end" "\"cde\"" "(subs \"abcde\" 2)"] - ["subs start>end" :throws "(subs \"abcde\" 2 1)"] - ["subs negative" :throws "(subs \"abcde\" -1)"] - ["subs end past len" :throws "(subs \"abcde\" 1 6)"] - ["subs nil start" :throws "(subs \"abcde\" nil 2)"] - ["subs on nil" :throws "(subs nil 1 2)"]) - -(defspec "string / namespace-munge" - ["hyphens to underscores" "\"a_b_c\"" "(namespace-munge \"a-b-c\")"] - ["from a symbol" "\"foo_bar\"" "(namespace-munge (quote foo-bar))"] - ["no hyphens unchanged" "\"ok\"" "(namespace-munge \"ok\")"]) - -# (get s i) indexes a string and returns the char, like Clojure (nth already -# did; get did not — reitit's path parser relies on it). -(defspec "strings / get indexes a string" - ["get returns the char" "true" "(= (get \"a:b\" 1) \\:)"] - ["get first char" "\\a" "(get \"abc\" 0)"] - ["get out of range nil" "nil" "(get \"abc\" 9)"] - ["get negative nil" "nil" "(get \"abc\" -1)"] - ["get default honored" ":none" "(get \"abc\" 9 :none)"]) - -# clojure.string/trim-newline (ported from clojure.string): strips trailing \n/\r. -(defspec "clojure.string / trim-newline" - ["trailing newline" "\"x\"" "(do (require (quote [clojure.string :as s])) (s/trim-newline \"x\\n\"))"] - ["trailing \\r\\n" "\"x\"" "(do (require (quote [clojure.string :as s])) (s/trim-newline \"x\\r\\n\"))"] - ["no trailing" "\"ab\"" "(do (require (quote [clojure.string :as s])) (s/trim-newline \"ab\"))"] - ["only newlines" "\"\"" "(do (require (quote [clojure.string :as s])) (s/trim-newline \"\\n\\n\"))"] - ["interior kept" "\"a\\nb\"" "(do (require (quote [clojure.string :as s])) (s/trim-newline \"a\\nb\\n\"))"]) diff --git a/test/spec/transducers-spec.janet b/test/spec/transducers-spec.janet deleted file mode 100644 index be21ca1..0000000 --- a/test/spec/transducers-spec.janet +++ /dev/null @@ -1,77 +0,0 @@ -# Specification: transducers. -(use ../support/harness) - -(defspec "transducers / into" - ["map xform" "[2 3 4]" "(into [] (map inc) [1 2 3])"] - ["filter xform" "[2 4]" "(into [] (filter even?) [1 2 3 4])"] - ["remove xform" "[1 3]" "(into [] (remove even?) [1 2 3 4])"] - ["take xform" "[1 2]" "(into [] (take 2) [1 2 3 4])"] - ["drop xform" "[3 4]" "(into [] (drop 2) [1 2 3 4])"] - ["take-while xform" "[1 2]" "(into [] (take-while (fn [x] (< x 3))) [1 2 3 1])"] - ["keep xform" "[1 3]" "(into [] (keep (fn [x] (if (odd? x) x nil))) [1 2 3 4])"] - ["map-indexed xform" "[[0 :a] [1 :b]]" "(into [] (map-indexed vector) [:a :b])"] - ["mapcat xform" "[1 1 2 2]" "(into [] (mapcat (fn [x] [x x])) [1 2])"] - ["cat xform" "[1 2 3 4]" "(into [] cat [[1 2] [3 4]])"] - ["into a set" "#{2 3 4}" "(into #{} (map inc) [1 2 3])"]) - -# transducer comp applies left-to-right: (comp (map a) (filter b)) maps then filters -(defspec "transducers / compose" - ["comp map+filter" "[2 4 6 8]" "(into [] (comp (map (fn [x] (* x 2))) (filter even?)) [1 2 3 4])"] - ["comp filter+map" "[2 4]" "(into [] (comp (filter odd?) (map inc)) [1 2 3 4])"] - ["comp three" "[2]" "(into [] (comp (map inc) (filter even?) (take 1)) [1 2 3 4])"]) - -(defspec "transducers / transduce & sequence" - ["transduce sum" "9" "(transduce (map inc) + [1 2 3])"] - ["transduce init" "19" "(transduce (map inc) + 10 [1 2 3])"] - ["transduce filter" "6" "(transduce (filter even?) + [1 2 3 4])"] - ["sequence xform" "[2 3 4]" "(sequence (map inc) [1 2 3])"] - ["eduction" "[2 3 4]" "(into [] (eduction (map inc) [1 2 3]))"] - ["completing" "9" "(transduce (map inc) (completing +) 0 [1 2 3])"]) - -# halt-when replaces the WHOLE reduction result with the halting input (or -# with (retf acc input)) — Clojure's ::halt map protocol, unwrapped by the -# transducer's completion arity. -(defspec "transducers / halt-when" - ["halt returns the halting input" "7" - "(transduce (halt-when (fn [x] (> x 5))) conj [1 2 7 3])"] - ["no halt is a plain reduction" "[1 2 3]" - "(transduce (halt-when (fn [x] (> x 5))) conj [1 2 3])"] - ["retf combines acc and input" "[[1 2] 7]" - "(transduce (halt-when (fn [x] (> x 5)) (fn [r i] [r i])) conj [1 2 7 3])"] - ["halt-when through into" "3" - "(into [] (halt-when odd?) [2 4 3 6])"]) - -# A `take`/`take-while` transducer returns `reduced`, which must short-circuit -# the reduction so transducing over an INFINITE seq terminates rather than -# realizing it eagerly. -(defspec "transducers / short-circuit over infinite seqs" - ["into take (range)" "[0 1 2 3 4]" "(into [] (take 5) (range))"] - ["transduce take (range)" "3" "(transduce (take 3) + 0 (range))"] - ["sequence take (range)" "[0 1 2 3 4]" "(sequence (take 5) (range))"] - ["take-while over (range)" "[0 1 2]" "(into [] (take-while (fn [x] (< x 3))) (range))"] - ["comp take over (range)" "[1 3 5]" "(into [] (comp (filter odd?) (take 3)) (range))"] - ["into take iterate" "[0 1 2 3 4]" "(into [] (take 5) (iterate inc 0))"]) - -# `reduce` itself honors `reduced`, so a reducing fn that returns `reduced` -# terminates even over an infinite seq. -(defspec "reduce / honors reduced" - ["reduced short-circuits inf" "105" - "(reduce (fn [a x] (if (> a 100) (reduced a) (+ a x))) 0 (range))"] - ["reduce take inf" "10" "(reduce + (take 5 (range)))"] - ["reduce no-init first elem" "6" "(reduce + [1 2 3])"] - ["reduce no-init single" "42" "(reduce + [42])"] - ["reduce empty calls f" "0" "(reduce + [])"] - ["reduce with-init" "16" "(reduce + 10 [1 2 3])"] - ["reduce reduced immediate" ":x" "(reduce (fn [a x] (reduced :x)) :init [1 2 3])"]) - -# into/transduce/eduction are overlay fns now (seed-shrink round 5): into -# takes a transient fast path for vectors and preserves metadata; eduction -# stays eager (documented divergence). -(defspec "transducers / into & eduction (overlay)" - ["into list prepends" "(quote (4 3 1 2))" "(into (quote (1 2)) [3 4])"] - ["into sorted-map" "{1 :a, 2 :b}" "(into (sorted-map) [[2 :b] [1 :a]])"] - ["into from map entry" "[:a 1]" "(into [] (first {:a 1}))"] - ["into xform on map" "{:a 2}" "(into {} (map (fn [e] [(key e) (inc (val e))])) {:a 1})"] - ["eduction multiple xforms" "[4]" "(into [] (eduction (filter odd?) (map inc) [2 3 4]))"] - ["->Eduction" "[2 3]" "(->Eduction (map inc) [1 2])"] - ["transduce no init uses (f)" "5" "(transduce (map inc) + [1 2])"]) diff --git a/test/spec/transients-spec.janet b/test/spec/transients-spec.janet deleted file mode 100644 index 26c523f..0000000 --- a/test/spec/transients-spec.janet +++ /dev/null @@ -1,96 +0,0 @@ -# Specification: transients (mutable scratch collections frozen by persistent!). -(use ../support/harness) - -(defspec "transient / vector" - ["conj! then persistent!" "[1 2]" "(persistent! (conj! (conj! (transient []) 1) 2))"] - ["reduce conj!" "[0 1 2 3 4]" "(persistent! (reduce conj! (transient []) (range 5)))"] - ["conj! many args" "[1 2 3]" "(persistent! (conj! (transient [1]) 2 3))"] - ["assoc! existing" "[1 9 3]" "(persistent! (assoc! (transient [1 2 3]) 1 9))"] - ["assoc! at count grows" "[1 2 3]" "(persistent! (assoc! (transient [1 2]) 2 3))"] - ["pop!" "[1 2]" "(persistent! (pop! (transient [1 2 3])))"] - ["from existing vector" "[1 2 3 4]" "(persistent! (conj! (transient [1 2 3]) 4))"] - ["count" "3" "(count (transient [1 2 3]))"] - ["nth" "2" "(nth (transient [1 2 3]) 1)"] - ["get" "2" "(get (transient [1 2 3]) 1)"] - ["persistent! is a vector" "true" "(vector? (persistent! (transient [1])))"] - ["transient? true" "true" "(transient? (transient []))"] - ["transient? false" "false" "(transient? [1 2])"]) - -(defspec "transient / map" - ["assoc! then persistent!" "{:a 1, :b 2}" "(persistent! (assoc! (assoc! (transient {}) :a 1) :b 2))"] - ["assoc! many" "{:a 1, :b 2}" "(persistent! (assoc! (transient {}) :a 1 :b 2))"] - ["dissoc!" "{:b 2}" "(persistent! (dissoc! (transient {:a 1 :b 2}) :a))"] - ["conj! map entry" "{:a 1}" "(persistent! (conj! (transient {}) [:a 1]))"] - ["from existing map" "{:a 1, :b 2}" "(persistent! (assoc! (transient {:a 1}) :b 2))"] - ["get" "1" "(get (transient {:a 1}) :a)"] - ["get missing default" ":x" "(get (transient {:a 1}) :z :x)"] - ["contains?" "true" "(contains? (transient {:a 1}) :a)"] - ["count" "2" "(count (transient {:a 1 :b 2}))"] - ["collection key by value" ":v" "(get (persistent! (assoc! (transient {}) [1 2] :v)) [1 2])"] - ["persistent! is a map" "true" "(map? (persistent! (transient {:a 1})))"] - ["reduce build" "{0 0, 1 1, 2 2}" "(persistent! (reduce (fn [t i] (assoc! t i i)) (transient {}) (range 3)))"]) - -(defspec "transient / set" - ["conj! dedups" "#{1 2 3}" "(persistent! (conj! (transient #{}) 1 2 2 3))"] - ["disj!" "#{1 3}" "(persistent! (disj! (transient #{1 2 3}) 2))"] - ["from existing set" "#{1 2 3}" "(persistent! (conj! (transient #{1 2}) 3))"] - ["contains?" "true" "(contains? (transient #{1 2}) 1)"] - ["count" "2" "(count (transient #{1 2}))"] - ["persistent! is a set" "true" "(set? (persistent! (transient #{1})))"] - ["map elements by value" "1" "(count (persistent! (conj! (transient #{}) {:a 1} (hash-map :a 1))))"]) - -(defspec "transient / immutability of source" - ["source vector unchanged" "true" - "(let [v [1 2 3] _ (persistent! (conj! (transient v) 4))] (= v [1 2 3]))"] - ["source map unchanged" "true" - "(let [m {:a 1} _ (persistent! (assoc! (transient m) :b 2))] (= m {:a 1}))"]) - -# Transients are invokable for read-only lookup, like their persistent forms. -(defspec "transient / invokable lookup" - ["vector index" "20" "((transient [10 20 30]) 1)"] - ["map key as fn" "7" "((transient {:x 7}) :x)"] - ["map key default" "99" "((transient {:x 7}) :z 99)"] - ["keyword on transient" "7" "(:x (transient {:x 7}))"] - ["set membership" "2" "((transient #{1 2 3}) 2)"] - ["set miss default" ":no" "((transient #{1 2 3}) 42 :no)"] - ["collection key" ":v" "((transient {[1 2] :v}) [1 2])"]) - -# assoc! requires an even key/val arg count, like assoc and Clojure's assoc!: a -# dangling key with no value throws (jolt-ea9k fixed the former lenient -# nil-fill, which was non-Clojure and inconsistent with jolt's own plain assoc). -(defspec "transient / assoc! odd args throw" - ["map dangling key" :throws "(persistent! (assoc! (transient {}) :a 1 :b))"] - ["map lone key" :throws "(persistent! (assoc! (transient {}) :a))"] - ["vector dangling" :throws "(persistent! (apply assoc! (transient []) [0 9 1]))"] - ["even args still ok" "true" - "(= {:a 1, :b 2} (persistent! (assoc! (transient {}) :a 1 :b 2)))"]) - -# Using a transient after persistent! (or popping an empty one) throws. -(defspec "transient / invalidation" - ["conj! after persistent!" :throws - "(let [t (transient [])] (persistent! t) (conj! t 1))"] - ["assoc! after persistent!" :throws - "(let [t (transient {})] (persistent! t) (assoc! t :a 1))"] - ["persistent! twice" :throws - "(let [t (transient [])] (persistent! t) (persistent! t))"] - ["pop! empty" :throws "(pop! (transient []))"]) - -# The bang ops require an appropriate transient (Clojure throws otherwise); -# conj! has the special 0-/1-arg identity arities. -(defspec "transient / strictness" - ["conj! on persistent" :throws "(conj! [1 2] 3)"] - ["assoc! on persistent" :throws "(assoc! {:a 1} :b 2)"] - ["persistent! on vector" :throws "(persistent! [1 2])"] - ["persistent! on nil" :throws "(persistent! nil)"] - ["pop! on transient map" :throws "(pop! (transient {:a 1}))"] - ["dissoc! on tset" :throws "(dissoc! (transient #{1}) 1)"] - ["conj! map bad item" :throws "(conj! (transient {}) #{:a 1})"] - ["conj! no args" "[]" "(persistent! (conj!))"] - ["conj! identity" "[1 2]" "(conj! [1 2])"] - ["conj! map merges map" "{:a 1, :b 2}" "(persistent! (conj! (transient {:a 1}) {:b 2}))"]) - -(defspec "transient / assoc! bounds" - ["assoc! existing idx" "[1 9 3]" "(persistent! (assoc! (transient [1 2 3]) 1 9))"] - ["assoc! at count grows" "[1 2 3]" "(persistent! (assoc! (transient [1 2]) 2 3))"] - ["assoc! out of bounds" :throws "(assoc! (transient [0 1 2]) 4 4)"] - ["assoc! negative" :throws "(assoc! (transient []) -1 0)"]) diff --git a/test/spec/truthiness-spec.janet b/test/spec/truthiness-spec.janet deleted file mode 100644 index a119e7a..0000000 --- a/test/spec/truthiness-spec.janet +++ /dev/null @@ -1,61 +0,0 @@ -# Specification: truthiness & boolean logic. -# The core Clojure rule: ONLY nil and false are logically false; every other -# value — including 0, 0.0, "", and empty collections — is logically true. -(use ../support/harness) - -(defspec "truthiness / if (only nil & false are falsy)" - ["nil is falsy" ":f" "(if nil :t :f)"] - ["false is falsy" ":f" "(if false :t :f)"] - ["zero is truthy" ":t" "(if 0 :t :f)"] - ["zero float truthy" ":t" "(if 0.0 :t :f)"] - ["empty string truthy" ":t" "(if \"\" :t :f)"] - ["empty list truthy" ":t" "(if (list) :t :f)"] - ["empty vector truthy" ":t" "(if [] :t :f)"] - ["empty map truthy" ":t" "(if {} :t :f)"] - ["empty set truthy" ":t" "(if #{} :t :f)"] - ["number truthy" ":t" "(if 42 :t :f)"] - ["string truthy" ":t" "(if \"x\" :t :f)"] - ["keyword truthy" ":t" "(if :kw :t :f)"] - ["symbol truthy" ":t" "(if (quote abc) :t :f)"] - ["coll truthy" ":t" "(if [1 2] :t :f)"] - ["map truthy" ":t" "(if {:a 1} :t :f)"] - ["if no else -> nil" "nil" "(if false :t)"]) - -(defspec "truthiness / not" - ["not nil" "true" "(not nil)"] - ["not false" "true" "(not false)"] - ["not zero" "false" "(not 0)"] - ["not empty vector" "false" "(not [])"] - ["not empty string" "false" "(not \"\")"] - ["not number" "false" "(not 42)"] - ["not true" "false" "(not true)"]) - -(defspec "truthiness / and" - ["empty is true" "true" "(and)"] - ["single value" "5" "(and 5)"] - ["all truthy -> last" "3" "(and 1 2 3)"] - ["stops at false" "false" "(and 1 false 3)"] - ["stops at nil" "nil" "(and 1 nil 3)"] - ["false alone" "false" "(and false)"] - ["nil alone" "nil" "(and nil)"] - ["zero is truthy" "0" "(and 1 0)"]) - -(defspec "truthiness / or" - ["empty is nil" "nil" "(or)"] - ["first truthy" "1" "(or 1 2)"] - ["skips nil/false" "5" "(or nil false 5)"] - ["all falsy -> last" "false" "(or nil false)"] - ["nil chain -> false" "false" "(or nil nil nil false)"] - ["zero is truthy" "0" "(or 0 1)"] - ["false alone" "false" "(or false)"]) - -(defspec "truthiness / if-not & boolean" - ["if-not false" ":yes" "(if-not false :yes :no)"] - ["if-not truthy" ":no" "(if-not 0 :yes :no)"] - ["when-not nil" "1" "(when-not nil 1)"] - ["when-not truthy" "nil" "(when-not 5 1)"] - ["boolean of nil" "false" "(boolean nil)"] - ["boolean of false" "false" "(boolean false)"] - ["boolean of 0" "true" "(boolean 0)"] - ["boolean of value" "true" "(boolean :x)"] - ["true?/false?" "true" "(and (true? true) (false? false) (not (true? 1)))"]) diff --git a/test/spec/untested-vars-spec.janet b/test/spec/untested-vars-spec.janet deleted file mode 100644 index b5da2ed..0000000 --- a/test/spec/untested-vars-spec.janet +++ /dev/null @@ -1,185 +0,0 @@ -# Specification: spec rows for every previously-untested implemented var -# (jolt-brh follow-up — promotes the dashboard's implemented-untested category). -# Rows assert jolt's ACTUAL documented behavior, including the stub families: -# arrays are vectors/host buffers, proxies/JVM reflection are resolve-only, -# unchecked-* are plain double ops, chunks are eager equivalents. -(use ../support/harness) - -(defspec "untested / primed + division + bit ops" - ["+'" "3" "(+' 1 2)"] - ["-'" "3" "(-' 5 2)"] - ["*'" "12" "(*' 3 4)"] - ["inc'" "2.5" "(inc' 1.5)"] - ["dec'" "1.5" "(dec' 2.5)"] - ["/" "2" "(/ 6 3)"] - ["/ ratio-as-double" "0.5" "(/ 1 2)"] - ["bit-not" "-6" "(bit-not 5)"] - ["bit-and-not" "4" "(bit-and-not 12 10)"] - ["bit-flip" "3" "(bit-flip 2 0)"] - ["unsigned-bit-shift-right" "2" "(unsigned-bit-shift-right 8 2)"]) - -(defspec "untested / hash family" - ["hash stable" "true" "(= (hash :a) (hash :a))"] - ["hash int" "true" "(int? (hash [1 2]))"] - ["hash-combine" "true" "(int? (hash-combine 1 2))"] - ["hash-ordered-coll" "true" "(int? (hash-ordered-coll [1 2]))"] - ["hash-unordered-coll" "true" "(int? (hash-unordered-coll #{1}))"]) - -(defspec "untested / array stubs (vectors + host buffers)" - ["make-array" "(quote (nil nil nil))" "(make-array 3)"] - ["into-array" "(quote (1 2))" "(into-array [1 2])"] - ["to-array" "(quote (1 2))" "(to-array [1 2])"] - ["aclone vec" "(quote (1 2))" "(aclone [1 2])"] - ["aclone independent" "(quote (9 2))" "(let [a (aclone (to-array [1 2]))] (aset a 0 9) (seq a))"] - ["aset/aget" "9" "(let [a (to-array [1 2 3])] (aset a 0 9) (aget a 0))"] - ["aset-int" "7" "(let [a (to-array [1 2])] (aset-int a 0 7) (aget a 0))"] - ["aset-boolean" "true" "(let [a (to-array [1])] (aset-boolean a 0 true) (aget a 0))"] - ["aset-byte" "9" "(let [a (to-array [0])] (aset-byte a 0 9) (aget a 0))"] - ["aset-char" "\\a" "(let [a (to-array [0])] (aset-char a 0 \\a) (aget a 0))"] - ["aset-double" "1.5" "(let [a (to-array [0])] (aset-double a 0 1.5) (aget a 0))"] - ["aset-float" "2.5" "(let [a (to-array [0])] (aset-float a 0 2.5) (aget a 0))"] - ["aset-long" "3" "(let [a (to-array [0])] (aset-long a 0 3) (aget a 0))"] - ["aset-short" "4" "(let [a (to-array [0])] (aset-short a 0 4) (aget a 0))"] - ["boolean-array" "(quote (false false))" "(boolean-array 2)"] - ["int-array" "(quote (1 2))" "(int-array [1 2])"] - ["long-array" "(quote (0 0))" "(long-array 2)"] - ["double-array" "(quote (0 0))" "(double-array 2)"] - ["float-array" "(quote (0 0))" "(float-array 2)"] - ["short-array" "(quote (0 0))" "(short-array 2)"] - ["char-array count" "2" "(count (char-array 2))"] - ["byte-array bytes?" "true" "(bytes? (byte-array 2))"] - ["bytes? not vec" "false" "(bytes? [1])"]) - -(defspec "untested / typed coercion views" - ["booleans" "(quote (true))" "(booleans [true])"] - ["doubles" "(quote (1))" "(doubles [1.0])"] - ["floats" "(quote (1))" "(floats [1.0])"] - ["ints" "(quote (1))" "(ints [1])"] - ["longs" "(quote (1))" "(longs [1])"] - ["shorts" "(quote (1))" "(shorts [1])"] - ["chars first" "\\a" "(first (chars [\\a]))"] - ["bytes view" "true" "(bytes? (bytes [65]))"] - ["byte" "65" "(byte 65)"] - ["short" "1" "(short 1)"] - ["long truncates" "1" "(long 1.7)"] - ["double" "3" "(double 3)"] - ["float" "3" "(float 3)"]) - -(defspec "untested / unchecked-* are plain ops" - ["unchecked-add" "3" "(unchecked-add 1 2)"] - ["unchecked-add-int" "3" "(unchecked-add-int 1 2)"] - ["unchecked-subtract" "3" "(unchecked-subtract 5 2)"] - ["unchecked-subtract-int" "3" "(unchecked-subtract-int 5 2)"] - ["unchecked-multiply" "6" "(unchecked-multiply 2 3)"] - ["unchecked-multiply-int" "6" "(unchecked-multiply-int 2 3)"] - ["unchecked-inc" "2" "(unchecked-inc 1)"] - ["unchecked-inc-int" "2" "(unchecked-inc-int 1)"] - ["unchecked-dec" "2" "(unchecked-dec 3)"] - ["unchecked-dec-int" "2" "(unchecked-dec-int 3)"] - ["unchecked-negate" "-4" "(unchecked-negate 4)"] - ["unchecked-negate-int" "-4" "(unchecked-negate-int 4)"] - ["unchecked-divide-int" "3" "(unchecked-divide-int 7 2)"] - ["unchecked-remainder-int" "1" "(unchecked-remainder-int 7 2)"] - ["unchecked-int" "3" "(unchecked-int 3.7)"] - ["unchecked-long" "3" "(unchecked-long 3.7)"] - ["unchecked-double" "3" "(unchecked-double 3)"] - ["unchecked-float" "3" "(unchecked-float 3)"] - ["unchecked-byte" "65" "(unchecked-byte 65)"] - ["unchecked-char" "97" "(unchecked-char 97)"] - ["unchecked-short" "5" "(unchecked-short 5)"]) - -(defspec "untested / chunk family (eager equivalents) + cat" - ["chunk round-trip" "1" - "(let [cb (chunk-buffer 4)] (chunk-append cb 1) (chunk-first (chunk-cons (chunk cb) nil)))"] - ["cat transducer" "[1 2 3]" "(into [] cat [[1] [2 3]])"] - ["ensure-reduced wraps" "true" "(reduced? (ensure-reduced 5))"] - ["ensure-reduced keeps reduced" "true" "(reduced? (ensure-reduced (reduced 5)))"] - ["halt-when" "4" "(transduce (halt-when even?) conj [] [1 3 4 5])"] - ["chunk-next exhausted" "nil" - "(let [cb (chunk-buffer 2)] (chunk-append cb 1) (chunk-next (chunk-cons (chunk cb) nil)))"] - ["chunk-rest seqable" "()" - "(let [cb (chunk-buffer 2)] (chunk-append cb 1) (vec (chunk-rest (chunk-cons (chunk cb) nil))))"]) - -(defspec "untested / JVM-shape stubs (documented jolt behavior)" - ["class number" "\"java.lang.Number\"" "(class 1)"] - ["class string" "\"java.lang.String\"" "(class \"s\")"] - ["class keyword" "\"clojure.lang.Keyword\"" "(class :k)"] - ["class nil" "nil" "(class nil)"] - ["bean is the map" "{:a 1}" "(bean {:a 1})"] - ["biginteger" "\"5\"" "(str (biginteger 5))"] - ["proxy resolves nil" "nil" "(proxy [Object] [] (toString [] \"x\"))"] - ["construct-proxy throws" :throws "(construct-proxy nil)"] - ["get-proxy-class throws" :throws "(get-proxy-class)"] - ["init-proxy" "nil" "(init-proxy nil {})"] - ["update-proxy" "nil" "(update-proxy nil {})"] - ["proxy-mappings" "{}" "(proxy-mappings nil)"] - ["proxy-call-with-super calls" "1" "(proxy-call-with-super (fn [] 1) nil \"m\")"] - ["memfn upper" "\"ABC\"" "((memfn toUpperCase) \"abc\")"] - ["memfn with args" "2" "((memfn indexOf needle) \"hello\" \"l\")"] - ["memfn length" "3" "((memfn length) \"abc\")"] - ["array-seq" "(quote (1 2 3))" "(array-seq (to-array [1 2 3]))"] - ["array-seq empty" "nil" "(array-seq (to-array []))"] - ["proxy-super throws" :throws "(proxy-super count [1])"] - ["re-groups throws" :throws "(re-groups (re-matcher #\"a\" \"b\"))"] - ["re-matcher builds" "false" "(nil? (re-matcher #\"a\" \"abc\"))"] - ["print-dup nil writer throws" :throws "(print-dup 1 nil)"] - ["print-method nil writer throws" :throws "(print-method 1 nil)"] - ["uri? string" "false" "(uri? \"http://x\")"] - ["uri? nil" "false" "(uri? nil)"] - ["definterface defines" "true" "(var? (definterface IFoo (foo [x])))"] - ["enumeration-seq" "(quote (1 2))" "(enumeration-seq [1 2])"] - ["iterator-seq" "(quote (1 2))" "(iterator-seq [1 2])"] - ["seque passthrough" "(quote (1 2))" "(seque [1 2])"] - ["delay? true" "true" "(delay? (delay 1))"] - ["delay? false" "false" "(delay? 1)"] - ["future-call" "42" "(deref (future-call (fn [] 42)))"] - [". calls String surface" "3" "(. \"abc\" length)"] - [".. threads members" "\"ABC\"" "(.. \"abc\" toUpperCase)"] - ["unknown String member throws" :throws "(. \"abc\" frobnicate)"]) - -(defspec "untested / protocols: extend + extends?" - ["extend registers" ":str" - "(do (defprotocol Pe (pe [x])) (extend (quote String) Pe {:pe (fn [x] :str)}) (pe \"s\"))"] - ["extend two methods" "[1 2]" - "(do (defprotocol P3 (pa [x]) (pb [x])) (extend (quote Long) P3 {:pa (fn [x] 1) :pb (fn [x] 2)}) [(pa 0) (pb 0)])"] - ["extends? after extend" "true" - "(do (defprotocol P4 (pc [x])) (extend (quote Long) P4 {:pc (fn [x] 1)}) (extends? P4 (quote Long)))"] - ["extends? without" "false" "(do (defprotocol P5 (pd [x])) (extends? P5 (quote Long)))"]) - -(defspec "untested / ns + REPL machinery" - ["all-ns non-empty" "true" "(pos? (count (all-ns)))"] - ["ns-interns sees def" "true" "(do (def zz 1) (pos? (count (ns-interns (quote user)))))"] - ["ns-interns countable" "true" "(map? (ns-interns (quote user)))"] - ["ns-imports empty user" "0" "(count (ns-imports (quote user)))"] - ["reset-meta!" "{:doc \"d\"}" "(do (def vv 1) (reset-meta! (var vv) {:doc \"d\"}))"] - ["prefers empty" "{}" "(do (defmulti mm identity) (prefers mm))"] - ["refer-clojure" "nil" "(refer-clojure)"] - ["special-symbol? if" "true" "(special-symbol? (quote if))"] - ["special-symbol? fn name" "false" "(special-symbol? (quote foo))"] - ["destructure expands" "true" "(pos? (count (destructure (quote [[a b] x]))))"] - ["seq-to-map-for-destructuring" "{:a 1}" "(seq-to-map-for-destructuring (quote (:a 1)))"] - ["s2m trailing map passes through" "{:b 2}" "(seq-to-map-for-destructuring (list {:b 2}))"] - ["s2m unpaired key throws" :throws "(seq-to-map-for-destructuring (quote (:a 1 :b)))"] - ["s2m kwargs trailing map call" "2" "((fn [& {:keys [b]}] b) {:b 2})"] - ["*clojure-version* major" "1" "(:major *clojure-version*)"] - ["*ns* user" "\"user\"" "(str *ns*)"] - ["*1 nil outside repl" "nil" "*1"] - ["*2 nil" "nil" "*2"] - ["*3 nil" "nil" "*3"] - ["*e nil" "nil" "*e"] - ["*unchecked-math*" "false" "*unchecked-math*"] - ["*in* bound" "true" "(map? *in*)"]) - -(defspec "untested / misc seqs + binding machinery" - ["nfirst" "(quote (2))" "(nfirst [[1 2] [3]])"] - ["xml-seq root" "1" "(count (xml-seq {:tag :a :content []}))"] - ["xml-seq walks" "2" "(count (xml-seq {:tag :a :content [{:tag :b :content []}]}))"] - # regression: comp with a keyword stage must use jolt IFn dispatch - ["comp keyword stage" "(quote (1 2))" "((comp seq :content) {:content [1 2]})"] - ["comp three stages" "4" "((comp inc inc :n) {:n 2})"] - ["random-sample all" "(quote (1 2))" "(random-sample 1.0 [1 2])"] - ["random-sample none" "()" "(random-sample 0.0 [1 2])"] - ["reader-conditional builds" "true" "(reader-conditional? (reader-conditional (quote (:clj 1)) false))"] - ["->Eduction" "[2 3]" "(vec (->Eduction (map inc) [1 2]))"] - ["bound-fn calls" "42" "((bound-fn [] 42))"] - ["push/pop-thread-bindings" ":ok" "(do (push-thread-bindings {}) (pop-thread-bindings) :ok)"]) diff --git a/test/spec/uuid-spec.janet b/test/spec/uuid-spec.janet deleted file mode 100644 index a9c8e7f..0000000 --- a/test/spec/uuid-spec.janet +++ /dev/null @@ -1,51 +0,0 @@ -# Specification: UUID support — random-uuid, parse-uuid, uuid?, #uuid literal. -# UUIDs are immutable tagged structs {:jolt/type :jolt/uuid :str ""}: -# value equality, usable as map keys, case-normalized at construction. -(use ../support/harness) - -(defspec "uuid / random-uuid" - ["returns a uuid" "true" "(uuid? (random-uuid))"] - ["str is 36 chars" "36" "(count (str (random-uuid)))"] - ["8-4-4-4-12 shape" "[8 4 4 4 12]" "(do (require (quote [clojure.string :as s])) (mapv count (s/split (str (random-uuid)) #\"-\")))"] - ["version nibble is 4" "\\4" "(nth (str (random-uuid)) 14)"] - ["variant nibble 8-b" "true" "(contains? #{\\8 \\9 \\a \\b} (nth (seq (str (random-uuid))) 19))"] - ["distinct" "10" "(count (set (repeatedly 10 random-uuid)))"] - ["all hex digits" "true" "(every? (fn [c] (contains? (set (seq \"0123456789abcdef-\")) c)) (seq (str (random-uuid))))"]) - -(defspec "uuid / parse-uuid" - ["valid round-trips" "\"b6883c0a-0342-4007-9966-bc2dfa6b109e\"" - "(str (parse-uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\"))"] - ["parses to uuid" "true" "(uuid? (parse-uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\"))"] - ["case-insensitive =" "true" - "(= (parse-uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\") (parse-uuid \"B6883C0A-0342-4007-9966-BC2DFA6B109E\"))"] - ["empty -> nil" "nil" "(parse-uuid \"\")"] - ["short -> nil" "nil" "(parse-uuid \"0\")"] - ["garbage -> nil" "nil" "(parse-uuid \"df0993\")"] - ["too long -> nil" "nil" "(parse-uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109eb\")"] - ["leading extra -> nil" "nil" "(parse-uuid \"ab6883c0a-0342-4007-9966-bc2dfa6b109e\")"] - ["non-hex -> nil" "nil" "(parse-uuid \"g6883c0a-0342-4007-9966-bc2dfa6b109e\")"] - ["bad dashes -> nil" "nil" "(parse-uuid \"b6883c0a00342-4007-9966-bc2dfa6b109e\")"] - ["non-string throws" :throws "(parse-uuid 1000)"] - ["keyword throws" :throws "(parse-uuid :key)"] - ["map throws" :throws "(parse-uuid {})"]) - -(defspec "uuid / value semantics" - ["equal by value" "true" - "(= (parse-uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\") (parse-uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\"))"] - ["unequal differs" "false" - "(= (random-uuid) (random-uuid))"] - ["works as map key" ":v" - "(let [u (parse-uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\")] (get {u :v} (parse-uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\")))"] - ["works in a set" "true" - "(contains? #{(parse-uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\")} (parse-uuid \"B6883C0A-0342-4007-9966-BC2DFA6B109E\"))"] - ["uuid? false on string" "false" "(uuid? \"b6883c0a-0342-4007-9966-bc2dfa6b109e\")"] - ["uuid? false on nil" "false" "(uuid? nil)"]) - -(defspec "uuid / #uuid reader literal" - ["reads to uuid" "true" "(uuid? #uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\")"] - ["= parse-uuid" "true" - "(= #uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\" (parse-uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\"))"] - ["str of literal" "\"b6883c0a-0342-4007-9966-bc2dfa6b109e\"" - "(str #uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\")"] - ["pr-str round-trips" "\"#uuid \\\"b6883c0a-0342-4007-9966-bc2dfa6b109e\\\"\"" - "(pr-str #uuid \"b6883c0a-0342-4007-9966-bc2dfa6b109e\")"]) diff --git a/test/spec/vectors-spec.janet b/test/spec/vectors-spec.janet deleted file mode 100644 index 136752d..0000000 --- a/test/spec/vectors-spec.janet +++ /dev/null @@ -1,69 +0,0 @@ -# Specification: vectors (persistent, indexed). -(use ../support/harness) - -(defspec "vector / construct & predicate" - ["literal" "[1 2 3]" "[1 2 3]"] - ["vector" "[1 2 3]" "(vector 1 2 3)"] - ["vector zero args" "[]" "(vector)"] - ["vec from list" "[1 2 3]" "(vec (list 1 2 3))"] - ["vec from range" "[0 1 2]" "(vec (range 3))"] - ["vec of map yields entries" "[[:a 1]]" "(vec {:a 1})"] - ["vector? true" "true" "(vector? [1])"] - ["vector? false on list" "false" "(vector? (list 1))"] - ["vector = list elts" "true" "(= [1 2 3] (list 1 2 3))"]) - -(defspec "vector / access" - ["nth" ":b" "(nth [:a :b :c] 1)"] - ["nth default" ":x" "(nth [:a] 5 :x)"] - ["get by index" ":b" "(get [:a :b] 1)"] - ["get out of range nil" "nil" "(get [:a] 5)"] - ["get default" ":x" "(get [:a] 5 :x)"] - ["first" "1" "(first [1 2 3])"] - ["last" "3" "(last [1 2 3])"] - ["peek is last" "3" "(peek [1 2 3])"] - ["count" "3" "(count [1 2 3])"] - ["contains? index" "true" "(contains? [:a :b] 1)"] - ["contains? past end" "false" "(contains? [:a] 3)"] - ["vector as fn" ":b" "([:a :b :c] 1)"] - # An IFn collection held in a binding (not just a literal) must dispatch as IFn, - # not as a host call: applies to vectors, keywords, and meta-bearing vectors. - ["vector-in-local as fn" "20" "(let [v [10 20 30]] (v 1))"] - ["keyword-in-local as fn" "7" "(let [k :a] (k {:a 7}))"] - ["meta vector as fn" "10" "((with-meta [10 20] {:k 1}) 0)"]) - -(defspec "vector / update (persistent)" - ["conj appends" "[1 2 3]" "(conj [1 2] 3)"] - ["conj many" "[1 2 3 4]" "(conj [1 2] 3 4)"] - ["assoc index" "[1 9 3]" "(assoc [1 2 3] 1 9)"] - ["assoc at count appends" "[1 2 3]" "(assoc [1 2] 2 3)"] - ["update" "[1 3 3]" "(update [1 2 3] 1 inc)"] - ["pop drops last" "[1 2]" "(pop [1 2 3])"] - ["subvec start end" "[2 3]" "(subvec [1 2 3 4] 1 3)"] - ["subvec to end" "[3 4]" "(subvec [1 2 3 4] 2)"] - ["mapv" "[2 3 4]" "(mapv inc [1 2 3])"] - ["filterv" "[2 4]" "(filterv even? [1 2 3 4])"]) - -(defspec "vector / immutability & nesting" - ["conj does not mutate" "true" "(let [v [1 2] w (conj v 3)] (and (= v [1 2]) (= w [1 2 3])))"] - ["assoc does not mutate" "true" "(let [v [1 2 3] w (assoc v 0 9)] (and (= v [1 2 3]) (= w [9 2 3])))"] - ["get-in" "2" "(get-in [[1 2] [3 4]] [0 1])"] - ["assoc-in" "[[1 9]]" "(assoc-in [[1 2]] [0 1] 9)"] - ["update-in" "[[1 3]]" "(update-in [[1 2]] [0 1] inc)"] - ["large vector nth" "1500" "(nth (vec (range 2000)) 1500)"] - ["large vector count" "2000" "(count (vec (range 2000)))"] - ["large conj immutable" "true" "(let [v (vec (range 1000)) w (conj v :end)] (and (= 1000 (count v)) (= 1001 (count w))))"]) - -# vec/into build the pvec trie BOTTOM-UP in one pass (pv-from-indexed, jolt-5vsp -# collections). Exercise the structure transitions: 32 (tail full), 33 (first -# trie leaf), 1024 (root full at shift 5), 1025 (root grows to shift 10) — and -# that a conj/assoc after a bulk build still lands and reads back. -(defspec "vector / bulk build boundaries" - ["count at 1025" "1025" "(count (vec (range 1025)))"] - ["into = vec at 1025" "true" "(= (vec (range 1025)) (into [] (range 1025)))"] - ["nth at leaf boundary" "32" "(nth (vec (range 1025)) 32)"] - ["nth at root boundary" "1024" "(nth (vec (range 1025)) 1024)"] - ["vec=into at 33" "true" "(= (vec (range 33)) (into [] (range 33)))"] - ["conj after bulk 1024" "1025" "(count (conj (vec (range 1024)) :x))"] - ["conj-after reads back" ":x" "(nth (conj (vec (range 1024)) :x) 1024)"] - ["assoc into bulk vec" "9" "(nth (assoc (vec (range 1025)) 1000 9) 1000)"] - ["into onto non-empty" "[0 1 2 0 1]" "(into (vec (range 3)) (range 2))"]) diff --git a/test/spec/walk-spec.janet b/test/spec/walk-spec.janet deleted file mode 100644 index 90a5aae..0000000 --- a/test/spec/walk-spec.janet +++ /dev/null @@ -1,23 +0,0 @@ -# Specification: clojure.walk must descend lists and seqs, not just vectors/maps -# (jolt-khk). postwalk-replace with symbol keys over a quoted list silently -# no-op'd because walk only handled vector?/map? and fell through for list?/seq? -# — which broke clojure.template/apply-template (found during reitit work). -(use ../support/harness) - -(defspec "clojure.walk / lists + seqs" - ["postwalk-replace symbol keys in a list" "(quote (+ 2 2))" - "(do (require (quote [clojure.walk :as w])) (w/postwalk-replace {(quote x) 2} (quote (+ x x))))"] - ["postwalk descends a list" "(quote (:a :a))" - "(do (require (quote [clojure.walk :as w])) (w/postwalk (fn [n] (if (symbol? n) :a n)) (quote (x y))))"] - ["prewalk-replace in a list" "(quote (* 3 3))" - "(do (require (quote [clojure.walk :as w])) (w/prewalk-replace {(quote *) (quote *) (quote y) 3} (quote (* y y))))"] - ["nested list + vector" "(quote (1 [2 1]))" - "(do (require (quote [clojure.walk :as w])) (w/postwalk-replace {:a 1 :b 2} (quote (:a [:b :a]))))"] - # vectors/maps still work (regression guard for the existing behavior) - ["postwalk-replace in a vector" "[:one 2 :one]" - "(do (require (quote [clojure.walk :as w])) (w/postwalk-replace {1 :one} [1 2 1]))"] - ["keywordize-keys still works" "{:a 1}" - "(do (require (quote [clojure.walk :as w])) (w/keywordize-keys {\"a\" 1}))"] - # clojure.template/apply-template (the real-world trigger) substitutes now - ["apply-template substitutes" "(quote (+ 1 2))" - "(do (require (quote [clojure.template :as t])) (t/apply-template (quote [x y]) (quote (+ x y)) (quote (1 2))))"]) diff --git a/test/support/clojure_test.clj b/test/support/clojure_test.clj deleted file mode 100644 index dfab28d..0000000 --- a/test/support/clojure_test.clj +++ /dev/null @@ -1,118 +0,0 @@ -;; Minimal `clojure.test` + `clojure.core-test.portability` shims. -;; -;; These exist solely so Jolt can load the external clojure-test-suite -;; (https://github.com/lread/clojure-test-suite, EPL) — 240 per-function -;; `.cljc` files written against `clojure.test`. They are NOT a full -;; clojure.test: just enough surface (deftest/is/testing/are + the suite's -;; portability helpers) to run the suite and tally pass/fail/error. -;; -;; Loaded by test/integration/clojure-test-suite-test.janet, which pre-loads -;; this file so the suite's `(require [clojure.test ...])` finds it already -;; populated (Jolt's require is a no-op for already-loaded namespaces). - -(ns clojure.test) - -;; --- result accumulator (plain atoms; no dynamic vars needed) ------------- - -(def jolt-report (atom {:pass 0 :fail 0 :error 0 :fails []})) -(def jolt-ctx (atom [])) ;; stack of `testing` context strings -(def registry (atom [])) ;; deftest fns defined since last reset - -(defn reset-report! [] - (reset! jolt-report {:pass 0 :fail 0 :error 0 :fails []}) - (reset! jolt-ctx []) - (reset! registry [])) - -(defn- ctx-str [] (apply str (interpose " " @jolt-ctx))) - -(defn inc-pass! [] (swap! jolt-report update :pass inc)) - -(defn fail! [form] - (swap! jolt-report - (fn [r] (-> r (update :fail inc) - (update :fails conj (str (ctx-str) " FAIL: " form)))))) - -(defn err! [form] - (swap! jolt-report - (fn [r] (-> r (update :error inc) - (update :fails conj (str (ctx-str) " ERROR: " form)))))) - -(defn n-pass [] (:pass @jolt-report)) -(defn n-fail [] (:fail @jolt-report)) -(defn n-error [] (:error @jolt-report)) -(defn failures [] (:fails @jolt-report)) - -;; --- assertion macros ------------------------------------------------------ - -;; `(is form)` / `(is form msg)` — the optional msg is absorbed and ignored. -(defmacro is [form & _] - `(try - (if ~form - (clojure.test/inc-pass!) - (clojure.test/fail! (pr-str '~form))) - (catch :default e# - (clojure.test/err! (str (pr-str '~form) " threw"))))) - -(defmacro testing [s & body] - `(do - (swap! clojure.test/jolt-ctx conj ~s) - (try - (do ~@body) - (finally (swap! clojure.test/jolt-ctx pop))))) - -(defmacro deftest [name & body] - `(do - (def ~name (fn [] ~@body)) - (swap! clojure.test/registry conj ~name) - ~name)) - -;; `(are [bindings] expr & data)` — substitute each row of `data` into the -;; template and assert via `is`. Expands to a `do` of let+is forms. -(defmacro are [argv expr & data] - (let [n (count argv) - rows (partition n data)] - `(do ~@(map (fn [row] - `(let [~@(interleave argv row)] - (clojure.test/is ~expr))) - rows)))) - -;; Run every deftest registered since the last reset, isolating crashes. -(defn run-registered [] - (doseq [t @registry] - (try (t) (catch :default e (clojure.test/err! (str "deftest crashed: " (clojure.core/ex-message e)))))) - nil) - -;; clojure.test entry points the suite may call — no-ops; the Janet runner -;; drives execution via run-registered instead. -(defn run-tests [& _] nil) -(defn run-test [& _] nil) -(defn test-var [& _] nil) - - -;; --- clojure.core-test.portability ---------------------------------------- - -(ns clojure.core-test.portability) - -;; Gate a test on whether its target var exists in this dialect. Jolt only -;; implements a subset of clojure.core, so unimplemented fns get skipped -;; cleanly rather than erroring. -;; Skips silently (no stdout) so the worker's stdout stays just the count line; -;; an unimplemented var simply contributes no assertions. -(defmacro when-var-exists [var-sym & body] - (if (resolve var-sym) - `(do ~@body) - nil)) - -;; `(thrown? body)` — true iff evaluating body throws. The suite always uses -;; the single-arg (no exception-class) form via this portability helper. -(defmacro thrown? [& body] - `(try (do ~@body false) (catch :default e# true))) - -(defn big-int? [n] - (and (integer? n) (not (int? n)))) - -(defn lazy-seq? [x] - ;; Jolt has no public LazySeq type test; approximate with seq?-of-non-vector. - (and (seq? x) (not (vector? x)))) - -(defn sleep [ms] nil) diff --git a/test/support/harness.janet b/test/support/harness.janet deleted file mode 100644 index 7675c87..0000000 --- a/test/support/harness.janet +++ /dev/null @@ -1,94 +0,0 @@ -# Shared test harness for Jolt. -# -# Two complementary styles: -# -# defspec — data-driven behavioral tables, for spec/ and integration batteries. -# Each case is ["label" expected actual] where `expected` and `actual` are -# Clojure source strings. Equality is checked with Jolt's own `=`, so it is -# representation-agnostic (a vector result compares equal to a vector -# literal regardless of the underlying Janet type). Use the :throws sentinel -# in the `expected` position to assert that `actual` raises an error. -# -# (defspec "clojure.core / seq" -# ["first of vector" "1" "(first [1 2 3])"] -# ["rest is a seq" "(2 3)" "(rest [1 2 3])"] -# ["nth out of range" :throws "(nth [1] 5)"]) -# -# jeval / expect= / expect-throws — assertion helpers for white-box unit/ tests -# that probe a single component and want Janet-level assertions. -# -# A failing suite prints every failing behavior, then raises — so `jpm test` -# reports a non-zero exit and the offending behaviors are visible. - -(use ../../src/jolt/api) - -# Every case still gets a fully-isolated context, but via api/fork (~2 ms deep -# copy of a snapshotted ctx) instead of a fresh init (~50 ms) — the same -# behavior, ~25x faster across the ~1500 spec cases. Built lazily so harness -# importers that never eval (or that only use run-spec) pay it once at most. -(var- base-snap nil) -(defn fresh-ctx - "A fresh, fully-isolated interpret-mode context (cheap fork of one shared init)." - [] - (when (nil? base-snap) (set base-snap (snapshot (init-cached)))) - (fork base-snap)) - -(defn jeval - "Evaluate a Clojure source string in a fresh context, normalizing persistent - vectors/lists to Janet tuples so results compare with `deep=`/tuple literals." - [s] - (normalize-pvecs (eval-string (fresh-ctx) s))) - -(defn- show [s] - (let [r (protect (eval-string (fresh-ctx) s))] - (if (= (r 0) true) - (string/format "%q" (normalize-pvecs (r 1))) - (string "")))) - -(defn run-spec - "Run a data-driven behavioral suite. See `defspec`." - [suite cases] - (var pass 0) - (def fails @[]) - (each case cases - (def label (in case 0)) - (def expected (in case 1)) - (def actual (in case 2)) - (if (= expected :throws) - (let [r (protect (eval-string (fresh-ctx) actual))] - (if (= (r 0) false) - (++ pass) - (array/push fails [label "expected an error, got a value"]))) - (let [r (protect (eval-string (fresh-ctx) (string "(= " expected " " actual ")")))] - (cond - (not= (r 0) true) (array/push fails [label (string "errored: " (r 1))]) - (= (r 1) true) (++ pass) - (array/push fails [label (string "want " expected ", got " (show actual))]))))) - (printf " %s: %d/%d" suite pass (length cases)) - (flush) - (each [l m] fails (printf " FAIL [%s] %s" l m)) - (when (> (length fails) 0) - (error (string suite ": " (length fails) " failing behavior(s)"))) - pass) - -(defmacro defspec - "Define and immediately run a behavioral suite of [label expected actual] cases." - [suite & cases] - ~(,run-spec ,suite [,;cases])) - -# --- white-box assertion helpers (unit tests) --- - -(defn expect= - "Assert that evaluating Clojure `s` yields `expected` (a Janet value, compared - with deep= after normalizing persistent collections to tuples)." - [expected s] - (let [got (jeval s)] - (assert (deep= expected got) - (string "expected " (string/format "%q" expected) - ", got " (string/format "%q" got) " for: " s)))) - -(defn expect-throws - "Assert that evaluating Clojure `s` raises an error." - [s] - (let [r (protect (eval-string (fresh-ctx) s))] - (assert (= (r 0) false) (string "expected an error for: " s)))) diff --git a/test/support/lazy-eval.janet b/test/support/lazy-eval.janet deleted file mode 100644 index e4d4eea..0000000 --- a/test/support/lazy-eval.janet +++ /dev/null @@ -1,16 +0,0 @@ -# Worker: evaluate a Clojure equality check in a fresh Jolt ctx and print -# @@RESULT true or @@RESULT false. Used by lazy-infinite-test under a wall-clock -# deadline so infinite-seq hangs are caught as test failures. -(use ../../src/jolt/api) -(use ../../src/jolt/reader) - -(def expected (get (dyn :args) 1)) -(def actual (get (dyn :args) 2)) - -(when (and expected actual) - (def ctx (init-cached {})) - (def prog (string "(= " expected " " actual ")")) - (def [ok val] (protect (eval-string ctx prog))) - (if ok - (printf "@@RESULT %q" val) - (printf "@@ERROR %q" val))) diff --git a/test/unit/compile-fallback-test.janet b/test/unit/compile-fallback-test.janet deleted file mode 100644 index 10abe80..0000000 --- a/test/unit/compile-fallback-test.janet +++ /dev/null @@ -1,41 +0,0 @@ -# Stage 2 Task 3: the compile path's interpreter fallback is DELIBERATE-ONLY. -# -# compile-and-eval used to wrap the compile step in a blanket protect — ANY -# failure (including a genuine compiler bug) silently fell back to the -# interpreter, hiding the bug behind a correct-looking result. Now only the -# analyzer's deliberate punt signal ("jolt/uncompilable: …", raised for the -# curated stateful/letrec set) may fall back; any other compile-step error -# propagates. Verified here by stubbing jolt.analyzer/analyze. - -(use ../../src/jolt/types) -(use ../../src/jolt/api) -(use ../../src/jolt/reader) -(import ../../src/jolt/backend :as backend) - -(def ctx (init-cached)) - -# 1. A deliberate punt (letfn needs letrec IR) falls back and evaluates correctly. -(assert (= 3 (backend/compile-and-eval ctx (parse-string "(letfn [(f [n] (+ n 1))] (f 2))"))) - "deliberate uncompilable punt falls back to the interpreter") - -(assert (backend/analyzer-built? ctx) "analyzer built") -(def analyze-var (ns-find (ctx-find-ns ctx "jolt.analyzer") "analyze")) -(def real-analyze (var-get analyze-var)) - -# 2. A NON-punt compile error must propagate — even though the interpreter could -# evaluate the form fine, it must NOT be silently used (that hides compiler bugs). -(var-set analyze-var (fn [ctx form] (error "boom: simulated compiler bug"))) -(def r (protect (backend/compile-and-eval ctx (parse-string "(+ 1 2)")))) -(assert (not (r 0)) "non-uncompilable compile error must propagate, not silently interpret") -(assert (string/find "boom" (string (r 1))) "the original error is surfaced") - -# 3. The punt marker is the one sanctioned fallback channel. -(var-set analyze-var (fn [ctx form] (error "jolt/uncompilable: stubbed"))) -(assert (= 3 (backend/compile-and-eval ctx (parse-string "(+ 1 2)"))) - "uncompilable punt falls back to the interpreter") - -# Restore the real analyzer and confirm the pipeline still works. -(var-set analyze-var real-analyze) -(assert (= 7 (backend/compile-and-eval ctx (parse-string "(+ 3 4)"))) "restored analyzer compiles") - -(print "All compile-fallback tests passed!") diff --git a/test/unit/config-test.janet b/test/unit/config-test.janet deleted file mode 100644 index 8d59e4a..0000000 --- a/test/unit/config-test.janet +++ /dev/null @@ -1,73 +0,0 @@ -(use ../../src/jolt/config) - -# ============================================================ -# resolve-run-mode (jolt-q5ql) -# ============================================================ - -# Save/restore the env vars these tests poke at. -(def touched ["JOLT_DIRECT_LINK" "JOLT_NO_DIRECT_LINK" "JOLT_OPTIMIZE" - "JOLT_WHOLE_PROGRAM" "JOLT_NO_WHOLE_PROGRAM" "JOLT_SHAPE" - "JOLT_NO_SHAPE"]) -(def saved (table ;(mapcat (fn [k] [k (os/getenv k)]) touched))) -(defn clear-env [] (each k touched (os/setenv k nil))) -(defn restore-env [] (each k touched (os/setenv k (get saved k)))) - -(clear-env) - -# Interactive (open) mode: no direct-linking, no optimization. -(let [m (resolve-run-mode true false)] - (assert (= false (m :direct-linking?)) "open mode: not direct-linked") - (assert (= false (m :inline?)) "open mode: not inlined") - (assert (not (m :whole-program?)) "open mode: no whole-program")) - -# Program entry (-m): direct-links by default, but optimization stays OFF unless -# opted in, so whole-program is off too. -(let [m (resolve-run-mode false true)] - (assert (= true (m :direct-linking?)) "program run: direct-linked") - (assert (= false (m :inline?)) "program run: optimization off by default") - (assert (m :direct-link-auto?) "program run: direct-link auto flag set") - (assert (not (m :whole-program?)) "program run: no whole-program without optimize")) - -# JOLT_OPTIMIZE turns on inlining; a -m entry then enables whole-program. -(os/setenv "JOLT_OPTIMIZE" "1") -(let [m (resolve-run-mode false true)] - (assert (m :inline?) "JOLT_OPTIMIZE: inlining on") - (assert (m :whole-program?) "JOLT_OPTIMIZE + main entry: whole-program on")) -(os/setenv "JOLT_OPTIMIZE" nil) - -# Explicit env wins: JOLT_NO_DIRECT_LINK forces open even for a program entry. -(os/setenv "JOLT_NO_DIRECT_LINK" "1") -(let [m (resolve-run-mode false true)] - (assert (= false (m :direct-linking?)) "JOLT_NO_DIRECT_LINK forces open") - (assert (not (m :direct-link-auto?)) "forced-off is not auto")) -(os/setenv "JOLT_NO_DIRECT_LINK" nil) - -# JOLT_DIRECT_LINK forces direct-linking + optimization on even in open mode. -(os/setenv "JOLT_DIRECT_LINK" "1") -(let [m (resolve-run-mode true false)] - (assert (m :direct-linking?) "JOLT_DIRECT_LINK forces direct-link in open mode") - (assert (m :inline?) "JOLT_DIRECT_LINK implies optimization") - (assert (not (m :direct-link-auto?)) "explicit direct-link is not auto")) -(os/setenv "JOLT_DIRECT_LINK" nil) - -# ============================================================ -# ctx-cache-key footgun (jolt-q5ql): the key must change when ANY ctx-shaping -# env var changes, and stay stable otherwise. -# ============================================================ - -(clear-env) -(def k0 (ctx-cache-key [:v "1" :ns "app"])) -(assert (= k0 (ctx-cache-key [:v "1" :ns "app"])) "same inputs -> same key") -(assert (not= k0 (ctx-cache-key [:v "2" :ns "app"])) "prefix change -> different key") - -# Every ctx-shaping env var must participate (this is the regression that the -# old positional key could miss): flipping each one alone changes the key. -(each ev ctx-shaping-env-vars - (os/setenv ev "X") - (assert (not= k0 (ctx-cache-key [:v "1" :ns "app"])) - (string "ctx-cache-key ignores " ev " — cache-key footgun")) - (os/setenv ev nil)) - -(restore-env) - -(print "config-test: all assertions passed") diff --git a/test/unit/eval-test.janet b/test/unit/eval-test.janet deleted file mode 100644 index 8b2ac87..0000000 --- a/test/unit/eval-test.janet +++ /dev/null @@ -1,14 +0,0 @@ -(use ../../src/jolt/api) -(defn ct-eval [ctx s] (normalize-pvecs (eval-string ctx s))) -(print "Eval Tests") - -(print "1: eval literal...") -(let [ctx (init-cached)] - (assert (= 42 (ct-eval ctx "(eval 42)")) "eval literal") - (assert (= 3 (ct-eval ctx "(eval '(+ 1 2))")) "eval quoted form") - (assert (= 3 (ct-eval ctx "(eval (eval '(+ 1 2)))")) "eval nested") - (ct-eval ctx "(eval '(def ex 99))") - (assert (= 99 (ct-eval ctx "ex")) "eval defines var")) -(print " ok") - -(print "\nAll Eval tests passed!") diff --git a/test/unit/evaluator-test.janet b/test/unit/evaluator-test.janet deleted file mode 100644 index 48f347b..0000000 --- a/test/unit/evaluator-test.janet +++ /dev/null @@ -1,158 +0,0 @@ -(use ../../src/jolt/evaluator) -(use ../../src/jolt/types) -(use ../../src/jolt/reader) -(use ../../src/jolt/api) - -# Helper: create a Jolt symbol -(defn sym [name] - (let [slash (string/find "/" name)] - (if slash - {:jolt/type :symbol :ns (string/slice name 0 slash) - :name (string/slice name (+ slash 1))} - {:jolt/type :symbol :ns nil :name name}))) - -# Helper: parse and eval -# init, not bare make-ctx: with the implicit Janet root-env fallback removed -# (Stage 3), a context without clojure.core interned can't resolve inc/+/etc. -(def- shared-ctx (init-cached)) -(defn eval-str [s] - (eval-form shared-ctx @{} (parse-string s))) - -(print "1: literals...") -(assert (= 42 (eval-str "42")) "integer") -(assert (= "hello" (eval-str "\"hello\"")) "string") -(assert (= true (eval-str "true")) "true") -(assert (= false (eval-str "false")) "false") -(assert (= nil (eval-str "nil")) "nil") -(print " passed") - -(print "2: quote...") -(assert (deep= (sym "x") (eval-str "'x")) "quote returns symbol") -(assert (deep= @[1 2 3] (eval-str "'(1 2 3)")) "quote list") -(print " passed") - -(print "3: do...") -(assert (= 2 (eval-str "(do 1 2)")) "do returns last") -(print " passed") - -(print "4: if...") -(assert (= 1 (eval-str "(if true 1 2)")) "if true") -(assert (= 2 (eval-str "(if false 1 2)")) "if false") -(assert (= :b (eval-str "(if nil :a :b)")) "if nil = false") -(assert (= nil (eval-str "(if false 1)")) "if with no else") -(print " passed") - -(print "5: def...") -(assert (= 42 (eval-str "(do (def x 42) x)")) "def in do") -(print " passed") - -(print "6: fn*...") -(let [f (eval-str "(fn* [x] (inc x))")] - (assert (function? f) "fn* returns function") - (assert (= 42 (f 41)) "fn* fn works")) -# nested function -(let [f (eval-str "(fn* [x] (inc (inc x)))")] - (assert (= 43 (f 41)) "nested inc")) -(print " passed") - -(print "7: let*...") -(assert (= 2 (eval-str "(let* [x 1 y 2] y)")) "let* binds") -(assert (= 3 (eval-str "(let* [x 1] (inc (inc x)))")) "let* with expr") -(print " passed") - -(print "8: loop*/recur...") -(assert (= 5 (eval-str "(loop* [x 0] (if (< x 5) (recur (inc x)) x))")) - "loop counts up") -(assert (= 10 (eval-str "(loop* [i 0 acc 0] (if (< i 5) (recur (inc i) (+ acc i)) acc))")) - "loop with multiple bindings") -(print " passed") - -(print "9: recur in fn*...") -(let [countdown (eval-str "(fn* [n] (if (< n 1) 0 (recur (dec n))))")] - (assert (= 0 (countdown 5)) "recur in fn")) -(print " passed") - -(print "10: throw/try/catch/finally...") -# throw + catch -(let [result (eval-str "(try (throw \"boom\") (catch Exception e \"caught\"))")] - (assert (= "caught" result) "catch catches throw")) - -# try with finally — body returns, finally runs -(let [result (eval-str "(try 1 (finally 2))")] - (assert (= 1 result) "try returns body even with finally")) - -# try/catch/finally — catch returns, finally runs -(let [result (eval-str "(try (throw \"err\") (catch Exception e \"handled\") (finally :cleanup))")] - (assert (= "handled" result) "catch + finally returns catch value")) -(print " passed") - -(print "11: set!...") -# set! on a var -(assert (= 99 (eval-str "(do (def x 1) (set! x 99) x)")) "set! on var") -# set! re-evaluates -(assert (= 3 (eval-str "(do (def a 1) (def b 2) (set! a (+ a b)) a)")) "set! with expression") -(print " passed") - -(print "12: var...") -# (var x) returns the var itself, not its value -(let [v (eval-str "(do (def x 42) (var x))")] - (assert (var? v) "(var x) returns a var") - (assert (= 42 (var-get v)) "var holds value")) -(print " passed") - -(print "13: locking...") -# locking/instance? are overlay macros now (Stage 2 tier 6c) — they need the -# full env (init loads the overlay), not a bare make-ctx. -(let [ctx (init-cached)] - (assert (= 42 (eval-string ctx "(locking :lock 42)")) "locking returns body result")) -(print " passed") - -(print "14: instance?...") -# instance? checks type -(let [ctx (init-cached)] - (assert (= true (eval-string ctx "(instance? Number 42)")) "instance? Number matches number") - (assert (= false (eval-string ctx "(instance? Number \"hello\")")) "instance? Number doesn't match string")) -(print " passed") - -(print "15: defmulti/defmethod...") -# defmulti/defmethod are overlay macros now (Stage 2 jolt-eaa), so this needs the -# full env (init loads the overlay + installs the *-setup fns), not a bare make-ctx. -(let [ctx (init-cached)] - (eval-form ctx @{} (parse-string "(defmulti my-dispatch (fn* [x] (x :type)))")) - (eval-form ctx @{} (parse-string "(defmethod my-dispatch :foo [_] :got-foo)")) - (eval-form ctx @{} (parse-string "(defmethod my-dispatch :bar [_] :got-bar)")) - (assert (= :got-foo (eval-form ctx @{} (parse-string "(my-dispatch {:type :foo})"))) "defmethod :foo dispatches") - (assert (= :got-bar (eval-form ctx @{} (parse-string "(my-dispatch {:type :bar})"))) "defmethod :bar dispatches")) -(print " passed") - -(print "16: deftype...") -# deftype is an overlay macro now (Stage 2 jolt-eaa) — needs the full env (init-cached). -(let [ctx (init-cached) - _ (eval-form ctx @{} (parse-string "(deftype Point [x y])")) - _ (eval-form ctx @{} (parse-string "(def p (Point. 10 20))")) - p-val (eval-form ctx @{} (parse-string "p")) - x-val (eval-form ctx @{} (parse-string "(p :x)")) - y-val (eval-form ctx @{} (parse-string "(p :y)")) - result [x-val y-val]] - (printf " p-val: %q" p-val) - (printf " x-val: %q, y-val: %q" x-val y-val) - (printf " result: %q" result) - (assert (deep= [10 20] result) "deftype creates tagged instances with fields")) -(print " passed") - -(print "17: defmacro...") -# define a macro using defmacro special form -# init loads clojure.core so `list` is available -(let [ctx (init-cached) - _ (eval-form ctx @{} (parse-string "(defmacro my-when [test body] (list 'if test body nil))")) - result (eval-form ctx @{} (parse-string "(my-when true 2)"))] - (assert (= 2 result) "defmacro defines callable macro")) -# verify the var is marked :macro -(let [ctx (make-ctx) - _ (eval-form ctx @{} (parse-string "(defmacro m [x] (list 'quote x))")) - v (resolve-var ctx @{} (parse-string "m"))] - (assert v "macro var exists") - (assert (v :macro) "macro var has :macro true")) -(print " passed") - -(print "\nAll evaluator tests passed!") diff --git a/test/unit/interop-test.janet b/test/unit/interop-test.janet deleted file mode 100644 index 83d89fc..0000000 --- a/test/unit/interop-test.janet +++ /dev/null @@ -1,46 +0,0 @@ -(use ../../src/jolt/api) -(defn ct-eval [ctx s] (normalize-pvecs (eval-string ctx s))) -(print "Janet Interop Tests") - -(print "1: field access on tables...") -(let [ctx (init-cached)] - (ct-eval ctx "(def t {:a 1 :b 2})") - (assert (= 1 (ct-eval ctx "(. t :a)")) ". field access table") - (assert (= 2 (ct-eval ctx "(. t :b)")) ". field access table 2") - (assert (= nil (ct-eval ctx "(. t :z)")) ". field access missing key")) -(print " ok") - -(print "2: field access on structs...") -(let [ctx (init-cached)] - (ct-eval ctx "(def s {:x 10 :y 20})") - (assert (= 10 (ct-eval ctx "(. s :x)")) ". field access struct") - (assert (= 20 (ct-eval ctx "(. s :y)")) ". field access struct 2")) -(print " ok") - -(print "3: method calls on tables...") -(let [ctx (init-cached)] - (ct-eval ctx "(def obj {:greet (fn [self name] (str \"Hello \" name))})") - (assert (= "Hello Alice" (ct-eval ctx "(. obj greet \"Alice\")")) ". method call on table")) -(print " ok") - -(print "4: field access via .- reader sugar...") -(let [ctx (init-cached)] - (ct-eval ctx "(def t {:x 42 :len 5})") - (assert (= 42 (ct-eval ctx "(.-x t)")) ".-x reader sugar") - (assert (= 5 (ct-eval ctx "(.-len t)")) ".-len reader sugar")) -(print " ok") - -(print "5: . field access still works on deftypes...") -(let [ctx (init-cached)] - (ct-eval ctx "(deftype Point [x y])") - (assert (= 3 (ct-eval ctx "(. (Point. 3 4) x)")) ". field access deftype")) -(print " ok") - -(print "6: method call with multiple args...") -(let [ctx (init-cached)] - (ct-eval ctx "(def calc {:add (fn [_ a b] (+ a b)) :mul (fn [_ a b] (* a b))})") - (assert (= 7 (ct-eval ctx "(. calc add 3 4)")) ". method add") - (assert (= 12 (ct-eval ctx "(. calc mul 3 4)")) ". method mul")) -(print " ok") - -(print "\nAll Janet Interop tests passed!") diff --git a/test/unit/lazy-seq-test.janet b/test/unit/lazy-seq-test.janet deleted file mode 100644 index dda9bfe..0000000 --- a/test/unit/lazy-seq-test.janet +++ /dev/null @@ -1,56 +0,0 @@ -(use ../../src/jolt/api) -(defn ct-eval [ctx s] (normalize-pvecs (eval-string ctx s))) -(print "LazySeq Tests") - -(print "1: lazy-seq from list...") -(let [ctx (init-cached)] - (assert (= true (ct-eval ctx "(= [1 2 3] (take 10 (lazy-seq [1 2 3])))")) "lazy-seq list") - (assert (= true (ct-eval ctx "(= 3 (count (lazy-seq [1 2 3])))")) "count lazy-seq")) -(print " ok") - -(print "2: lazy-cat concatenation...") -(let [ctx (init-cached)] - (assert (= true (ct-eval ctx "(= [1 2 3 4] (take 10 (lazy-cat [1 2] [3 4])))")) "lazy-cat concat") - (assert (= true (ct-eval ctx "(= 4 (count (lazy-cat [1 2] [3 4])))")) "lazy-cat count")) -(print " ok") - -(print "3: first/rest on lazy-seqs...") -(let [ctx (init-cached)] - (assert (= true (ct-eval ctx "(= 1 (first (lazy-seq [1 2 3])))")) "first lazy") - (assert (= true (ct-eval ctx "(= 2 (first (rest (lazy-seq [1 2 3]))))")) "first rest lazy")) -(print " ok") - -(print "4: drop/nth on lazy-seqs...") -(let [ctx (init-cached)] - (assert (= true (ct-eval ctx "(= [3 4 5] (take 10 (drop 2 (lazy-seq [1 2 3 4 5]))))")) "drop 2 take 10") - (assert (= true (ct-eval ctx "(= 3 (nth (lazy-seq [1 2 3 4 5]) 2))")) "nth lazy")) -(print " ok") - -(print "5: concat on lazy-seqs...") -(let [ctx (init-cached)] - (assert (= true (ct-eval ctx "(= 5 (count (concat (lazy-seq [1 2]) (lazy-seq [3 4 5]))))")) "concat lazy")) -(print " ok") - -(print "6: reverse/sort on lazy-seqs...") -(let [ctx (init-cached)] - (assert (= true (ct-eval ctx "(= [3 2 1] (reverse (lazy-seq [1 2 3])))")) "reverse lazy") - (assert (= true (ct-eval ctx "(= [1 2 3] (sort (lazy-seq [3 1 2])))")) "sort lazy")) -(print " ok") - -(print "7: distinct on lazy-seqs...") -(let [ctx (init-cached)] - (assert (= true (ct-eval ctx "(= [1 2 3] (distinct (lazy-seq [1 2 1 3 2])))")) "distinct lazy")) -(print " ok") - -(print "8: fib-seq (deferred — eager core-map needs lazy upgrade)...") -(let [ctx (init-cached)] - (print " The cell-by-cell lazy-seq architecture is correct. concat, take,") - (print " drop, nth, first, rest all work with self-referencing patterns.") - (print " core-map still eagerly realizes all lazy-seq arguments, which") - (print " loops on infinite sequences. Making core-map return a lazy") - (print " result would complete the self-referencing lazy-seq story.") - (print " When fixed: (def fib-seq (lazy-cat [0 1] (map + (rest fib-seq) fib-seq)))") - (print " → (take 10 fib-seq) = [0 1 1 2 3 5 8 13 21 34]")) -(print " ok (deferred — core-map needs lazy upgrade)") - -(print "\nAll LazySeq tests passed!") diff --git a/test/unit/macro-test.janet b/test/unit/macro-test.janet deleted file mode 100644 index 7444a06..0000000 --- a/test/unit/macro-test.janet +++ /dev/null @@ -1,129 +0,0 @@ -(use ../../src/jolt/reader) -(use ../../src/jolt/types) -(use ../../src/jolt/evaluator) - -# Helper: create a Jolt symbol -(defn sym [name] - (let [slash (string/find "/" name)] - (if slash - {:jolt/type :symbol :ns (string/slice name 0 slash) - :name (string/slice name (+ slash 1))} - {:jolt/type :symbol :ns nil :name name}))) - -# Helper: parse and eval -(defn eval-str [s] - (let [ctx (make-ctx) - form (parse-string s)] - (eval-form ctx @{} form))) - -# ============================================================ -# 1. syntax-quote — literals pass through -# ============================================================ -(print "1: syntax-quote literals...") -(assert (= 42 (eval-str "`42")) "syntax-quote number") -(assert (= "hello" (eval-str "`\"hello\"")) "syntax-quote string") -(assert (= :foo (eval-str "`:foo")) "syntax-quote keyword") -(assert (= nil (eval-str "`nil")) "syntax-quote nil") -(assert (= true (eval-str "`true")) "syntax-quote true") -(assert (= false (eval-str "`false")) "syntax-quote false") -(print " passed") - -# ============================================================ -# 2. syntax-quote — qualify symbols -# ============================================================ -(print "2: syntax-quote qualifies symbols...") -# In the 'user namespace, `x → user/x -(let [form (eval-str "`x")] - (assert (deep= {:jolt/type :symbol :ns "user" :name "x"} form) - "qualifies bare symbol to current ns")) - -# Already qualified symbols stay as-is -(let [form (eval-str "`foo/bar")] - (assert (deep= {:jolt/type :symbol :ns "foo" :name "bar"} form) - "qualified symbol unchanged")) -(print " passed") - -# ============================================================ -# 3. syntax-quote — lists: qualify symbols, literal items as-is -# ============================================================ -(print "3: syntax-quote lists...") -# `(+ 1 2) → (user/+ 1 2) — but 1 and 2 are numbers, stay as-is -(let [form (eval-str "`(+ 1 2)")] - (assert (array? form) "syntax-quote list is array") - (assert (= 3 (length form)) "has 3 elements") - (assert (deep= {:jolt/type :symbol :ns "user" :name "+"} (in form 0)) - "operator qualified") - (assert (= 1 (in form 1)) "number stays") - (assert (= 2 (in form 2)) "number stays")) -(print " passed") - -# ============================================================ -# 4. unquote inside syntax-quote -# ============================================================ -(print "4: unquote...") -# `~x inside (let* [x 10] ...) → 10 -(let [form (eval-str "(let* [x 10] `~x)")] - (assert (= 10 form) "unquote evaluates")) -# `(~x) produces a list containing x -(let [form2 (eval-str "(let* [x 10] `(~x))")] - (assert (deep= @[10] form2) "unquote in list")) - -# `(+ ~x ~y) with x=1 y=2 → (+ 1 2) -(let [form (eval-str "(let* [x 1 y 2] `(+ ~x ~y))")] - (assert (array? form) "result is list") - (assert (= 1 (in form 1)) "first unquoted value") - (assert (= 2 (in form 2)) "second unquoted value")) -(print " passed") - -# ============================================================ -# 5. unquote-splicing inside syntax-quote -# ============================================================ -(print "5: unquote-splicing...") -# `[1 2 ~@xs] with xs = (3 4) → [1 2 3 4] -(let [form (eval-str "(let* [xs '(3 4)] `[1 2 ~@xs])")] - (assert (tuple? form) "result is vector") - (assert (= 4 (length form)) "spliced items merged") - (assert (deep= [1 2 3 4] form) "correct items")) - -# `(1 ~@xs) with xs = (2 3) → (1 2 3) -(let [form (eval-str "(let* [xs '(2 3)] `(1 ~@xs))")] - (assert (array? form) "result is list") - (assert (= 3 (length form)) "spliced into list") - (assert (deep= @[1 2 3] form) "correct items")) -(print " passed") - -# ============================================================ -# 6. Macro function application -# ============================================================ -(print "6: macro application...") - -# Define a simple macro: (my-when test body) → (if test body nil) -(def ctx (make-ctx)) -(def macro-fn-form (parse-string "(fn* [test body] (if test body nil))")) -(def macro-fn (eval-form ctx @{} macro-fn-form)) -# intern it in user namespace with string key -(let [ns (ctx-find-ns ctx "user")] - (ns-intern ns "my-when" macro-fn) - (put (ns-find ns "my-when") :macro true)) - -# (my-when true 42) should expand to (if true 42 nil), evaluating to 42 -(let [form (parse-string "(my-when true 42)")] - (assert (= 42 (eval-form ctx @{} form)) "macro application returns correct value")) - -# (my-when false 99) should expand to (if false 99 nil), evaluating to nil -(let [form (parse-string "(my-when false 99)")] - (assert (= nil (eval-form ctx @{} form)) "macro returns nil when false")) -(print " passed") - -# ============================================================ -# 7. Nested syntax-quote -# ============================================================ -(print "7: nested syntax-quote...") -# ``x → (syntax-quote user/x) -(let [form (eval-str "``x")] - (assert (array? form) "nested syntax-quote produces list") - (assert (deep= {:jolt/type :symbol :ns nil :name "syntax-quote"} (in form 0)) - "outer is syntax-quote")) -(print " passed") - -(print "\nAll macro tests passed!") diff --git a/test/unit/persistent-map-test.janet b/test/unit/persistent-map-test.janet deleted file mode 100644 index 867990a..0000000 --- a/test/unit/persistent-map-test.janet +++ /dev/null @@ -1,92 +0,0 @@ -# Phase 2: PersistentHashMap Tests -# Uses Clojure = (core-=) for PHM-aware comparison - -(use ../../src/jolt/api) - -(defn ct-eval [ctx s] (normalize-pvecs (eval-string ctx s))) - -# Helper: compare via Clojure = which handles PHM -(defn clj= [ctx a b] - (eval-string ctx (string "(= " a " " b ")"))) - -# ============================================================ -# 1. Basic hash-map construction and access -# ============================================================ -(print "1: hash-map construction...") -(let [ctx (init-cached)] - (def m1 (ct-eval ctx "(hash-map :a 1)")) - (assert (not (nil? m1)) "hash-map returns non-nil") - (assert (= true (ct-eval ctx "(map? (hash-map :a 1))")) "map? returns true for PHM") - (assert (= true (ct-eval ctx "(= (hash-map :a 1) {:a 1})")) "PHM = struct via Clojure =") - - (assert (= 0 (ct-eval ctx "(count (hash-map))")) "count empty") - (assert (= 2 (ct-eval ctx "(count (hash-map :a 1 :b 2))")) "count two") - (assert (= 1 (ct-eval ctx "(get (hash-map :a 1 :b 2) :a)")) "get present") - (assert (= nil (ct-eval ctx "(get (hash-map :a 1) :z)")) "get missing")) -(print " passed") - -# ============================================================ -# 2. assoc and dissoc -# ============================================================ -(print "2: assoc/dissoc...") -(let [ctx (init-cached)] - (assert (= true (ct-eval ctx "(= (assoc (hash-map :a 1) :b 2) (hash-map :a 1 :b 2))")) "assoc add") - (assert (= true (ct-eval ctx "(= (assoc (hash-map :a 1) :a 99) (hash-map :a 99))")) "assoc replace") - (assert (= true (ct-eval ctx "(= (dissoc (hash-map :a 1 :b 2) :a) (hash-map :b 2))")) "dissoc") - (assert (= true (ct-eval ctx "(contains? (hash-map :a 1) :a)")) "contains? true") - (assert (= false (ct-eval ctx "(contains? (hash-map :a 1) :z)")) "contains? false")) -(print " passed") - -# ============================================================ -# 3. keys, vals, merge -# ============================================================ -(print "3: keys/vals/merge...") -(let [ctx (init-cached)] - (assert (= 2 (ct-eval ctx "(count (keys (hash-map :a 1 :b 2)))")) "keys count") - (assert (= 2 (ct-eval ctx "(count (vals (hash-map :a 1 :b 2)))")) "vals count") - (assert (= true (ct-eval ctx "(= (merge (hash-map :a 1) (hash-map :b 2)) (hash-map :a 1 :b 2))")) "merge")) - -(print " passed") - -# ============================================================ -# 4. Empty and seq -# ============================================================ -(print "4: empty? and seq...") -(let [ctx (init-cached)] - (assert (= true (ct-eval ctx "(empty? (hash-map))")) "empty? true") - (assert (= false (ct-eval ctx "(empty? (hash-map :a 1))")) "empty? false") - (assert (= 1 (ct-eval ctx "(count (seq (hash-map :a 1)))")) "seq count")) -(print " passed") - -# ============================================================ -# 5. Larger maps -# ============================================================ -(print "5: larger maps...") -(let [ctx (init-cached)] - (eval-string ctx " - (def big-map - (reduce (fn [m i] (assoc m (keyword (str \"k\" i)) i)) - (hash-map) - (range 100)))") - (assert (= 100 (ct-eval ctx "(count big-map)")) "count 100") - (assert (= 42 (ct-eval ctx "(get big-map :k42)")) "get k42")) -(print " passed") - -(print "6: bucket resize (jolt-s3y)...") -(let [ctx (init-cached)] - # Crossing the load-factor boundary several times: every key still found, - # nil values preserved, collection keys still canonical, dissoc intact. - (eval-string ctx " - (def m (reduce (fn [m i] (assoc m i (* 10 i))) (hash-map) (range 500)))") - (assert (= 500 (ct-eval ctx "(count m)")) "count survives rehash") - (assert (= true (ct-eval ctx "(every? (fn [i] (= (* 10 i) (get m i))) (range 500))")) - "every key found after rehash") - (assert (= true (ct-eval ctx "(let [m2 (assoc m :nilv nil)] (and (contains? m2 :nilv) (nil? (get m2 :nilv :miss))))")) - "nil value present after rehash") - (assert (= :hit (ct-eval ctx "(get (assoc m [1 2] :hit) [1 2])")) - "collection key canonical after rehash") - (assert (= 499 (ct-eval ctx "(count (dissoc m 0))")) "dissoc after rehash") - (assert (= 500 (ct-eval ctx "(count m)")) "persistence: source unchanged")) -(print " passed") - -(print "\nAll PersistentHashMap tests passed!") diff --git a/test/unit/phm-hamt-test.janet b/test/unit/phm-hamt-test.janet deleted file mode 100644 index 92df973..0000000 --- a/test/unit/phm-hamt-test.janet +++ /dev/null @@ -1,107 +0,0 @@ -# Persistent hash map correctness + complexity (jolt-684u). Exercises the phm-* -# primitives directly (scalar keys — the perf-critical path) against a plain -# Janet table oracle, then asserts assoc is sub-linear per op (a HAMT, not the -# old O(n) copy-on-write bucket array). Collection-key value-equality is covered -# by the full clojure suite (needs core's canonicalize-key); here we test the -# representation in isolation. -(import ../../src/jolt/phm :as phm) - -(var fails 0) -(defn check [label got expected] - (if (deep= got expected) (print " ok " label) - (do (++ fails) (printf " FAIL %s: want %p got %p" label expected got)))) - -# --- basic assoc / get / overwrite / dissoc / count ------------------------- -(var m (phm/make-phm)) -(check "empty count" (phm/phm-count m) 0) -(check "get missing -> default" (phm/phm-get m :x :none) :none) -(set m (phm/phm-assoc m :a 1)) -(set m (phm/phm-assoc m :b 2)) -(set m (phm/phm-assoc m :c 3)) -(check "count after 3" (phm/phm-count m) 3) -(check "get a" (phm/phm-get m :a) 1) -(check "get c" (phm/phm-get m :c) 3) -(check "contains b" (phm/phm-contains? m :b) true) -(check "contains missing" (phm/phm-contains? m :z) false) -(set m (phm/phm-assoc m :b 22)) # overwrite -(check "overwrite value" (phm/phm-get m :b) 22) -(check "overwrite keeps count" (phm/phm-count m) 3) -(set m (phm/phm-dissoc m :a)) -(check "dissoc removes" (phm/phm-get m :a :gone) :gone) -(check "dissoc decrements" (phm/phm-count m) 2) -(check "dissoc missing is noop" (phm/phm-count (phm/phm-dissoc m :zzz)) 2) - -# --- nil key (Clojure maps allow nil keys; struct drops them) --------------- -(var n (phm/phm-assoc (phm/make-phm) nil :nilval)) -(check "nil key get" (phm/phm-get n nil) :nilval) -(check "nil key count" (phm/phm-count n) 1) -(check "nil key contains" (phm/phm-contains? n nil) true) -(set n (phm/phm-assoc n :k :v)) -(check "nil + other count" (phm/phm-count n) 2) -(check "nil after add other" (phm/phm-get n nil) :nilval) -(set n (phm/phm-dissoc n nil)) -(check "dissoc nil key" (phm/phm-get n nil :gone) :gone) -(check "dissoc nil count" (phm/phm-count n) 1) - -# --- many keys vs a Janet-table oracle (string + int + keyword keys) -------- -(def oracle @{}) -(var big (phm/make-phm)) -(def N 5000) -(loop [i :range [0 N]] - (def k (cond (= 0 (% i 3)) (string "s" i) - (= 1 (% i 3)) i - (keyword "k" i))) - (put oracle k i) - (set big (phm/phm-assoc big k i))) -(check "big count == oracle" (phm/phm-count big) (length oracle)) -(var mism 0) -(eachp [k v] oracle (unless (= (phm/phm-get big k :MISS) v) (++ mism))) -(check "all keys read back correctly" mism 0) -# entries round-trip -(check "entries count" (length (phm/phm-entries big)) (length oracle)) -(def back @{}) -(each e (phm/phm-entries big) (put back (in e 0) (in e 1))) -(check "entries round-trip == oracle" back oracle) -# dissoc half, recheck -(var half big) -(loop [i :range [0 N 2]] - (def k (cond (= 0 (% i 3)) (string "s" i) (= 1 (% i 3)) i (keyword "k" i))) - (set half (phm/phm-dissoc half k))) -(var hmism 0) -(loop [i :range [0 N]] - (def k (cond (= 0 (% i 3)) (string "s" i) (= 1 (% i 3)) i (keyword "k" i))) - (def want (if (even? i) :gone i)) - (unless (= (phm/phm-get half k :gone) want) (++ hmism))) -(check "dissoc half reads correctly" hmism 0) - -# --- hash collisions (HashCollisionNode path) ------------------------------- -# "k6595" and "k144747" both hash to 690120568 — distinct keys, same 32-bit hash. -(when (= (hash "k6595") (hash "k144747")) # guard: only if Janet's hash still collides them - (var c (phm/make-phm)) - (set c (phm/phm-assoc c "k6595" :A)) - (set c (phm/phm-assoc c "k144747" :B)) - (set c (phm/phm-assoc c :other 99)) - (check "collision: both keys present" (phm/phm-count c) 3) - (check "collision: get first" (phm/phm-get c "k6595") :A) - (check "collision: get second" (phm/phm-get c "k144747") :B) - (check "collision: overwrite one" (phm/phm-get (phm/phm-assoc c "k6595" :A2) "k6595") :A2) - (set c (phm/phm-dissoc c "k6595")) - (check "collision: dissoc one keeps other" (phm/phm-get c "k144747") :B) - (check "collision: dissoc removes" (phm/phm-get c "k6595" :gone) :gone) - (check "collision: count after dissoc" (phm/phm-count c) 2)) - -# --- complexity: assoc must be sub-linear per op (HAMT, not O(n) copy) ------- -# Build 20000 entries; on the old O(n)-copy map this is O(n^2) (~minutes). A HAMT -# does it in well under a second. Guard generously (5s) to avoid flakiness. -(def t0 (os/clock)) -(var perf (phm/make-phm)) -(loop [i :range [0 20000]] (set perf (phm/phm-assoc perf i i))) -(def elapsed (- (os/clock) t0)) -(printf " 20000 assocs: %.3fs" elapsed) -(check "20000 assocs complete" (phm/phm-count perf) 20000) -(if (< elapsed 5.0) - (print " ok assoc is sub-linear (< 5s)") - (do (++ fails) (printf " FAIL assoc too slow (%.2fs) — O(n) per op?" elapsed))) - -(if (> fails 0) (do (printf "phm-hamt: %d FAILED" fails) (os/exit 1)) - (print "phm-hamt: all passed")) diff --git a/test/unit/reader-test.janet b/test/unit/reader-test.janet deleted file mode 100644 index c528e02..0000000 --- a/test/unit/reader-test.janet +++ /dev/null @@ -1,155 +0,0 @@ -(use ../../src/jolt/reader) - -# Helper: create a symbol -(defn sym [name] - (let [slash (string/find "/" name)] - (if slash - {:jolt/type :symbol - :ns (string/slice name 0 slash) - :name (string/slice name (+ slash 1))} - {:jolt/type :symbol - :ns nil - :name name}))) - -# Symbols -(assert (deep= (sym "foo") (parse-string "foo")) - "bare symbol") -(assert (deep= (sym "foo/bar") (parse-string "foo/bar")) - "namespaced symbol") -(assert (deep= (sym "+") (parse-string "+")) - "operator symbol") -(assert (deep= (sym "->foo") (parse-string "->foo")) - "arrow symbol") - -# Keywords -(assert (= :foo (parse-string ":foo")) - "bare keyword") -(assert (= :foo/bar (parse-string "::foo/bar")) - "auto-resolved keyword") -(assert (= :foo/bar (parse-string ":foo/bar")) - "namespaced keyword") - -# Numbers -(assert (= 1 (parse-string "1")) - "integer") -(assert (= -42 (parse-string "-42")) - "negative integer") -(assert (= 3.14 (parse-string "3.14")) - "float") - -# Strings -(assert (= "hello" (parse-string "\"hello\"")) - "simple string") - -# Nil, booleans -(assert (= nil (parse-string "nil")) - "nil") -(assert (= true (parse-string "true")) - "true") -(assert (= false (parse-string "false")) - "false") - -# Lists → Janet arrays (to distinguish from vectors) -(assert (array? (parse-string "(1 2 3)")) - "list produces array") -(assert (deep= @[1 2 3] (parse-string "(1 2 3)")) - "simple list") - -# Vectors → Janet tuples -(assert (tuple? (parse-string "[1 2 3]")) - "vector produces tuple") -(assert (deep= [1 2 3] (parse-string "[1 2 3]")) - "simple vector") - -# Maps → Janet structs -(let [m (parse-string "{:a 1 :b 2}")] - (assert (struct? m) "map is struct") - (assert (= 1 (m :a)) "map key lookup")) - -# Sets → tagged with :jolt/set -(let [form (parse-string "#{1 2 3}")] - (assert (struct? form) "set is struct") - (assert (= :jolt/set (form :jolt/type)) "set type tag")) - -# Quote and shorthand -(assert (deep= @[(sym "quote") (sym "x")] (parse-string "'x")) - "quote shorthand") -(assert (deep= @[(sym "syntax-quote") (sym "x")] (parse-string "`x")) - "syntax-quote") -(assert (deep= @[(sym "unquote") (sym "x")] (parse-string "~x")) - "unquote") -(assert (deep= @[(sym "unquote-splicing") (sym "x")] (parse-string "~@x")) - "unquote-splicing") -# @x reads as the QUALIFIED clojure.core/deref (like Clojure) so it derefs even -# where a ns excludes/rebinds `deref` (e.g. malli). -(assert (deep= @[(sym "clojure.core/deref") (sym "x")] (parse-string "@x")) - "deref shorthand") - -# Metadata: a keyword/symbol/string hint on a symbol attaches to the symbol's -# :meta and keeps it a bare symbol (so type hints are transparent everywhere). -(let [form (parse-string "^:meta x")] - (assert (and (struct? form) (= :symbol (form :jolt/type))) "meta-hinted symbol stays a symbol") - (assert (= "x" (form :name)) "symbol name preserved") - (assert (= true (get (form :meta) :meta)) "keyword hint -> {kw true}")) -(let [form (parse-string "^String s")] - (assert (= "s" (form :name)) "type-hinted symbol name preserved") - (assert (= "String" (get (form :meta) :tag)) "symbol hint -> {:tag name}")) -# Map metadata on a symbol still uses a runtime with-meta form. -(let [form (parse-string "^{:doc \"d\"} y")] - (assert (and (array? form) (struct? (first form)) (= "with-meta" ((first form) :name))) - "map metadata -> with-meta form")) - -# Comments (skip to end of line) -(assert (= 42 (parse-string "; comment\n42")) - "comment then form") - -# Discard #_ -(assert (= 42 (parse-string "#_ (ignored 1 2) 42")) - "discard skips next form") - -# Anonymous function #() -(let [form (parse-string "#(+ %1 %2)")] - (assert (array? form) "fn form is array") - (assert (deep= (sym "fn*") (in form 0)) "first element is fn*")) - -# Nested forms -(let [form (parse-string "(+ 1 (* 2 3))")] - (assert (array? form) "outer list is array") - (assert (deep= (sym "+") (in form 0)) "+ is first") - (assert (= 1 (in form 1)) "1 is second") - (assert (array? (in form 2)) "nested list is array")) - -# Multiple forms: parse-next -(let [[form1 rest-str] (parse-next "(1 2) [3 4]")] - (assert (deep= @[1 2] form1) "first form is list") - (let [[form2 _] (parse-next rest-str)] - (assert (deep= [3 4] form2) "second form is vector"))) - -# Reader conditional — feature set is #{:jolt :default} (spec 02-reader S18, -# RFC 0002); matching is by clause order. reader-features-set! lets a loading -# context opt a clj-targeted library into :clj compat (restored below). -(assert (= 3 (parse-string "#?(:clj 1 :jolt 3 :cljs 2)")) - "#?(...) picks :jolt branch") -(assert (= nil (parse-string "#?(:cljs 999)")) - "unmatched conditional reads as nothing") -(assert (= 7 (parse-string "#?(:clj 1 :default 7)")) - ":default reached when :clj not in feature set") -(assert (= 5 (parse-string "#?(:default 5 :jolt 6)")) - "clause order wins, not key priority") -(assert (deep= @[(sym "+") 1 3] (parse-string "(+ 1 #?(:jolt 3 :cljs 4))")) - "#? inside list picks :jolt") -(let [prev (reader-features-set! ["jolt" "clj" "default"])] - (assert (= 1 (parse-string "#?(:clj 1 :cljs 2)")) - "clj-compat opt-in picks :clj") - (reader-features-set! (keys prev))) - -# Characters — the reader now produces char values {:jolt/type :jolt/char :ch N} -(let [form (parse-string "\\newline")] - (assert (struct? form) "char is struct") - (assert (= :jolt/char (form :jolt/type)) "char type") - (assert (= 10 (form :ch)) "newline codepoint")) - -(let [form (parse-string "\\a")] - (assert (= 97 (form :ch)) "simple char codepoint")) - -(print "All reader tests passed!") diff --git a/test/unit/seed-overlay-registry-test.janet b/test/unit/seed-overlay-registry-test.janet deleted file mode 100644 index b89315c..0000000 --- a/test/unit/seed-overlay-registry-test.janet +++ /dev/null @@ -1,104 +0,0 @@ -# Drift check for the seed ↔ overlay boundary (refactor phase 5d). -# -# Recomputes the dispatch-twin set from source and asserts it matches what -# docs/seed-overlay-registry.md documents. A twin is a name with BOTH a seed -# `core-X` defn (src/jolt/*.janet) and an overlay `(defn X …)` -# (jolt-core/clojure/core/*.clj). If you add, remove, or re-home a twin, update -# the doc table and the EXPECTED-TWINS set below together. -# -# This is source analysis, not Clojure eval — a plain Janet test (no harness). - -(def repo-root - # test/unit/ -> repo root is two levels up - (let [d (os/cwd)] d)) - -(defn- slurp-safe [path] - (try (slurp path) ([_] nil))) - -(defn- files-with-ext [dir ext] - (def acc @[]) - (each name (os/dir dir) - (def full (string dir "/" name)) - (case (os/stat full :mode) - :directory (array/concat acc (files-with-ext full ext)) - :file (when (string/has-suffix? ext name) (array/push acc full)))) - acc) - -# Collect bare names from `(defn NAME` / `(defn- NAME`, optionally stripping a -# `prefix` (e.g. "core-") and keeping only those that had the prefix. -(defn- defn-names [src prefix] - (def names @{}) - (def pat (peg/compile - ~{:sym (capture (some (+ (range "az" "AZ" "09") (set "*?!<>=+/.&_-")))) - :defn (* "(defn" (? "-") (some (set " \t")) :sym) - :main (some (+ :defn 1))})) - (each m (or (peg/match pat src) @[]) - (when (string? m) - (if prefix - (when (string/has-prefix? prefix m) - (put names (string/slice m (length prefix)) true)) - (put names m true)))) - names) - -(defn- merge-into [dst src] (eachk k src (put dst k true)) dst) - -# --- seed core-X names across src/jolt/*.janet --- -(def seed-names @{}) -(each f (files-with-ext (string repo-root "/src/jolt") ".janet") - (merge-into seed-names (defn-names (slurp f) "core-"))) - -# --- overlay public defns across jolt-core/clojure/core/*.clj --- -(def overlay-names @{}) -(each f (files-with-ext (string repo-root "/jolt-core/clojure/core") ".clj") - (merge-into overlay-names (defn-names (slurp f) nil))) - -# --- twins = intersection --- -(def twins @{}) -(eachk k seed-names (when (get overlay-names k) (put twins k true))) - -(def EXPECTED-TWINS - {"char?" true "sorted?" true "sorted-map?" true "sorted-set?" true - "transduce" true}) - -(defn- keyset [t] (sort (keys t))) - -(unless (deep= (keyset twins) (keyset EXPECTED-TWINS)) - (error (string "seed↔overlay twin drift!\n" - " computed: " (string/join (keyset twins) ", ") "\n" - " expected: " (string/join (keyset EXPECTED-TWINS) ", ") "\n" - " Update docs/seed-overlay-registry.md and EXPECTED-TWINS together."))) - -# --- core-bindings registered keys (the public/dispatch registration table) --- -(def core-src (slurp (string repo-root "/src/jolt/core.janet"))) -(def bind-start (string/find "@{" core-src (string/find "core-bindings" core-src))) -# brace-match from the `@{` to its close -(defn- match-brace [src open] - (var depth 0) (var i open) (var end nil) - (while (and (< i (length src)) (nil? end)) - (case (src i) - (chr "{") (++ depth) - (chr "}") (do (-- depth) (when (= depth 0) (set end i)))) - (++ i)) - end) -(def bind-end (match-brace core-src (+ bind-start 1))) -(def bind-region (string/slice core-src bind-start (+ bind-end 1))) -(def registered @{}) -(each m (or (peg/match ~(some (+ (* "\"" (capture (some (if-not "\"" 1))) "\"") 1)) bind-region) @[]) - (put registered m true)) - -# Twins must NOT be registered — the overlay copy shadows; the seed copy is -# internal-only. A twin sneaking into core-bindings means the seed copy is -# masquerading as the public binding. -(eachk t EXPECTED-TWINS - (when (get registered t) - (error (string "twin '" t "' is registered in core-bindings — it should be " - "overlay-public only (see docs/seed-overlay-registry.md)")))) - -# The seed-public anchors must stay registered (guards the into/transduce -# asymmetry the registry documents). -(each anchor ["into" "reduce"] - (unless (get registered anchor) - (error (string "seed-public anchor '" anchor "' missing from core-bindings")))) - -(print "seed↔overlay registry: " (length (keys twins)) " twins, " - (length (keys registered)) " registered bindings — OK") diff --git a/test/unit/try-catch-validation-test.janet b/test/unit/try-catch-validation-test.janet deleted file mode 100644 index 6ef0782..0000000 --- a/test/unit/try-catch-validation-test.janet +++ /dev/null @@ -1,48 +0,0 @@ -# A malformed catch clause must be rejected with a clean, Clojure-like error in -# BOTH the interpreter and the compiler — not an internal Janet crash ("expected -# integer key for array …") and not silently swallowed. jolt's catch is -# (catch Class binding body*); the binding (3rd element) must be a symbol. -# Regression for jolt-kg6p (surfaced building the Chez try/throw emit). -(import ../../src/jolt/api :as api) - -(var total 0) (var fails 0) -(defn ok [name pred &opt extra] - (++ total) - (if pred (printf "ok: %s" name) - (do (++ fails) (printf "FAIL: %s %s" name (or extra ""))))) - -(defn err-msg [ctx s] - (let [r (protect (api/eval-string ctx s))] - (if (r 0) :no-error (string (r 1))))) - -(defn val-of [ctx s] (api/eval-string ctx s)) - -# malformed: the binding position holds a non-symbol (a call form / a literal), -# or the clause is too short. Each must raise a clean error mentioning catch, -# and must NOT leak the internal Janet indexing crash. -(def malformed - ["(try 1 (catch e (* e 10)))" - "(try 1 (catch e 5))" - "(try 1 (catch Exception))"]) - -# well-formed catch still works (class is a symbol or :default; binding a symbol). -(def wellformed - [["(try (throw 7) (catch Exception e (* e 10)))" 70] - ["(try (throw 42) (catch :default e e))" 42] - ["(try (+ 2 3) (catch :default e 0))" 5]]) - -(each [mode opts] [["interpret" {}] ["compile" {:compile? true}]] - (def ctx (api/init opts)) - (each s malformed - (def m (err-msg ctx s)) - (ok (string mode " rejects: " s) - (and (not= m :no-error) - (string/find "catch" m) - (not (string/find "expected integer key" m))) - (string "msg=" m))) - (each [s want] wellformed - (ok (string mode " ok: " s) (= want (val-of ctx s)) - (string "got " (val-of ctx s))))) - -(printf "\ntry-catch-validation: %d/%d passed" (- total fails) total) -(when (> fails 0) (error (string fails " failing"))) diff --git a/test/unit/types-test.janet b/test/unit/types-test.janet deleted file mode 100644 index 4acd864..0000000 --- a/test/unit/types-test.janet +++ /dev/null @@ -1,133 +0,0 @@ -(use ../../src/jolt/types) - -# ============================================================ -# Var tests -# ============================================================ - -# make-var -(let [v (make-var 'x 42)] - (assert (var? v) "var? returns true") - (assert (= 42 (var-get v)) "var-get returns root binding") - (assert (deep= {:name 'x} (var-meta v)) "var-meta returns metadata") - (assert (deep= 'x (var-name v)) "var-name returns name symbol")) - -# var without init value -(let [v (make-var 'y)] - (assert (var? v) "unbound var is still a var")) - -# dynamic var -(let [v (make-var '*dyn* 1 {:dynamic true})] - (assert (var-dynamic? v) "var-dynamic? true") - (assert (not (var-macro? v)) "var-macro? false for dynamic var")) - -# macro var -(let [v (make-var 'when nil {:macro true})] - (assert (var-macro? v) "var-macro? true")) - -# var-set — set root binding -(let [v (make-var 'x 1)] - (var-set v 99) - (assert (= 99 (var-get v)) "var-set changes root binding")) - -# alter-var-root -(let [v (make-var 'c 0)] - (alter-var-root v inc) - (assert (= 1 (var-get v)) "alter-var-root applies fn")) - -# with-meta — returns new var with updated meta -(let [v (make-var 'x 42) - v2 (with-meta v {:private true})] - (assert (deep= {:name 'x :private true} (var-meta v2)) "with-meta merges meta") - (assert (= 42 (var-get v2)) "with-meta preserves root binding")) - -# generation counter — bumps on every root change (substrate for direct-link -# staleness detection and redefinition-aware dispatch caches) -(let [v (make-var 'g 1)] - (assert (= 0 (v :gen)) "fresh var starts at generation 0") - (bind-root v 2) - (assert (= 1 (v :gen)) "bind-root bumps generation") - (var-set v 3) - (assert (= 2 (v :gen)) "var-set (root) bumps generation") - (alter-var-root v inc) - (assert (= 3 (v :gen)) "alter-var-root bumps generation") - (assert (= 4 (var-get v)) "value still tracks through gen bumps")) -(let [v (make-var 'g 1) - v2 (with-meta v {:doc "x"})] - (assert (= (v :gen) (v2 :gen)) "with-meta carries generation")) - -# var with namespace -(let [ns (make-ns 'my.ns) - v (make-var 'my.ns/x 1 {:ns ns})] - (assert (= ns (var-ns v)) "var-ns returns namespace")) - -# ============================================================ -# Namespace tests -# ============================================================ - -(let [ns (make-ns 'foo.bar)] - (assert (ns? ns) "ns? returns true") - (assert (deep= 'foo.bar (ns-name ns)) "ns-name returns name symbol") - (assert (table? (ns-map ns)) "ns-map returns table") - (assert (= 0 (length (ns-map ns))) "empty namespace has no mappings")) - -# ns-intern -(let [ns (make-ns 'test.ns) - v (ns-intern ns 'x 42)] - (assert (var? v) "ns-intern returns a var") - (assert (= 42 (var-get v)) "ns-intern sets root binding") - # check ns-find returns the same var (by reference, not deep=) - (assert (= v (ns-find ns 'x)) "ns-find returns interned var")) - -# ns-intern without value -(let [ns (make-ns 'test.ns) - v (ns-intern ns 'y)] - (assert (var? v) "ns-intern without value creates unbound var")) - -# ns-unmap -(let [ns (make-ns 'test.ns) - _ (ns-intern ns 'x 1) - _ (ns-unmap ns 'x)] - (assert (nil? (ns-find ns 'x)) "ns-unmap removes mapping")) - -# ns-resolve — own ns -(let [ns (make-ns 'test.ns) - v (ns-intern ns 'x 10)] - (assert (= v (ns-resolve ns 'x)) "ns-resolve finds var in own ns")) - -# ns-import -(let [ns (make-ns 'test.ns)] - (ns-import ns 'Date 'java.util.Date) - (assert (= 'java.util.Date (ns-import-lookup ns 'Date)) "ns-import-lookup returns import")) - -# ============================================================ -# Context tests -# ============================================================ - -(let [ctx (make-ctx)] - (assert (ctx? ctx) "ctx? returns true")) - -# ctx with initial namespaces -(let [ctx (make-ctx {:namespaces {"user" {"x" 1 "y" 2}}})] - (let [ns (ctx-find-ns ctx "user")] - (assert (ns? ns) "ctx-find-ns returns namespace for user") - (let [v (ns-find ns "x")] - (assert (var? v) "user/x is a var") - (assert (= 1 (var-get v)) "user/x has correct value")))) - -# ctx-find-ns creates ns if not present -(let [ctx (make-ctx) - ns (ctx-find-ns ctx "foo")] - (assert (ns? ns) "ctx-find-ns creates namespace on demand")) - -# ============================================================ -# Dynamic binding support (thread-local bindings table) -# ============================================================ - -# push-thread-bindings / pop-thread-bindings -(let [v (make-var '*dyn* 0 {:dynamic true})] - (push-thread-bindings @{v 100}) - (assert (= 100 (var-get v)) "push-thread-bindings sets binding") - (pop-thread-bindings) - (assert (= 0 (var-get v)) "pop-thread-bindings restores root")) - -(print "All types tests passed!") diff --git a/vendor/clojure-test-suite b/vendor/clojure-test-suite deleted file mode 160000 index e20ea02..0000000 --- a/vendor/clojure-test-suite +++ /dev/null @@ -1 +0,0 @@ -Subproject commit e20ea0289e57fe5c8b78e66865176bb7af42939d diff --git a/vendor/sci b/vendor/sci deleted file mode 160000 index ebd5cfa..0000000 --- a/vendor/sci +++ /dev/null @@ -1 +0,0 @@ -Subproject commit ebd5cfacda272eabf91f3168d56d08b64f770a80