simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge pull request #188 from jolt-lang/spike/arch-refactor

Browse source 
Architecture refactor + AOT/runtime fixes
This commit is contained in:
Dmitri Sotnikov 2026-06-24 05:45:09 +00:00 • committed by GitHub
commit 53b1c79d99
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
51 changed files with 1825 additions and 1397 deletions
Download patch file Download diff file Expand all files Collapse all files

12
CLAUDE.md
View file

@ -109,6 +109,18 @@ Issue tracking and design notes live in beads (`bd prime`, `bd memories`).
forever. Use `jolt.host/ref-get`.
- **Map literals with `:jolt/type` as a key** parse as tagged reader forms —
don't tag overlay value maps in source.
- **The compiler is reached from the runtime by `var-deref` string lookup.** The
`.ss` runtime calls into the cross-compiled compiler with
`(var-deref "jolt.analyzer" "analyze")` etc., and the compiler resolves its own
unqualified `jolt.host/…` refs the same way against `host-contract.ss`. So a
public `defn` with no in-Clojure callers may still be a live entry point — don't
treat it as dead. Only a private `defn-` with no callers is safe to remove.
- **A native `clojure.core` fn is a `(def-var! "clojure.core" "name" …)`** in a
`host/chez/*.ss`; the rest of core is the overlay (`jolt-core/clojure/core/*.clj`).
A few natives are re-asserted in `post-prelude.ss` so they win over the overlay.
See [docs/MODULES.md](docs/MODULES.md) for where a given fn lives, and
[docs/seed-overlay-registry.md](docs/seed-overlay-registry.md) for the shadowing
rule. Start at [docs/MODULES.md](docs/MODULES.md) to find a feature's files.
- **Fix latent bugs to match Clojure** rather than preserving them, with a
regression case. Match the JVM (or provide a superset); the JVM-sourced corpus
is the contract.

97
docs/MODULES.md Normal file
View file

@ -0,0 +1,97 @@
# Module map
Where things live and what to read before changing them. Start here to answer
"where does feature X live?" and "what else do I need to touch?"
## Areas
| Area | Directory | Responsibility | Re-mint? |
| --- | --- | --- | --- |
| Chez runtime | `host/chez/*.ss` | The substrate: value model, persistent collections, seqs, vars/namespaces, host interop, native `clojure.core` shims, regex, FFI, IO, the **reader**. Composed by `rt.ss`. | only `reader.ss` |
| Compiler | `jolt-core/jolt/*.clj` | analyzer → IR → backend, the optimization passes, the CLI, the deps resolver, nREPL. Baked into the seed. | **yes** |
| `clojure.core` overlay | `jolt-core/clojure/core/NN-*.clj` | Portable `clojure.core` in dependency-ordered tiers (`00-syntax` … `50-io`); the `NN` prefix *is* the load order. | **yes** |
| Stdlib | `stdlib/clojure/*.clj` | Lazily-loaded portable namespaces (string/set/walk/edn/pprint/zip/test/data). | no |
| Build & tooling | `host/chez/build.ss`, `emit-image.ss`, `compile-eval.ss`, `loader.ss`, `cli.ss`, `bootstrap.ss` | AOT binary build, cross-compile, runtime eval/load, CLI spine, seed mint. | no (except via `reader.ss`) |
| Tests & gate | `test/chez/`, `test/conformance/`, `host/chez/run-*.ss`, `Makefile` | Corpus (JVM oracle), unit, per-feature tests. Every `make` target has a comment. | no |
**The reader is in `host/chez/reader.ss`** (Scheme, a seed source) — *not* in
`jolt-core/jolt/` with the rest of the compiler. Re-mint applies to it.
`rt.ss` is the runtime's load-order manifest: it `(load …)`s every shim in
dependency order with a per-file comment. Read it to see how the runtime is
composed and where a given `.ss` fits.
## `host/chez/*.ss` by family
- **Value model**: `values.ss` (nil/numbers/keywords/symbols), `collections.ss`
(persistent vec + HAMT map/set), `seq.ss` + `lazy-bridge.ss` (seqs, lazy-seqs),
`transients.ss`, `records.ss` + `records-interop.ss`.
- **Native `clojure.core` shims**: `natives-*.ss` (array/coll/format/meta/misc/num/
queue/reader/seq/str/transduce), plus `predicates.ss`, `converters.ss`, `printing.ss`.
- **Vars / namespaces / dynamics**: `vars.ss`, `ns.ss`, `dyn-binding.ss` (the
thread-local binding stack), `dynamic-var-defaults.ss` (a few `*…*` constant defaults),
`atoms.ss`, `multimethods.ss`.
- **Host interop**: `host-class.ss` (class tokens + method dispatch),
`host-static.ss` (interop registry core) + `host-static-methods.ss` (`Class/member`
statics) + `host-static-classes.ss` (instantiable object classes), `host-table.ss`,
`host-contract.ss` (the `jolt.host` seam the compiler resolves against),
`dot-forms.ss`, `records-interop.ss`.
- **Scalars / misc**: `regex.ss` (vendored irregex), `math.ss`, `inst-time.ss`,
`bigdec.ss`, `syntax-quote.ss`.
- **IO / system / concurrency / FFI**: `io.ss`, `png.ss`, `concurrency.ss`,
`async.ss`, `ffi.ss`.
- **Compiler entry on Chez**: `reader.ss`, `compile-eval.ss`, `emit-image.ss`,
`loader.ss`, `cli.ss`, `build.ss`, `bootstrap.ss`.
## Where is a `clojure.core` fn implemented?
Two homes, with a defined precedence:
1. **Native shim** — a `(def-var! "clojure.core" "name" …)` in a `host/chez/*.ss`
(hot/representation-coupled fns: `first`, `get`, `=`, the predicates).
2. **Overlay** — a `defn` in a `jolt-core/clojure/core/NN-*.clj` tier (most of
`clojure.core`, in portable Clojure).
3. **`post-prelude.ss`** re-asserts a handful of natives *after* the overlay loads,
so the native version wins (the overlay's value-reading versions are wrong for
Chez-native chars/atoms/etc.). Each entry there says why.
`grep 'def-var! "clojure.core" "frequencies"' host/chez` and
`grep -rn 'defn frequencies' jolt-core/clojure/core` to find a given fn. See
[seed-overlay-registry.md](seed-overlay-registry.md) for the shadowing mechanism.
## Cross-cutting features — touch points
A feature's *core* lives in one file; these are the other files you must keep in
sync when changing it.
- **Tree-shaking / DCE** (`--tree-shake`): `emit-image.ss` (the `dce-*` helpers +
record producers) and `build.ss` (`bld-shake-all` reachability + the manifest
splice in `bld-emit-runtime`); the flag in `main.clj`; validated by
`host/chez/tree-shake-smoke.sh` (`make shakesmoke`) and `build-smoke.sh`. See
[tools-deps.md](tools-deps.md#tree-shaking).
- **Direct-linking** (`--direct-link`): `backend_scheme.clj` (`direct-link?`,
`emit-top-form`, the `jv$<fqn>` bindings); `build.ss` turns it on; `main.clj` the
flag; `test/chez/directlink-test.ss`.
- **Numeric fl*/fx\*** (`^double`/`^long` hints): `jolt-core/jolt/passes/numeric.clj`
(the hint-directed pass + loop-counter + `:coerce`); `backend_scheme.clj`
(`dbl-ops`/`lng-ops` op strings, `emit-numeric`, entry/return coercion);
`analyzer.clj` (`nhint-of`, `:nhints`, `with-ret-nhint`); `host-contract.ss`
(`:num-ret` on resolve); `rt.ss` (`jolt->fx`); `test/chez/numeric-test.ss`.
- **IR inlining** (under `--opt`): `passes/inline.clj` (splice) + `passes.clj`
(stash) + `host-contract.ss` (`inline-ir`/`stash-inline!`); `test/chez/inline-test.ss`.
- **Multimethods**: `host/chez/multimethods.ss` (dispatch) + the overlay
`defmulti`/`defmethod` macros + `host-contract.ss` late-bind.
- **AOT namespace context** (`jolt build`): `build.ss` (`bld-ns-prelude`) emits
`(set-chez-ns! ns)` + `chez-register-alias!` per app namespace (both the normal
and tree-shake emit paths), matching the loader's per-file ns context;
`test/chez/build-app` (`make buildsmoke`).
- **Deps resolution**: `jolt-core/jolt/deps.clj` (the only file) + `main.clj`
(applies the roots) + `loader.ss` (the `require` path).
## Conventions you must preserve
See **CLAUDE.md → "Conventions & Patterns"** for the load-bearing rules: the
re-mint trigger, the tier macro-ordering rule, the `get`-on-your-own-wrapper trap,
`:jolt/type`-as-a-key parsing, the `var-deref` calling convention (the compiler is
reached from the `.ss` runtime by string lookup, so a public `defn` with no
in-Clojure callers can still be live), and the writing style.

5
docs/libraries.md
View file

@ -16,6 +16,11 @@ Libraries confirmed to load and pass their conformance checks on Jolt
reitit.Trie Java class is mirrored in Clojure by
[jolt-lang/router](https://github.com/jolt-lang/router). Load with
`JOLT_FEATURES` including `clj`.
* [integrant](https://github.com/weavejester/integrant) — data-driven system
configuration; `ig/init`/`ig/halt!` build and tear down a component graph wired
with `#ig/ref`, on the ring-app example. Loads unmodified with its
[dependency](https://github.com/weavejester/dependency) and
[meta-merge](https://github.com/weavejester/meta-merge) deps.
* [honeysql](https://github.com/seancorfield/honeysql) — full formatter + helpers
(select/insert/update/delete/joins/:inline), loaded unmodified from git
* [clojure.jdbc](https://github.com/yogthos/clojure.jdbc) — as [jolt-lang/db](https://github.com/jolt-lang/db)'s

21
docs/rfc/README.md Normal file
View file

@ -0,0 +1,21 @@
# RFCs
Design notes for non-obvious language and compiler decisions. An RFC records *why*
a thing is built the way it is; the code is the source of truth for *how*.
| # | Title | Status | Governs |
| --- | --- | --- | --- |
| [0001](0001-language-specification.md) | A Specification for the Clojure Language | Draft | The conformance target — what "is Clojure" means for jolt. |
| [0002](0002-reader-conditional-features.md) | Reader-Conditional Feature Set | Accepted | `#?(...)` feature keys (`:jolt`, `:clj`, `:default`). |
| [0003](0003-transients.md) | Transients | Accepted | `transient`/`persistent!` semantics + the Chez mutable backing. |
| [0004](0004-type-hints.md) | Type hints + keyword-lookup specialization | Accepted | `^Type`/`^:struct` hints → the bare-`get` fast path. |
| [0005](0005-structural-type-inference.md) | Structural collection-type inference | Implemented | The `:struct`/`:vec`/`:set` lattice in `passes/types`. |
| [0006](0006-success-type-checking.md) | Success typing (provably-wrong-code detection) | Implemented | The error-domain checker in `passes/types`. |
| [0007](0007-compilation-modes-and-binary-output.md) | Compilation modes + binary output | Implemented (doc lags) | `release`/`--opt`/`--dev`, `--direct-link`, `--tree-shake`. |
RFC 0007's own status line still says "Draft, no code yet" — that is stale:
direct-linking and tree-shaking shipped (see [tools-deps.md](../tools-deps.md) and
`backend_scheme.clj` / `build.ss`). Two compiler features that grew alongside it —
**IR inlining** (`passes/inline.clj`, under `--opt`) and **numeric `fl*`/`fx*`
lowering** from `^double`/`^long` hints (`passes/numeric.clj`) — are not yet written
up as RFCs; their touch points are in [../MODULES.md](../MODULES.md).

BIN
guestbook.sqlite3 Normal file
View file

Binary file not shown.

16
host/chez/bigdec.ss
View file

@ -61,22 +61,14 @@
(def-var! "clojure.core" "bigdec" jolt-bigdec)
;; equality: a bigdec equals only another bigdec, by value (matching (= 3M 3) = false).
(define %bd-jolt=2 jolt=2)
(set! jolt=2 (lambda (a b)
(cond ((and (jbigdec? a) (jbigdec? b)) (jbigdec=? a b))
((or (jbigdec? a) (jbigdec? b)) #f)
(else (%bd-jolt=2 a b)))))
(register-eq-arm! (lambda (a b) (or (jbigdec? a) (jbigdec? b)))
(lambda (a b) (and (jbigdec? a) (jbigdec? b) (jbigdec=? a b))))
;; str drops the M; pr/pr-str keep it.
(register-str-render! jbigdec? jbigdec->string)
(define %bd-pr-str jolt-pr-str)
(set! jolt-pr-str (lambda (x) (if (jbigdec? x) (string-append (jbigdec->string x) "M") (%bd-pr-str x))))
(define %bd-pr-readable jolt-pr-readable)
(set! jolt-pr-readable (lambda (x) (if (jbigdec? x) (string-append (jbigdec->string x) "M") (%bd-pr-readable x))))
(register-pr-arm! jbigdec? (lambda (x) (string-append (jbigdec->string x) "M")))
;; class / decimal?
(define %bd-class jolt-class)
(set! jolt-class (lambda (x) (if (jbigdec? x) "java.math.BigDecimal" (%bd-class x))))
(def-var! "clojure.core" "class" jolt-class)
(register-class-arm! jbigdec? (lambda (x) "java.math.BigDecimal"))
(set! jolt-decimal? (lambda (x) (jbigdec? x)))
(def-var! "clojure.core" "decimal?" jolt-decimal?)

4
host/chez/build-smoke.sh
View file

@ -44,7 +44,9 @@ want='embedded resource ok
HELLO FROM A BUILT BINARY!
HELLO FROM A BUILT BINARY!
args: [alpha bb ccc]
sum: 10'
sum: 10
greet-default: greet:default
greet-loud: greet:loud'
if [ "$got" != "$want" ]; then
echo " FAIL: binary output mismatch"
echo "--- want ---"; echo "$want"

175
host/chez/build.ss
View file

@ -18,6 +18,7 @@
;; normal run never pays for it.
(load "host/chez/emit-image.ss")
(load "host/chez/dce.ss")
;; --- shell helpers ----------------------------------------------------------
;; Run a command, return its stdout as one trimmed string ("" on no output).
@ -94,21 +95,30 @@
"-llz4 -lz -lncurses -ltinfo -ldl -lm -lpthread -luuid -lrt"))
;; --- runtime manifest (mirrors host/chez/cli.ss's load order) ---------------
;; A line is either literal Scheme text to inline, or a tag whose emission the build
;; controls: 'prelude (the clojure.core blob, replaced by the shaken core under
;; tree-shake), 'image + 'compile-eval (the compiler, dropped for a no-eval app).
;; Tagging keeps the splice/drop decisions off fragile substring matching.
(define bld-runtime-manifest
(list
"(load \"host/chez/rt.ss\")"
"(set-chez-ns! \"clojure.core\")"
"(load \"host/chez/seed/prelude.ss\")"
'prelude
"(load \"host/chez/post-prelude.ss\")"
"(set-chez-ns! \"user\")"
"(load \"host/chez/host-contract.ss\")"
"(load \"host/chez/seed/image.ss\")"
"(load \"host/chez/compile-eval.ss\")"
'image
'compile-eval
"(load \"host/chez/png.ss\")"
"(load \"host/chez/loader.ss\")"
"(load \"host/chez/ffi.ss\")"
"(set-source-roots! (list \"jolt-core\" \"stdlib\"))"))
(define bld-tagged-loads
'((prelude . "(load \"host/chez/seed/prelude.ss\")")
(image . "(load \"host/chez/seed/image.ss\")")
(compile-eval . "(load \"host/chez/compile-eval.ss\")")))
;; A single-line top-level `(load "PATH")` -> PATH, else #f.
(define (bld-load-path line)
(let ((s (let trim ((i 0))
@ -137,19 +147,21 @@
(for-each (lambda (l) (bld-inline-line l out (+ depth 1))) (bld-file-lines p))
(begin (put-string out line) (put-string out "\n")))))
;; Inline the runtime manifest. When drop-compiler? (a closed AOT app that never
;; compiles from source at runtime), omit the compiler image + compile-eval shim —
;; Inline the runtime manifest, dispatching on the manifest tags. core-strs (the
;; shaken clojure.core defs, or #f) replaces the 'prelude blob; drop-compiler? (a
;; closed AOT app that never compiles from source) omits 'image + 'compile-eval —
;; the analyzer/back end are dead weight in the binary (~0.8MB).
(define (bld-emit-runtime out drop-compiler? core-strs)
(for-each (lambda (l)
(for-each
(lambda (entry)
(cond
;; core-shake: emit the shaken clojure.core defs in place of the blob.
((and core-strs (bld-contains? l "seed/prelude.ss"))
(for-each (lambda (s) (put-string out s) (put-string out "\n")) core-strs))
((and drop-compiler?
(or (bld-contains? l "seed/image.ss") (bld-contains? l "compile-eval.ss")))
#f)
(else (bld-inline-line l out 0))))
((eq? entry 'prelude)
(if core-strs
(for-each (lambda (s) (put-string out s) (put-string out "\n")) core-strs)
(bld-inline-line (cdr (assq 'prelude bld-tagged-loads)) out 0)))
((memq entry '(image compile-eval))
(unless drop-compiler? (bld-inline-line (cdr (assq entry bld-tagged-loads)) out 0)))
(else (bld-inline-line entry out 0))))
bld-runtime-manifest))
;; --- app emission -----------------------------------------------------------
@ -158,65 +170,47 @@
;; The loop itself is emit-image's ei-emit-ns* (optimize? #t, guard? #f).
(define (bld-emit-ns ns-name src) (ei-emit-ns* ns-name src #t #f))
;; Tree-shake the whole closed program — the clojure.core prelude (read into records
;; by dce-blob-records) AND the re-emitted app + library namespaces — over one
;; reachability graph: keep every non-def form (side effects), -main, the core fns the
;; runtime shims need, and every def reachable from those; drop the rest. Bails to
;; keep-all if reachable code resolves vars by name at runtime (closed-world
;; violation). Returns (values core-strs app-strs drop-compiler?); core-strs is #f on
;; a bail, signalling "inline prelude.ss unshaken".
(define (bld-shake-all core-records app-records entry-main)
(let ((all (append core-records app-records))
(edges (make-hashtable string-hash string=?))
(roots (cons entry-main dce-runtime-core-roots)))
(for-each (lambda (r)
(if (vector-ref r 0)
(set! roots (append (vector-ref r 2) roots))
(hashtable-set! edges (vector-ref r 1) (vector-ref r 2))))
all)
(let ((reached (make-hashtable string-hash string=?)))
(let bfs ((work roots))
(unless (null? work)
(let ((fq (car work)))
(if (hashtable-ref reached fq #f)
(bfs (cdr work))
(begin (hashtable-set! reached fq #t)
(bfs (append (or (hashtable-ref edges fq #f) '()) (cdr work))))))))
(let ((kept? (lambda (r) (or (vector-ref r 0) (hashtable-ref reached (vector-ref r 1) #f))))
(refs-any (lambda (r set) (ormap (lambda (b) (and (member b (vector-ref r 2)) #t)) set)))
(bail #f) (bail-why '()) (needs-compiler #f))
(for-each (lambda (r)
(when (kept? r)
(for-each (lambda (b)
(when (member b (vector-ref r 2))
(set! bail #t)
(when (< (length bail-why) 6)
(set! bail-why (cons (cons (or (vector-ref r 1) "<form>") b) bail-why)))))
dce-bail-refs)
(when (refs-any r dce-compile-refs) (set! needs-compiler #t))))
all)
(let ((drop-compiler? (and (not bail) (not needs-compiler)))
;; -> (values strs n-defs n-kept)
(pick (lambda (recs)
(let loop ((rs recs) (acc '()) (n 0) (k 0))
(if (null? rs)
(values (reverse acc) n k)
(let* ((r (car rs)) (isdef (and (vector-ref r 1) #t)))
(if (kept? r)
(loop (cdr rs) (cons (vector-ref r 3) acc)
(if isdef (+ n 1) n) (if isdef (+ k 1) k))
(loop (cdr rs) acc (if isdef (+ n 1) n) k))))))))
(if bail
(begin (display "jolt build: tree-shake skipped (reachable code resolves vars at runtime):\n")
(for-each (lambda (w) (display (string-append " " (car w) " -> " (cdr w) "\n")))
(reverse bail-why))
(values #f (map (lambda (r) (vector-ref r 3)) app-records) drop-compiler?))
(let-values (((core-strs cn ck) (pick core-records))
((app-strs an ak) (pick app-records)))
(display (string-append "jolt build: tree-shake kept " (number->string (+ ck ak))
" of " (number->string (+ cn an)) " defs (core "
(number->string ck) "/" (number->string cn) ")\n"))
(values core-strs app-strs drop-compiler?))))))))
;; Strings emitted before each app ns's forms, replaying what the source loader
;; does per file: (1) set chez-current-ns so runtime ns-sensitive setup forms
;; (defmulti/defmethod resolve their target var through it) land in the right ns;
;; (2) register the ns's :as aliases so a quoted alias resolves at runtime — a
;; (defmethod ig/foo …) passes 'ig/foo to defmethod-setup, which needs ig -> the
;; real ns, but the build strips the (ns …) form that would register it.
(define (bld-scan-spec! ns-name spec emit!)
(let ((items (cond ((pvec? spec) (seq->list spec))
((and (cseq? spec) (cseq-list? spec)) (seq->list spec))
(else '()))))
(when (and (pair? items) (symbol-t? (car items)))
(let ((target (symbol-t-name (car items))))
(let loop ((xs (cdr items)))
(when (and (pair? xs) (pair? (cdr xs)))
(let ((k (car xs)) (v (cadr xs)))
(when (and (keyword? k) (string=? (keyword-t-name k) "as") (symbol-t? v))
(emit! (string-append "(chez-register-alias! " (ei-str-lit ns-name)
" " (ei-str-lit (symbol-t-name v))
" " (ei-str-lit target) ")"))))
(loop (cddr xs))))))))
(define (bld-ns-prelude ns-name src)
(let ((acc (list (string-append "(set-chez-ns! " (ei-str-lit ns-name) ")")))
(nsf (let loop ((fs (ei-read-all src)))
(cond ((null? fs) #f)
((ei-ns-form? (car fs)) (car fs))
(else (loop (cdr fs)))))))
(when nsf
(for-each
(lambda (clause)
(when (and (cseq? clause) (cseq-list? clause))
(let ((citems (seq->list clause)))
(when (and (pair? citems) (keyword? (car citems))
(let ((kn (keyword-t-name (car citems))))
(or (string=? kn "require") (string=? kn "use"))))
(for-each (lambda (spec)
(bld-scan-spec! ns-name spec
(lambda (s) (set! acc (cons s acc)))))
(cdr citems))))))
(seq->list nsf)))
(reverse acc)))
;; --- bundling: native libs + resources --------------------------------------
;; A jolt seq of jolt strings -> a Scheme list of Scheme strings.
@ -305,24 +299,45 @@
;; every mode. The defined-set accumulates across the dependency-ordered
;; namespaces, so a dep's defs are direct-linkable by the time the entry that
;; calls them is emitted.
;; set-optimize!/set-direct-link! are process-global flags in the back end;
;; dynamic-wind guarantees they revert even if a strict form errors mid-emit
;; (a failing form errors the build by design), so the compiler isn't left in
;; optimize/direct-link mode for a later caller.
(let*-values
(((core-strs app-strs drop-compiler?)
(dynamic-wind
(lambda ()
(set-optimize! (string=? mode "optimized"))
(when direct-link?
((var-deref "jolt.backend-scheme" "set-direct-link!") #t)
((var-deref "jolt.backend-scheme" "direct-link-reset!")))
(let*-values
(((core-strs app-strs drop-compiler?)
((var-deref "jolt.backend-scheme" "direct-link-reset!"))))
(lambda ()
(if tree-shake?
(bld-shake-all
(dce-shake
(dce-blob-records "host/chez/seed/prelude.ss")
(apply append
(map (lambda (nf) (ei-emit-ns-records (car nf) (read-file-string (cdr nf)))) ordered))
(map (lambda (nf)
;; ns-prelude forms (always kept, no fqn/refs) set the
;; ns + register aliases before this ns's forms; dce
;; keeps original order.
(let ((src (read-file-string (cdr nf))))
(append
(map (lambda (s) (dce-rec #t #f '() s))
(bld-ns-prelude (car nf) src))
(ei-emit-ns-records (car nf) src))))
ordered))
(string-append entry-ns "/-main"))
(values #f
(apply append
(map (lambda (nf) (bld-emit-ns (car nf) (read-file-string (cdr nf)))) ordered))
#f))))
(map (lambda (nf)
(let ((src (read-file-string (cdr nf))))
(append (bld-ns-prelude (car nf) src)
(bld-emit-ns (car nf) src))))
ordered))
#f)))
(lambda ()
(set-optimize! #f)
((var-deref "jolt.backend-scheme" "set-direct-link!") #f)
((var-deref "jolt.backend-scheme" "set-direct-link!") #f)))))
(when drop-compiler? (display "jolt build: dropping compiler image (no runtime eval)\n"))
(let* ((builddir (string-append out-path ".build"))
(flat-ss (string-append builddir "/flat.ss"))

22
host/chez/collections.ss
View file

@ -225,16 +225,28 @@
(fold-left jolt-conj1 jolt-empty-list xs)
(fold-left jolt-conj1 coll xs)))))
(define jolt-get
(case-lambda
((coll k) (jolt-get coll k jolt-nil))
((coll k d)
;; A host shim registers a type's get via register-get-arm! (handler: (coll k d) ->
;; value) instead of set!-wrapping jolt-get — disjoint coll types, checked before the
;; base map/set/vec/string cases (cf. register-hash-arm!).
(define jolt-get-arms '())
(define (register-get-arm! pred handler)
(set! jolt-get-arms (cons (cons pred handler) jolt-get-arms)))
(define (jolt-get-base coll k d)
(cond ((pmap? coll) (pmap-get coll k d))
((pset? coll) (if (pset-contains? coll k) k d))
((pvec? coll) (pvec-nth-d coll k d))
((string? coll) (let ((i (->idx k)))
(if (and (fixnum? i) (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i) d)))
(else d)))))
(else d)))
(define (jolt-get-dispatch coll k d)
(let loop ((as jolt-get-arms))
(cond ((null? as) (jolt-get-base coll k d))
(((caar as) coll) ((cdar as) coll k d))
(else (loop (cdr as))))))
(define jolt-get
(case-lambda
((coll k) (jolt-get-dispatch coll k jolt-nil))
((coll k d) (jolt-get-dispatch coll k d))))
(define jolt-nth
(case-lambda

183
host/chez/dce.ss Normal file
View file

@ -0,0 +1,183 @@
;; dce.ss — tree-shaking (jolt build --tree-shake): whole-program reachability DCE.
;;
;; Build one call graph over the re-emitted app + libraries AND the clojure.core
;; prelude, keep -main + every side-effecting top-level form + everything reachable
;; from those, drop the rest. Bails (keeps everything) if reachable code resolves a
;; var by name at runtime (eval/resolve/...), which a static graph can't follow. Per
;; Stalin's rule, ANY reference — a call OR a value/#'x — keeps its target live, so a
;; fn passed to map or referenced as #'x is never dropped.
;;
;; Loaded by build.ss after the compiler image (needs jolt.ir/reduce-ir-children).
;; The records it consumes come from ei-emit-ns-records (app/libs) + dce-blob-records
;; (the prelude); both build the (dce-rec …) shape below.
;; --- the DCE record ---------------------------------------------------------
;; keep?: #t = a non-def form (side effect / registration) — always emitted, and its
;; refs are reachability roots. #f = a prunable def emitted only if fqn is reached.
;; fqn: "ns/name" of a prunable def, else #f. refs: "ns/name" strings it references.
;; str: the Scheme source to emit.
(define (dce-rec keep? fqn refs str) (vector keep? fqn refs str))
(define (dce-rec-keep? r) (vector-ref r 0))
(define (dce-rec-fqn r) (vector-ref r 1))
(define (dce-rec-refs r) (vector-ref r 2))
(define (dce-rec-str r) (vector-ref r 3))
;; --- reference extraction from IR -------------------------------------------
(define dce-kw-op (keyword #f "op"))
(define dce-kw-var (keyword #f "var"))
(define dce-kw-the-var (keyword #f "the-var"))
(define dce-kw-def (keyword #f "def"))
(define dce-kw-ns (keyword #f "ns"))
(define dce-kw-name (keyword #f "name"))
(define dce-reduce-children (var-deref "jolt.ir" "reduce-ir-children"))
;; "ns/name" of every var reference anywhere in an IR node, prepended to acc. Counts
;; a :var (call head or value) and a :the-var (#'x). Arg order (acc node) matches
;; reduce-ir-children's fold fn so it nests directly.
(define (dce-collect-refs acc node)
(let ((op (jolt-get node dce-kw-op)))
(if (or (eq? op dce-kw-var) (eq? op dce-kw-the-var))
(cons (string-append (jolt-get node dce-kw-ns) "/" (jolt-get node dce-kw-name)) acc)
(dce-reduce-children dce-collect-refs acc node))))
;; The fqn of a bare top-level def (the only prunable IR form), else #f.
(define (dce-def-fqn node)
(and (eq? (jolt-get node dce-kw-op) dce-kw-def)
(string-append (jolt-get node dce-kw-ns) "/" (jolt-get node dce-kw-name))))
;; --- reference sets that gate the analysis ----------------------------------
;; A reference whose presence in reachable code forces keep-everything (the static
;; graph can't follow runtime name resolution).
(define dce-bail-refs
'("clojure.core/eval" "clojure.core/resolve" "clojure.core/ns-resolve"
"clojure.core/requiring-resolve" "clojure.core/find-var" "clojure.core/intern"
"clojure.core/load-string" "clojure.core/load-file" "clojure.core/load-reader"
"clojure.core/load"))
;; A reference that needs the analyzer/back end at runtime (compile-from-source). If
;; reachable code uses none of these, the compiler image is dropped from the binary —
;; an AOT app is fully compiled. (resolve/require don't need it: resolve is a
;; var-table lookup; a require of a baked ns no-ops.)
(define dce-compile-refs
'("clojure.core/eval" "clojure.core/load-string" "clojure.core/load-file"
"clojure.core/load-reader" "clojure.core/load"))
;; clojure.core fns the runtime .ss shims reference by name (via var-deref) — they
;; aren't visible in the IR call graph, so seed them as roots. (Found by grepping the
;; runtime shims; the smoke harness catches a miss as a diff/crash.)
(define dce-runtime-core-roots
'("clojure.core/identity" "clojure.core/isa?" "clojure.core/line-seq"
"clojure.core/make-hierarchy" "clojure.core/read" "clojure.core/read-string"
"clojure.core/read+string" "clojure.core/realized?" "clojure.core/reset!"))
;; --- reading a minted blob (prelude.ss) into records ------------------------
;; The prelude is a flat list of (guard CLAUSE (def-var! "ns" "name" V)) forms (+ the
;; occasional side-effecting init). Read each with Chez `read` so it joins the graph
;; instead of being baked wholesale: a def-var! is a prunable node whose core->core
;; edges are the (var-deref/jolt-var "ns" "name") calls in V; any other form is
;; non-prunable (kept, refs are roots).
(define (dce-unwrap form)
(if (and (pair? form) (eq? (car form) 'guard) (pair? (cddr form))) (caddr form) form))
(define (dce-sexp-refs form acc)
(cond
((and (pair? form) (memq (car form) '(var-deref jolt-var))
(pair? (cdr form)) (string? (cadr form)) (pair? (cddr form)) (string? (caddr form)))
(cons (string-append (cadr form) "/" (caddr form)) acc))
((pair? form) (dce-sexp-refs (cdr form) (dce-sexp-refs (car form) acc)))
(else acc)))
;; str re-serializes the read form (compiled identically; comments/whitespace are
;; irrelevant).
(define (dce-blob-records path)
(call-with-input-file path
(lambda (p)
(let loop ((acc '()))
(let ((form (read p)))
(if (eof-object? form)
(reverse acc)
(let ((b (dce-unwrap form))
(str (with-output-to-string (lambda () (write form))))
(refs (dce-sexp-refs form '())))
(loop (cons
(if (and (pair? b) (eq? (car b) 'def-var!) (pair? (cdr b)) (string? (cadr b))
(pair? (cddr b)) (string? (caddr b)))
(dce-rec #f (string-append (cadr b) "/" (caddr b)) refs str)
(dce-rec #t #f refs str))
acc)))))))))
;; --- the shake: graph -> reachable -> bail check -> partition ----------------
;; edges: fqn -> refs (prunable defs only). roots: -main + the runtime-core roots +
;; every non-def form's refs.
(define (dce-build-graph records entry-main)
(let ((edges (make-hashtable string-hash string=?))
(roots (cons entry-main dce-runtime-core-roots)))
(for-each (lambda (r)
(if (dce-rec-keep? r)
(set! roots (append (dce-rec-refs r) roots))
(hashtable-set! edges (dce-rec-fqn r) (dce-rec-refs r))))
records)
(values edges roots)))
;; Closure of roots over edges -> a reached set (hashtable fqn -> #t).
(define (dce-reachable edges roots)
(let ((reached (make-hashtable string-hash string=?)))
(let bfs ((work roots))
(unless (null? work)
(let ((fq (car work)))
(if (hashtable-ref reached fq #f)
(bfs (cdr work))
(begin (hashtable-set! reached fq #t)
(bfs (append (or (hashtable-ref edges fq #f) '()) (cdr work))))))))
reached))
(define (dce-rec-reached? r reached)
(or (dce-rec-keep? r) (hashtable-ref reached (dce-rec-fqn r) #f)))
;; Scan the KEPT records: does any resolve a var at runtime (bail), and does any need
;; the compiler? Returns (values bail? bail-why needs-compiler?). bail-why is up to 6
;; (def . bail-ref) pairs for the diagnostic.
(define (dce-bail-scan records reached)
(let ((bail #f) (why '()) (needs-compiler #f))
(for-each
(lambda (r)
(when (dce-rec-reached? r reached)
(for-each (lambda (b)
(when (member b (dce-rec-refs r))
(set! bail #t)
(when (< (length why) 6)
(set! why (cons (cons (or (dce-rec-fqn r) "<form>") b) why)))))
dce-bail-refs)
(when (ormap (lambda (c) (and (member c (dce-rec-refs r)) #t)) dce-compile-refs)
(set! needs-compiler #t))))
records)
(values bail (reverse why) needs-compiler)))
;; Kept records -> (values kept-strings n-defs n-kept-defs).
(define (dce-partition records reached)
(let loop ((rs records) (acc '()) (n 0) (k 0))
(if (null? rs)
(values (reverse acc) n k)
(let* ((r (car rs)) (isdef (and (dce-rec-fqn r) #t)))
(if (dce-rec-reached? r reached)
(loop (cdr rs) (cons (dce-rec-str r) acc) (if isdef (+ n 1) n) (if isdef (+ k 1) k))
(loop (cdr rs) acc (if isdef (+ n 1) n) k))))))
;; Returns (values core-strs app-strs drop-compiler?). core-strs is #f on a bail,
;; signalling "inline prelude.ss unshaken" + keep the compiler.
(define (dce-shake core-records app-records entry-main)
(let-values (((edges roots) (dce-build-graph (append core-records app-records) entry-main)))
(let* ((reached (dce-reachable edges roots)))
(let-values (((bail why needs-compiler) (dce-bail-scan (append core-records app-records) reached)))
(let ((drop-compiler? (and (not bail) (not needs-compiler))))
(if bail
(begin
(display "jolt build: tree-shake skipped (reachable code resolves vars at runtime):\n")
(for-each (lambda (w) (display (string-append " " (car w) " -> " (cdr w) "\n"))) why)
(values #f (map dce-rec-str app-records) drop-compiler?))
(let-values (((core-strs cn ck) (dce-partition core-records reached))
((app-strs an ak) (dce-partition app-records reached)))
(display (string-append "jolt build: tree-shake kept " (number->string (+ ck ak))
" of " (number->string (+ cn an)) " defs (core "
(number->string ck) "/" (number->string cn) ")\n"))
(values core-strs app-strs drop-compiler?))))))))

7
host/chez/dyn-binding.ss
View file

@ -132,12 +132,7 @@
;; var-cell keys hash/compare by ns/name (jolt=2 in vars.ss already compares
;; ns/name) — stable under root mutation, so a var works as a map key (with-redefs
;; builds (hash-map (var f) v); get-thread-bindings returns a var-keyed map).
(define %dyn-hash jolt-hash)
(set! jolt-hash
(lambda (x)
(if (var-cell? x)
(equal-hash (cons (var-cell-ns x) (var-cell-name x)))
(%dyn-hash x))))
(register-hash-arm! var-cell? (lambda (x) (equal-hash (cons (var-cell-ns x) (var-cell-name x)))))
;; --- bind the host seams the overlay references -----------------------------
(def-var! "clojure.core" "push-thread-bindings" jolt-push-thread-bindings)

8
host/chez/dynamic-vars.ss → host/chez/dynamic-var-defaults.ss
View file

@ -1,6 +1,8 @@
;; dynamic vars — the handful of clojure.core dynamic vars that aren't emitted into
;; the prelude. These two are plain constants; *ns* (a namespace object) needs a
;; value type with get-see-through and map?=false and is tracked separately. Loaded
;; dynamic-var-defaults.ss — default values for the handful of clojure.core dynamic
;; vars that aren't emitted into the prelude (*clojure-version*, *assert*, …). Plain
;; constant def-var!s; *ns* (a namespace object) needs a value type with
;; get-see-through and map?=false and is tracked separately. The binding-stack
;; machinery (binding / var-set / thread-bound?) lives in dyn-binding.ss. Loaded
;; from rt.ss after the value model + def-var!.
;; *clojure-version* — a map {:major 1 :minor 11 :incremental 0 :qualifier nil}.

106
host/chez/emit-image.ss
View file

@ -84,100 +84,13 @@
(define (ei-emit-ns ns-name src) (ei-emit-ns* ns-name src #f #t))
;; --- tree-shaking (jolt build --tree-shake) ---------------------------------
;; Reachability DCE over the re-emitted app + library forms: keep -main, every
;; side-effecting (non-def) top-level form, and every def reachable from those;
;; drop the rest (unused library code). Bails (keeps everything) if the app resolves
;; vars by name at runtime (eval/resolve/...), which static reachability can't
;; follow. clojure.core / the compiler stay baked (the prelude + image blobs), so
;; only the re-emitted namespaces are shaken.
(define dce-kw-op (keyword #f "op"))
(define dce-kw-var (keyword #f "var"))
(define dce-kw-the-var (keyword #f "the-var"))
(define dce-kw-def (keyword #f "def"))
(define dce-kw-ns (keyword #f "ns"))
(define dce-kw-name (keyword #f "name"))
(define dce-reduce-children (var-deref "jolt.ir" "reduce-ir-children"))
;; "ns/name" of every var reference anywhere in node, prepended to acc. Counts BOTH
;; a :var (call head or value) and a :the-var (#'x / (var x)) — per Stalin's rule,
;; any reference (not just a direct call) keeps the target live, so a var passed as a
;; value or referenced as #'x is reachable. Arg order (acc node) matches
;; reduce-ir-children's fold fn, so it nests directly.
(define (dce-collect-refs acc node)
(let ((op (jolt-get node dce-kw-op)))
(if (or (eq? op dce-kw-var) (eq? op dce-kw-the-var))
(cons (string-append (jolt-get node dce-kw-ns) "/" (jolt-get node dce-kw-name)) acc)
(dce-reduce-children dce-collect-refs acc node))))
;; The fqn of a bare top-level def (the only prunable form), else #f.
(define (dce-def-fqn node)
(and (eq? (jolt-get node dce-kw-op) dce-kw-def)
(string-append (jolt-get node dce-kw-ns) "/" (jolt-get node dce-kw-name))))
;; A reference whose presence forces keep-everything (runtime name resolution).
(define dce-bail-refs
'("clojure.core/eval" "clojure.core/resolve" "clojure.core/ns-resolve"
"clojure.core/requiring-resolve" "clojure.core/find-var" "clojure.core/intern"
"clojure.core/load-string" "clojure.core/load-file" "clojure.core/load-reader"
"clojure.core/load"))
;; clojure.core fns the runtime .ss shims reference by name (via var-deref) — they
;; aren't visible in the IR call graph, so seed them as roots. (Found by grepping the
;; runtime shims; the smoke harness catches a miss as a diff/crash.)
(define dce-runtime-core-roots
'("clojure.core/identity" "clojure.core/isa?" "clojure.core/line-seq"
"clojure.core/make-hierarchy" "clojure.core/read" "clojure.core/read-string"
"clojure.core/read+string" "clojure.core/realized?" "clojure.core/reset!"))
;; --- reading a minted blob (prelude.ss) into DCE records --------------------
;; The prelude is a flat list of (guard CLAUSE (def-var! "ns" "name" V)) forms (+ the
;; occasional side-effecting init). Read each with Chez `read` so it joins the
;; reachability graph instead of being baked wholesale: a def-var! is a prunable node
;; whose core->core edges are the (var-deref/jolt-var "ns" "name") calls in V; any
;; other form is non-prunable (kept, refs are roots).
(define (dce-unwrap form)
(if (and (pair? form) (eq? (car form) 'guard) (pair? (cddr form))) (caddr form) form))
(define (dce-sexp-refs form acc)
(cond
((and (pair? form) (memq (car form) '(var-deref jolt-var))
(pair? (cdr form)) (string? (cadr form)) (pair? (cddr form)) (string? (caddr form)))
(cons (string-append (cadr form) "/" (caddr form)) acc))
((pair? form) (dce-sexp-refs (cdr form) (dce-sexp-refs (car form) acc)))
(else acc)))
;; Records (same shape as ei-emit-ns-records) for a minted blob file. str re-serializes
;; the read form (compiled identically; comments/whitespace are irrelevant).
(define (dce-blob-records path)
(call-with-input-file path
(lambda (p)
(let loop ((acc '()))
(let ((form (read p)))
(if (eof-object? form)
(reverse acc)
(let ((b (dce-unwrap form))
(str (with-output-to-string (lambda () (write form))))
(refs (dce-sexp-refs form '())))
(loop (cons
(if (and (pair? b) (eq? (car b) 'def-var!) (pair? (cdr b)) (string? (cadr b))
(pair? (cddr b)) (string? (caddr b)))
(vector #f (string-append (cadr b) "/" (caddr b)) refs str)
(vector #t #f refs str))
acc)))))))))
;; A reference that needs the analyzer/back end at runtime (compile-from-source). If
;; reachable code uses none of these, the compiler image can be dropped from the
;; binary — the AOT app is fully compiled. (resolve/require don't need it: resolve is
;; a var-table lookup; a require of a baked ns no-ops.)
(define dce-compile-refs
'("clojure.core/eval" "clojure.core/load-string" "clojure.core/load-file"
"clojure.core/load-reader" "clojure.core/load"))
;; One record per form: (vector keep? fqn refs str). keep? #t = a non-def form,
;; always emitted, its refs are reachability roots; #f = a prunable def emitted only
;; if fqn is reached. A macro is a prunable def (its expander isn't called at runtime
;; in an AOT build). Strict (no guard) like the build's ei-emit-ns* path.
;; --- DCE record producer ----------------------------------------------------
;; Cross-compile a namespace's source to tree-shaking records — the app/library
;; counterpart to dce-blob-records (the prelude). The shake itself and all dce-*
;; helpers live in dce.ss; this stays here because it drives the ei-* compiler. A
;; top-level def becomes a prunable record; any other form a kept (side-effecting)
;; record whose refs are roots. A macro is prunable — its expander isn't called at
;; runtime in an AOT build.
(define (ei-emit-ns-records ns-name src)
(let loop ((forms (ei-read-all src)) (acc '()))
(if (null? forms)
@ -192,7 +105,7 @@
(ir (jolt-ce-run-passes (jolt-ce-analyze ctx fn-form) ctx))
(str (ei-macro-string ns-name nm (jolt-ce-emit-top ir) #f))
(refs (dce-collect-refs '() ir)))
(loop (cdr forms) (cons (vector #f (string-append ns-name "/" nm) refs str) acc)))))
(loop (cdr forms) (cons (dce-rec #f (string-append ns-name "/" nm) refs str) acc)))))
(else
(let* ((ctx (make-analyze-ctx ns-name))
(ir (jolt-ce-run-passes (jolt-ce-analyze ctx f) ctx))
@ -200,7 +113,7 @@
(fqn (dce-def-fqn ir))
(refs (dce-collect-refs '() ir)))
(loop (cdr forms)
(cons (if fqn (vector #f fqn refs str) (vector #t #f refs str)) acc)))))))))
(cons (if fqn (dce-rec #f fqn refs str) (dce-rec #t #f refs str)) acc)))))))))
;; Scheme string literal for a ns/name — uses the runtime's own writer
;; (printable ASCII identifiers only here).
@ -217,6 +130,7 @@
(cons "jolt.passes.numeric" "jolt-core/jolt/passes/numeric.clj")
(cons "jolt.passes.inline" "jolt-core/jolt/passes/inline.clj")
(cons "jolt.passes.types.lattice" "jolt-core/jolt/passes/types/lattice.clj")
(cons "jolt.passes.types.check" "jolt-core/jolt/passes/types/check.clj")
(cons "jolt.passes.types" "jolt-core/jolt/passes/types.clj")
(cons "jolt.passes" "jolt-core/jolt/passes.clj")))

13
host/chez/host-class.ss
View file

@ -13,7 +13,13 @@
;; (str (type x)) is the clean host taxonomy and
;; is never compared against a class token in the corpus. Records yield their
;; ns-qualified class name (= (str (type x))). Total — never crashes.
(define (jolt-class x)
;; A host shim (bigdec, queue, host-table) registers its type's class name via
;; register-class-arm! instead of set!-wrapping jolt-class (cf. register-hash-arm!).
;; The entry is stable, so the var cell bound below stays current as arms register.
(define jolt-class-arms '())
(define (register-class-arm! pred handler)
(set! jolt-class-arms (cons (cons pred handler) jolt-class-arms)))
(define (jolt-class-base x)
(cond
((jolt-nil? x) jolt-nil)
((boolean? x) "java.lang.Boolean")
@ -35,6 +41,11 @@
;; (thrown? Class …) match (records.ss ex-info-map?/ex-info-class).
((ex-info-map? x) (ex-info-class x))
(else (jolt-str-render-one (jolt-type x)))))
(define (jolt-class x)
(let loop ((as jolt-class-arms))
(cond ((null? as) (jolt-class-base x))
(((caar as) x) ((cdar as) x))
(else (loop (cdr as))))))
(def-var! "clojure.core" "class" jolt-class)

9
host/chez/host-static-objects.ss → host/chez/host-static-classes.ss
View file

@ -1,7 +1,8 @@
;; host-static-objects.ss — host object classes (ArrayList, HashMap, the
;; String/Reader/Writer/Tokenizer shims, BigInteger/MapEntry ctors, URL codecs)
;; and the tagged-table method dispatch + pluggable instance? hook. Continues
;; host-static-statics.ss; loaded last of the three.
;; host-static-classes.ss — instantiable host object classes: ArrayList, HashMap,
;; the String/Reader/Writer/Tokenizer shims, BigInteger/MapEntry ctors, and URL
;; codecs. Holds the tagged-table method dispatch (the (.method ...) arm on a jhost)
;; and the pluggable instance? hook. Loaded after host-static-methods.ss; the
;; `Class/member` static methods live there, the registry core in host-static.ss.
;; ---- java.util.ArrayList ----------------------------------------------------
;; A mutable list backed by a growable Scheme vector. State is #(backing count);

8
host/chez/host-static-statics.ss → host/chez/host-static-methods.ss
View file

@ -1,6 +1,8 @@
;; host-static-statics.ss — java.lang / java.util.* static methods and the
;; NumberFormat / Class registries. Continues host-static.ss (its registries +
;; jhost record + coercion helpers); loaded right after it.
;; host-static-methods.ss — the `Class/member` static surface: java.lang.Math,
;; System (properties/env), Thread, the Long/Integer/Double/Character/String static
;; methods, java.text.NumberFormat, and the Class registry. Registers into
;; host-static.ss's class-statics table (loaded just before this); instantiable host
;; object classes (ArrayList, StringBuilder, …) live in host-static-classes.ss.
;; ---- java.lang statics ------------------------------------------------------
;; java.lang.Math: sqrt/pow/floor/ceil/trig/log/exp always return a DOUBLE on the

5
host/chez/host-static.ss
View file

@ -1,4 +1,7 @@
;; host-static.ss — host class statics + constructors on Chez.
;; host-static.ss — the host-interop registry core: the class-statics / class-ctors
;; / tagged-methods tables, the jhost record, and the coercion helpers. The actual
;; entries are registered by host-static-methods.ss (Class/member statics) and
;; host-static-classes.ss (instantiable object classes), loaded after this.
;;
;; The analyzer lowers `Class/member` to a :host-static node and `(Class. ...)` /
;; `(new Class ...)` to a :host-new node (jolt-core/jolt/analyzer.clj); the Chez

34
host/chez/host-table.ss
View file

@ -72,10 +72,7 @@
(set! jolt-seq (lambda (x) (if (htable-sorted? x) (sc-call x kw-op-seq) (%h-seq x))))
(define %h-count jolt-count)
(set! jolt-count (lambda (coll) (if (htable-sorted? coll) (sc-call coll kw-op-count) (%h-count coll))))
(define %h-get jolt-get)
(set! jolt-get (case-lambda
((coll k) (if (htable-sorted? coll) (sc-call coll kw-op-get k jolt-nil) (%h-get coll k)))
((coll k d) (if (htable-sorted? coll) (sc-call coll kw-op-get k d) (%h-get coll k d)))))
(register-get-arm! htable-sorted? (lambda (coll k d) (sc-call coll kw-op-get k d)))
(define %h-contains? jolt-contains?)
(set! jolt-contains? (lambda (coll k)
(if (htable-sorted? coll) (if (jolt-truthy? (sc-call coll kw-op-contains k)) #t #f) (%h-contains? coll k))))
@ -131,13 +128,13 @@
(define (sorted-set->pset sc)
(fold-left (lambda (s x) (pset-conj s x)) empty-pset (seq->list (sc-call sc kw-op-seq))))
(define (sorted->plain x) (if (htable-sorted-map? x) (sorted-map->pmap x) (sorted-set->pset x)))
(define %h-jolt=2 jolt=2)
(set! jolt=2 (lambda (a b)
(cond ((htable-sorted? a) (%h-jolt=2 (sorted->plain a) (if (htable-sorted? b) (sorted->plain b) b)))
((htable-sorted? b) (%h-jolt=2 a (sorted->plain b)))
(else (%h-jolt=2 a b)))))
(define %h-jolt-hash jolt-hash)
(set! jolt-hash (lambda (x) (if (htable-sorted? x) (%h-jolt-hash (sorted->plain x)) (%h-jolt-hash x))))
;; a sorted coll compares as its plain equivalent: normalize and re-dispatch (the
;; normalized values aren't sorted, so this arm won't re-match — the base compares).
(register-eq-arm! (lambda (a b) (or (htable-sorted? a) (htable-sorted? b)))
(lambda (a b) (jolt=2 (if (htable-sorted? a) (sorted->plain a) a)
(if (htable-sorted? b) (sorted->plain b) b))))
;; a sorted coll hashes as its plain equivalent (jolt-hash recurses through the base).
(register-hash-arm! htable-sorted? (lambda (x) (jolt-hash (sorted->plain x))))
;; --- printing ----------------------------------------------------------------
;; sorted colls render in SORTED order (the value's :seq), not HAMT order — and
@ -156,10 +153,9 @@
(define (sorted-render x render)
(if (htable-sorted-map? x) (sorted-map-render x render) (sorted-set-render x render)))
(define %h-pr-readable jolt-pr-readable)
(set! jolt-pr-readable (lambda (x) (if (htable-sorted? x) (sorted-render x jolt-pr-readable) (%h-pr-readable x))))
(define %h-pr-str jolt-pr-str)
(set! jolt-pr-str (lambda (x) (if (htable-sorted? x) (sorted-render x jolt-pr-str) (%h-pr-str x))))
;; sorted colls render in :seq order via the calling printer (str vs readable).
(register-pr-readable-arm! htable-sorted? (lambda (x) (sorted-render x jolt-pr-readable)))
(register-pr-str-arm! htable-sorted? (lambda (x) (sorted-render x jolt-pr-str)))
(register-str-render! htable-sorted? (lambda (x) (sorted-render x jolt-str-render-one)))
;; --- protocol dispatch over builtins (extend-protocol Map/Set on sorted) ------
@ -177,8 +173,6 @@
;; (class e) on a throwable tagged-table (a library's ex-info envelope carrying a
;; JVM :class, e.g. jolt-lang/http-client's UnknownHostException) reads that
;; class name, so clojure.test's (thrown? Class …) / (= Class (class e)) match.
(define %h-class jolt-class)
(set! jolt-class (lambda (x)
(let ((c (and (htable? x) (hashtable-ref (htable-h x) "class" #f))))
(if (and c (string? c)) c (%h-class x)))))
(def-var! "clojure.core" "class" jolt-class)
;; an htable carrying a string "class" entry reports it (a host-object class mirror).
(register-class-arm! (lambda (x) (and (htable? x) (string? (hashtable-ref (htable-h x) "class" #f))))
(lambda (x) (hashtable-ref (htable-h x) "class" #f)))

24
host/chez/inst-time.ss
View file

@ -232,29 +232,19 @@
(define kw-ms (keyword #f "ms"))
(define inst-type-kw (keyword "jolt" "inst"))
(define %it-get jolt-get)
(set! jolt-get (case-lambda
((coll k) (jolt-get coll k jolt-nil))
((coll k d) (if (jinst? coll)
(register-get-arm! jinst?
(lambda (coll k d)
(cond ((jolt=2 k kw-jolt-type) inst-type-kw)
((jolt=2 k kw-ms) (jinst-ms coll))
(else d))
(%it-get coll k d)))))
(else d))))
(define %it-=2 jolt=2)
(set! jolt=2 (lambda (a b)
(cond ((jinst? a) (and (jinst? b) (= (jinst-ms a) (jinst-ms b))))
((jinst? b) #f)
(else (%it-=2 a b)))))
(register-eq-arm! (lambda (a b) (or (jinst? a) (jinst? b)))
(lambda (a b) (and (jinst? a) (jinst? b) (= (jinst-ms a) (jinst-ms b)))))
(define %it-hash jolt-hash)
(set! jolt-hash (lambda (x) (if (jinst? x) (jolt-hash (jinst-ms x)) (%it-hash x))))
(register-hash-arm! jinst? (lambda (x) (jolt-hash (jinst-ms x))))
(define (inst-pr i) (string-append "#inst \"" (inst-rfc3339 i) "\""))
(define %it-pr-str jolt-pr-str)
(set! jolt-pr-str (lambda (x) (if (jinst? x) (inst-pr x) (%it-pr-str x))))
(define %it-pr-readable jolt-pr-readable)
(set! jolt-pr-readable (lambda (x) (if (jinst? x) (inst-pr x) (%it-pr-readable x))))
(register-pr-arm! jinst? inst-pr)
(register-str-render! jinst? inst-rfc3339)
(define %it-type jolt-type)

18
host/chez/io.ss
View file

@ -487,17 +487,9 @@
;; str / pr-str of a uri -> its string form.
(register-str-render! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "uri")))
(lambda (x) (uri-field x 'string)))
(define %uri-pr-readable jolt-pr-readable)
(set! jolt-pr-readable
(lambda (x) (if (and (jhost? x) (string=? (jhost-tag x) "uri"))
(string-append "#object[java.net.URI \"" (uri-field x 'string) "\"]")
(%uri-pr-readable x))))
(register-pr-readable-arm! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "uri")))
(lambda (x) (string-append "#object[java.net.URI \"" (uri-field x 'string) "\"]")))
;; class of the host value types defined by now (uri/uuid/file).
(define %uri-class jolt-class)
(set! jolt-class
(lambda (x)
(cond ((and (jhost? x) (string=? (jhost-tag x) "uri")) "java.net.URI")
((juuid? x) "java.util.UUID")
((jfile? x) "java.io.File")
(else (%uri-class x)))))
(def-var! "clojure.core" "class" jolt-class)
(register-class-arm! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "uri"))) (lambda (x) "java.net.URI"))
(register-class-arm! juuid? (lambda (x) "java.util.UUID"))
(register-class-arm! jfile? (lambda (x) "java.io.File"))

7
host/chez/lazy-bridge.ss
View file

@ -65,10 +65,9 @@
(set! jolt-nth (case-lambda
((coll i) (if (jolt-lazyseq? coll) (%ls-nth (jolt-seq coll) i) (%ls-nth coll i)))
((coll i d) (if (jolt-lazyseq? coll) (%ls-nth (jolt-seq coll) i d) (%ls-nth coll i d)))))
(define %ls-pr-str jolt-pr-str)
(set! jolt-pr-str (lambda (x) (if (jolt-lazyseq? x) (%ls-pr-str (jolt-seq x)) (%ls-pr-str x))))
(define %ls-pr-readable jolt-pr-readable)
(set! jolt-pr-readable (lambda (x) (if (jolt-lazyseq? x) (%ls-pr-readable (jolt-seq x)) (%ls-pr-readable x))))
;; a lazy seq prints as its realized seq — force, then re-dispatch through the printer.
(register-pr-str-arm! jolt-lazyseq? (lambda (x) (jolt-pr-str (jolt-seq x))))
(register-pr-readable-arm! jolt-lazyseq? (lambda (x) (jolt-pr-readable (jolt-seq x))))
(register-str-render! jolt-lazyseq? (lambda (x) (jolt-str-render-one (jolt-seq x))))
;; seq? — a lazy seq IS a seq (predicates.ss's jolt-seq? predates the lazyseq

62
host/chez/natives-format.ss Normal file
View file

@ -0,0 +1,62 @@
;; natives-format.ss — a small %-format engine for clojure.core `format` over the
;; all-flonum number model: %d (integer), %s (str), %f / %.Nf (fixed-point), %x/%X
;; (hex int), %o (octal), %c (char int), %b (boolean), %% (literal). Enough for the
;; corpus, not the full Java Formatter spec. Loaded after natives-misc.ss (uses
;; jolt-str-render-one via converters + jolt-truthy?).
(define (->long x) (exact (truncate x)))
(define (pad-left s n c) (if (fx>=? (string-length s) n) s (string-append (make-string (fx- n (string-length s)) c) s)))
(define (fmt-float x prec)
(let* ((neg (< x 0)) (ax (abs x))
(scale (expt 10 prec))
(scaled (round (* (inexact ax) scale)))
(i (exact (truncate (/ scaled scale))))
(frac (exact (truncate (- scaled (* i scale))))))
(string-append (if neg "-" "")
(number->string i)
(if (fx>? prec 0) (string-append "." (pad-left (number->string frac) prec #\0)) ""))))
(define (jolt-format fmt . args)
(let ((out (open-output-string)))
(let loop ((i 0) (as args))
(if (fx>=? i (string-length fmt))
(get-output-string out)
(let ((c (string-ref fmt i)))
(if (char=? c #\%)
;; parse a directive: %[-][0][width][.prec]conv
(let scan ((j (fx+ i 1)) (left #f) (zero #f) (width #f) (prec #f) (seen-dot #f))
(let ((d (string-ref fmt j)))
(cond
((char=? d #\%) (write-char #\% out) (loop (fx+ j 1) as))
((and (not seen-dot) (not width) (char=? d #\-))
(scan (fx+ j 1) #t zero width prec seen-dot))
((and (not seen-dot) (not width) (char=? d #\0))
(scan (fx+ j 1) left #t width prec seen-dot))
((char=? d #\.) (scan (fx+ j 1) left zero width 0 #t))
((and (char>=? d #\0) (char<=? d #\9))
(if seen-dot
(scan (fx+ j 1) left zero width (fx+ (fx* (or prec 0) 10) (fx- (char->integer d) 48)) seen-dot)
(scan (fx+ j 1) left zero (fx+ (fx* (or width 0) 10) (fx- (char->integer d) 48)) prec seen-dot)))
(else
(let* ((a (if (null? as) jolt-nil (car as)))
(rest (if (null? as) '() (cdr as)))
(s (case d
((#\d) (number->string (->long a)))
((#\s) (jolt-str-render-one a))
((#\f) (fmt-float a (or prec 6)))
((#\x) (number->string (->long a) 16))
((#\X) (string-upcase (number->string (->long a) 16)))
((#\o) (number->string (->long a) 8))
((#\b) (if (jolt-truthy? a) "true" "false"))
((#\c) (string (integer->char (->long a))))
(else (string #\% d))))
;; pad to width: left-justify with spaces, else right-justify
;; (zero-pad only a right-justified number).
(s (if (and width (fx<? (string-length s) width))
(let ((p (fx- width (string-length s))))
(if left (string-append s (make-string p #\space))
(string-append (make-string p (if (and zero (memv d '(#\d #\f #\x #\X #\o))) #\0 #\space)) s)))
s)))
(display s out)
(loop (fx+ j 1) rest))))))
(begin (write-char c out) (loop (fx+ i 1) as))))))))
(def-var! "clojure.core" "format" jolt-format)

106
host/chez/natives-misc.ss
View file

@ -1,4 +1,5 @@
;; misc scalar natives — UUID, format/printf, tagged-literal, bigint.
;; misc scalar natives — UUID, tagged-literal, bigint, and the hash API. (format /
;; printf moved to natives-format.ss.)
;;
;; Loaded after the printers (pr-str of a uuid is #uuid "…") and converters
;; (jolt-str-render-one for %s / str of a uuid).
@ -53,16 +54,10 @@
;; str of a uuid -> the bare 36-char string; pr-str -> #uuid "…".
(register-str-render! juuid? juuid-s)
(define (juuid-pr u) (string-append "#uuid \"" (juuid-s u) "\""))
(define %m-pr-str jolt-pr-str)
(set! jolt-pr-str (lambda (x) (if (juuid? x) (juuid-pr x) (%m-pr-str x))))
(define %m-pr-readable jolt-pr-readable)
(set! jolt-pr-readable (lambda (x) (if (juuid? x) (juuid-pr x) (%m-pr-readable x))))
(register-pr-arm! juuid? juuid-pr)
;; two uuids are = iff same string.
(define %m-=2 jolt=2)
(set! jolt=2 (lambda (a b)
(cond ((juuid? a) (and (juuid? b) (string=? (juuid-s a) (juuid-s b))))
((juuid? b) #f)
(else (%m-=2 a b)))))
(register-eq-arm! (lambda (a b) (or (juuid? a) (juuid? b)))
(lambda (a b) (and (juuid? a) (juuid? b) (string=? (juuid-s a) (juuid-s b)))))
;; --- bigint / biginteger -----------------------------------------------------
;; jolt models every number as a double; an integer-valued double prints without
@ -80,79 +75,30 @@
(define (jolt-tagged-literal-pred? x) (jtagged? x))
(define kw-tl-tag (keyword #f "tag"))
(define kw-tl-form (keyword #f "form"))
(define %m-get jolt-get)
(set! jolt-get (case-lambda
((coll k) (if (jtagged? coll) (jolt-get coll k jolt-nil) (%m-get coll k)))
((coll k d) (if (jtagged? coll)
(register-get-arm! jtagged?
(lambda (coll k d)
(cond ((jolt=2 k kw-tl-tag) (jtagged-tag coll))
((jolt=2 k kw-tl-form) (jtagged-form coll))
(else d))
(%m-get coll k d)))))
(else d))))
(define (jtagged-pr t) (string-append "#" (jolt-pr-str (jtagged-tag t)) " " (jolt-pr-readable (jtagged-form t))))
(define %m2-pr-str jolt-pr-str)
(set! jolt-pr-str (lambda (x) (if (jtagged? x) (jtagged-pr x) (%m2-pr-str x))))
(define %m2-pr-readable jolt-pr-readable)
(set! jolt-pr-readable (lambda (x) (if (jtagged? x) (jtagged-pr x) (%m2-pr-readable x))))
(register-pr-arm! jtagged? jtagged-pr)
(def-var! "clojure.core" "tagged-literal" jolt-tagged-literal)
;; tagged-literal? is OVERLAY (reads :jolt/type) — asserted in post-prelude.ss.
;; --- format / printf ---------------------------------------------------------
;; A small %-format engine over the all-flonum number model: %d (integer), %s
;; (str), %f / %.Nf (fixed-point), %x/%X (hex int), %o (octal), %c (char int),
;; %b (boolean), %% (literal). Enough for the corpus; not the full Java spec.
(define (->long x) (exact (truncate x)))
(define (pad-left s n c) (if (fx>=? (string-length s) n) s (string-append (make-string (fx- n (string-length s)) c) s)))
(define (fmt-float x prec)
(let* ((neg (< x 0)) (ax (abs x))
(scale (expt 10 prec))
(scaled (round (* (inexact ax) scale)))
(i (exact (truncate (/ scaled scale))))
(frac (exact (truncate (- scaled (* i scale))))))
(string-append (if neg "-" "")
(number->string i)
(if (fx>? prec 0) (string-append "." (pad-left (number->string frac) prec #\0)) ""))))
(define (jolt-format fmt . args)
(let ((out (open-output-string)))
(let loop ((i 0) (as args))
(if (fx>=? i (string-length fmt))
(get-output-string out)
(let ((c (string-ref fmt i)))
(if (char=? c #\%)
;; parse a directive: %[-][0][width][.prec]conv
(let scan ((j (fx+ i 1)) (left #f) (zero #f) (width #f) (prec #f) (seen-dot #f))
(let ((d (string-ref fmt j)))
(cond
((char=? d #\%) (write-char #\% out) (loop (fx+ j 1) as))
((and (not seen-dot) (not width) (char=? d #\-))
(scan (fx+ j 1) #t zero width prec seen-dot))
((and (not seen-dot) (not width) (char=? d #\0))
(scan (fx+ j 1) left #t width prec seen-dot))
((char=? d #\.) (scan (fx+ j 1) left zero width 0 #t))
((and (char>=? d #\0) (char<=? d #\9))
(if seen-dot
(scan (fx+ j 1) left zero width (fx+ (fx* (or prec 0) 10) (fx- (char->integer d) 48)) seen-dot)
(scan (fx+ j 1) left zero (fx+ (fx* (or width 0) 10) (fx- (char->integer d) 48)) prec seen-dot)))
(else
(let* ((a (if (null? as) jolt-nil (car as)))
(rest (if (null? as) '() (cdr as)))
(s (case d
((#\d) (number->string (->long a)))
((#\s) (jolt-str-render-one a))
((#\f) (fmt-float a (or prec 6)))
((#\x) (number->string (->long a) 16))
((#\X) (string-upcase (number->string (->long a) 16)))
((#\o) (number->string (->long a) 8))
((#\b) (if (jolt-truthy? a) "true" "false"))
((#\c) (string (integer->char (->long a))))
(else (string #\% d))))
;; pad to width: left-justify with spaces, else right-justify
;; (zero-pad only a right-justified number).
(s (if (and width (fx<? (string-length s) width))
(let ((p (fx- width (string-length s))))
(if left (string-append s (make-string p #\space))
(string-append (make-string p (if (and zero (memv d '(#\d #\f #\x #\X #\o))) #\0 #\space)) s)))
s)))
(display s out)
(loop (fx+ j 1) rest))))))
(begin (write-char c out) (loop (fx+ i 1) as))))))))
(def-var! "clojure.core" "format" jolt-format)
;; --- hash family (24-bit masked so int? holds) -------------------------------
;; The public hash API over jolt-hash (values.ss). hash-ordered/-unordered-coll
;; fold the element hashes the way Clojure's IHash mixers do.
(define (nm-h24 x) (bitwise-and (jolt-hash x) #xffffff))
(define (nm-hash x) (nm-h24 x))
(define (nm-hash-combine a b)
(bitwise-and (bitwise-xor (nm-h24 a) (+ (nm-h24 b) #x9e3779)) #xffffff))
(define (nm-hash-ordered-coll coll)
(let loop ((xs (seq->list (jolt-seq coll))) (h 1))
(if (null? xs) h (loop (cdr xs) (bitwise-and (+ (* 31 h) (nm-h24 (car xs))) #xffffff)))))
(define (nm-hash-unordered-coll coll)
(let loop ((xs (seq->list (jolt-seq coll))) (h 0))
(if (null? xs) h (loop (cdr xs) (bitwise-and (+ h (nm-h24 (car xs))) #xffffff)))))
(def-var! "clojure.core" "hash" nm-hash)
(def-var! "clojure.core" "hash-combine" nm-hash-combine)
(def-var! "clojure.core" "hash-ordered-coll" nm-hash-ordered-coll)
(def-var! "clojure.core" "hash-unordered-coll" nm-hash-unordered-coll)

91
host/chez/natives-parity.ss
View file

@ -1,91 +0,0 @@
;; natives-parity.ss — native Chez shims for clojure.core fns. Pure-Chez,
;; JVM-matching.
;;
;; Loaded after host-table.ss (htable-sorted?), transients.ss (jolt-transient?),
;; values.ss (jolt-hash), seq.ss (jolt-seq/seq->list/list->cseq/jolt-invoke).
;; --- hash family (24-bit masked so int? holds) ------
(define (np-h24 x) (bitwise-and (jolt-hash x) #xffffff))
(define (np-hash x) (np-h24 x))
(define (np-hash-combine a b)
(bitwise-and (bitwise-xor (np-h24 a) (+ (np-h24 b) #x9e3779)) #xffffff))
(define (np-hash-ordered-coll coll)
(let loop ((xs (seq->list (jolt-seq coll))) (h 1))
(if (null? xs) h (loop (cdr xs) (bitwise-and (+ (* 31 h) (np-h24 (car xs))) #xffffff)))))
(define (np-hash-unordered-coll coll)
(let loop ((xs (seq->list (jolt-seq coll))) (h 0))
(if (null? xs) h (loop (cdr xs) (bitwise-and (+ h (np-h24 (car xs))) #xffffff)))))
;; --- transient? ---------------------------------------------------------------
(define (np-transient? x) (jolt-transient? x))
;; --- rseq: vectors + sorted colls only (Clojure), reverse of the ascending seq.
(define (np-rseq coll)
(if (or (pvec? coll) (htable-sorted? coll))
(list->cseq (reverse (seq->list (jolt-seq coll))))
(jolt-throw (jolt-ex-info "rseq requires a vector or sorted collection" (jolt-hash-map)))))
;; --- cat transducer: each item of the input
;; is itself a collection, concatenated into the downstream reducing fn.
(define (np-cat rf)
(lambda a
(cond
((null? a) (jolt-invoke rf))
((null? (cdr a)) (jolt-invoke rf (car a)))
(else
(let loop ((xs (seq->list (jolt-seq (cadr a)))) (acc (car a)))
(if (null? xs) acc (loop (cdr xs) (jolt-invoke rf acc (car xs)))))))))
;; --- reader feature set (for #?() conditionals) — mutable list of name strings,
;; default jolt + default. __reader-features returns the strings; -set! replaces.
(define np-reader-features (list "jolt" "default"))
(define (np-reader-features-get) (list->cseq np-reader-features))
(define (np-reader-features-set! names)
(set! np-reader-features
(map (lambda (n) (cond ((keyword-t? n) (keyword-t-name n)) ((string? n) n) (else (jolt-pr-str n))))
(seq->list (jolt-seq names))))
jolt-nil)
;; --- reader-conditional / re-matcher: tagged maps (reader-conditional? + the
;; matcher consumers are overlay tagged-value predicates that read :jolt/type).
(define np-kw-type (keyword "jolt" "type"))
(define np-kw-rc (keyword "jolt" "reader-conditional"))
(define np-kw-form (keyword #f "form"))
(define np-kw-spl (keyword #f "splicing?"))
(define np-kw-mat (keyword "jolt" "matcher"))
(define np-kw-re (keyword #f "re"))
(define np-kw-s (keyword #f "s"))
(define np-kw-pos (keyword #f "pos"))
(define (np-reader-conditional form splicing?)
(jolt-hash-map np-kw-type np-kw-rc np-kw-form form np-kw-spl splicing?))
(define (np-re-matcher re s)
(jolt-hash-map np-kw-type np-kw-mat np-kw-re re np-kw-s s np-kw-pos 0.0))
;; (delay? / make-delay / force live in concurrency.ss with the real delay type.)
;; --- macroexpand-1 / macroexpand: expand a (quoted) call form via the runtime
;; macro table (host-contract hc-macro?/hc-expand-1; forward-referenced, resolved
;; at call time after the spine loads). macroexpand loops until the head is no
;; longer a macro (subforms are not expanded, matching Clojure).
(define (np-macroexpand-1 form)
(if (and (cseq? form) (cseq-list? form) (symbol-t? (seq-first form)))
(let ((ctx (make-analyze-ctx (chez-current-ns))))
(if (hc-macro? ctx (seq-first form)) (hc-expand-1 ctx form) form))
form))
(define (np-macroexpand form)
(let loop ((cur form))
(let ((nxt (np-macroexpand-1 cur))) (if (eq? cur nxt) cur (loop nxt)))))
(def-var! "clojure.core" "hash" np-hash)
(def-var! "clojure.core" "hash-combine" np-hash-combine)
(def-var! "clojure.core" "hash-ordered-coll" np-hash-ordered-coll)
(def-var! "clojure.core" "hash-unordered-coll" np-hash-unordered-coll)
(def-var! "clojure.core" "transient?" np-transient?)
(def-var! "clojure.core" "rseq" np-rseq)
(def-var! "clojure.core" "cat" np-cat)
(def-var! "clojure.core" "__reader-features" np-reader-features-get)
(def-var! "clojure.core" "__reader-features-set!" np-reader-features-set!)
(def-var! "clojure.core" "reader-conditional" np-reader-conditional)
(def-var! "clojure.core" "re-matcher" np-re-matcher)
(def-var! "clojure.core" "macroexpand-1" np-macroexpand-1)
(def-var! "clojure.core" "macroexpand" np-macroexpand)

7
host/chez/natives-queue.ss
View file

@ -44,14 +44,11 @@
;; printing: render the elements as a parenthesized list (delegate to the seq path).
(define (jolt-seq-or-empty x) (let ((s (jolt-seq x))) (if (jolt-nil? s) jolt-empty-list s)))
(define %q-pr-readable jolt-pr-readable)
(set! jolt-pr-readable (lambda (x) (if (jolt-queue? x) (%q-pr-readable (jolt-seq-or-empty x)) (%q-pr-readable x))))
(register-pr-readable-arm! jolt-queue? (lambda (x) (jolt-pr-readable (jolt-seq-or-empty x))))
(register-str-render! jolt-queue? (lambda (x) (jolt-str-render-one (jolt-seq-or-empty x))))
;; class / type / instance? recognize a queue.
(define %q-class jolt-class)
(set! jolt-class (lambda (x) (if (jolt-queue? x) "clojure.lang.PersistentQueue" (%q-class x))))
(def-var! "clojure.core" "class" jolt-class)
(register-class-arm! jolt-queue? (lambda (x) "clojure.lang.PersistentQueue"))
(register-instance-check-arm!
(lambda (type-sym val)
(if (jolt-queue? val)

52
host/chez/natives-reader.ss Normal file
View file

@ -0,0 +1,52 @@
;; natives-reader.ss — reader/macro runtime-support natives: the #?() reader feature
;; set, the reader-conditional + re-matcher tagged-map constructors, and macroexpand.
;;
;; Loaded late (after ns.ss): macroexpand forward-refs the runtime macro table
;; (host-contract hc-macro?/hc-expand-1) + the analyzer ctx, resolved at call time
;; after the spine loads. The hash / transient? / rseq / cat natives that used to
;; live here moved to natives-misc, transients, natives-seq, and natives-transduce.
;; --- reader feature set (for #?() conditionals) — mutable list of name strings,
;; default jolt + default. __reader-features returns the strings; -set! replaces.
(define nr-reader-features (list "jolt" "default"))
(define (nr-reader-features-get) (list->cseq nr-reader-features))
(define (nr-reader-features-set! names)
(set! nr-reader-features
(map (lambda (n) (cond ((keyword-t? n) (keyword-t-name n)) ((string? n) n) (else (jolt-pr-str n))))
(seq->list (jolt-seq names))))
jolt-nil)
;; --- reader-conditional / re-matcher: tagged maps (reader-conditional? + the
;; matcher consumers are overlay tagged-value predicates that read :jolt/type).
(define nr-kw-type (keyword "jolt" "type"))
(define nr-kw-rc (keyword "jolt" "reader-conditional"))
(define nr-kw-form (keyword #f "form"))
(define nr-kw-spl (keyword #f "splicing?"))
(define nr-kw-mat (keyword "jolt" "matcher"))
(define nr-kw-re (keyword #f "re"))
(define nr-kw-s (keyword #f "s"))
(define nr-kw-pos (keyword #f "pos"))
(define (nr-reader-conditional form splicing?)
(jolt-hash-map nr-kw-type nr-kw-rc nr-kw-form form nr-kw-spl splicing?))
(define (nr-re-matcher re s)
(jolt-hash-map nr-kw-type nr-kw-mat nr-kw-re re nr-kw-s s nr-kw-pos 0.0))
;; --- macroexpand-1 / macroexpand: expand a (quoted) call form via the runtime
;; macro table (host-contract hc-macro?/hc-expand-1; forward-referenced, resolved
;; at call time after the spine loads). macroexpand loops until the head is no
;; longer a macro (subforms are not expanded, matching Clojure).
(define (nr-macroexpand-1 form)
(if (and (cseq? form) (cseq-list? form) (symbol-t? (seq-first form)))
(let ((ctx (make-analyze-ctx (chez-current-ns))))
(if (hc-macro? ctx (seq-first form)) (hc-expand-1 ctx form) form))
form))
(define (nr-macroexpand form)
(let loop ((cur form))
(let ((nxt (nr-macroexpand-1 cur))) (if (eq? cur nxt) cur (loop nxt)))))
(def-var! "clojure.core" "__reader-features" nr-reader-features-get)
(def-var! "clojure.core" "__reader-features-set!" nr-reader-features-set!)
(def-var! "clojure.core" "reader-conditional" nr-reader-conditional)
(def-var! "clojure.core" "re-matcher" nr-re-matcher)
(def-var! "clojure.core" "macroexpand-1" nr-macroexpand-1)
(def-var! "clojure.core" "macroexpand" nr-macroexpand)

7
host/chez/natives-seq.ss
View file

@ -213,3 +213,10 @@
(def-var! "clojure.core" "partition" jolt-partition)
(def-var! "clojure.core" "sort" jolt-sort)
(def-var! "clojure.core" "identical?" jolt-identical?)
;; rseq: vectors + sorted colls only (Clojure), the reverse of the ascending seq.
(define (jolt-rseq coll)
(if (or (pvec? coll) (htable-sorted? coll))
(list->cseq (reverse (seq->list (jolt-seq coll))))
(jolt-throw (jolt-ex-info "rseq requires a vector or sorted collection" (jolt-hash-map)))))
(def-var! "clojure.core" "rseq" jolt-rseq)

16
host/chez/natives-xform.ss → host/chez/natives-transduce.ss
View file

@ -1,4 +1,5 @@
;; volatiles + sequence / transduce — the transducer application surface.
;; natives-transduce.ss — the transducer surface: volatiles, the `cat` transducer,
;; and sequence / transduce application.
;;
;; `sequence` and `transduce` are seed natives. The stateful transducer arities
;; (take-nth/map-indexed/partition-by/dedupe/distinct, all overlay) use
@ -47,3 +48,16 @@
(def-var! "clojure.core" "transduce" jolt-transduce)
(def-var! "clojure.core" "sequence" jolt-sequence)
;; --- cat ---------------------------------------------------------------------
;; cat transducer: each input item is itself a collection, concatenated into the
;; downstream reducing fn.
(define (jolt-cat rf)
(lambda a
(cond
((null? a) (jolt-invoke rf))
((null? (cdr a)) (jolt-invoke rf (car a)))
(else
(let loop ((xs (seq->list (jolt-seq (cadr a)))) (acc (car a)))
(if (null? xs) acc (loop (cdr xs) (jolt-invoke rf acc (car xs)))))))))
(def-var! "clojure.core" "cat" jolt-cat)

5
host/chez/ns.ss
View file

@ -344,8 +344,5 @@
(def-var! "clojure.core" "*ns*" (intern-ns! "user"))
;; --- printer patches: a namespace renders as its name (str / pr-str / -e) ----
(define %ns-pr-str jolt-pr-str)
(set! jolt-pr-str (lambda (x) (if (jns? x) (jns-name x) (%ns-pr-str x))))
(define %ns-pr-readable jolt-pr-readable)
(set! jolt-pr-readable (lambda (x) (if (jns? x) (jns-name x) (%ns-pr-readable x))))
(register-pr-arm! jns? jns-name)
(register-str-render! jns? jns-name)

2
host/chez/post-prelude.ss
View file

@ -18,7 +18,7 @@
(def-var! "clojure.core" "get-validator" jolt-get-validator)
;; volatiles: a Chez volatile is a jvol record, but the overlay vreset!/vswap!/
;; volatile? drive it via jolt.host/ref-put!+get / :jolt/type (tagged-table only).
;; Override with the native versions (defined in natives-xform.ss).
;; Override with the native versions (defined in natives-transduce.ss).
(def-var! "clojure.core" "vreset!" jolt-vreset!)
(def-var! "clojure.core" "vswap!" jolt-vswap!)
(def-var! "clojure.core" "volatile?" jolt-volatile-pred?)

30
host/chez/printing.ss
View file

@ -24,7 +24,16 @@
((#\return) (cons #\r (cons #\\ acc)))
(else (cons c acc))))))))
(define (jolt-pr-readable x)
;; A host shim registers a type's readable rendering via register-pr-readable-arm!,
;; or register-pr-arm! for types whose str and readable forms match (most host types:
;; inst, uuid, record, var, …). Disjoint types, checked before the base cases.
(define jolt-pr-readable-arms '())
(define (register-pr-readable-arm! pred render)
(set! jolt-pr-readable-arms (cons (cons pred render) jolt-pr-readable-arms)))
(define (register-pr-arm! pred render)
(register-pr-str-arm! pred render)
(register-pr-readable-arm! pred render))
(define (jolt-pr-readable-base x)
(cond
((string? x) (string-append "\"" (jolt-str-escape x) "\""))
;; pr renders the infinities / NaN in READABLE form (##Inf reads back), unlike
@ -58,6 +67,11 @@
(if (jolt-nil? s) (reverse acc)
(loop (jolt-seq (seq-more s)) (cons (jolt-pr-readable (seq-first s)) acc))))) ")"))
(else (jolt-pr-str x))))
(define (jolt-pr-readable x)
(let loop ((as jolt-pr-readable-arms))
(cond ((null? as) (jolt-pr-readable-base x))
(((caar as) x) ((cdar as) x))
(else (loop (cdr as))))))
;; __pr-str1: render ONE value readably (the overlay's pr-str joins these).
(define (jolt-pr-str1 x) (jolt-pr-readable x))
@ -71,10 +85,18 @@
(define (jolt-with-out-str thunk)
(with-output-to-string (lambda () (jolt-invoke thunk))))
;; __eprint / __eprintf: stderr seams.
(define (jolt-eprint s) (display s (current-error-port)) jolt-nil)
;; __eprint / __eprintf: stderr seams. Flush each write — like the JVM's
;; auto-flushing System.err — so a long-running process (a server that never
;; returns from -main) shows its log lines instead of leaving them in a buffer
;; that only drains at exit.
(define (jolt-eprint s)
(display s (current-error-port))
(flush-output-port (current-error-port))
jolt-nil)
(define (jolt-eprintf fmt . args)
(apply fprintf (current-error-port) fmt args) jolt-nil)
(apply fprintf (current-error-port) fmt args)
(flush-output-port (current-error-port))
jolt-nil)
(def-var! "clojure.core" "__pr-str1" jolt-pr-str1)
(def-var! "clojure.core" "__write" jolt-write)

2
host/chez/records-interop.ss
View file

@ -50,7 +50,7 @@
(else (let ((p (assoc c exception-parent))) (loop (and p (cdr p))))))))
;; instance-check: (type-sym val) — type/protocol membership. Host shims loaded
;; later (io, inst-time, natives-array, natives-queue, host-static-objects)
;; later (io, inst-time, natives-array, natives-queue, host-static-classes)
;; register an arm with register-instance-check-arm! instead of set!-wrapping
;; instance-check; an arm returns #t/#f to decide or 'pass to defer to the next.
;; Newest arm is checked first (matches the old outermost-wins set! order).

20
host/chez/records.ss
View file

@ -62,17 +62,10 @@
"}"))
;; ---- extend the collection dispatchers with a jrec arm ----------------------
(define %r-jolt=2 jolt=2)
(set! jolt=2 (lambda (a b)
(cond ((jrec? a) (and (jrec? b) (jrec=? a b)))
((jrec? b) #f)
(else (%r-jolt=2 a b)))))
(define %r-jolt-hash jolt-hash)
(set! jolt-hash (lambda (x) (if (jrec? x) (jrec-hash x) (%r-jolt-hash x))))
(define %r-jolt-get jolt-get)
(set! jolt-get (case-lambda
((coll k) (if (jrec? coll) (jrec-lookup coll k jolt-nil) (%r-jolt-get coll k)))
((coll k d) (if (jrec? coll) (jrec-lookup coll k d) (%r-jolt-get coll k d)))))
(register-eq-arm! (lambda (a b) (or (jrec? a) (jrec? b)))
(lambda (a b) (and (jrec? a) (jrec? b) (jrec=? a b))))
(register-hash-arm! jrec? jrec-hash)
(register-get-arm! jrec? (lambda (coll k d) (jrec-lookup coll k d)))
(define %r-jolt-count jolt-count)
(set! jolt-count (lambda (coll) (if (jrec? coll) (length (jrec-pairs coll)) (%r-jolt-count coll))))
(define %r-jolt-contains? jolt-contains?)
@ -90,10 +83,7 @@
(define %r-jolt-conj1 jolt-conj1)
(set! jolt-conj1 (lambda (coll x)
(if (jrec? coll) (jolt-assoc1 coll (jolt-nth x 0) (jolt-nth x 1)) (%r-jolt-conj1 coll x))))
(define %r-jolt-pr-str jolt-pr-str)
(set! jolt-pr-str (lambda (x) (if (jrec? x) (jrec-pr x) (%r-jolt-pr-str x))))
(define %r-jolt-pr-readable jolt-pr-readable)
(set! jolt-pr-readable (lambda (x) (if (jrec? x) (jrec-pr x) (%r-jolt-pr-readable x))))
(register-pr-arm! jrec? jrec-pr)
;; records are map? and coll? (Clojure: a record IS an associative map). The
;; predicates.ss vars hold a snapshot, so re-def-var! after extending. record? is

37
host/chez/rt.ss
View file

@ -179,7 +179,13 @@
;; bare nil renders as the empty string (a nil ELEMENT inside a collection still
;; prints "nil", which jolt-pr-str handles).
(define (jolt-final-str x) (if (jolt-nil? x) "" (jolt-pr-str x)))
(define (jolt-pr-str x)
;; A host shim registers a type's str-style rendering via register-pr-str-arm! (or
;; register-pr-arm! in printing.ss for both printers at once) instead of
;; set!-wrapping jolt-pr-str. Disjoint types, checked before the base cases.
(define jolt-pr-str-arms '())
(define (register-pr-str-arm! pred render)
(set! jolt-pr-str-arms (cons (cons pred render) jolt-pr-str-arms)))
(define (jolt-pr-str-base x)
(cond
((jolt-nil? x) "nil")
((eq? x #t) "true")
@ -206,6 +212,11 @@
(if (jolt-nil? s) (reverse acc)
(loop (jolt-seq (seq-more s)) (cons (jolt-pr-str (seq-first s)) acc))))) ")"))
(else (format "~a" x))))
(define (jolt-pr-str x)
(let loop ((as jolt-pr-str-arms))
(cond ((null? as) (jolt-pr-str-base x))
(((caar as) x) ((cdar as) x))
(else (loop (cdr as))))))
;; converters + string ops: str/subs/vec/keyword/symbol/compare/int/
;; double/gensym — host-coupled seed natives def-var!'d into clojure.core. Loaded
@ -261,7 +272,7 @@
;; dynamic vars: *clojure-version* / *unchecked-math* constants the host
;; binds natively. After collections.ss (jolt-hash-map) + def-var!.
(load "host/chez/dynamic-vars.ss")
(load "host/chez/dynamic-var-defaults.ss")
;; host tables + sorted collections: jolt.host/tagged-table/
;; ref-put!/ref-get + the 25-sorted tier's runtime (sorted-map/sorted-set routed
@ -275,13 +286,13 @@
;; Loaded LAST so %ls-seq captures the fully-extended (sorted-aware) jolt-seq.
(load "host/chez/lazy-bridge.ss")
;; volatiles + sequence / transduce: native volatile boxes +
;; transducer surface: native volatile boxes, cat, +
;; the transduce/sequence entry points over into-xform/reduce-seq. After
;; natives-seq.ss (into-xform), seq.ss (reduce-seq) + atoms.ss (deref).
(load "host/chez/natives-xform.ss")
(load "host/chez/natives-transduce.ss")
;; vars as first-class objects: var?/var-get/deref/invoke/=/
;; pr-str over the rt.ss var-cell. After natives-xform.ss (chains deref) + the
;; pr-str over the rt.ss var-cell. After natives-transduce.ss (chains deref) + the
;; printers. emit lowers :the-var to (jolt-var ns name).
(load "host/chez/vars.ss")
@ -291,6 +302,10 @@
;; in post-prelude.ss.
(load "host/chez/natives-misc.ss")
;; format / printf: the %-directive engine. After natives-misc.ss + converters.ss
;; (jolt-str-render-one).
(load "host/chez/natives-format.ss")
;; namespaces: the namespace value model — find-ns/ns-name/
;; all-ns/the-ns/create-ns/in-ns/ns-publics/ns-map/ns-interns/ns-aliases/resolve/
;; find-var/ns-unmap/*ns*, over the var-table + chez-current-ns. Loaded LAST: needs
@ -316,8 +331,8 @@
;; record-method-dispatch (records.ss) and reuses natives-str helpers (str-trim,
;; ascii-string-down, re-split, str-split-drop-trailing) + the regex-t accessors.
(load "host/chez/host-static.ss") ; registries + jhost + coercion helpers
(load "host/chez/host-static-statics.ss") ; java.lang/util static methods
(load "host/chez/host-static-objects.ss") ; host object classes + instance? hook
(load "host/chez/host-static-methods.ss") ; Class/member static methods + fields
(load "host/chez/host-static-classes.ss") ; instantiable host object classes
;; generic dot-form dispatch: field access + map/vector member access
;; for the `.` / `.-field` desugar. Loads after host-static.ss so it wraps every
@ -345,10 +360,10 @@
;; clojure.math ns. Self-contained (only def-var! + Chez math), order-independent.
(load "host/chez/math.ss")
;; parity shims: native clojure.core fns not covered by the overlay
;; (hash family / rseq / cat / transient?). After host-table.ss (sorted),
;; transients.ss, values.ss (jolt-hash), seq.ss.
(load "host/chez/natives-parity.ss")
;; reader/macro runtime support: #?() feature set, reader-conditional + re-matcher
;; tagged-map ctors, macroexpand. After ns.ss; macroexpand call-time-refs the macro
;; table (host-contract) + analyzer ctx.
(load "host/chez/natives-reader.ss")
;; Java-style arrays: object/typed array constructors + a jolt-array
;; backing; extends count/nth/seq/get/ref-put! so the overlay aget/aset/alength see

490
host/chez/seed/image.ss
View file

File diff suppressed because one or more lines are too long

834
host/chez/seed/prelude.ss
View file

File diff suppressed because one or more lines are too long

7
host/chez/transients.ss
View file

@ -169,11 +169,7 @@
;; Redefine the native get/count/contains?/nth (captured first) so the existing
;; emit lowerings unwrap a transient; non-transients are untouched.
(define %prev-jolt-get jolt-get)
(set! jolt-get
(case-lambda
((coll k) (if (jolt-transient? coll) (t-get coll k jolt-nil) (%prev-jolt-get coll k)))
((coll k d) (if (jolt-transient? coll) (t-get coll k d) (%prev-jolt-get coll k d)))))
(register-get-arm! jolt-transient? (lambda (coll k d) (t-get coll k d)))
(define %prev-jolt-count jolt-count)
(set! jolt-count (lambda (coll) (if (jolt-transient? coll) (t-count coll) (%prev-jolt-count coll))))
(define %prev-jolt-contains? jolt-contains?)
@ -196,6 +192,7 @@
(%prev-jolt-nth coll i d)))))
(def-var! "clojure.core" "transient" jolt-transient-new)
(def-var! "clojure.core" "transient?" jolt-transient?)
(def-var! "clojure.core" "persistent!" jolt-persistent!)
(def-var! "clojure.core" "conj!" jolt-conj!)
(def-var! "clojure.core" "assoc!" jolt-assoc!)

29
host/chez/values.ss
View file

@ -43,7 +43,15 @@
;; chars/strings: Chez natives (strings treated immutable).
;; --- jolt equality (Clojure =) — scalars + collections ----------------------
(define (jolt=2 a b)
;; A host shim registers a type's equality via register-eq-arm! instead of
;; set!-wrapping jolt=2 (cf. register-hash-arm!). An arm is (pred . handler), both
;; (a b): the arm applies when pred holds (typically either arg is the type), and
;; handler returns the #t/#f result. Arms are checked before the base scalar/coll
;; cases; the entry is stable.
(define jolt-eq-arms '())
(define (register-eq-arm! pred handler)
(set! jolt-eq-arms (cons (cons pred handler) jolt-eq-arms)))
(define (jolt=2-base a b)
(cond
((and (jolt-nil? a) (jolt-nil? b)) #t)
((or (jolt-nil? a) (jolt-nil? b)) #f)
@ -63,6 +71,11 @@
;; other collections (map/set): forward to collections.ss.
((and (jolt-coll? a) (jolt-coll? b)) (jolt-coll=? a b))
(else (eq? a b))))
(define (jolt=2 a b)
(let loop ((as jolt-eq-arms))
(cond ((null? as) (jolt=2-base a b))
(((caar as) a b) ((cdar as) a b))
(else (loop (cdr as))))))
(define (jolt= a . rest)
(let loop ((a a) (rest rest))
(cond ((null? rest) #t)
@ -70,7 +83,14 @@
(else #f))))
;; --- jolt hash — consistent with jolt= (for the HAMT) -----------------------
(define (jolt-hash x)
;; A host shim (records, host-table, inst-time, …) registers its type's hash via
;; register-hash-arm! instead of set!-wrapping jolt-hash — the arms are disjoint
;; types, checked before the base cases, so the full behavior is gathered here plus
;; the registry rather than scattered across a set! chain (cf. register-str-render!).
(define jolt-hash-arms '())
(define (register-hash-arm! pred handler)
(set! jolt-hash-arms (cons (cons pred handler) jolt-hash-arms)))
(define (jolt-hash-base x)
(cond
((jolt-nil? x) 0)
((keyword-t? x) (keyword-t-khash x))
@ -87,3 +107,8 @@
((jolt-sequential? x) (seq-hash x)) ; vector/list/seq hash alike (forward to seq.ss)
((jolt-coll? x) (jolt-coll-hash x)) ; map/set; forward to collections.ss
(else (equal-hash x))))
(define (jolt-hash x)
(let loop ((as jolt-hash-arms))
(cond ((null? as) (jolt-hash-base x))
(((caar as) x) ((cdar as) x))
(else (loop (cdr as))))))

16
host/chez/vars.ss
View file

@ -9,7 +9,7 @@
;; with-redefs) lives in dyn-binding.ss, which chains the var-read paths set up
;; here.
;;
;; Loaded LAST (after natives-xform.ss): chains jolt-deref (atom/volatile arms)
;; Loaded LAST (after natives-transduce.ss): chains jolt-deref (atom/volatile arms)
;; and the printers.
(define (jolt-var-pred? x) (var-cell? x))
@ -31,20 +31,14 @@
(if (var-cell? f) (apply jolt-invoke (var-cell-root f) args) (apply %v-invoke f args))))
;; two var cells are = iff same ns/name (Clojure var identity).
(define %v-=2 jolt=2)
(set! jolt=2 (lambda (a b)
(cond ((var-cell? a) (and (var-cell? b)
(register-eq-arm! (lambda (a b) (or (var-cell? a) (var-cell? b)))
(lambda (a b) (and (var-cell? a) (var-cell? b)
(string=? (var-cell-ns a) (var-cell-ns b))
(string=? (var-cell-name a) (var-cell-name b))))
((var-cell? b) #f)
(else (%v-=2 a b)))))
(string=? (var-cell-name a) (var-cell-name b)))))
;; pr-str / str of a var -> #'ns/name.
(define (var->str v) (string-append "#'" (var-cell-ns v) "/" (var-cell-name v)))
(define %v-pr-str jolt-pr-str)
(set! jolt-pr-str (lambda (x) (if (var-cell? x) (var->str x) (%v-pr-str x))))
(define %v-pr-readable jolt-pr-readable)
(set! jolt-pr-readable (lambda (x) (if (var-cell? x) (var->str x) (%v-pr-readable x))))
(register-pr-arm! var-cell? var->str)
(register-str-render! var-cell? var->str)
;; bound? — native (the overlay's (get v :root) is nil on a var-cell record).

2
jolt-core/jolt/analyzer.clj
View file

@ -18,7 +18,7 @@
def-node let-node fn-node vector-node map-node set-node
quote-node throw-node host-static host-new]]
[jolt.host :refer [form-sym? form-sym-name form-sym-ns form-list?
form-vec? form-map? form-set? form-char?
form-vec? form-map? form-set?
form-literal? form-keyword? form-elements form-vec-items
form-map-pairs form-set-items form-special? compile-ns
form-regex? form-regex-source

26
jolt-core/jolt/backend_scheme.clj
View file

@ -80,6 +80,10 @@
;; :num-kind :double|:long when every operand is that kind; these are the Chez
;; flonum/fixnum ops it lowers to — no generic dispatch, fixnums unboxed. fl?/fx?
;; comparisons carry the question mark; fl+/fx+ don't.
;;
;; CONTRACT: every op name jolt.passes.numeric/dbl-spec (resp. lng-spec) tags must
;; have an entry here, or emit-numeric splices a nil op string into the output. Keep
;; these tables and those specializers in sync.
(def ^:private dbl-ops
{"+" "fl+" "-" "fl-" "*" "fl*" "/" "fl/" "min" "flmin" "max" "flmax"
"<" "fl<?" ">" "fl>?" "<=" "fl<=?" ">=" "fl>=?" "=" "fl=?" "==" "fl=?"})
@ -109,7 +113,12 @@
;; set — one defined earlier in emission order (or itself), so the Scheme binding
;; exists by the time the reference runs. Reset per build.
(def direct-link-defined (atom #{}))
(defn direct-link-reset! [] (reset! direct-link-defined #{}))
;; Of those, the ones whose init is a fn literal — safe to call as a raw Scheme
;; application. A def of a non-fn value (a map, set, keyword, …) is invokable in
;; Clojure but is not a Scheme procedure, so its calls must still route through
;; jolt-invoke even with a direct binding.
(def direct-link-fns (atom #{}))
(defn direct-link-reset! [] (reset! direct-link-defined #{}) (reset! direct-link-fns #{}))
;; A direct-link Scheme binding name for a var. The fqn maps to a unique identifier
;; jv$<ns>$<name>; chars that break a Scheme identifier or the `$` separator are
@ -120,6 +129,10 @@
(defn- dl-fqn [ns nm] (str ns "/" nm))
(defn- direct-linkable? [ns nm]
(and @direct-link? (contains? @direct-link-defined (dl-fqn ns nm))))
;; A direct-linked var whose value is a fn literal — its binding is a Scheme
;; procedure, so a call site can apply it directly.
(defn- direct-link-fn? [ns nm]
(contains? @direct-link-fns (dl-fqn ns nm)))
;; recur-target and the set of munged local names known to hold a procedure (a
;; named fn's self-recursion name) are lexically scoped — dynamic vars so the
@ -486,9 +499,13 @@
;; a :local callee that isn't a known procedure -> dynamic IFn dispatch.
(and (= :local (:op fnode)) (not (*known-procs* (munge-name (:name fnode)))))
(invoke)
;; closed-world direct call: the callee var is an app def already emitted with
;; a Scheme binding — call it directly, no var lookup, no jolt-invoke.
(and (= :var (:op fnode)) (direct-linkable? (:ns fnode) (:name fnode)))
;; closed-world direct call: the callee var is an app fn def already emitted
;; with a Scheme binding — apply it directly, no var lookup, no jolt-invoke.
;; Only fn-valued defs qualify; a non-fn invokable value (a map/set/keyword
;; held in a var) isn't a Scheme procedure, so it falls through to jolt-invoke
;; below (which still uses the direct binding as the invoke target).
(and (= :var (:op fnode)) (direct-linkable? (:ns fnode) (:name fnode))
(direct-link-fn? (:ns fnode) (:name fnode)))
(order-args (fn [as] (str "(" (dl-name (:ns fnode) (:name fnode))
(if (seq as) (str " " (str/join " " as)) "") ")")))
;; a late-bound :var call head can hold a procedure OR a non-applicable
@ -636,6 +653,7 @@
(let [ns (:ns node) nm (:name node) b (dl-name ns nm)]
;; register before emitting the init so a self-referential body direct-links.
(swap! direct-link-defined conj (dl-fqn ns nm))
(when (= :fn (:op (:init node))) (swap! direct-link-fns conj (dl-fqn ns nm)))
(let [init (emit (:init node))]
(if (jmeta-nonempty? (:meta node))
(str "(begin (define " b " " init ") (def-var-with-meta! "

16
jolt-core/jolt/passes/fold.clj
View file

@ -73,3 +73,19 @@
(defn scalar-const? [n]
(and (= :const (get n :op))
(let [v (get n :val)] (or (keyword? v) (string? v) (number? v) (boolean? v)))))
;; The two callee shapes a constant-keyword map lookup takes: a keyword in fn
;; position — (:k m) — or clojure.core/get with a const key — (get m :k). The
;; inliner (scalar replacement) and the type inferencer both recognize these;
;; sharing the head predicates keeps the two from drifting. Each caller still
;; imposes its own arity, subject, and key-type constraints.
(defn kw-callee?
"True if fnode is a constant keyword used as a function head — the (:k m) form."
[fnode]
(and (= :const (get fnode :op)) (keyword? (get fnode :val))))
(defn get-callee?
"True if fnode is the clojure.core/get (or host get) callee — the (get m k) form."
[fnode]
(or (and (= :var (get fnode :op)) (= "clojure.core" (get fnode :ns)) (= "get" (get fnode :name)))
(and (= :host (get fnode :op)) (= "get" (get fnode :name)))))

11
jolt-core/jolt/passes/inline.clj
View file

@ -5,7 +5,7 @@
and the `dirty` fixpoint flag. Portable Clojure (compiler-tier)."
(:require [jolt.host :refer [inline-ir]]
[jolt.ir :refer [map-ir-children reduce-ir-children coerce-node]]
[jolt.passes.fold :refer [scalar-const?]]))
[jolt.passes.fold :refer [scalar-const? kw-callee? get-callee?]]))
;; ---------------------------------------------------------------------------
;; Shared state: a dirty flag the fixpoint loop reads, and a fresh-name counter
@ -229,7 +229,7 @@
(defn- pure-fn? [f]
(let [op (get f :op)]
(cond
(and (= op :const) (keyword? (get f :val))) true
(kw-callee? f) true
(= op :var) (and (= "clojure.core" (get f :ns)) (contains? pure-fns (get f :name)))
(= op :host) (contains? pure-fns (get f :name))
:else false)))
@ -282,13 +282,12 @@
(if (= :invoke (get node :op))
(let [f (get node :fn) args (get node :args)]
(cond
(and (= :const (get f :op)) (keyword? (get f :val))
(and (kw-callee? f)
(= 1 (count args))
(= :local (get (nth args 0) :op)) (= nm (get (nth args 0) :name)))
(get f :val)
(and (or (and (= :var (get f :op)) (= "clojure.core" (get f :ns)) (= "get" (get f :name)))
(and (= :host (get f :op)) (= "get" (get f :name))))
(and (get-callee? f)
(= 2 (count args))
(= :local (get (nth args 0) :op)) (= nm (get (nth args 0) :name))
(scalar-const? (nth args 1)))
@ -500,7 +499,7 @@
lookup folds only for a declared field."
[node]
(let [f (get node :fn) args (get node :args)]
(if (and (= :const (get f :op)) (keyword? (get f :val)) (= 1 (count args)))
(if (and (kw-callee? f) (= 1 (count args)))
(let [m (nth args 0) k (get f :val)]
(if (and (= :map (get m :op)) (const-key-map? m) (all-vals-pure? m))
(do (mark!) (map-val m k))

10
jolt-core/jolt/passes/numeric.clj
View file

@ -28,6 +28,8 @@
;; result kind of a double-specialized op at this name/arity, or nil if N/A.
;; arithmetic -> :double; comparison -> :bool (operands specialized, result not numeric).
;; Every op name dbl-spec / lng-spec returns non-nil for must have a Chez op in
;; jolt.backend-scheme/dbl-ops resp. lng-ops, or emit-numeric splices a nil op.
(defn- dbl-spec [nm n]
(cond
(and (>= n 1) (contains? #{"+" "-" "*" "/" "min" "max"} nm)) :double
@ -127,7 +129,13 @@
pe (reduce (fn [e p] (assoc e p (get nh p))) tenv (get a :params))]
(if (get a :rest) (assoc pe (get a :rest) nil) pe)))
(defn- an-invoke [node tenv]
(defn- an-invoke
"Annotate an :invoke with its numeric kind. An arithmetic core op specializes to
the Chez fl*/fx* op only when every operand is the same kind (:double or :long),
except an integer literal is :wild — valid in either — so (+ ^double x 2) stays
double. A call to a ^double/^long-returning var yields that kind without lowering
the call (its body already coerces the return)."
[node tenv]
(let [fnode (get node :fn)
nm (when (and (= :var (get fnode :op)) (= "clojure.core" (get fnode :ns)))
(get fnode :name))

394
jolt-core/jolt/passes/types.clj
View file

@ -4,8 +4,10 @@
top = :any) that types expressions and reuses the same walk as a loose success
checker. Also the inter-procedural driver API the back end calls to
propagate param types across a unit / the whole program. Weakly coupled to the
IR-rewriting passes — shares only the const-shape predicate (jolt.passes.fold)."
(:require [jolt.passes.fold :refer [scalar-const?]]
IR-rewriting passes — shares the const-shape predicates (jolt.passes.fold)."
(:require [jolt.passes.fold :refer [scalar-const? kw-callee? get-callee?]]
[jolt.passes.types.check :refer
[not-callable? type-name check-invoke register-user-fn!]]
[jolt.passes.types.lattice :refer
[velem selem sfields vec-type? set-type? struct-type? mk-vec mk-set
mk-struct union-cap scalar-t? union-type? umembers union-of merge-fields
@ -82,8 +84,9 @@
;; result of (rand-nth coll-of-structs) etc. types as the element.
(def ^:private elem-fns #{"rand-nth" "first" "peek" "last" "nth" "fnext" "second"})
;; the checker's emission points, defined after infer but referenced from it
(declare check-invoke check-user-call register-user-fn! not-callable? type-name)
;; defined after infer but referenced from it (the rest of the checker lives in
;; jolt.passes.types.check, required above)
(declare check-user-call)
(defn- var-key [fnode] (str (get fnode :ns) "/" (get fnode :name)))
@ -145,6 +148,12 @@
(declare infer)
;; infer (and infer-fn-seeded) return a [type node'] tuple — the result type plus
;; the rewritten subtree. A bare (nth r 0)/(nth r 1) transposes silently and still
;; type-checks, so name the projections; the call-pattern code below is dense in them.
(defn- ty [r] (nth r 0))
(defn- nd [r] (nth r 1))
;; HOFs that apply their fn arg to the ELEMENTS of a collection. :epos is which
;; param of the fn receives an element. reduce is
;; handled separately (its arity changes the coll position, and its closure
@ -167,11 +176,167 @@
tenv (range (count params)))
pe (if (get a :rest) (assoc pe (get a :rest) :any) pe)
br (infer (get a :body) pe env)]
[(nth br 0) (assoc a :body (nth br 1))]))
[(ty br) (assoc a :body (nd br))]))
(get node :arities))
rets (mapv (fn [r] (nth r 0)) res)
rets (mapv (fn [r] (ty r)) res)
ret (if (empty? rets) :any (reduce join (first rets) (rest rets)))]
[ret (assoc node :arities (mapv (fn [r] (nth r 1)) res))]))
[ret (assoc node :arities (mapv (fn [r] (nd r)) res))]))
;; --- :invoke call patterns ---------------------------------------------------
;; infer's :invoke arm splits the callee/args once, then dispatches by callee
;; shape to one of these. Each returns [type node']; all recurse through `infer`.
(defn- infer-pred-fold
"A type predicate over a single side-effect-free arg whose type PROVES the answer
folds to a boolean constant — eliminating the call, and (once const-fold runs
after inference) collapsing any `if` it gates. Falls back to the normal call path
when the answer isn't provable or the arg is impure."
[node fnode cn args tenv env]
(let [ar (infer (nth args 0) tenv env)
v (pred-on cn (ty ar))]
(if (and (not (nil? v)) (pure-node? (nd ar)))
[:any {:op :const :val v}]
[(call-ret-type fnode env) (assoc node :args [(nd ar)])])))
(defn- infer-kw-lookup
"(:k m) / (:k m default): the result is m's field type, and if m is a struct the
subject is tagged so the back end drops the guard — this types nested access end
to end (RFC 0005)."
[node fnode args n tenv env]
(let [mr (infer (nth args 0) tenv env)
mt (ty mr)
msub (if (struct-safe? mt) (mark-struct (nd mr) mt) (nd mr))
ft (field-type mt (get fnode :val))
dr (when (= n 2) (infer (nth args 1) tenv env))]
[(if dr (join ft (ty dr)) ft)
(assoc node :args (if dr [msub (nd dr)] [msub]))]))
(defn- infer-get-lookup
"(get m :k [default]): the keyword-lookup result type, when the key is a constant
keyword."
[node args n tenv env]
(let [mr (infer (nth args 0) tenv env)
mt (ty mr)
msub (if (struct-safe? mt) (mark-struct (nd mr) mt) (nd mr))
kr (infer (nth args 1) tenv env)
ft (field-type mt (get (nth args 1) :val))
dr (when (= n 3) (infer (nth args 2) tenv env))]
[(if dr (join ft (ty dr)) ft)
(assoc node :args (if dr [msub (nd kr) (nd dr)] [msub (nd kr)]))]))
(defn- infer-reduce-hof
"reduce over a typed vector with a fn-literal: seed the closure's accumulator
(param 0) to the init type and its element (param 1) to the vector's element
type, so its body — and any calls it makes — see those types."
[node args n tenv env]
(let [three (>= n 3)
coll-r (infer (nth args (if three 2 1)) tenv env)
init-r (when three (infer (nth args 1) tenv env))
et (let [ct (ty coll-r)] (if (vec-type? ct) (velem ct) :any))
init-t (if init-r (ty init-r) :any)
fn-r (infer-fn-seeded (nth args 0) {0 init-t 1 et} tenv env)]
[(join init-t (ty fn-r))
(assoc node :args (if three
[(nd fn-r) (nd init-r) (nd coll-r)]
[(nd fn-r) (nd coll-r)]))]))
(defn- infer-seq-hof
"map/mapv/filter/... over a typed vector with a fn-literal: seed the fn's element
param; mapv/filterv produce a typed vector."
[node cn args tenv env]
(let [coll-r (infer (nth args 1) tenv env)
et (let [ct (ty coll-r)] (if (vec-type? ct) (velem ct) :any))
fn-r (infer-fn-seeded (nth args 0) {(get (get hof-table cn) :epos) et} tenv env)
rt (cond (= cn "mapv") (mk-vec (ty fn-r))
(= cn "filterv") (mk-vec et)
:else :any)]
[rt (assoc node :args [(nd fn-r) (nd coll-r)])]))
(defn- infer-conj-into
"conj/into: track the element type of a vector being grown."
[node fnode cn args n tenv env]
(let [ares (mapv (fn [a] (infer a tenv env)) args)
base (ty (nth ares 0))
rest-ts (mapv (fn [r] (ty r)) (rest ares))
rt (cond
(and (= cn "conj") (vec-type? base))
(mk-vec (reduce join (velem base) rest-ts))
(and (= cn "into") (vec-type? base) (= 2 n) (vec-type? (nth rest-ts 0)))
(mk-vec (join (velem base) (velem (nth rest-ts 0))))
:else (call-ret-type fnode env))]
[rt (assoc node :args (mapv (fn [r] (nd r)) ares))]))
(defn- infer-call
"Everything else: type the args, collect the call (var callee) for whole-program
inference, run the success-type check, and use the declared/estimated return type.
range produces a numeric vector; an element-returning fn over a typed vector
yields the element type. A protocol-method call whose receiver (arg 0) is a known
record type is annotated [type-tag proto method] for devirtualization — the back
end looks up the impl at emit time and calls it directly, skipping the registry
dispatch (~19x cheaper)."
[node fnode iscall-var cn args n tenv env]
(let [fr (when (not iscall-var) (infer fnode tenv env))
fnode' (if iscall-var fnode (nd fr))
;; the callee's value type: a var's from vtypes (a fn is :truthy, a def
;; carries its inferred type), else the inferred type of the callee expr
callee-t (if iscall-var (get (get env :vtypes) (var-key fnode)) (ty fr))
ares (mapv (fn [a] (infer a tenv env)) args)]
(when iscall-var
(swap! (get env :calls) conj [(var-key fnode) (mapv (fn [r] (ty r)) ares)]))
;; success-type check at this call, reusing the arg types just computed (jolt
;; audit): core error domains always, user-fn domains in strict mode.
(when (get env :checking?)
(let [ats (mapv (fn [r] (ty r)) ares) pos (get node :pos)]
(when cn (check-invoke cn args ats pos env))
(when (not-callable? callee-t)
(swap! (get env :diags) conj
{:op :call :type (type-name callee-t) :pos pos
:msg (str "cannot call " (type-name callee-t) " as a function")}))
(when (and (get env :strict?) iscall-var)
(let [k (var-key fnode) usig (get @(get env :user-sigs) k)]
(when usig (check-user-call k usig ats pos env))))))
(let [pm (and iscall-var (get (get env :protocol-methods) (var-key fnode)))
rtype (when (and pm (pos? n)) (get (ty (nth ares 0)) :type))
base (assoc node :fn fnode' :args (mapv (fn [r] (nd r)) ares))]
[(cond
(= cn "range") (mk-vec :num)
(and cn (contains? elem-fns cn) (> n 0))
(let [a0 (ty (nth ares 0))] (if (vec-type? a0) (velem a0) :any))
:else (call-ret-type fnode env))
(if rtype
(assoc base :devirt-type rtype :devirt-proto (nth pm 0) :devirt-method (nth pm 1))
base)])))
(defn- infer-invoke
"Split the callee/args once and dispatch by callee shape to a pattern helper."
[node tenv env]
(let [fnode (get node :fn)
iscall-var (= :var (get fnode :op))
cn (when (and iscall-var (= "clojure.core" (get fnode :ns))) (get fnode :name))
args (get node :args)
n (count args)]
(cond
(and iscall-var (contains? fold-preds cn) (= n 1))
(infer-pred-fold node fnode cn args tenv env)
(and (kw-callee? fnode) (>= n 1) (<= n 2))
(infer-kw-lookup node fnode args n tenv env)
(and (get-callee? fnode)
(>= n 2) (= :const (get (nth args 1) :op)) (keyword? (get (nth args 1) :val)))
(infer-get-lookup node args n tenv env)
(and (= cn "reduce") (>= n 2) (= :fn (get (nth args 0) :op)))
(infer-reduce-hof node args n tenv env)
(and cn (get hof-table cn) (>= n 2) (= :fn (get (nth args 0) :op)))
(infer-seq-hof node cn args tenv env)
(and (or (= cn "conj") (= cn "into")) (>= n 1))
(infer-conj-into node fnode cn args n tenv env)
:else
(infer-call node fnode iscall-var cn args n tenv env))))
(defn- infer
"Returns [type node'] — the inferred type of node and node with struct-safe
@ -242,127 +407,7 @@
;; inferred type); unknown -> :any.
(= op :var) (do (swap! (get env :escapes) conj (var-key node))
[(let [vt (get (get env :vtypes) (var-key node))] (if vt vt :any)) node])
(= op :invoke)
(let [fnode (get node :fn)
iscall-var (= :var (get fnode :op))
cn (when (and iscall-var (= "clojure.core" (get fnode :ns))) (get fnode :name))
args (get node :args)
n (count args)]
(cond
;; predicate folding: a type predicate over a single,
;; side-effect-free argument whose type PROVES the answer becomes a
;; boolean constant — eliminating the call, and (once const-fold runs
;; after inference) collapsing any `if` it gates. Falls through to the
;; normal call path when the answer isn't provable or the arg is impure.
(and iscall-var (contains? fold-preds cn) (= n 1))
(let [ar (infer (nth args 0) tenv env)
v (pred-on cn (nth ar 0))]
(if (and (not (nil? v)) (pure-node? (nth ar 1)))
[:any {:op :const :val v}]
[(call-ret-type fnode env) (assoc node :args [(nth ar 1)])]))
;; (:k m) / (:k m default): the result is m's field type, and if m is a
;; struct the subject is tagged so the back end drops the guard — this
;; types nested access end to end (RFC 0005).
(and (= :const (get fnode :op)) (keyword? (get fnode :val)) (>= n 1) (<= n 2))
(let [mr (infer (nth args 0) tenv env)
mt (nth mr 0)
msub (if (struct-safe? mt) (mark-struct (nth mr 1) mt) (nth mr 1))
ft (field-type mt (get fnode :val))
dr (when (= n 2) (infer (nth args 1) tenv env))]
[(if dr (join ft (nth dr 0)) ft)
(assoc node :args (if dr [msub (nth dr 1)] [msub]))])
;; (get m :k [default]): same, when the key is a constant keyword.
(and (or (and (= :var (get fnode :op)) (= "clojure.core" (get fnode :ns)) (= "get" (get fnode :name)))
(and (= :host (get fnode :op)) (= "get" (get fnode :name))))
(>= n 2) (= :const (get (nth args 1) :op)) (keyword? (get (nth args 1) :val)))
(let [mr (infer (nth args 0) tenv env)
mt (nth mr 0)
msub (if (struct-safe? mt) (mark-struct (nth mr 1) mt) (nth mr 1))
kr (infer (nth args 1) tenv env)
ft (field-type mt (get (nth args 1) :val))
dr (when (= n 3) (infer (nth args 2) tenv env))]
[(if dr (join ft (nth dr 0)) ft)
(assoc node :args (if dr [msub (nth kr 1) (nth dr 1)] [msub (nth kr 1)]))])
;; reduce over a typed vector with a fn-literal: seed the
;; closure's accumulator (param 0) to the init type and its element
;; (param 1) to the vector's element type, so its body — and any calls
;; it makes — see those types.
(and (= cn "reduce") (>= n 2) (= :fn (get (nth args 0) :op)))
(let [three (>= n 3)
coll-r (infer (nth args (if three 2 1)) tenv env)
init-r (when three (infer (nth args 1) tenv env))
et (let [ct (nth coll-r 0)] (if (vec-type? ct) (velem ct) :any))
init-t (if init-r (nth init-r 0) :any)
fn-r (infer-fn-seeded (nth args 0) {0 init-t 1 et} tenv env)]
[(join init-t (nth fn-r 0))
(assoc node :args (if three
[(nth fn-r 1) (nth init-r 1) (nth coll-r 1)]
[(nth fn-r 1) (nth coll-r 1)]))])
;; map/mapv/filter/... over a typed vector with a fn-literal: seed the
;; fn's element param; mapv/filterv produce a typed vector.
(and cn (get hof-table cn) (>= n 2) (= :fn (get (nth args 0) :op)))
(let [coll-r (infer (nth args 1) tenv env)
et (let [ct (nth coll-r 0)] (if (vec-type? ct) (velem ct) :any))
fn-r (infer-fn-seeded (nth args 0) {(get (get hof-table cn) :epos) et} tenv env)
rt (cond (= cn "mapv") (mk-vec (nth fn-r 0))
(= cn "filterv") (mk-vec et)
:else :any)]
[rt (assoc node :args [(nth fn-r 1) (nth coll-r 1)])])
;; conj/into: track the element type of a vector being grown.
(and (or (= cn "conj") (= cn "into")) (>= n 1))
(let [ares (mapv (fn [a] (infer a tenv env)) args)
base (nth (nth ares 0) 0)
rest-ts (mapv (fn [r] (nth r 0)) (rest ares))
rt (cond
(and (= cn "conj") (vec-type? base))
(mk-vec (reduce join (velem base) rest-ts))
(and (= cn "into") (vec-type? base) (= 2 n) (vec-type? (nth rest-ts 0)))
(mk-vec (join (velem base) (velem (nth rest-ts 0))))
:else (call-ret-type fnode env))]
[rt (assoc node :args (mapv (fn [r] (nth r 1)) ares))])
;; everything else: type args, collect the call (var callee), use the
;; declared/estimated return type. range produces a numeric vector.
:else
(let [fr (when (not iscall-var) (infer fnode tenv env))
fnode' (if iscall-var fnode (nth fr 1))
;; the callee's value type: a var's from vtypes (a fn is
;; :truthy, a def carries its inferred type), else the inferred
;; type of the callee expression
callee-t (if iscall-var (get (get env :vtypes) (var-key fnode)) (nth fr 0))
ares (mapv (fn [a] (infer a tenv env)) args)]
(when iscall-var
(swap! (get env :calls) conj [(var-key fnode) (mapv (fn [r] (nth r 0)) ares)]))
;; success-type check at this call, reusing the arg types just
;; computed (jolt audit): core error domains always, user-fn domains
;; in strict mode. The arg subtrees are inferred exactly once.
(when (get env :checking?)
(let [ats (mapv (fn [r] (nth r 0)) ares) pos (get node :pos)]
(when cn (check-invoke cn args ats pos env))
;; calling a provably non-function
(when (not-callable? callee-t)
(swap! (get env :diags) conj
{:op :call :type (type-name callee-t) :pos pos
:msg (str "cannot call " (type-name callee-t) " as a function")}))
(when (and (get env :strict?) iscall-var)
(let [k (var-key fnode) usig (get @(get env :user-sigs) k)]
(when usig (check-user-call k usig ats pos env))))))
;; devirtualization: a protocol-method call whose receiver
;; (arg 0) is a known record type resolves to a direct method call.
;; Annotate the node with [type-tag proto method]; the back end looks
;; up the impl at emit time and calls it directly, skipping the
;; registry dispatch (~19x cheaper than protocol-dispatch).
(let [pm (and iscall-var (get (get env :protocol-methods) (var-key fnode)))
rtype (when (and pm (pos? n)) (get (nth (nth ares 0) 0) :type))
base (assoc node :fn fnode' :args (mapv (fn [r] (nth r 1)) ares))]
[(cond
(= cn "range") (mk-vec :num)
;; element-returning fn over a typed vector -> the element type
(and cn (contains? elem-fns cn) (> n 0))
(let [a0 (nth (nth ares 0) 0)] (if (vec-type? a0) (velem a0) :any))
:else (call-ret-type fnode env))
(if rtype
(assoc base :devirt-type rtype :devirt-proto (nth pm 0) :devirt-method (nth pm 1))
base)]))))
(= op :invoke) (infer-invoke node tenv env)
(= op :let)
(let [res (reduce (fn [acc b]
(let [te (nth acc 0) binds (nth acc 1)
@ -421,81 +466,6 @@
;; there are no false positives. The table is curated to genuinely-throwing
;; cases; lenient ops ((get 5 :k) -> nil, (:k 5) -> nil) are NOT listed.
;; concrete non-numbers: arithmetic provably throws on these. A union is in the
;; error domain only when EVERY member is — if any member is an
;; accepted type the call is accepted (no false positive).
(defn- not-number? [t]
(if (union-type? t)
(every? not-number? (umembers t))
(or (= t :str) (= t :kw) (= t :phm)
(struct-type? t) (vec-type? t) (set-type? t))))
;; concrete non-seqable scalars: seq/count/first/nth provably throw on these.
;; (Strings and collections ARE seqable/countable; :truthy is ambiguous; :nil
;; and :any are accepted.) A union throws only when every member does.
(defn- not-seqable? [t]
(if (union-type? t)
(every? not-seqable? (umembers t))
(or (= t :num) (= t :kw))))
;; concrete non-callable values: calling them throws "Cannot call X
;; as a function". Only :num and :str — keywords/maps/vectors/sets are IFn,
;; :truthy/:any/:nil are ambiguous (accepted). A union is non-callable only when
;; every member is.
(defn- not-callable? [t]
(if (union-type? t)
(every? not-callable? (umembers t))
(or (= t :num) (= t :str))))
;; arithmetic / numeric ops: EVERY argument must be a number.
(def ^:private num-ops
#{"+" "-" "*" "/" "inc" "dec" "mod" "rem" "quot" "min" "max" "abs"
"bit-and" "bit-or" "bit-xor" "bit-not" "bit-shift-left" "bit-shift-right"})
;; seq/count/index ops: argument 0 must be seqable/countable.
(def ^:private seq-ops #{"count" "first" "rest" "next" "seq" "nth"})
(defn- type-name
"Render an inferred type for an error message."
[t]
(cond (union-type? t)
(reduce (fn [s m] (if (= s "") (type-name m) (str s " or " (type-name m))))
"" (umembers t))
(struct-type? t) "a map"
(vec-type? t) "a vector"
(set-type? t) "a set"
(= t :str) "a string"
(= t :kw) "a keyword"
(= t :num) "a number"
(= t :phm) "a map"
:else (str t)))
(defn- check-invoke
"If node is a core-op call whose argument type is provably in the error domain,
conj a diagnostic into env's diags cell. arg-types is the vector of inferred
argument types; pos is the call form's source offset, carried into each
diagnostic."
[cn args arg-types pos env]
(cond
(contains? num-ops cn)
(reduce (fn [_ i]
(let [t (nth arg-types i)]
(when (not-number? t)
(swap! (get env :diags) conj
{:op cn :argpos i :type (type-name t) :pos pos
:msg (str "`" cn "` requires a number, but argument "
(inc i) " is " (type-name t))})))
nil)
nil (range (count args)))
(and (contains? seq-ops cn) (> (count args) 0))
(let [t (nth arg-types 0)]
(when (not-seqable? t)
(swap! (get env :diags) conj
{:op cn :argpos 0 :type (type-name t) :pos pos
:msg (str "`" cn "` requires "
(if (= cn "count") "a countable collection" "a seqable")
", but argument 1 is " (type-name t))})))
:else nil))
;; --- user-function error domains, opt-in -------------------------------------
(defn- all-any-env
"tenv binding every param name to :any (the all-ambiguous baseline)."
@ -512,24 +482,6 @@
(infer body tenv sub)
(count @(get sub :diags))))
(defn- register-user-fn!
"Record a (def name (fn [params] body)) — single fixed arity, not redefinable —
for later user-fn call checking. Redefinable/dynamic and multi/variadic fns are
skipped (their body is not a stable requirement)."
[node env]
(let [init (get node :init)
m (get node :meta)
redefable (and m (or (get m :redef) (get m :dynamic)))]
(when (and (not redefable) (= :fn (get init :op)))
(let [arities (get init :arities)]
(when (= 1 (count arities))
(let [ar (first arities)]
(when (not (get ar :rest))
(swap! (get env :user-sigs) assoc
(str (get node :ns) "/" (get node :name))
{:name (get node :name)
:params (get ar :params) :body (get ar :body)}))))))))
(defn- check-user-call
"Strict mode: report a call to a registered user fn that provably throws —
either a WRONG ARITY (the registered fn has one fixed arity, so a different

102
jolt-core/jolt/passes/types/check.clj Normal file
View file

@ -0,0 +1,102 @@
(ns jolt.passes.types.check
"Success-type error domains (RFC 0006): the curated tables of which concrete
types each core op provably throws on, the diagnostic emitter, and the user-fn
signature registry. Pure over inferred types plus the run's `env` cells — no
inference — so the inferencer (jolt.passes.types) and these rules can't perturb
each other. The inferencer calls these during its walk; the infer-coupled user
call probes (re-inference) stay in the inferencer."
(:require [jolt.passes.types.lattice :refer
[union-type? umembers struct-type? vec-type? set-type?]]))
;; concrete non-numbers: arithmetic provably throws on these. A union is in the
;; error domain only when EVERY member is — if any member is an
;; accepted type the call is accepted (no false positive).
(defn- not-number? [t]
(if (union-type? t)
(every? not-number? (umembers t))
(or (= t :str) (= t :kw) (= t :phm)
(struct-type? t) (vec-type? t) (set-type? t))))
;; concrete non-seqable scalars: seq/count/first/nth provably throw on these.
;; (Strings and collections ARE seqable/countable; :truthy is ambiguous; :nil
;; and :any are accepted.) A union throws only when every member does.
(defn- not-seqable? [t]
(if (union-type? t)
(every? not-seqable? (umembers t))
(or (= t :num) (= t :kw))))
;; concrete non-callable values: calling them throws "Cannot call X
;; as a function". Only :num and :str — keywords/maps/vectors/sets are IFn,
;; :truthy/:any/:nil are ambiguous (accepted). A union is non-callable only when
;; every member is.
(defn not-callable? [t]
(if (union-type? t)
(every? not-callable? (umembers t))
(or (= t :num) (= t :str))))
;; arithmetic / numeric ops: EVERY argument must be a number.
(def ^:private num-ops
#{"+" "-" "*" "/" "inc" "dec" "mod" "rem" "quot" "min" "max" "abs"
"bit-and" "bit-or" "bit-xor" "bit-not" "bit-shift-left" "bit-shift-right"})
;; seq/count/index ops: argument 0 must be seqable/countable.
(def ^:private seq-ops #{"count" "first" "rest" "next" "seq" "nth"})
(defn type-name
"Render an inferred type for an error message."
[t]
(cond (union-type? t)
(reduce (fn [s m] (if (= s "") (type-name m) (str s " or " (type-name m))))
"" (umembers t))
(struct-type? t) "a map"
(vec-type? t) "a vector"
(set-type? t) "a set"
(= t :str) "a string"
(= t :kw) "a keyword"
(= t :num) "a number"
(= t :phm) "a map"
:else (str t)))
(defn check-invoke
"If node is a core-op call whose argument type is provably in the error domain,
conj a diagnostic into env's diags cell. arg-types is the vector of inferred
argument types; pos is the call form's source offset, carried into each
diagnostic."
[cn args arg-types pos env]
(cond
(contains? num-ops cn)
(reduce (fn [_ i]
(let [t (nth arg-types i)]
(when (not-number? t)
(swap! (get env :diags) conj
{:op cn :argpos i :type (type-name t) :pos pos
:msg (str "`" cn "` requires a number, but argument "
(inc i) " is " (type-name t))})))
nil)
nil (range (count args)))
(and (contains? seq-ops cn) (> (count args) 0))
(let [t (nth arg-types 0)]
(when (not-seqable? t)
(swap! (get env :diags) conj
{:op cn :argpos 0 :type (type-name t) :pos pos
:msg (str "`" cn "` requires "
(if (= cn "count") "a countable collection" "a seqable")
", but argument 1 is " (type-name t))})))
:else nil))
(defn register-user-fn!
"Record a (def name (fn [params] body)) — single fixed arity, not redefinable —
for later user-fn call checking. Redefinable/dynamic and multi/variadic fns are
skipped (their body is not a stable requirement)."
[node env]
(let [init (get node :init)
m (get node :meta)
redefable (and m (or (get m :redef) (get m :dynamic)))]
(when (and (not redefable) (= :fn (get init :op)))
(let [arities (get init :arities)]
(when (= 1 (count arities))
(let [ar (first arities)]
(when (not (get ar :rest))
(swap! (get env :user-sigs) assoc
(str (get node :ns) "/" (get node :name))
{:name (get node :name)
:params (get ar :params) :body (get ar :body)}))))))))

5
stdlib/clojure/walk.clj
View file

@ -7,6 +7,11 @@
; vectors/maps first so seq? can't swallow them (a vector is not seq? on
; jolt, but keep the concrete branches authoritative)
(vector? form) (outer (vec (map inner form)))
; a record is also map?, but (empty record) yields a plain map — rebuild by
; conj-ing the walked entries back onto the original so the record TYPE
; survives. Type-dispatched walks depend on it (e.g. integrant resolves
; #ig/ref by detecting its Ref record while postwalking the config).
(record? form) (outer (reduce (fn [r x] (conj r (inner x))) form form))
(map? form) (outer (into (empty form) (map inner form)))
; lists rebuild as lists, other seqs (incl. macro/template output: cons/
; concat/lazy-seq) walk too — without this, postwalk-replace silently no-op'd

9
test/chez/build-app/src/app/core.clj
View file

@ -2,10 +2,17 @@
(:require [app.util :as util]
[clojure.java.io :as io]))
;; An aliased cross-ns defmethod: 'util/greet is passed quoted to defmethod-setup,
;; so the AOT build must register the `util` alias for app.core or it resolves to
;; ns "util" and never reaches app.util/greet (the dispatch falls to :default).
(defmethod util/greet :loud [_] "greet:loud")
(defn -main [& args]
;; the resource is baked into the binary (deps.edn :jolt/build :embed), so this
;; resolves with no resources/ dir on disk, run from any cwd.
(println (slurp (io/resource "greeting.txt")))
(util/twice (println (util/shout "hello from a built binary")))
(println "args:" (vec args))
(println "sum:" (reduce + (map count args))))
(println "sum:" (reduce + (map count args)))
(println "greet-default:" (util/greet :unknown))
(println "greet-loud:" (util/greet :loud)))

7
test/chez/build-app/src/app/util.clj
View file

@ -6,3 +6,10 @@
(defmacro twice [x]
`(do ~x ~x))
;; A multimethod with a :default method. The AOT build must set the per-ns
;; current ns before these forms run, or the defmethod registers app.util/greet
;; under the wrong ns and a dispatch to :default crashes (not a fn nil). app.core
;; adds an aliased method (util/greet :loud) — see there.
(defmulti greet (fn [kind] kind))
(defmethod greet :default [_] "greet:default")

5
test/chez/corpus.edn
View file

@ -2640,6 +2640,11 @@
{:suite "clojure.walk / lists + seqs" :label "postwalk-replace in a vector" :expected "[:one 2 :one]" :actual "(do (require (quote [clojure.walk :as w])) (w/postwalk-replace {1 :one} [1 2 1]))"}
{:suite "clojure.walk / lists + seqs" :label "keywordize-keys still works" :expected "{:a 1}" :actual "(do (require (quote [clojure.walk :as w])) (w/keywordize-keys {\"a\" 1}))"}
{:suite "clojure.walk / lists + seqs" :label "apply-template substitutes" :expected "(quote (+ 1 2))" :actual "(do (require (quote [clojure.template :as t])) (t/apply-template (quote [x y]) (quote (+ x y)) (quote (1 2))))"}
{:suite "clojure.walk / records keep their type" :label "postwalk preserves record type" :expected "true" :actual "(do (require (quote [clojure.walk :as w])) (defrecord R [a]) (record? (w/postwalk identity (->R 1))))"}
{:suite "clojure.walk / records keep their type" :label "postwalk still walks record fields" :expected "2" :actual "(do (require (quote [clojure.walk :as w])) (defrecord R [a]) (:a (w/postwalk (fn [x] (if (number? x) (inc x) x)) (->R 1))))"}
{:suite "clojure.walk / records keep their type" :label "instance? survives a walk" :expected "true" :actual "(do (require (quote [clojure.walk :as w])) (defrecord R [a]) (instance? R (w/postwalk identity (->R 1))))"}
{:suite "clojure.walk / records keep their type" :label "a record nested in a map keeps its type" :expected "true" :actual "(do (require (quote [clojure.walk :as w])) (defrecord R [a]) (record? (:r (w/postwalk identity {:r (->R 1)}))))"}
{:suite "clojure.walk / records keep their type" :label "prewalk preserves record type" :expected "true" :actual "(do (require (quote [clojure.walk :as w])) (defrecord R [a]) (record? (w/prewalk identity (->R 1))))"}
{:suite "conformance / CRITICAL: lazy sequences" :label "self-ref lazy-cat fib" :expected "[0 1 1 2 3 5 8 13 21 34]" :actual "(do (def fib-seq (lazy-cat [0 1] (map + (rest fib-seq) fib-seq))) (take 10 fib-seq))"}
{:suite "conformance / CRITICAL: multi-collection map" :label "map two colls" :expected "[11 22 33]" :actual "(map + [1 2 3] [10 20 30])"}
{:suite "conformance / CRITICAL: multi-collection map" :label "map three colls" :expected "[12 24 36]" :actual "(map + [1 2 3] [10 20 30] [1 2 3])"}

12
test/chez/directlink-test.ss
View file

@ -44,6 +44,8 @@
(jolt-compile-eval "(def hof (fn* ([] a)))" "app")
(jolt-compile-eval "(def ^:dynamic d 5)" "app")
(jolt-compile-eval "(def usesd (fn* ([] (d))))" "app")
(jolt-compile-eval "(def cfg {:a 1 :b 2})" "app")
(jolt-compile-eval "(def usecfg (fn* ([] (cfg :a))))" "app")
;; --- direct-link OFF: every reference stays indirect (var-deref) ---
(let ((eb (emit-form "app" "(def b (fn* ([] (a))))")))
@ -72,6 +74,16 @@
(ok "on: a used as a value references the binding directly" (contains? eh " jv$app$a)"))
(ok "on: value-ref to a is NOT var-deref'd" (not (contains? eh "(var-deref \"app\" \"a\")"))))
;; A map-valued (non-fn) def is invokable in Clojure but is NOT a Scheme procedure;
;; a direct-link call to it must route through jolt-invoke, never raw-apply the
;; binding (which crashed with "attempt to apply non-procedure" before the fix).
(let ((ec (emit-form "app" "(def cfg {:a 1 :b 2})"))) ; registers app/cfg (non-fn) in the set
(ok "on: a non-fn def still gets a jv$ binding" (contains? ec "(define jv$app$cfg ")))
(let ((eu (emit-form "app" "(def usecfg (fn* ([] (cfg :a))))")))
(ok "on: call to a map-valued def routes through jolt-invoke" (contains? eu "(jolt-invoke"))
(ok "on: call to a map-valued def still uses the direct binding" (contains? eu "jv$app$cfg"))
(ok "on: a map-valued def is NOT raw-applied as a procedure" (not (contains? eu "(jv$app$cfg"))))
;; ^:dynamic opts out: no jv$ binding, callers stay indirect.
(let ((ed (emit-form "app" "(def ^:dynamic d 5)")))
(ok "on: ^:dynamic def gets no jv$ binding" (not (contains? ed "(define jv$app$d"))))