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

Compiler research (#10)

Browse source 
adds self-hosted compiler is functionally:
 
- The default compile path is the portable pipeline using jolt.analyzer (Clojure) → host-neutral IR → backend.janet.
- The analyzer is itself Clojure, compiled by jolt for true self-hosting.
- bootstrap-fixpoint passes (stage1 == stage2 == stage3): rebuilding the compiler on its own output.
- clojure.core is now self-hosted in the overlay.
- Stateful forms (defmacro/ns/deftype/defmulti/require/in-ns) are interpreted by design.
This commit is contained in:
Dmitri Sotnikov 2026-06-09 07:30:25 +08:00 • committed by GitHub
parent 607779866e
commit d3194aae59
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
68 changed files with 6590 additions and 2019 deletions
Download patch file Download diff file Expand all files Collapse all files

47
src/jolt/aot.janet Normal file
View file

@ -0,0 +1,47 @@
# Ahead-of-time images for compiled namespaces.
#
# Compile-by-default turns each form into Janet bytecode at load time. AOT skips
# that work on subsequent runs by serializing a namespace's compiled vars to a
# bytecode image and loading them back.
#
# The trick is the marshal dictionary. A compiled jolt function closes over core
# fns (core-map, +, …) and var cells; those core fns are Janet cfunctions/closures
# that can't be marshaled by value. But the runtime env that holds them is baked
# into the binary and is byte-for-byte identical at save and load time, so we
# marshal *against* it: core fns are referenced by name, and only the user's
# bytecode plus its var cells are actually serialized.
(use ./compiler) # jolt-runtime-env
(use ./types)
# Forward dict (key -> value) for unmarshal; reverse (value -> key) for marshal.
# Built from the runtime env, which chains to the Janet boot env, so both core fns
# and Janet builtins resolve by name.
(defn- fwd-dict [] (env-lookup jolt-runtime-env))
(defn- rev-dict [] (invert (env-lookup jolt-runtime-env)))
(defn marshal-ns
"Marshal namespace `ns-name`'s var mappings to a byte buffer. The whole mappings
table is marshaled in one call so var cells shared between defs stay shared."
[ctx ns-name]
(marshal ((ctx-find-ns ctx ns-name) :mappings) (rev-dict)))
(defn unmarshal-ns!
"Install mappings produced by marshal-ns into `ns-name` in ctx, overwriting
same-named vars. Returns ns-name."
[ctx ns-name bytes]
(let [mappings (unmarshal bytes (fwd-dict))
ns (ctx-find-ns ctx ns-name)]
(each [sym v] (pairs mappings) (put (ns :mappings) sym v))
ns-name))
(defn save-ns
"Write an AOT image of compiled namespace `ns-name` to `path`."
[ctx ns-name path]
(spit path (marshal-ns ctx ns-name)))
(defn load-ns-image
"Read an AOT image written by save-ns back into ctx under `ns-name`. Skips
parse/analyze/emit/compile entirely — the bytecode is already built."
[ctx ns-name path]
(unmarshal-ns! ctx ns-name (slurp path)))

105
src/jolt/api.janet
View file

@ -10,7 +10,18 @@
(use ./compiler)
(use ./loader)
(use ./async)
(import ./backend :as backend)
(import ./stdlib_embed :as stdlib-embed)
(import ./host_iface :as host)
# A defmacro expander compiles to a native fn (built as (fn* args body...) and run
# through the self-hosted pipeline) so macro expansion is compiled, zero runtime
# cost — instead of an interpreted closure. Returns nil (interpreted fallback) when
# the analyzer isn't built yet or the body isn't compilable.
(set macro-compile-hook
(fn [ctx args-form body]
(backend/try-compile-fn ctx
(array/concat @[{:jolt/type :symbol :ns nil :name "fn*"} args-form] body))))
(defn normalize-pvecs
"Deep-convert any sequential (pvec/tuple/array) to a Janet tuple. Test helper
@ -19,6 +30,9 @@
and lists with the same elements are equal."
[x]
(cond
# lazy-seq: realize to a tuple (map/filter/take now return lazy seqs).
(and (table? x) (= (get x :jolt/type) :jolt/lazy-seq))
(tuple ;(map normalize-pvecs (realize-for-iteration x)))
(pvec? x) (tuple ;(map normalize-pvecs (pv->array x)))
(plist? x) (tuple ;(map normalize-pvecs (pl->array x)))
(tuple? x) (tuple ;(map normalize-pvecs x))
@ -26,12 +40,66 @@
x))
# Ordered clojure.core tiers (embedded jolt-core/clojure/core/NN-*.clj). Each tier
# may reference only the Janet seed + earlier tiers. A :kernel tier holds the
# structural fns the self-hosted compiler itself uses (second/peek/subvec/mapv/
# update); in compile mode it must be bootstrap-compiled into clojure.core BEFORE
# the analyzer is built (the analyzer depends on it), so it bypasses the
# self-hosted pipeline. Non-kernel tiers route through eval-toplevel like any
# source (compiled when :compile?, interpreted otherwise — the analyzer, built
# lazily on the first such form, sees the kernel tier already in place).
(def- core-tiers
[{:ns "clojure.core.00-syntax" :kernel false}
{:ns "clojure.core.00-kernel" :kernel true}
{:ns "clojure.core.10-seq" :kernel false}
{:ns "clojure.core.20-coll" :kernel false}
{:ns "clojure.core.30-macros" :kernel false}])
(defn- eval-overlay-source [ctx src]
(var s src)
(while (> (length (string/trim s)) 0)
(def [form rest] (parse-next s))
(set s rest)
(when (not (nil? form)) (eval-toplevel ctx form))))
(defn- load-core-overlay!
"Load the Clojure portion of clojure.core in dependency-ordered tiers. See
core-tiers and jolt-core/clojure/core/."
[ctx]
(def env (ctx :env))
(def compile? (get env :compile?))
# Core compiles with direct-linking on when :aot-core? (so core->core calls
# are direct). The flag is restored to the user-code default afterward, so
# user/REPL code stays indirect and fully redefinable.
(def user-dl (get env :direct-linking?))
(def core-dl (get env :aot-core?))
(def saved (ctx-current-ns ctx))
(ctx-set-current-ns ctx "clojure.core")
# Gate the analyzer build until the kernel tier loads (see ensure-analyzer):
# present-and-false here means pre-kernel compiles fall back to the interpreter.
(put env :kernel-ready? false)
(each tier core-tiers
(when-let [src (get stdlib-embed/sources (tier :ns))]
(put env :direct-linking? core-dl)
(if (and compile? (tier :kernel))
(backend/bootstrap-load-source ctx "clojure.core" src)
(eval-overlay-source ctx src))
# The self-hosted compiler depends on the kernel tier (second/peek/mapv/...).
# Mark it ready once that tier is in place so the analyzer can be built; a
# pre-kernel tier that triggers a compile (e.g. a defn in 00-syntax) instead
# falls back to the interpreter rather than building the analyzer against a
# half-loaded core (which would forward-ref the missing kernel fns to nil).
(when (tier :kernel) (put env :kernel-ready? true))))
(put env :direct-linking? user-dl)
(ctx-set-current-ns ctx saved))
(defn init
"Create a new Jolt evaluation context.
opts may contain:
:namespaces — map of {ns-name → {sym → value, ...}, ...}
:mutable? — use Janet mutable data structures instead of persistent
:compile? — enable compilation of Clojure forms to Janet
:compile? — compile Clojure forms via the self-hosted pipeline (analyzer ->
IR -> Janet back end), falling back to the interpreter as needed
:paths — extra source roots to search for namespaces (after the stdlib)"
[&opt opts]
(default opts {})
@ -53,34 +121,21 @@
# clojure.core.async (channels + go blocks on Janet fibers); pre-populated
# so (require '[clojure.core.async ...]) finds it and applies :as/:refer.
(install-async! ctx)
# Host contract (ns jolt.host): the seam the portable jolt-core compiler calls.
(host/install! ctx)
# Clojure portion of clojure.core (jolt-core/clojure/core.clj): fns expressed
# in plain Clojure on top of the Janet primitives interned above. Loaded into
# clojure.core and compiled by the self-hosted pipeline (or interpreted when
# :compile? is off). Phase 4 kernel-shrink seam — see that file.
(load-core-overlay! ctx)
ctx))
# Stateful / context-modifying forms always use the interpreter (they mutate
# the context: namespaces, macros, types, multimethods, dynamic vars, …).
(defn- stateful-head? [head-name]
(or (= head-name "defmacro") (= head-name "ns")
(= head-name "deftype") (= head-name "defmulti") (= head-name "defmethod")
(= head-name "require") (= head-name "in-ns")
(= head-name "syntax-quote") (= head-name "set!")
(= head-name "var") (= head-name ".") (= head-name "new")
(= head-name "eval")))
(defn eval-one
"Evaluate a single already-parsed form, routing to the compiler when the
context has :compile? enabled (stateful forms always interpret)."
"Evaluate a single already-parsed form. Routing (compile when :compile? is set,
stateful forms interpret, interpreter fallback for forms the compiler can't
handle) lives in loader/eval-toplevel so load-ns and eval-one stay in sync."
[ctx form]
(if (get (ctx :env) :compile?)
(if (array? form)
(let [first-form (first form)
head-name (if (and (struct? first-form) (= :symbol (first-form :jolt/type)))
(first-form :name) nil)]
(if (stateful-head? head-name)
(eval-form ctx @{} form)
(compile-and-eval form ctx)))
(if (or (and (struct? form) (= :symbol (form :jolt/type))) (tuple? form))
(compile-and-eval form ctx)
(eval-form ctx @{} form)))
(eval-form ctx @{} form)))
(eval-toplevel ctx form))
(defn eval-string
"Evaluate a Clojure source string in a Jolt context.

367
src/jolt/backend.janet Normal file
View file

@ -0,0 +1,367 @@
# Janet back end: host-neutral IR (from jolt.analyzer) -> Janet form -> bytecode.
#
# Host-specific by definition (it targets Janet). It resolves name-based :var
# nodes to Janet var cells and reuses runtime helpers (jolt-call, make-vec,
# build-map-literal). The portable front end (jolt.analyzer) never sees any of
# this; a different runtime provides its own back end against the same IR.
#
# In src/jolt/ (not host/janet/) for the same module-resolution reason as
# host_iface — see that file's header.
(use ./types)
(use ./core)
(import ./compiler :as comp)
(use ./evaluator)
(import ./reader :as r)
(import ./phm :as phm)
# The IR is portable data; reading its representation is a host-layer concern.
# Most nodes are Janet structs (raw-readable), but a node carrying a nil-valued
# field — an anonymous fn's :name, a nil const's :val, a def with no :meta, an
# arity with no :rest — is a phm, whose fields live under :buckets, not as direct
# keys. Densify such a node to a struct: phm-to-struct drops exactly those
# nil-valued fields, which is what the back end wants (it already treats an absent
# field as nil). Structs (the common case) pass through untouched. Applied at the
# few points where a node first reaches the emitter, so the rest of the back end
# keeps using plain (node :key) access and the portable front end never sees this.
(defn- norm-node [n]
(if (phm/phm? n) (phm/phm-to-struct n) n))
# Var late-binding: reads go through `(var-get cell)` with the cell embedded as a
# constant, so compiled code sees redefinition (Janet early-binds plain symbols)
# — var-get reads the cell's root live. Writes go through a memoized setter.
(defn- var-setter [cell]
(or (get cell :jolt/setter)
(let [s (fn [v] (bind-root cell v) cell)] (put cell :jolt/setter s) s)))
# Setter that also applies def metadata to the var (so ^:dynamic / ^:redef /
# ^:private survive compilation, matching the interpreter's def). Not memoized:
# the meta is specific to this def site.
(defn- var-setter-meta [cell meta]
(fn [v]
(bind-root cell v)
(put cell :meta (merge (or (cell :meta) {}) meta))
(when (get meta :dynamic) (put cell :dynamic true))
cell))
(defn- cell-for [ctx ns-name nm]
(ns-intern (ctx-find-ns ctx ns-name) nm))
# Direct-linking decision (call-site/unit property, Clojure-style). A var
# reference compiles to its embedded value (direct) iff:
# - the compiling unit has direct-linking on (env :direct-linking?),
# - the target opts in (NOT ^:redef / ^:dynamic — those force indirect),
# - the target is already defined AND its root is a Janet function.
# The function? guard is essential: embedding a non-function value (a jolt
# collection/symbol) into the emitted form would make Janet evaluate it AS code.
# So we direct-link exactly the call-optimization case; everything else stays
# indirect (live var deref → redefinable). Default user/REPL units: flag off,
# so all user calls are indirect and redefinable with no annotation.
(defn- direct-var? [ctx cell]
(and (get (ctx :env) :direct-linking?)
(not (cell :dynamic))
(not (let [m (cell :meta)] (and m (get m :redef))))
(function? (cell :root))))
# Fresh Janet symbol for back-end-introduced bindings (arity dispatch). NOT
# Janet's `gensym` — `(use ./core)` shadows it with Jolt's, which returns a jolt
# symbol struct (invalid in a Janet param position).
(var- gsym-counter 0)
(defn- gsym [] (def s (symbol "_be$" gsym-counter)) (++ gsym-counter) s)
(var emit nil)
(defn- emit-seq [ctx node]
(def out @['do])
(each s (vview (node :statements)) (array/push out (emit ctx s)))
(array/push out (emit ctx (node :ret)))
(tuple/slice out))
(defn- emit-let [ctx node]
(def binds @[])
(each pair (vview (node :bindings))
(def p (vview pair))
(array/push binds (symbol (in p 0)))
(array/push binds (emit ctx (in p 1))))
['let (tuple/slice binds) (emit ctx (node :body))])
# An arity compiles to a named Janet fn whose name is its recur target, so recur
# is a self-call (Janet tail-calls it). The rest param is an ORDINARY positional
# param holding a seq (not Janet `&`), so `(recur fixed... rest-seq)` re-enters
# the way Clojure recur into a variadic arity does (rebinds the rest seq directly,
# no re-collection). The dispatch wrapper (emit-fn-body) collects the call's args.
(defn- emit-arity-fn [ctx ar]
(def ps @[])
(each pn (vview (ar :params)) (array/push ps (symbol pn)))
(when (ar :rest) (array/push ps (symbol (ar :rest))))
['fn (symbol (ar :recur-name)) (tuple/slice ps) (emit ctx (ar :body))])
# Invoke an arity's fn with args pulled from the dispatch tuple: fixed params by
# index, rest as a slice from n-fixed on.
(defn- emit-arity-invoke [ctx ar jargs]
(def nfixed (length (vview (ar :params))))
(def call @[(emit-arity-fn ctx ar)])
(for i 0 nfixed (array/push call ['in jargs i]))
(when (ar :rest) (array/push call ['tuple/slice jargs nfixed]))
(tuple/slice call))
(defn- emit-loop [ctx node]
(def L (symbol (node :recur-name)))
(def params @[])
(def inits @[])
(each pair (vview (node :bindings))
(def p (vview pair))
(array/push params (symbol (in p 0)))
(array/push inits (emit ctx (in p 1))))
['do
['var L nil]
['set L ['fn (tuple/slice params) (emit ctx (node :body))]]
(tuple/slice (array/concat @[L] inits))])
(defn- emit-recur [ctx node]
(tuple/slice (array/concat @[(symbol (node :recur-name))]
(map |(emit ctx $) (vview (node :args))))))
(defn- emit-try [ctx node]
(def core
(if (node :catch-sym)
['try (emit ctx (node :body))
[[(symbol (node :catch-sym))] (emit ctx (node :catch-body))]]
(emit ctx (node :body))))
(if (node :finally)
['defer (emit ctx (node :finally)) core]
core))
(defn- emit-fn-body [ctx node]
(def arities (map norm-node (vview (node :arities))))
(def multi (> (length arities) 1))
(cond
# Single fixed arity (the hot case): emit the arity fn directly — its name is
# the recur target, no dispatch overhead.
(and (not multi) (not ((first arities) :rest)))
(emit-arity-fn ctx (first arities))
# Single variadic arity: a thin wrapper collects the call's args so the rest
# seq can be built, then hands off to the arity fn.
(not multi)
(let [jargs (gsym)]
['fn ['& jargs] (emit-arity-invoke ctx (first arities) jargs)])
# Multi-arity: dispatch on arg count. Fixed arities match exactly; the (one)
# variadic arity matches >= its fixed count.
(let [jargs (gsym)
nsym (gsym)
cf @['cond]]
(each ar arities
(def nfixed (length (vview (ar :params))))
(array/push cf (if (ar :rest) [>= nsym nfixed] [= nsym nfixed]))
(array/push cf (emit-arity-invoke ctx ar jargs)))
(array/push cf ['error "wrong number of args passed to fn"])
['fn ['& jargs]
['do ['def nsym ['length jargs]] (tuple/slice cf)]])))
# A named fn (fn self [..] .. (self ..)) references itself by name. The analyzer
# binds that name as a local; bind it here to the fn value via a var (set before
# any call, so the captured closure sees it — same scheme as emit-loop). recur
# stays a separate self-call to the arity fn; this only covers by-name self-refs.
(defn- emit-fn [ctx node]
(def body (emit-fn-body ctx node))
(if (node :name)
(let [s (symbol (node :name))]
['do ['var s nil] ['set s body] s])
body))
# A direct Janet call (f args) is only correct when the callee is definitely a
# function: Janet calling a pvec/keyword/etc. does get (or the wrong thing), not
# IFn dispatch. So only emit a direct call for :fn / :host (always functions) and
# a :var whose CURRENT root is a function (the common user/core-fn case). A :var
# holding an IFn COLLECTION (vector/keyword/set used as a fn) or a :local of
# unknown value falls through to jolt-call, which dispatches IFn correctly
# (function fast-path first). Trade-off, like direct-linking: a fn-var redefined
# to a collection after this call was compiled would still emit a direct call.
(defn- direct-call? [ctx fnode]
(case (fnode :op)
:fn true
:host true
:var (let [r (get (cell-for ctx (fnode :ns) (fnode :name)) :root)]
(or (function? r) (cfunction? r)))
false))
# Hot primitives emitted as native Janet ops (host-specific optimization): a
# call to clojure.core/+ etc. becomes (+ …) rather than a var deref + variadic
# core fn. Matches numeric semantics; relaxes the non-number checks (a documented
# perf-mode divergence, same as the bootstrap's core-renames).
(def- native-ops
{"+" '+ "-" '- "*" '* "<" '< ">" '> "<=" '<= ">=" '>= "inc" '++ "dec" '--})
(defn- native-op
"If fnode is a clojure.core ref (or host ref) to a native-op primitive, return
the Janet op symbol, else nil. inc/dec are unary so only at arity 1."
[fnode nargs]
(def nm (case (fnode :op)
:var (when (= "clojure.core" (fnode :ns)) (fnode :name))
:host (fnode :name)
nil))
(def op (and nm (get native-ops nm)))
(cond
(nil? op) nil
(and (or (= op '++) (= op '--)) (not= nargs 1)) nil
op))
(defn- emit-invoke [ctx node]
(def fnode (norm-node (node :fn)))
(def args (map |(emit ctx $) (vview (node :args))))
(def nop (native-op fnode (length args)))
(cond
nop (case nop
'++ ['+ (in args 0) 1]
'-- ['- (in args 0) 1]
(tuple nop ;args))
(direct-call? ctx fnode) (tuple (emit ctx fnode) ;args)
(tuple jolt-call (emit ctx fnode) ;args)))
(defn- emit-vector [ctx node]
(def items (map |(emit ctx $) (vview (node :items))))
(tuple make-vec (tuple/slice (array/concat @['tuple] items))))
(defn- emit-map [ctx node]
(def args @[comp/build-map-literal])
(each pair (vview (node :pairs))
(def p (vview pair))
(array/push args (emit ctx (in p 0)))
(array/push args (emit ctx (in p 1))))
(tuple/slice args))
(set emit
(fn emit [ctx raw]
(def node (norm-node raw))
(case (node :op)
:const (node :val)
:local (symbol (node :name))
:host (symbol (node :name))
:var (let [cell (cell-for ctx (node :ns) (node :name))]
(if (direct-var? ctx cell)
(cell :root) # direct link: embed the fn value
# Indirect: live deref. Quote the cell so it's embedded by
# reference (a bare table in arg position would be re-evaluated as
# a constructor — deep-copying it, and any atom in :root, each call).
(tuple var-get (tuple 'quote cell))))
:if ['if (emit ctx (node :test)) (emit ctx (node :then)) (emit ctx (node :else))]
:do (emit-seq ctx node)
:loop (emit-loop ctx node)
:recur (emit-recur ctx node)
:try (emit-try ctx node)
:throw ['error (emit ctx (node :expr))]
:def (let [cell (cell-for ctx (node :ns) (node :name))
meta (node :meta)]
(tuple (if (and meta (not (empty? meta))) (var-setter-meta cell meta) (var-setter cell))
(emit ctx (node :init))))
:let (emit-let ctx node)
:fn (emit-fn ctx node)
:invoke (emit-invoke ctx node)
:vector (emit-vector ctx node)
:map (emit-map ctx node)
:quote ['quote (node :form)]
(error (string "backend: unhandled op " (node :op))))))
(defn emit-ir
"IR node -> Janet form (public entry for the back end)."
[ctx node]
(emit ctx node))
# --- pipeline wiring (the self-hosted compile path) ---
# Bootstrap-compile a source string into target-ns: each form is compiled via the
# bootstrap (native Janet) compiler and its defs interned in target-ns. This is
# the stage-1 builder — it runs BEFORE the self-hosted analyzer exists, so it's
# how both the compiler namespaces (jolt.ir/jolt.analyzer) and the clojure.core
# kernel tier (the structural fns the analyzer itself calls) get built. The
# analyzer uses unqualified referred names (jolt.host form-* + IR ctors), so the
# bootstrap's plain :var path compiles it; stateful forms fall back to interp.
(defn bootstrap-load-source [ctx target-ns src]
(def saved (ctx-current-ns ctx))
(ctx-set-current-ns ctx target-ns)
(var s src)
(while (> (length (string/trim s)) 0)
(def parsed (r/parse-next s))
(set s (in parsed 1))
(def f (in parsed 0))
(when (not (nil? f))
# Guard BOTH compile and the Janet-compile-of-emitted step: a form whose
# emitted Janet is invalid (e.g. a bad splice) falls back to interpreted
# definition rather than killing the whole load.
(def r (protect (comp/eval-compiled (comp/compile-ast f ctx) ctx)))
(unless (r 0) (eval-form ctx @{} f))))
(ctx-set-current-ns ctx saved))
# Compile-load an embedded jolt-core namespace by name (source from the stdlib map).
(defn- compile-load [ctx ns-name]
(def src (get (get (ctx :env) :embedded-sources @{}) ns-name))
(when src (bootstrap-load-source ctx ns-name src)))
# Build the self-hosted compiler (IR ctors + analyzer) via the bootstrap. The
# analyzer's references to clojure.core fns it uses (second/peek/subvec/mapv/
# update) resolve to whatever is interned in clojure.core at this point — so the
# kernel tier must already be loaded (see api/load-core-overlay!).
(defn- build-compiler! [ctx]
(compile-load ctx "jolt.ir")
(compile-load ctx "jolt.analyzer"))
(defn- ensure-analyzer [ctx]
# Don't build until the kernel tier is loaded (see api/load-core-overlay! and
# build-compiler!). Before then a compile request — e.g. a defn in a pre-kernel
# tier — must fall back to the interpreter, not build the analyzer against a
# core missing the fns it references (which would intern them as nil cells that
# then shadow the real definitions on the self-rebuild). The flag is absent in
# bare/test contexts that never load core; treat that as ready so those keep
# building the analyzer lazily as before.
(def env (ctx :env))
(def gated (and (has-key? env :kernel-ready?) (not (get env :kernel-ready?))))
(when (and (not gated)
(= 0 (length ((ctx-find-ns ctx "jolt.analyzer") :mappings))))
(build-compiler! ctx)))
(defn rebuild-compiler!
"Recompile the self-hosted compiler (jolt.ir + jolt.analyzer) against the
CURRENT clojure.core. The fractal turn: once a core tier supplies Clojure
definitions the compiler itself uses, rebuilding makes the compiler run on
them. Idempotent; re-interns the compiler namespaces over the existing cells."
[ctx]
(build-compiler! ctx))
(defn analyze-form
"Run the portable Clojure analyzer (jolt.analyzer/analyze) on a reader form,
returning host-neutral IR."
[ctx form]
(ensure-analyzer ctx)
# Capture the real compile ns: the analyzer runs interpreted (defined in
# jolt.analyzer), and the interpreter rebinds current-ns to a fn's defining ns
# while it runs — so h/current-ns must read this instead of ctx-current-ns.
(put (ctx :env) :compile-ns (ctx-current-ns ctx))
(def av (ns-find (ctx-find-ns ctx "jolt.analyzer") "analyze"))
(def r ((var-get av) ctx form))
(put (ctx :env) :compile-ns nil)
r)
(defn compile-and-eval
"Self-hosted compile path: analyze (portable Clojure) -> IR -> Janet -> eval.
Hybrid: only the compile step (analyze+emit) is guarded — a form the analyzer
can't handle throws and falls back to the interpreter; runtime errors in
compiled code propagate (no double-eval, no hidden errors)."
[ctx form]
(def compiled (protect (emit-ir ctx (analyze-form ctx form))))
(if (compiled 0)
(eval (compiled 1) (comp/ctx-janet-env ctx))
(eval-form ctx @{} form)))
(defn analyzer-built? [ctx]
(> (length ((ctx-find-ns ctx "jolt.analyzer") :mappings)) 0))
(defn try-compile-fn
"Compile a fn* form to a native Janet fn via the self-hosted pipeline, or nil if
it can't be compiled (analyzer not yet built, or the body isn't compilable).
Used to compile macro expanders for native-speed expansion."
[ctx fn-form]
(when (analyzer-built? ctx)
(def compiled (protect (emit-ir ctx (analyze-form ctx fn-form))))
(when (compiled 0)
(def r (protect (eval (compiled 1) (comp/ctx-janet-env ctx))))
(when (r 0) (r 1)))))

98
src/jolt/clojure/data.clj Normal file
View file

@ -0,0 +1,98 @@
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
;; Ported from clojure.data (Stuart Halloway). The reference dispatches via the
;; EqualityPartition/Diff protocols extended over host types; Jolt uses a plain
;; equality-partition fn over its own predicates instead — same behaviour, no
;; host-type protocol plumbing.
(ns clojure.data
"Non-core data functions."
(:require [clojure.set :as set]))
(declare diff)
(defn- atom-diff [a b]
(if (= a b) [nil nil a] [a b nil]))
;; Convert an associative-by-numeric-index collection into an equivalent vector,
;; with nil for any missing keys.
(defn- vectorize [m]
(when (seq m)
(reduce
(fn [result [k v]] (assoc result k v))
(vec (repeat (apply max (keys m)) nil))
m)))
(defn- diff-associative-key
"Diff associative things a and b, comparing only the key k."
[a b k]
(let [va (get a k)
vb (get b k)
[a* b* ab] (diff va vb)
in-a (contains? a k)
in-b (contains? b k)
same (and in-a in-b
(or (not (nil? ab))
(and (nil? va) (nil? vb))))]
[(when (and in-a (or (not (nil? a*)) (not same))) {k a*})
(when (and in-b (or (not (nil? b*)) (not same))) {k b*})
(when same {k ab})]))
(defn- diff-associative
"Diff associative things a and b, comparing only keys in ks."
[a b ks]
(reduce
;; mapv (vector result) rather than the reference's (doall (map …)): the diff
;; triples are destructured positionally and a list with a nil middle element
;; mis-binds under jolt destructuring, whereas a vector indexes cleanly.
(fn [diff1 diff2] (mapv merge diff1 diff2))
[nil nil nil]
(mapv (partial diff-associative-key a b) ks)))
(defn- diff-sequential [a b]
(vec (mapv vectorize (diff-associative
(if (vector? a) a (vec a))
(if (vector? b) b (vec b))
(range (max (count a) (count b)))))))
(defn- diff-set [a b]
[(not-empty (set/difference a b))
(not-empty (set/difference b a))
(not-empty (set/intersection a b))])
(defn- equality-partition [x]
(cond
(nil? x) :atom
(map? x) :map
(set? x) :set
(sequential? x) :sequential
:else :atom))
(defn- diff-similar [a b]
((case (equality-partition a)
:atom atom-diff
:set diff-set
:sequential diff-sequential
:map (fn [a b] (diff-associative a b (set/union (keys a) (keys b)))))
a b))
(defn diff
"Recursively compares a and b, returning a tuple of
[things-only-in-a things-only-in-b things-in-both].
Comparison rules:
* For equal a and b, return [nil nil a].
* Maps are subdiffed where keys match and values differ.
* Sets are never subdiffed.
* All sequential things are treated as associative collections
by their indexes, with results returned as vectors.
* Everything else (including strings!) is treated as
an atom and compared for equality."
[a b]
(if (= a b)
[nil nil a]
(if (= (equality-partition a) (equality-partition b))
(diff-similar a b)
(atom-diff a b))))

42
src/jolt/clojure/edn.clj
View file

@ -1,13 +1,41 @@
; Jolt Standard Library: clojure.edn
; EDN reading and writing (stubs using the Jolt reader).
;; clojure.edn — reading EDN data. Delegates to the Jolt reader via
;; clojure.core/read-string (which parses, never evaluates — safe for EDN), and
;; adds the opts-map arity with :eof plus nil/blank-input handling.
(ns clojure.edn
"Reading EDN data."
(:require [clojure.string :as cstr]))
;; The reader yields set literals as a FORM ({:jolt/type :jolt/set :value [...]})
;; rather than a constructed set, so build the actual values, recursing into
;; maps/vectors/lists. (Lists stay lists — EDN never evaluates them as code.)
(defn- edn->value [x]
(cond
(and (map? x) (= :jolt/set (get x :jolt/type))) (set (map edn->value (get x :value)))
;; Only untagged structs are real maps; symbols/chars/tagged literals are also
;; struct? (=> map?) but carry a :jolt/type and must pass through unchanged.
(and (map? x) (nil? (get x :jolt/type)))
(into {} (map (fn [e] [(edn->value (key e)) (edn->value (val e))]) x))
(vector? x) (mapv edn->value x)
(seq? x) (map edn->value x)
:else x))
;; Private helper, NOT named read-string: an unqualified (read-string …) call
;; dispatches the core read-string SPECIAL FORM (by name, regardless of ns), so
;; the 1-arity can't delegate to the 2-arity through that name.
(defn- read-edn [opts s]
(if (or (nil? s) (cstr/blank? s))
(get opts :eof nil)
(edn->value (clojure.core/read-string s))))
(defn read-string
[s]
(let [ctx ((get (dyn :current-env) (symbol "init")))]
((get (dyn :current-env) (symbol "eval-string")) ctx s)))
"Reads one object from the string s. Returns the :eof option value (default
nil) for nil or blank input. opts is an options map; :eof sets the value
returned at end of input."
([s] (read-edn {} s))
([opts s] (read-edn opts s)))
(defn read
"Reads the next line from reader and parses one EDN object from it."
[reader]
(let [line ((get (dyn :current-env) (symbol "file/read")) reader :line)]
(when line
(read-string line))))
(when line (read-string line))))

7
src/jolt/clojure/set.clj
View file

@ -24,7 +24,12 @@
(defn rename-keys
[map kmap]
(reduce (fn [m [old new]] (if (contains? m old) (assoc m new (get m old) old nil) m)) map kmap))
(reduce (fn [m [old new]]
(if (contains? map old)
(assoc m new (get map old))
m))
(apply dissoc map (keys kmap))
kmap))
(defn map-invert
[m]

265
src/jolt/clojure/zip.clj
View file

@ -1,98 +1,177 @@
; Jolt Standard Library: clojure.zip
; Functional zipper for tree navigation and editing.
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; Ported from clojure.zip (Rich Hickey). A loc is a vector [node path] carrying
;; the zipper fns (:zip/branch? :zip/children :zip/make-node) as metadata. The
;; reference indexes a loc with (loc 0)/(loc 1); Jolt uses (nth loc ...) because a
;; metadata-bearing vector is not currently invocable as a fn (see jolt-vh5).
(ns clojure.zip
"Functional hierarchical zipper, with navigation, editing, and enumeration.")
(defn zipper
"Creates a new zipper structure. branch? is a fn that, given a node, returns
true if it can have children. children returns a seq of a branch node's
children. make-node, given an existing node and a seq of children, returns a
new branch node. root is the root node."
[branch? children make-node root]
(let [z {:l [] :r [] :node root :pnodes [] :ppath nil :changed? false}]
(if (branch? root)
(let [chs (children root)]
(assoc z :l (vec (rest chs)) :node (first chs) :pnodes (conj (:pnodes z) root)))
z)))
(with-meta [root nil]
{:zip/branch? branch? :zip/children children :zip/make-node make-node}))
(defn node [z] (:node z))
(defn branch? [z] (and z (not (nil? (:node z)))))
(defn make-node [z node children]
(let [m (assoc z :node node :changed? true)]
(if children (assoc m :l (vec children)) m)))
(defn path [z] (:pnodes z))
(defn left [z]
(let [ls (:l z)]
(if (and (branch? z) (seq ls))
(assoc z :l (vec (rest ls)) :node (first ls)) nil)))
(defn right [z]
(if (and (branch? z) (seq (:r z)))
(assoc z :l (conj (:l z) (:node z)) :node (first (:r z)) :r (vec (rest (:r z)))) nil))
(defn up [z]
(if (seq (path z))
(let [pn (peek (path z))]
(assoc z :l nil :r (vec (concat (conj (:l z) (:node z)) (:r z))) :node pn :pnodes (pop (path z)))) nil))
(defn down [z]
(when (branch? z)
(let [chs (children z)]
(when (seq chs)
(assoc z :node (first chs) :l [] :r (vec (rest chs)) :pnodes (conj (path z) (:node z)))))))
(defn leftmost [z]
(let [p (up z)] (if p (down p) z)))
(defn rightmost [z]
(let [p (up z)]
(if p
(let [chs (children p)]
(assoc z :node (last chs) :l (vec (butlast chs)) :r [] :pnodes (conj (pop (path z)) (:node p)))) z)))
(defn next [z]
(if (= :end z) z
(or (and (branch? z) (down z))
(right z)
(loop [p z]
(if (up p)
(or (right (up p)) (recur (up p)))
(assoc z :node :end))))))
(defn prev [z]
(if-let [l (left z)]
(loop [l l]
(if-let [d (and (branch? l) (down l))]
(recur (rightmost d)) l)) (up z)))
(defn end? [z] (= :end (:node z)))
(defn remove [z]
(if-let [p (up z)]
(let [chs (children p)
new-chs (remove #{(:node z)} chs)]
(up (make-node p (:node p) new-chs))) (assoc z :node nil)))
(defn replace [z node]
(assoc z :node node :changed? true))
(defn edit [z f & args]
(replace z (apply f (:node z) args)))
(defn insert-left [z item]
(assoc z :l (conj (:l z) item)))
(defn insert-right [z item]
(assoc z :r (into [item] (:r z))))
(defn insert-child [z item]
(assoc z :l (into [item] (:l z))))
(defn append-child [z item]
(assoc z :l (conj (vec (:l z)) item)))
(defn root [z]
(if (seq (path z)) (recur (up z)) (:node z)))
(defn vector-zip [root]
(zipper vector? seq (fn [node children] (vec children)) root))
(defn seq-zip [root]
(defn seq-zip
"Returns a zipper for nested sequences, given a root sequence"
[root]
(zipper seq? identity (fn [node children] (with-meta children (meta node))) root))
(defn vector-zip
"Returns a zipper for nested vectors, given a root vector"
[root]
(zipper vector? seq (fn [node children] (with-meta (vec children) (meta node))) root))
(defn node "Returns the node at loc" [loc] (nth loc 0))
(defn branch? "Returns true if the node at loc is a branch"
[loc] ((:zip/branch? (meta loc)) (node loc)))
(defn children "Returns a seq of the children of node at loc, which must be a branch"
[loc]
(if (branch? loc)
((:zip/children (meta loc)) (node loc))
(throw "called children on a leaf node")))
(defn make-node "Returns a new branch node, given an existing node and new children."
[loc node children] ((:zip/make-node (meta loc)) node children))
(defn path "Returns a seq of nodes leading to this loc" [loc] (:pnodes (nth loc 1)))
(defn lefts "Returns a seq of the left siblings of this loc" [loc] (seq (:l (nth loc 1))))
(defn rights "Returns a seq of the right siblings of this loc" [loc] (:r (nth loc 1)))
(defn down "Returns the loc of the leftmost child of the node at this loc, or nil"
[loc]
(when (branch? loc)
(let [[node path] loc
[c & cnext :as cs] (children loc)]
(when cs
(with-meta [c {:l []
:pnodes (if path (conj (:pnodes path) node) [node])
:ppath path
:r cnext}]
(meta loc))))))
(defn up "Returns the loc of the parent of the node at this loc, or nil if at the top"
[loc]
(let [[node {l :l, ppath :ppath, pnodes :pnodes, r :r, changed? :changed?, :as path}] loc]
(when pnodes
(let [pnode (peek pnodes)]
(with-meta (if changed?
[(make-node loc pnode (concat l (cons node r)))
(and ppath (assoc ppath :changed? true))]
[pnode ppath])
(meta loc))))))
(defn root "Zips all the way up and returns the root node, reflecting any changes."
[loc]
(if (= :end (nth loc 1))
(node loc)
(let [p (up loc)]
(if p (recur p) (node loc)))))
(defn right "Returns the loc of the right sibling of the node at this loc, or nil"
[loc]
(let [[node {l :l, [r & rnext :as rs] :r, :as path}] loc]
(when (and path rs)
(with-meta [r (assoc path :l (conj l node) :r rnext)] (meta loc)))))
(defn rightmost "Returns the loc of the rightmost sibling of the node at this loc, or self"
[loc]
(let [[node {l :l r :r :as path}] loc]
(if (and path r)
(with-meta [(last r) (assoc path :l (apply conj l node (butlast r)) :r nil)] (meta loc))
loc)))
(defn left "Returns the loc of the left sibling of the node at this loc, or nil"
[loc]
(let [[node {l :l r :r :as path}] loc]
(when (and path (seq l))
(with-meta [(peek l) (assoc path :l (pop l) :r (cons node r))] (meta loc)))))
(defn leftmost "Returns the loc of the leftmost sibling of the node at this loc, or self"
[loc]
(let [[node {l :l r :r :as path}] loc]
(if (and path (seq l))
(with-meta [(first l) (assoc path :l [] :r (concat (rest l) [node] r))] (meta loc))
loc)))
(defn insert-left "Inserts the item as the left sibling of the node at this loc, without moving"
[loc item]
(let [[node {l :l :as path}] loc]
(if (nil? path)
(throw "Insert at top")
(with-meta [node (assoc path :l (conj l item) :changed? true)] (meta loc)))))
(defn insert-right "Inserts the item as the right sibling of the node at this loc, without moving"
[loc item]
(let [[node {r :r :as path}] loc]
(if (nil? path)
(throw "Insert at top")
(with-meta [node (assoc path :r (cons item r) :changed? true)] (meta loc)))))
(defn replace "Replaces the node at this loc, without moving"
[loc node]
(let [[_ path] loc]
(with-meta [node (assoc path :changed? true)] (meta loc))))
(defn edit "Replaces the node at this loc with the value of (f node args)"
[loc f & args]
(replace loc (apply f (node loc) args)))
(defn insert-child "Inserts the item as the leftmost child of the node at this loc, without moving"
[loc item]
(replace loc (make-node loc (node loc) (cons item (children loc)))))
(defn append-child "Inserts the item as the rightmost child of the node at this loc, without moving"
[loc item]
(replace loc (make-node loc (node loc) (concat (children loc) [item]))))
(defn next
"Moves to the next loc in the hierarchy, depth-first. At the end, returns a
distinguished loc detectable via end?; if already at the end, stays there."
[loc]
(if (= :end (nth loc 1))
loc
(or
(and (branch? loc) (down loc))
(right loc)
(loop [p loc]
(if (up p)
(or (right (up p)) (recur (up p)))
[(node p) :end])))))
(defn prev
"Moves to the previous loc in the hierarchy, depth-first. At the root, returns nil."
[loc]
(if-let [lloc (left loc)]
(loop [loc lloc]
(if-let [child (and (branch? loc) (down loc))]
(recur (rightmost child))
loc))
(up loc)))
(defn end? "Returns true if loc represents the end of a depth-first walk"
[loc] (= :end (nth loc 1)))
(defn remove
"Removes the node at loc, returning the loc that would have preceded it in a
depth-first walk."
[loc]
(let [[node {l :l, ppath :ppath, pnodes :pnodes, rs :r, :as path}] loc]
(if (nil? path)
(throw "Remove at top")
(if (pos? (count l))
(loop [loc (with-meta [(peek l) (assoc path :l (pop l) :changed? true)] (meta loc))]
(if-let [child (and (branch? loc) (down loc))]
(recur (rightmost child))
loc))
(with-meta [(make-node loc (peek pnodes) rs)
(and ppath (assoc ppath :changed? true))]
(meta loc))))))

537
src/jolt/compiler.janet
View file

@ -91,13 +91,16 @@
"complement" "core-complement"
"constantly" "core-constantly"
"memoize" "core-memoize"
"some" "core-some"
"range" "core-range"
"take" "core-take"
"drop" "core-drop"
"take-while" "core-take-while"
"drop-while" "core-drop-while"
"interpose" "core-interpose"
"nth" "core-nth"
"mapcat" "core-mapcat"
"apply" "core-apply"
"trampoline" "core-trampoline"
"list" "core-list"
"name" "core-name"
"subs" "core-subs"
@ -139,6 +142,42 @@
(= name "defmulti") (= name "defmethod") (= name "locking")
(= name "prefer-method") (= name "remove-method") (= name "remove-all-methods")))
# Forms the compiler can't compile correctly: definitional/stateful special
# forms and macros that mutate the context or build runtime values the emitter
# doesn't model (types, protocols, multimethods, dynamic binding, host interop).
# analyze-form throws uncompilable on these so the enclosing top-level form falls
# back to the interpreter — which handles them — instead of silently miscompiling.
# (Top-level occurrences are usually routed straight to the interpreter by
# loader/stateful-head?; this also covers them nested inside compiled forms.)
(def- uncompilable-heads
(let [t @{}]
# Interpreter special forms the compiler does NOT itself implement (it
# handles quote/do/if/def/fn*/let*/loop*/recur/throw/try). Kept in sync with
# eval-form's special-form match in evaluator.janet.
(each n ["syntax-quote" "unquote" "unquote-splicing" "eval" "read-string"
"macroexpand-1" "defonce" "defmacro" "deftype" "defmulti"
"defmethod" "prefer-method" "remove-method" "remove-all-methods"
"get-method" "methods" "register-method" "protocol-dispatch"
"make-reified" "satisfies?" "instance?" "set!" "var" "var-get"
"var-set" "var?" "in-ns" "ns" "require" "create-ns" "remove-ns"
"find-ns" "all-ns" "the-ns" "find-var" "intern" "resolve"
"ns-resolve" "ns-aliases" "ns-imports" "ns-interns"
"alter-var-root" "alter-meta!" "reset-meta!" "locking" "new"
"disj" "set?"
# Definitional/host macros that mutate context or build runtime
# values the emitter doesn't model.
"defrecord" "defprotocol" "definterface" "reify" "proxy"
"extend-type" "extend-protocol" "extend" "gen-class" "import"
"use" "refer" "monitor-enter" "monitor-exit" "binding" "."
# letfn needs all its fns in scope simultaneously (mutual
# recursion); the sequential let* the compiler would build can't
# express that, so interpret it.
"letfn"]
(put t n true))
t))
(defn- uncompilable-head? [name] (get uncompilable-heads name))
# ============================================================
# Macro resolution
# ============================================================
@ -149,7 +188,12 @@
(let [name (sym-s :name)
ns-sym (sym-s :ns)]
(if ns-sym
(let [target-ns (ctx-find-ns ctx ns-sym)
# Resolve :as aliases (e.g. (t/is …) where t aliases clojure.test) so
# aliased macros are recognized as macros — matching the interpreter's
# resolve-var — rather than miscompiled as a value ref to the macro var.
(let [cur (ctx-find-ns ctx (ctx-current-ns ctx))
aliased (ns-import-lookup cur ns-sym)
target-ns (ctx-find-ns ctx (or aliased ns-sym))
v (ns-find target-ns name)]
(if (and v (var-macro? v)) v))
(let [current-ns-name (ctx-current-ns ctx)
@ -161,100 +205,6 @@
cv (ns-find core-ns name)]
(if (and cv (var-macro? cv)) cv))))))))
# ============================================================
# Core function value lookup
# ============================================================
(def- core-fn-values
(let [t @{}]
(put t "core-+" core-+)
(put t "core-sub" core-sub)
(put t "core-*" core-*)
(put t "core-/" core-/)
(put t "core-inc" core-inc)
(put t "core-dec" core-dec)
(put t "core-=" core-=)
(put t "core-not=" core-not=)
(put t "core-<" core-<)
(put t "core->" core->)
(put t "core-<=" core-<=)
(put t "core->=" core->=)
(put t "core-nil?" core-nil?)
(put t "core-not" core-not)
(put t "core-some?" core-some?)
(put t "core-string?" core-string?)
(put t "core-number?" core-number?)
(put t "core-fn?" core-fn?)
(put t "core-keyword?" core-keyword?)
(put t "core-symbol?" core-symbol?)
(put t "core-vector?" core-vector?)
(put t "core-map?" core-map?)
(put t "core-seq?" core-seq?)
(put t "core-coll?" core-coll?)
(put t "core-true?" core-true?)
(put t "core-false?" core-false?)
(put t "core-identical?" core-identical?)
(put t "core-zero?" core-zero?)
(put t "core-pos?" core-pos?)
(put t "core-neg?" core-neg?)
(put t "core-even?" core-even?)
(put t "core-odd?" core-odd?)
(put t "core-empty?" core-empty?)
(put t "core-every?" core-every?)
(put t "core-first" core-first)
(put t "core-rest" core-rest)
(put t "core-next" core-next)
(put t "core-cons" core-cons)
(put t "core-conj" core-conj)
(put t "core-assoc" core-assoc)
(put t "core-dissoc" core-dissoc)
(put t "core-get" core-get)
(put t "core-get-in" core-get-in)
(put t "core-contains?" core-contains?)
(put t "core-count" core-count)
(put t "core-seq" core-seq)
(put t "core-vec" core-vec)
(put t "core-map" core-map)
(put t "core-filter" core-filter)
(put t "core-remove" core-remove)
(put t "core-reduce" core-reduce)
(put t "core-str" core-str)
(put t "core-prn" core-prn)
(put t "core-println" core-println)
(put t "core-print" core-print)
(put t "core-identity" core-identity)
(put t "core-comp" core-comp)
(put t "core-partial" core-partial)
(put t "core-complement" core-complement)
(put t "core-constantly" core-constantly)
(put t "core-memoize" core-memoize)
(put t "core-range" core-range)
(put t "core-take" core-take)
(put t "core-drop" core-drop)
(put t "core-take-while" core-take-while)
(put t "core-drop-while" core-drop-while)
(put t "core-reverse" core-reverse)
(put t "core-into" core-into)
(put t "core-merge" core-merge)
(put t "core-merge-with" core-merge-with)
(put t "core-keys" core-keys)
(put t "core-vals" core-vals)
(put t "core-zipmap" core-zipmap)
(put t "core-select-keys" core-select-keys)
(put t "core-max" core-max)
(put t "core-min" core-min)
(put t "core-quot" core-quot)
(put t "core-rem" core-rem)
(put t "core-mod" core-mod)
(put t "core-apply" apply)
(put t "core-some" core-some?)
(put t "core-pr-str" core-pr-str)
(put t "core-nth" core-nth)
(put t "core-list" core-list)
(put t "core-name" core-name)
(put t "core-subs" core-subs)
t))
# Loop counter for generating unique loop function names
(var loop-counter 0)
@ -264,6 +214,15 @@
(++ loop-counter)
name))
(defn- make-gensym
"A fresh, collision-proof Janet symbol name for compiler-introduced bindings
(recur targets, arity-dispatch arg vectors). The leading `_jolt$` can't appear
in a Clojure source symbol, so these never shadow user names."
[prefix]
(let [name (string "_jolt$" prefix "_" loop-counter)]
(++ loop-counter)
name))
# ============================================================
# Syntax-quote expansion
# ============================================================
@ -352,6 +311,24 @@
# Analyzer
# ============================================================
(defn- plain-symbol?
"A bare Clojure symbol (not a destructuring pattern). `&` counts — it's the
varargs marker, which the emitter passes straight through to Janet."
[x]
(and (struct? x) (= :symbol (x :jolt/type))))
(defn- uncompilable
"Signal that the compiler can't (yet) handle this form. eval-one catches this
and falls back to the interpreter, which handles every form correctly. Throwing
here — rather than miscompiling — is what makes the hybrid path sound."
[reason]
(error (string "jolt/uncompilable: " reason)))
# fn* analysis is large enough (optional self-name, multi-arity, varargs, recur
# targets) to live in its own helper. Forward-declared so the fn* case in
# analyze-form can call it; defined after analyze-form (which it recurses into).
(var analyze-fn nil)
(defn analyze-form
"Analyze a Clojure form and return an AST node with :op key.
Takes bindings (table) and optional ctx (for macro expansion)."
@ -370,13 +347,35 @@
{:op :local :name name}
(if (and (not (special-form? name)) (get core-renames name))
{:op :core-symbol :name name :janet-name (get core-renames name)}
{:op :symbol :name name}))))
# A global reference. Resolution mirrors the interpreter's resolve-sym
# so compiled and interpreted code agree:
# 1. a jolt var in the current ns (which also holds refers) or
# clojure.core -> deref through the cell, so redefinition is
# visible to compiled callers (Janet early-binds plain symbols);
# 2. otherwise a binding in the runtime/Janet env (resolve-sym's own
# fallback — this is how int?, type, etc. resolve) -> emit it
# directly;
# 3. otherwise a forward reference -> intern a pending cell whose
# getter derefs at call time, once a later def fills it in.
# No ctx -> plain symbol.
(if ctx
(let [cur-ns (ctx-find-ns ctx (ctx-current-ns ctx))
cell (or (ns-find cur-ns name)
(ns-find (ctx-find-ns ctx "clojure.core") name))]
(cond
cell {:op :var :name name :var cell}
(get jolt-runtime-env (symbol name))
{:op :core-symbol :name name :janet-name name}
{:op :var :name name :var (ns-intern cur-ns name)}))
{:op :symbol :name name})))))
(array? form)
(let [first-form (first form)
head-name (if (and (struct? first-form) (= :symbol (first-form :jolt/type)))
(first-form :name)
nil)]
(when (and head-name (uncompilable-head? head-name))
(uncompilable head-name))
# Macro expansion
(if (and ctx head-name
(not (special-form? head-name))
@ -426,54 +425,48 @@
"do" (let [all-statements (array/slice form 1)
n (length all-statements)
analyzed (map |(analyze-form $ bindings ctx) all-statements)]
{:op :do
:statements (array/slice analyzed 0 (- n 1))
:ret (in analyzed (- n 1))})
(if (= n 0)
{:op :const :val nil} # (do) -> nil
{:op :do
:statements (array/slice analyzed 0 (- n 1))
:ret (in analyzed (- n 1))}))
"if" {:op :if
:test (analyze-form (in form 1) bindings ctx)
:then (analyze-form (in form 2) bindings ctx)
:else (if (> (length form) 3)
(analyze-form (in form 3) bindings ctx)
{:op :const :val nil})}
"def" {:op :def
:name (in form 1)
:init (analyze-form (in form 2) bindings ctx)}
"fn*" (let [params (in form 1)
body-bindings (do
(var bb @{})
(loop [[k v] :pairs bindings] (put bb k v))
(each p params
(put bb (if (struct? p) (p :name) p) :jolt/local))
bb)
body-exprs (tuple/slice form 2)
analyzed-body (map |(analyze-form $ body-bindings ctx) body-exprs)
n-body (length analyzed-body)]
{:op :fn :params params
:body (if (> n-body 1)
{:op :do
:statements (array/slice analyzed-body 0 (- n-body 1))
:ret (last analyzed-body)}
(first analyzed-body))})
"def" (let [name-sym (in form 1)
nm (if (struct? name-sym) (name-sym :name) (string name-sym))
# Create/find the var cell first so a recursive init body
# self-references the same cell.
cell (when ctx (ns-intern (ctx-find-ns ctx (ctx-current-ns ctx)) nm))
# (def x) with no init (declare) -> nil.
init-form (if (> (length form) 2) (in form 2) nil)]
{:op :def :name name-sym :var cell
:init (analyze-form init-form bindings ctx)})
"fn*" (analyze-fn form bindings ctx)
"let*" (let [bind-vec (in form 1)
body-exprs (tuple/slice form 2)
# Accumulate scope as we go so a later binding's init can
# reference an earlier binding (sequential let scoping).
acc (do (var bb @{}) (loop [[k v] :pairs bindings] (put bb k v)) bb)
binding-pairs (do
(var pairs @[])
(var i 0)
(let [n (length bind-vec)]
(while (< i n)
(let [sym-s (in bind-vec i)
name (if (struct? sym-s) (sym-s :name) sym-s)
_ (unless (plain-symbol? sym-s)
(uncompilable "destructuring let binding"))
name (sym-s :name)
val-form (if (< (+ i 1) n) (in bind-vec (+ i 1)) nil)
val-ast (if val-form (analyze-form val-form bindings ctx) {:op :const :val nil})]
val-ast (if val-form (analyze-form val-form acc ctx) {:op :const :val nil})]
(array/push pairs {:name name :init val-ast})
(put acc name :jolt/local)
(+= i 2))))
pairs)
body-bindings (do
(var bb @{})
(loop [[k v] :pairs bindings] (put bb k v))
(each bp binding-pairs
(put bb (bp :name) :jolt/local))
bb)
body-bindings acc
analyzed-body (map |(analyze-form $ body-bindings ctx) body-exprs)
n-body (length analyzed-body)]
{:op :let
@ -485,16 +478,20 @@
(first analyzed-body))})
"loop*" (let [bind-vec (in form 1)
loop-name (make-loop-name)
acc (do (var bb @{}) (loop [[k v] :pairs bindings] (put bb k v)) bb)
binding-pairs (do
(var pairs @[])
(var i 0)
(let [n (length bind-vec)]
(while (< i n)
(let [sym-s (in bind-vec i)
name (if (struct? sym-s) (sym-s :name) sym-s)
_ (unless (plain-symbol? sym-s)
(uncompilable "destructuring loop binding"))
name (sym-s :name)
val-form (if (< (+ i 1) n) (in bind-vec (+ i 1)) nil)
val-ast (if val-form (analyze-form val-form bindings ctx) {:op :const :val nil})]
val-ast (if val-form (analyze-form val-form acc ctx) {:op :const :val nil})]
(array/push pairs {:name name :init val-ast})
(put acc name :jolt/local)
(+= i 2))))
pairs)
param-names (map |($ :name) binding-pairs)
@ -534,10 +531,94 @@
{:op :set :items (map |(analyze-form $ bindings ctx) (form :value))}
(= :jolt/char (form :jolt/type))
{:op :const :val form}
{:op :map :form form})
# Tagged literals (#"regex", data readers) need runtime construction the
# compiler doesn't model — interpret them.
(form :jolt/type)
(uncompilable (string "tagged literal " (form :jolt/type)))
# Plain map literal: keys and values are expressions to evaluate.
{:op :map
:pairs (map (fn [k] [(analyze-form k bindings ctx)
(analyze-form (get form k) bindings ctx)])
(keys form))})
{:op :const :val form}))
(defn- parse-fn-params
"Split a param vector into fixed param names and an optional rest name. Only
plain symbols are handled here; destructuring params signal uncompilable so the
whole fn falls back to the interpreter."
[params]
(unless (tuple? params) (uncompilable "fn params not a vector"))
(def fixed @[])
(var rest-name nil)
(var i 0)
(def n (length params))
(while (< i n)
(def p (in params i))
(unless (plain-symbol? p) (uncompilable "destructuring fn params"))
(if (= "&" (p :name))
(do
(++ i)
(when (< i n)
(def r (in params i))
(unless (plain-symbol? r) (uncompilable "destructuring fn rest param"))
(set rest-name (r :name)))
(++ i))
(do (array/push fixed (p :name)) (++ i))))
{:fixed (tuple/slice fixed) :rest rest-name})
(set analyze-fn
(fn analyze-fn [form bindings ctx]
# (fn* name? params-or-clauses...) where a clause is (params body...).
(def named? (plain-symbol? (in form 1)))
(def fn-name (when named? ((in form 1) :name)))
(def idx (if named? 2 1))
(def first-clause (in form idx))
# Single arity: a param vector at idx. Multi arity: each remaining element is
# an (params body...) list.
(def raw-clauses
(cond
(tuple? first-clause) [[first-clause (tuple/slice form (+ idx 1))]]
(array? first-clause) (map |[(in $ 0) (tuple/slice $ 1)] (tuple/slice form idx))
(uncompilable "fn: unexpected param shape")))
(def multi (> (length raw-clauses) 1))
# Public name: the symbol the fn binds to itself. Single-arity fns recur
# straight into this name; multi-arity fns recur into a per-arity inner fn so
# recur stays in its own arity rather than re-dispatching.
(def outer-name (or fn-name (make-gensym "fn")))
(def arities
(map
(fn [clause]
(def pinfo (parse-fn-params (in clause 0)))
(def fixed (pinfo :fixed))
(def rest-name (pinfo :rest))
(def recur-name
(if (and (not multi) (not rest-name)) outer-name (make-gensym "arity")))
(def body-bindings
(do
(var bb @{})
(loop [[k v] :pairs bindings] (put bb k v))
(when fn-name (put bb fn-name :jolt/local))
(each pn fixed (put bb pn :jolt/local))
(when rest-name (put bb rest-name :jolt/local))
(put bb :jolt/current-loop recur-name)
bb))
(def body-exprs (in clause 1))
(def analyzed (map |(analyze-form $ body-bindings ctx) body-exprs))
(def n-body (length analyzed))
{:param-names fixed
:rest-name rest-name
:n-fixed (length fixed)
:recur-name recur-name
:body (cond
(= 0 n-body) {:op :const :val nil}
(= 1 n-body) (first analyzed)
{:op :do
:statements (array/slice analyzed 0 (- n-body 1))
:ret (last analyzed)})})
raw-clauses))
{:op :fn :name outer-name :fn-name fn-name :multi multi :arities arities}))
# ============================================================
# Emitter — AST → Janet source string
# ============================================================
@ -575,16 +656,32 @@
(buffer/push buf "(def ") (buffer/push buf (name-sym :name))
(buffer/push buf " ") (emit-ast init buf) (buffer/push buf ")"))
(defn- emit-fn-str [params body buf]
(buffer/push buf "(fn [")
(defn- emit-arity-str [ar buf]
(buffer/push buf "[")
(var i 0)
(let [n (length params)]
(let [n (length (ar :param-names))]
(while (< i n)
(let [p (in params i)]
(buffer/push buf (if (struct? p) (p :name) (string p))))
(when (< (+ i 1) n) (buffer/push buf " "))
(buffer/push buf (in (ar :param-names) i))
(when (or (< (+ i 1) n) (ar :rest-name)) (buffer/push buf " "))
(++ i)))
(buffer/push buf "] ") (emit-ast body buf) (buffer/push buf ")"))
(when (ar :rest-name)
(buffer/push buf "& ") (buffer/push buf (ar :rest-name)))
(buffer/push buf "] ")
(emit-ast (ar :body) buf))
# Debug/source rendering. Single arity matches the original `(fn [params] body)`
# shape; multi-arity renders each arity as a clause. This path is for inspection
# (compile-string); the data emitter is the one that actually runs.
(defn- emit-fn-str [ast buf]
(def arities (ast :arities))
(if (ast :multi)
(do
(buffer/push buf "(fn")
(each ar arities
(buffer/push buf " (") (emit-arity-str ar buf) (buffer/push buf ")"))
(buffer/push buf ")"))
(do
(buffer/push buf "(fn ") (emit-arity-str (first arities) buf) (buffer/push buf ")"))))
(defn- emit-let-str [binding-pairs body buf]
(buffer/push buf "(let [")
@ -670,7 +767,12 @@
(++ i)))
(buffer/push buf "]"))
(defn- emit-map-str [form buf] (buffer/push buf (string form)))
(defn- emit-map-str [pairs buf]
(buffer/push buf "(build-map-literal")
(each [k v] pairs
(buffer/push buf " ") (emit-ast k buf)
(buffer/push buf " ") (emit-ast v buf))
(buffer/push buf ")"))
(defn- emit-set-str [items buf]
(buffer/push buf "(make-phs")
@ -709,13 +811,14 @@
(match (ast :op)
:const (emit-const-str (ast :val) buf)
:symbol (emit-symbol-str (ast :name) buf)
:var (emit-symbol-str (ast :name) buf)
:local (emit-local-str (ast :name) buf)
:core-symbol (emit-core-symbol-str (ast :janet-name) buf)
:qualified-symbol (emit-qualified-symbol-str (ast :ns) (ast :name) buf)
:do (emit-do-str (ast :statements) (ast :ret) buf)
:if (emit-if-str (ast :test) (ast :then) (ast :else) buf)
:def (emit-def-str (ast :name) (ast :init) buf)
:fn (emit-fn-str (ast :params) (ast :body) buf)
:fn (emit-fn-str ast buf)
:let (emit-let-str (ast :binding-pairs) (ast :body) buf)
:throw (emit-throw-str (ast :val) buf)
:try (emit-try-str (ast :body) (ast :catch-sym) (ast :catch-body) (ast :finally-body) buf)
@ -723,7 +826,7 @@
:recur (emit-recur-str (ast :args) (ast :loop-name) buf)
:invoke (emit-invoke-str (ast :fn) (ast :args) buf)
:vector (emit-vector-str (ast :items) buf)
:map (emit-map-str (ast :form) buf)
:map (emit-map-str (ast :pairs) buf)
:set (emit-set-str (ast :items) buf)
:quote (emit-quote-str (ast :expr) buf)
(buffer/push buf (string "/* unhandled op: " (ast :op) " */")))))
@ -746,8 +849,12 @@
(defn- emit-core-symbol-expr [janet-name]
(if (get native-ops janet-name)
(symbol janet-name)
(or (get core-fn-values janet-name)
(error (string "Core fn not found: " janet-name)))))
# Resolve the core-* function value from the compiler's runtime env (where
# `(use ./core)` bound them all) rather than a hand-maintained table that can
# drift out of sync. A name with no binding falls back to the interpreter.
(let [b (get jolt-runtime-env (symbol janet-name))]
(if b (b :value)
(uncompilable (string "core fn not found: " janet-name))))))
(defn- emit-qualified-symbol-expr [ns name]
(error (string "Cannot eval qualified symbol at compile time: " ns "/" name)))
@ -768,11 +875,62 @@
(defn- emit-def-expr [name-sym init]
['def (symbol (name-sym :name)) (emit-expr init)])
(defn- emit-fn-expr [params body]
(def param-syms @[])
(each p params
(array/push param-syms (symbol (if (struct? p) (p :name) p))))
['fn (tuple/slice (tuple ;param-syms)) (emit-expr body)])
# Var-indirection: a global reference derefs its cell at call time, and a def
# sets the same cell's root and returns it (Clojure's #'var). Janet COPIES table
# constants when compiling but references functions, so we embed memoized
# getter/setter CLOSURES over the cell (by reference) rather than the cell itself.
(defn- var-getter [cell]
(or (get cell :jolt/getter)
(let [g (fn [] (var-get cell))] (put cell :jolt/getter g) g)))
(defn- var-setter [cell]
(or (get cell :jolt/setter)
(let [s (fn [v] (bind-root cell v) cell)] (put cell :jolt/setter s) s)))
(defn- emit-var-expr [cell] (tuple (var-getter cell)))
(defn- emit-def-var-expr [cell init] (tuple (var-setter cell) (emit-expr init)))
# An arity compiles to a named Janet fn whose name is its recur target — a
# recur is just a self-call (Janet tail-calls it). The rest param is an ordinary
# param holding a seq (not Janet `&`), so `(recur fixed... rest-seq)` works the
# way Clojure recur into a variadic arity does.
(defn- emit-arity-fn [ar]
(def ps @[])
(each pn (ar :param-names) (array/push ps (symbol pn)))
(when (ar :rest-name) (array/push ps (symbol (ar :rest-name))))
['fn (symbol (ar :recur-name)) (tuple/slice ps) (emit-expr (ar :body))])
# Invoke an arity's fn with the actual args pulled out of the dispatch vector:
# fixed params by index, rest as a tuple slice.
(defn- emit-arity-invoke [ar jargs]
(def call @[(emit-arity-fn ar)])
(for i 0 (ar :n-fixed) (array/push call ['in jargs i]))
(when (ar :rest-name) (array/push call ['tuple/slice jargs (ar :n-fixed)]))
(tuple/slice call))
(defn- emit-fn-expr [ast]
(def arities (ast :arities))
(cond
# Single fixed arity — the common, hot case. Emit the arity fn directly
# (its name is the public name and the recur target); no dispatch overhead.
(and (not (ast :multi)) (not ((first arities) :rest-name)))
(emit-arity-fn (first arities))
# Single variadic arity: a thin wrapper collects the call's args so the rest
# seq can be built, then hands off to the arity fn.
(not (ast :multi))
(let [jargs (symbol (make-gensym "args"))]
['fn (symbol (ast :name)) ['& jargs] (emit-arity-invoke (first arities) jargs)])
# Multi-arity: dispatch on arg count. Fixed arities match exactly; the (one)
# variadic arity matches >= its fixed count and goes last.
(let [jargs (symbol (make-gensym "args"))
n-sym (symbol (make-gensym "n"))
cond-form @['cond]]
(each ar arities
(if (ar :rest-name)
(array/push cond-form ['>= n-sym (ar :n-fixed)])
(array/push cond-form ['= n-sym (ar :n-fixed)]))
(array/push cond-form (emit-arity-invoke ar jargs)))
(array/push cond-form ['error "Wrong number of args passed to fn"])
['fn (symbol (ast :name)) ['& jargs]
['let [n-sym ['length jargs]] (tuple/slice cond-form)]])))
(defn- emit-let-expr [binding-pairs body]
(def bind-tuple @[])
@ -828,7 +986,7 @@
# only when the head is a keyword/collection literal in call position (an IFn
# that needs runtime lookup), e.g. (:k m) or ({:a 1} :a).
(def direct (case (f-ast :op)
:core-symbol true :symbol true :local true
:core-symbol true :symbol true :var true :local true
:qualified-symbol true :fn true
false))
(def f (emit-expr f-ast))
@ -836,12 +994,40 @@
(each arg args (array/push exprs (emit-expr arg)))
(tuple/slice (tuple ;exprs)))
# A vector literal builds a mode-appropriate jolt vector (pvec when immutable,
# array when mutable) via make-vec — the same constructor the interpreter uses —
# so compiled and interpreted vectors share one representation. (Emitting a bare
# Janet tuple diverged: type-strict ops like rseq reject tuples.)
(defn- emit-vector-expr [items]
(def exprs @['tuple])
(each item items (array/push exprs (emit-expr item)))
(tuple/slice (tuple ;exprs)))
(def t @['tuple])
(each item items (array/push t (emit-expr item)))
[make-vec (tuple/slice t)])
(defn- emit-map-expr [form] form)
# Build a jolt map literal from evaluated alternating k/v args, mirroring the
# interpreter (eval-form's map-literal case): a Janet struct unless a key is a
# collection, in which case a phm so the key compares by value. Embedded as a
# function constant in emitted code (functions marshal by reference).
(defn build-map-literal [& kvs]
# phm (not a Janet struct) when a key is a collection (value-based hashing) or a
# key/value is nil (structs drop nil; phm preserves it, matching Clojure).
(var need-phm false)
(var ki 0)
(while (< ki (length kvs))
(let [kk (in kvs ki) vv (in kvs (+ ki 1))]
(when (or (table? kk) (array? kk) (nil? kk) (nil? vv)) (set need-phm true)))
(+= ki 2))
(if need-phm
(do (var m (make-phm)) (var j 0)
(while (< j (length kvs)) (set m (phm-assoc m (in kvs j) (in kvs (+ j 1)))) (+= j 2))
m)
(struct ;kvs)))
(defn- emit-map-expr [pairs]
(def call @[build-map-literal])
(each [k v] pairs
(array/push call (emit-expr k))
(array/push call (emit-expr v)))
(tuple/slice call))
(defn- emit-set-expr [items]
(tuple/slice (tuple make-phs ;(map emit-expr items))))
@ -854,13 +1040,15 @@
(match (ast :op)
:const (emit-const-expr (ast :val))
:symbol (emit-symbol-expr (ast :name))
:var (emit-var-expr (ast :var))
:local (emit-local-expr (ast :name))
:core-symbol (emit-core-symbol-expr (ast :janet-name))
:qualified-symbol (emit-qualified-symbol-expr (ast :ns) (ast :name))
:do (emit-do-expr (ast :statements) (ast :ret))
:if (emit-if-expr (ast :test) (ast :then) (ast :else))
:def (emit-def-expr (ast :name) (ast :init))
:fn (emit-fn-expr (ast :params) (ast :body))
:def (if (ast :var) (emit-def-var-expr (ast :var) (ast :init))
(emit-def-expr (ast :name) (ast :init)))
:fn (emit-fn-expr ast)
:let (emit-let-expr (ast :binding-pairs) (ast :body))
:throw (emit-throw-expr (ast :val))
:try (emit-try-expr (ast :body) (ast :catch-sym) (ast :catch-body) (ast :finally-body))
@ -868,7 +1056,7 @@
:recur (emit-recur-expr (ast :args) (ast :loop-name))
:invoke (emit-invoke-expr (ast :fn) (ast :args))
:vector (emit-vector-expr (ast :items))
:map (emit-map-expr (ast :form))
:map (emit-map-expr (ast :pairs))
:set (emit-set-expr (ast :items))
:quote (emit-quote-expr (ast :expr))
(error (string "Unhandled op: " (ast :op))))))
@ -893,30 +1081,17 @@
(emit-expr (analyze-form form @{} ctx)))
(defn compile-and-eval
"Compile a Clojure form and evaluate it as Janet, in the context's persistent
Janet env (so compiled def/defn bindings resolve across forms). For def/defn
forms, also interns the result in the Jolt namespace so the interpreter can
resolve it later."
"Compile a Clojure form and evaluate it as Janet. Globals resolve through Jolt
var cells (see analyze-form/:var), so compiled def/defn results are visible to
the interpreter (the cell is the namespace var), recursion self-references the
cell, and redefinition is seen by compiled callers — no separate interning or
named-fn rewrite needed."
[form ctx]
(def env (ctx-janet-env ctx))
(def def-form? (and ctx (array? form) (> (length form) 0)
(struct? (first form)) (= :symbol ((first form) :jolt/type))
(let [h ((first form) :name)] (or (= h "def") (= h "defn") (= h "defn-")))))
(def def-name (when def-form?
(let [name-sym (in form 1)] (if (struct? name-sym) (name-sym :name) name-sym))))
(var compiled (compile-ast form ctx))
# Name the fn after the def so a recursive body self-references lexically
# ((def f (fn [..] (f ..))) -> (def f (fn f [..] (f ..)))); the anonymous form
# can't resolve f at compile time.
(when (and def-name (indexed? compiled) (= 3 (length compiled))
(= 'def (in compiled 0))
(indexed? (in compiled 2)) (= 'fn (in (in compiled 2) 0))
(indexed? (in (in compiled 2) 1))) # 3rd elem is (fn [params] ...)
(let [f (in compiled 2)]
(set compiled [(in compiled 0) (in compiled 1)
[(in f 0) (symbol def-name) ;(tuple/slice f 1)]])))
(def result (eval compiled env))
# Also intern def/defn results in the Jolt namespace for interpreter resolution.
(when def-name
(ns-intern (ctx-find-ns ctx (ctx-current-ns ctx)) def-name result))
result)
(eval (compile-ast form ctx) (ctx-janet-env ctx)))
(defn eval-compiled
"Evaluate an already-compiled Janet form (the result of compile-ast) in the
context's compiled env. Split out from compile-and-eval so callers can guard
the compile step alone — see eval-one's hybrid fallback."
[compiled ctx]
(eval compiled (ctx-janet-env ctx)))

2011
src/jolt/core.janet
View file

File diff suppressed because it is too large Load diff

324
src/jolt/evaluator.janet
View file

@ -34,6 +34,30 @@
(var eval-form nil)
# Macro expansion cache (interpreter): a macro CALL form expands ONCE and the
# result is reused — macroexpansion is a compile-time step with zero runtime cost,
# the proper Lisp model. Keyed by the call form's identity (a fn body re-evaluates
# the same form arrays each call). Also gives compile-once gensym semantics (a
# foo# auto-gensym is fixed across calls, unlike per-call re-expansion). Cleared
# when a macro is (re)defined so stale expansions don't linger.
(def macro-cache @{})
# Compile hook for macro expanders: set by the api to (fn [ctx args-form body] ->
# compiled-janet-fn | nil). When set and the body is compilable (no &env/&form,
# analyzer available), defmacro uses the compiled expander instead of the
# interpreted closure — macro expansion at native speed, zero runtime cost.
(var macro-compile-hook nil)
(defn- form-uses-sym? [form nm]
(cond
(and (struct? form) (= :symbol (form :jolt/type))) (= nm (form :name))
(or (array? form) (tuple? form))
(do (var found false) (each x form (when (form-uses-sym? x nm) (set found true) (break))) found)
(and (struct? form) (nil? (form :jolt/type)))
(do (var found false) (each k (keys form)
(when (or (form-uses-sym? k nm) (form-uses-sym? (get form k) nm)) (set found true) (break))) found)
false))
# A transient is a tagged mutable table @{:jolt/type :jolt/transient :kind ...}.
(defn- jolt-transient? [x]
(and (table? x) (= :jolt/transient (get x :jolt/type))))
@ -128,6 +152,25 @@
{:jolt/type :symbol :ns (ctx-current-ns ctx) :name nm}))
form))
(defn- d-realize
"Realize a lazy-seq to an array for positional destructuring / splicing; pass
others (pvec/plist coerced to array, everything else unchanged)."
[val]
(if (pvec? val) (pv->array val)
(if (plist? val) (pl->array val)
(if (lazy-seq? val)
(do
(var items @[]) (var cur val) (var go true)
(while go
(let [cell (realize-ls cur)]
(if (or (nil? cell) (= :jolt/pending cell) (= 0 (length cell)))
(set go false)
(do (array/push items (in cell 0))
(let [rt (in cell 1)]
(if (nil? rt) (set go false) (set cur (make-lazy-seq rt))))))))
items)
val))))
(defn- syntax-quote*
[ctx bindings form &opt gsmap]
(default gsmap @{})
@ -145,7 +188,7 @@
(let [item (in form i)]
(if (and (array? item) (> (length item) 0) (sym-name? (first item) "unquote-splicing"))
(let [sv (eval-form ctx bindings (in item 1))]
(each v (if (pvec? sv) (pv->array sv) sv) (array/push result v)))
(each v (d-realize sv) (array/push result v)))
(array/push result (syntax-quote* ctx bindings item gsmap))))
(++ i)) (tuple ;result))
(array? form)
@ -153,7 +196,7 @@
(let [item (in form i)]
(if (and (array? item) (> (length item) 0) (sym-name? (first item) "unquote-splicing"))
(let [sv (eval-form ctx bindings (in item 1))]
(each v (if (pvec? sv) (pv->array sv) sv) (array/push result v)))
(each v (d-realize sv) (array/push result v)))
(array/push result (syntax-quote* ctx bindings item gsmap))))
(++ i)) result)
(and (struct? form) (get form :jolt/type)) form
@ -163,6 +206,49 @@
(array/push kvs (syntax-quote* ctx bindings (get form k) gsmap))) (struct ;kvs))
form))
# Syntax-quote LOWERING: instead of evaluating a `(...) form to a value (what
# syntax-quote* does), produce equivalent CONSTRUCTION CODE so a backtick body is
# plain compilable code (read -> macroexpand -> compile, zero runtime cost).
# Mirrors syntax-quote*/sq-symbol exactly; the canonical algorithm is
# tools.reader's syntax-quote*/expand-list. List forms build via __sqcat (-> array),
# vectors via __sqvec (-> tuple), maps via __sqmap; symbols become (quote resolved);
# ~ leaves the expr in place, ~@ passes the seq straight to __sqcat for splicing.
(defn- sqsym* [nm] {:jolt/type :symbol :ns nil :name nm})
(var syntax-quote-lower nil)
(defn- sq-lower-part [ctx item gsmap]
(if (and (array? item) (> (length item) 0) (sym-name? (first item) "unquote-splicing"))
(in item 1)
@[(sqsym* "__sq1") (syntax-quote-lower ctx item gsmap)]))
(set syntax-quote-lower
(fn syntax-quote-lower [ctx form &opt gsmap]
(default gsmap @{})
(cond
(and (array? form) (> (length form) 0) (sym-name? (first form) "unquote"))
(in form 1)
(and (array? form) (> (length form) 0) (sym-name? (first form) "unquote-splicing"))
(error "~@ used outside of a list or vector in syntax-quote")
(or (number? form) (string? form) (keyword? form) (nil? form) (= true form) (= false form))
form
(and (struct? form) (= :symbol (form :jolt/type)))
@[(sqsym* "quote") (sq-symbol ctx form gsmap)]
(array? form)
(array/concat @[(sqsym* "__sqcat")] (map (fn [it] (sq-lower-part ctx it gsmap)) form))
(tuple? form)
(array/concat @[(sqsym* "__sqvec")] (map (fn [it] (sq-lower-part ctx it gsmap)) form))
# tagged structs (sets/chars): syntax-quote* returns them as-is (no recursion)
(and (struct? form) (get form :jolt/type))
@[(sqsym* "quote") form]
(struct? form)
(do (var parts @[(sqsym* "__sqmap")])
(each k (keys form)
(array/push parts (syntax-quote-lower ctx k gsmap))
(array/push parts (syntax-quote-lower ctx (get form k) gsmap)))
parts)
@[(sqsym* "quote") form])))
(defn resolve-var
[ctx bindings sym-s]
(let [name (sym-s :name) ns (sym-s :ns)]
@ -430,24 +516,6 @@
(do (array/push fixed a) (+= i 1)))))
{:fixed (tuple/slice (tuple ;fixed)) :rest rest-pat})
(defn- d-realize
"Realize a lazy-seq to an array for positional destructuring; pass others through."
[val]
(if (pvec? val) (pv->array val)
(if (plist? val) (pl->array val)
(if (lazy-seq? val)
(do
(var items @[]) (var cur val) (var go true)
(while go
(let [cell (realize-ls cur)]
(if (or (nil? cell) (= :jolt/pending cell) (= 0 (length cell)))
(set go false)
(do (array/push items (in cell 0))
(let [rt (in cell 1)]
(if (nil? rt) (set go false) (set cur (make-lazy-seq rt))))))))
items)
val))))
(defn- d-get
"Look up key k in a map-like value (phm/struct/table/nil)."
[m k]
@ -482,14 +550,24 @@
(while (< di n)
(let [elem (in pat di)]
(cond
# & rest
(and (struct? elem) (= :symbol (elem :jolt/type)) (= "&" (elem :name)))
(do
# rest binds a seq (jolt list = array), per Clojure semantics
(destructure-bind ctx bindings (in pat (+ di 1))
(if (and seqable? (< vi (length rv)))
(array/slice (if (tuple? rv) (array/slice rv) rv) vi)
@[]))
# & rest
(and (struct? elem) (= :symbol (elem :jolt/type)) (= "&" (elem :name)))
(do
# rest binds a seq (jolt list = array), per Clojure semantics.
# For lazy-seqs, preserve laziness: walk vi steps via ls-rest
# instead of slicing the eagerly-realized array.
(destructure-bind ctx bindings (in pat (+ di 1))
(if (lazy-seq? val)
(do
(var c val) (var i 0)
(while (< i vi)
(let [nxt (ls-rest c)]
(if (nil? nxt) (break)
(do (set c nxt) (++ i)))))
c)
(if (and seqable? (< vi (length rv)))
(array/slice (if (tuple? rv) (array/slice rv) rv) vi)
@[])))
(set di (+ di 2)))
# :as whole
(= elem :as)
@ -611,12 +689,20 @@
(defn- eval-list
[ctx bindings form]
(def first-form (first form))
# Safe name extraction: non-symbol heads (e.g. keywords) fall through to default
# Safe name extraction: non-symbol heads (e.g. keywords) fall through to default.
# A head qualified to a NON-core namespace (e.g. clojure.edn/read-string) must
# resolve to that var, not the like-named clojure.core special form — so only
# unqualified or clojure.core-qualified heads dispatch as special forms.
(def name (if (and (struct? first-form) (= :symbol (first-form :jolt/type)))
(first-form :name)
(let [ns (first-form :ns)]
(if (or (nil? ns) (= ns "clojure.core")) (first-form :name) nil))
nil))
(match name
"quote" (in form 1)
# Interpreter builds the form directly (self-contained, no core dependency).
# The COMPILE path instead lowers syntax-quote to construction code (via
# syntax-quote-lower) so a backtick body is compilable; the two are kept in
# sync and cross-checked by conformance (interpret vs compile modes).
"syntax-quote" (syntax-quote* ctx bindings (in form 1))
"unquote" (error "Unquote not valid outside of syntax-quote")
"unquote-splicing" (error "Unquote-splicing not valid outside of syntax-quote")
@ -686,7 +772,7 @@
fixed-pats (param-info :fixed)
rest-pat (param-info :rest)
defining-ns (ctx-current-ns ctx)]
(def macro-fn (fn [& macro-args]
(def interp-fn (fn [& macro-args]
(var new-bindings @{})
(table/setproto new-bindings bindings)
(put new-bindings "&env" @{}) # implicit &env for macro bodies (table — nil-safe)
@ -706,10 +792,20 @@
(set result (eval-form ctx new-bindings bf)))
(ctx-set-current-ns ctx saved-ns)
result))
# Prefer a COMPILED expander (native-speed expansion, zero runtime
# cost). Skip when the body uses &env/&form (the compiled fn has no
# such params) — those fall back to the interpreted closure.
(def uses-env (or (form-uses-sym? body "&env") (form-uses-sym? body "&form")))
(def compiled-fn
(when (and macro-compile-hook (not uses-env))
(macro-compile-hook ctx args-form body)))
(def macro-fn (or compiled-fn interp-fn))
(let [ns-name (ctx-current-ns ctx)
ns (ctx-find-ns ctx ns-name)]
(def v (ns-intern ns (name-sym :name) macro-fn))
(put v :macro true)
# A (re)defined macro invalidates any cached expansions.
(table/clear macro-cache)
(var-get v)))
"ns" (let [raw-name (in form 1)
name-sym (unwrap-meta-name raw-name)
@ -810,15 +906,20 @@
arities @{}
defining-ns (ctx-current-ns ctx)]
(var self nil)
# The (single) variadic clause is dispatched separately: it handles
# any arg count >= its fixed count. Storing it in `arities` by
# fixed-count would collide with a same-fixed-count fixed clause and
# only match that exact count.
(var variadic-fn nil)
(var variadic-min 0)
(each pair pairs
(let [args-form (in pair 0)
body (tuple/slice pair 1)
param-info (parse-params args-form)
fixed-pats (param-info :fixed)
rest-pat (param-info :rest)
n-fixed (length fixed-pats)]
(put arities n-fixed
(fn [& fn-args]
n-fixed (length fixed-pats)
f (fn [& fn-args]
(var fn-bindings @{})
(table/setproto fn-bindings bindings)
(var i 0)
@ -836,12 +937,16 @@
(each body-form body
(set result (eval-form ctx fn-bindings body-form)))
(ctx-set-current-ns ctx saved-ns)
result))))
result)]
(if rest-pat
(do (set variadic-fn f) (set variadic-min n-fixed))
(put arities n-fixed f))))
(set self (fn [& fn-args]
(let [n (length fn-args)
f (get arities n)]
(if f
(apply f fn-args)
(cond
f (apply f fn-args)
(and variadic-fn (>= n variadic-min)) (apply variadic-fn fn-args)
(error (string "Wrong number of args (" n ") passed to fn"))))))
self)
# Single-arity: (fn* [args] body...)
@ -920,7 +1025,14 @@
(error {:jolt/type :jolt/exception :value val}))
"try" (let [body-form (in form 1)
clauses (tuple/slice form 2)
n (length clauses)]
n (length clauses)
# current-ns is dynamic state. The interpreter rebinds it to a
# fn's defining ns while that fn runs and restores it on normal
# return, but a fn that THROWS unwinds past its own restore — so
# the ns can leak. try is the unwind boundary: restore the ns that
# was current at try entry before running catch/finally, so caught
# code (and the harness's is/thrown?) sees the right namespace.
try-ns (ctx-current-ns ctx)]
(var catch-sym nil)
(var catch-body nil)
(var finally-body nil)
@ -943,6 +1055,7 @@
(try
(eval-form ctx bindings body-form)
([err]
(ctx-set-current-ns ctx try-ns)
(var new-bindings @{})
(table/setproto new-bindings bindings)
# bind the originally-thrown value (unwrap the :jolt/exception
@ -965,6 +1078,7 @@
(run-finally finally-body)
result)
([err]
(ctx-set-current-ns ctx try-ns)
(run-finally finally-body)
(error err)))
(eval-form ctx bindings body-form))))
@ -1051,12 +1165,30 @@
(let [fn (find-protocol-method ctx type-tag proto-name method-name)]
(if fn (apply fn obj rest-args)
(error (string "No method " method-name " in " proto-name " for " type-tag))))
# host value: try candidate host type-tags (Long/String/Object/...)
(let [cands (value-host-tags obj)]
(var found nil)
(each tag cands
(when (nil? found)
(set found (find-protocol-method ctx tag proto-name method-name))))
# host value: try candidate host type-tags (Long/String/Object/...).
# Generation-guarded inline cache: the candidate
# walk (array alloc + up to ~15 registry lookups) is
# the same for every value of a given host class, so
# cache (most-specific-tag, proto, method) -> fn,
# invalidated when the registry generation bumps.
(let [env (ctx :env)
reg-gen (or (get env :type-registry-gen) 0)
pc (let [c (get env :proto-dispatch-cache)]
(if (and c (= (c :gen) reg-gen)) c
(let [n @{:gen reg-gen :map @{}}]
(put env :proto-dispatch-cache n) n)))
cands (value-host-tags obj)
ckey [(first cands) proto-name method-name]
cached (get (pc :map) ckey)
found (if (nil? cached)
(let [f (do (var r nil)
(each tag cands
(when (nil? r)
(set r (find-protocol-method ctx tag proto-name method-name))))
r)]
(put (pc :map) ckey (if f f :jolt/none))
f)
(if (= cached :jolt/none) nil cached))]
(if found (apply found obj rest-args)
(error (string "No dispatch for " method-name " on " (type obj))))))))
"register-method" (let [type-sym (in form 1)
@ -1149,27 +1281,38 @@
(+= i 2))) h)
ns (ctx-find-ns ctx (ctx-current-ns ctx))
methods @{}
# Cache for hierarchy-resolved dispatch values: the isa? walk
# over every method key is the expensive path (derive-based
# dispatch). Direct (get methods dv) hits stay uncached (already
# fast). Cleared in place when methods/prefs change (defmethod,
# prefer-method, remove-method, …) so a redef can't be hidden.
dispatch-cache @{}
mm-fn (fn [& args]
(let [dv (apply dispatch-fn args)
method (get methods dv)]
(if method
(apply method args)
# hierarchy-based match (explicit :hierarchy or
# the global hierarchy from derive)
(let [h (or hierarchy the-global-hierarchy)
found (do (var f nil) (var i 0)
(let [ks (keys methods)]
(while (and (nil? f) (< i (length ks)))
(if (isa? h dv (in ks i)) (set f (get methods (in ks i))))
(++ i))) f)]
(if found (apply found args)
# fall back to the method registered under the default key
(let [dm (get methods default-key)]
(if dm (apply dm args)
(error (string "No method in multimethod "
(name-sym :name) " for dispatch value: " dv)))))))))]
(let [cached (get dispatch-cache dv)]
(if cached
(apply cached args)
# hierarchy-based match (explicit :hierarchy or
# the global hierarchy from derive)
(let [h (or hierarchy the-global-hierarchy)
found (do (var f nil) (var i 0)
(let [ks (keys methods)]
(while (and (nil? f) (< i (length ks)))
(if (isa? h dv (in ks i)) (set f (get methods (in ks i))))
(++ i))) f)]
(if found
(do (put dispatch-cache dv found) (apply found args))
# fall back to the method registered under the default key
(let [dm (get methods default-key)]
(if dm (apply dm args)
(error (string "No method in multimethod "
(name-sym :name) " for dispatch value: " dv))))))))))) ]
(def v (ns-intern ns (name-sym :name) mm-fn))
(put v :jolt/methods methods)
(put v :jolt/dispatch-cache dispatch-cache)
(put v :jolt/default default-key)
(when hierarchy (put v :jolt/hierarchy hierarchy))
(var-get v))
@ -1194,6 +1337,8 @@
methods (or (get mm-var :jolt/methods)
(let [m @{}] (put mm-var :jolt/methods m) m))]
(put methods dispatch-val impl)
(let [dc (get mm-var :jolt/dispatch-cache)]
(when dc (each k (keys dc) (put dc k nil))))
mm-var)
"prefer-method" (let [mm-arg (in form 1)
mm-var (if (and (struct? mm-arg) (= :symbol (mm-arg :jolt/type)))
@ -1211,6 +1356,8 @@
prefs (or (get mm-var :jolt/prefers)
(do (put mm-var :jolt/prefers @{}) (mm-var :jolt/prefers)))]
(put prefs dispatch-val-a dispatch-val-b)
(let [dc (get mm-var :jolt/dispatch-cache)]
(when dc (each k (keys dc) (put dc k nil))))
mm-var)
# A multimethod's methods live on its VAR, but the value is the dispatch fn;
# so resolve the var from the symbol rather than evaluating it.
@ -1234,11 +1381,15 @@
dispatch-val (eval-form ctx bindings (in form 2))]
(when mm-var
(let [methods (get mm-var :jolt/methods)]
(when methods (put methods dispatch-val nil))))
(when methods (put methods dispatch-val nil)))
(let [dc (get mm-var :jolt/dispatch-cache)]
(when dc (each k (keys dc) (put dc k nil)))))
mm-var)
"remove-all-methods" (let [mm-var (eval-form ctx bindings (in form 1))]
(if mm-var
(put mm-var :jolt/methods @{}))
(when mm-var
(put mm-var :jolt/methods @{})
(let [dc (get mm-var :jolt/dispatch-cache)]
(when dc (each k (keys dc) (put dc k nil)))))
mm-var)
"deftype" (let [raw-name (in form 1)
type-name (unwrap-meta-name raw-name)
@ -1363,9 +1514,14 @@
(apply ctor args))
(let [v (resolve-var ctx bindings first-form)]
(if (and v (var-macro? v))
(let [macro-fn (var-get v)
args (tuple/slice form 1)]
(eval-form ctx bindings (apply macro-fn args)))
# Expand once (cached by call-form identity), then evaluate the
# macro-free expansion with the current bindings each call.
(let [cached (in macro-cache form)]
(if (not (nil? cached))
(eval-form ctx bindings cached)
(let [expanded (apply (var-get v) (tuple/slice form 1))]
(put macro-cache form expanded)
(eval-form ctx bindings expanded))))
(let [f (eval-form ctx bindings first-form)
args (map |(eval-form ctx bindings $) (tuple/slice form 1))]
(jolt-invoke ctx f args)))))))
@ -1373,6 +1529,24 @@
args (map |(eval-form ctx bindings $) (tuple/slice form 1))]
(jolt-invoke ctx f args)))))
# Build a map value from an array of evaluated [k v k v ...]. A phm (not a Janet
# struct) is used when a key is a collection (value-based hashing) OR a key/value
# is nil (Janet structs drop nil; phm preserves it, matching Clojure). The common
# scalar/nil-free case stays a struct.
(defn- map-needs-phm? [kvs]
(var need false) (var i 0)
(while (< i (length kvs))
(let [k (in kvs i) v (in kvs (+ i 1))]
(when (or (table? k) (array? k) (nil? k) (nil? v)) (set need true) (break)))
(+= i 2))
need)
(defn- build-eval-map [kvs]
(if (map-needs-phm? kvs)
(do (var m (make-phm)) (var j 0)
(while (< j (length kvs)) (set m (phm-assoc m (in kvs j) (in kvs (+ j 1)))) (+= j 2)) m)
(struct ;kvs)))
(set eval-form (fn [ctx bindings form]
(cond
(nil? form) nil
@ -1408,19 +1582,15 @@
(each k (keys form)
(array/push kvs (eval-form ctx bindings k))
(array/push kvs (eval-form ctx bindings (get form k))))
# If any key is a collection (a Janet table/array — phm/pvec/plist/
# record/list), a Janet struct would key it by identity; use a phm so
# such keys compare by value.
(var coll-key false)
(var ki 0)
(while (< ki (length kvs))
(let [kk (in kvs ki)] (when (or (table? kk) (array? kk)) (set coll-key true)))
(+= ki 2))
(if coll-key
(do (var m (make-phm)) (var j 0)
(while (< j (length kvs)) (set m (phm-assoc m (in kvs j) (in kvs (+ j 1)))) (+= j 2))
m)
(struct ;kvs))))))))
(build-eval-map kvs)))))))
# A phm map-literal FORM (reader emits one for {:a nil} etc., which a struct
# would have dropped): evaluate its key/value forms and rebuild, preserving nil.
(phm? form)
(let [kvs @[]]
(each e (phm-entries form)
(array/push kvs (eval-form ctx bindings (in e 0)))
(array/push kvs (eval-form ctx bindings (in e 1))))
(build-eval-map kvs))
(array? form)
(if (= 0 (length form))
@[]

173
src/jolt/host_iface.janet Normal file
View file

@ -0,0 +1,173 @@
# Janet implementation of the Jolt host contract (ns `jolt.host`).
#
# This is the seam between the portable jolt-core (analyzer/IR/core, pure Clojure
# under jolt-core/) and the Janet runtime. jolt-core calls ONLY these functions —
# never Janet directly. Re-hosting Jolt to another runtime means reimplementing
# this contract (+ the back end and RT) for that runtime.
#
# Lives in src/jolt/ (with the rest of the Janet host) rather than a separate
# host/janet/ dir: Janet resolves relative imports per-file, so a host/janet
# module importing ../../src/jolt/* loads SECOND instances of compiler/types/core
# (inconsistent state). The portability boundary is the `jolt.host` namespace
# contract + jolt-core/, not the directory.
#
# Two groups:
# 1. Form introspection — reader forms are host-specific (the reader is the
# host's), so shape predicates/accessors live here. Returns jolt values the
# analyzer walks with ordinary Clojure.
# 2. Compile-time environment — resolve symbols to vars/macros, expand macros,
# the current namespace. These take ctx (an opaque host handle).
(use ./types)
(use ./evaluator)
(use ./core)
(import ./phm :as phm)
# ---------------------------------------------------------------------------
# Form introspection
# ---------------------------------------------------------------------------
(defn h-sym? [form] (and (struct? form) (= :symbol (form :jolt/type))))
(defn h-sym-name [form] (form :name))
(defn h-sym-ns [form] (form :ns))
# Reader metadata on a symbol (e.g. ^:dynamic / ^:redef / ^:private on a def
# name). Returns the meta map or nil. Lets the analyzer carry def metadata that
# the back end applies to the var — without it, compiled defs drop all var meta.
(defn h-sym-meta [form] (form :meta))
(defn h-list? [form] (array? form)) # a call / list (reader: array)
(defn h-vector? [form] (tuple? form)) # a vector literal (reader: tuple)
# A map-literal form is a plain struct, or a phm when the reader preserved a nil
# key/value (Janet structs drop nil). Sets/chars/symbols are tagged structs (have
# :jolt/type); phm carries :jolt/deftype, distinct from those.
(defn h-map? [form]
(or (and (struct? form) (nil? (form :jolt/type)))
(phm/phm? form)))
(defn h-set? [form] (and (struct? form) (= :jolt/set (form :jolt/type))))
(defn h-char? [form] (and (struct? form) (= :jolt/char (form :jolt/type))))
(defn h-literal? [form]
(or (nil? form) (boolean? form) (number? form) (string? form)
(keyword? form) (h-char? form)))
# Items of a list/vector as a jolt vector, so the analyzer walks them with Clojure.
(defn h-elements [form] (make-vec form))
(defn h-vector-items [form] (make-vec form))
(defn h-map-pairs [form]
(if (phm/phm? form)
(make-vec (map (fn [e] (make-vec [(in e 0) (in e 1)])) (phm/phm-entries form)))
(make-vec (map (fn [k] (make-vec [k (get form k)])) (keys form)))))
(defn h-set-items [form] (make-vec (form :value)))
# ---------------------------------------------------------------------------
# Compile-time environment
# ---------------------------------------------------------------------------
# Names the analyzer must NOT treat as a function call: interpreter special forms
# plus definitional/host macros the compiler doesn't lower. The analyzer handles
# a subset (quote/if/do/def/fn*/let*/loop*/recur/throw/try) and falls back to the
# interpreter for the rest. Kept in sync with evaluator/special-symbol? and
# compiler/uncompilable-heads.
(def- special-names
(let [t @{}]
(each n ["quote" "syntax-quote" "unquote" "unquote-splicing" "do" "if" "def"
"defmacro" "fn*" "let*" "loop*" "recur" "throw" "try" "set!" "var"
"locking" "eval" "instance?" "defmulti" "defmethod" "deftype" "new"
"." "var-get" "var-set" "var?" "alter-var-root" "find-var" "intern"
"alter-meta!" "reset-meta!" "disj" "set?" "satisfies?"
"protocol-dispatch" "register-method" "make-reified" "prefer-method"
"remove-method" "remove-all-methods" "get-method" "methods"
# ns-management forms dispatched by the interpreter (not core vars)
"create-ns" "remove-ns" "find-ns" "all-ns" "the-ns" "resolve"
"ns-resolve" "ns-aliases" "ns-imports" "ns-interns"
"read-string" "macroexpand-1" "defonce" "ns" "in-ns" "require"
"import" "use" "refer" "defrecord" "defprotocol" "definterface"
"reify" "proxy" "extend-type" "extend-protocol" "extend" "gen-class"
"monitor-enter" "monitor-exit" "binding" "letfn"]
(put t n true))
t))
# Interop-shaped heads the interpreter lowers but the back end doesn't model:
# (.method obj …) / (.-field obj) — member access (name starts with ".")
# (Foo. …) — constructor (name ends with "." )
# Treated as special so the analyzer marks them uncompilable and falls back.
(defn- interop-head? [name]
(def n (length name))
(and (> n 1)
(or (= (string/slice name 0 1) ".")
(= (string/slice name (- n 1)) "."))))
(defn h-special? [name]
(if (or (get special-names name) (interop-head? name)) true false))
# The namespace being compiled. NOT ctx-current-ns directly: the interpreter
# rebinds current-ns to a fn's defining ns while that fn runs, so an interpreted
# analyzer (defined in jolt.analyzer) would otherwise see jolt.analyzer. The back
# end stashes the real compile ns in :compile-ns before invoking the analyzer.
(defn h-current-ns [ctx] (or (get (ctx :env) :compile-ns) (ctx-current-ns ctx)))
(defn h-macro? [ctx sym]
(let [v (resolve-var ctx @{} sym)]
(if (and v (var-macro? v)) true false)))
(defn h-expand-1 [ctx form]
(let [head (in form 0)
v (resolve-var ctx @{} head)
macro-fn (var-get v)]
(apply macro-fn (tuple/slice form 1))))
# Classify a global (non-local) symbol reference:
# {:kind :var :ns NS :name NAME} — a Jolt var (current ns / clojure.core)
# {:kind :host :name NAME} — resolves only via the host env (+, int?, …),
# same fallback the interpreter's resolve-sym uses
# {:kind :unresolved :name NAME} — not yet defined (forward reference)
(defn h-resolve-global [ctx sym]
(let [v (resolve-var ctx @{} sym)]
(if v
{:kind :var :ns (var-ns v) :name (var-name v)}
(let [nm (sym :name)
entry (in (fiber/getenv (fiber/current)) (symbol nm))]
(if (not (nil? entry))
{:kind :host :name nm}
{:kind :unresolved :name nm})))))
(defn h-intern! [ctx ns-name nm]
(ns-intern (ctx-find-ns ctx ns-name) nm)
nil)
# ---------------------------------------------------------------------------
# Installation: bind these fns as vars in the `jolt.host` namespace so jolt-core
# can call them. Idempotent per context.
# ---------------------------------------------------------------------------
# Form predicates use `form-*` names (not list?/vector?/map?/set?/char?) so the
# analyzer can refer them unqualified without the bootstrap's core-renames
# intercepting them as the value-level predicates.
# Lower a syntax-quote's inner form to construction code (so the analyzer can
# compile it). The portable analyzer calls this and analyzes the result.
(defn h-syntax-quote-lower [ctx inner]
(syntax-quote-lower ctx inner))
# Runtime host primitive: set a key on a mutable reference cell (an atom, the
# watches sub-table, ...). The minimal mutation kernel the overlay can't express
# over core fns — putting nil removes the key (Janet table semantics). Returns the
# table so callers can thread; overlay wrappers return the Clojure-meaningful value.
(defn h-ref-put! [tab key val] (put tab key val) tab)
(def- exports
{"form-sym?" h-sym? "form-sym-name" h-sym-name "form-sym-ns" h-sym-ns
"ref-put!" h-ref-put!
"form-sym-meta" h-sym-meta
"form-list?" h-list? "form-vec?" h-vector? "form-map?" h-map?
"form-set?" h-set? "form-char?" h-char? "form-literal?" h-literal?
"form-elements" h-elements "form-vec-items" h-vector-items
"form-map-pairs" h-map-pairs "form-set-items" h-set-items
"form-special?" h-special? "compile-ns" h-current-ns "form-macro?" h-macro?
"form-expand-1" h-expand-1 "resolve-global" h-resolve-global
"form-syntax-quote-lower" h-syntax-quote-lower
"host-intern!" h-intern!})
(defn install! [ctx]
(def ns (ctx-find-ns ctx "jolt.host"))
(eachp [nm f] exports (ns-intern ns nm f))
ns)

131
src/jolt/loader.janet
View file

@ -3,77 +3,76 @@
# Supports in-memory bytecode caching when :compile? is enabled.
(use ./reader)
(use ./compiler)
(use ./evaluator)
(import ./backend :as backend)
# Stateful / context-modifying forms always interpret: they mutate the context
# (namespaces, macros, types, multimethods, dynamic vars, …) in ways the compiler
# doesn't model. Kept here so the compile/interpret routing lives in one place,
# used by both load-ns and the public eval-one.
(defn- stateful-head? [head-name]
(or (= head-name "defmacro") (= head-name "ns")
(= head-name "deftype") (= head-name "defmulti") (= head-name "defmethod")
(= head-name "require") (= head-name "in-ns")
(= head-name "syntax-quote") (= head-name "set!")
(= head-name "var") (= head-name ".") (= head-name "new")
(= head-name "eval")))
(defn- form-head-name [form]
(when (array? form)
(let [ff (first form)]
(when (and (struct? ff) (= :symbol (ff :jolt/type))) (ff :name)))))
(defn eval-toplevel
"Evaluate one top-level form for ctx, honoring :compile?. Stateful forms always
interpret; otherwise the form runs through the self-hosted compile pipeline
(portable Clojure analyzer -> IR -> Janet back end), which falls back to the
interpreter for forms it can't compile. Only the compile step is guarded —
runtime errors in compiled code propagate (no double-eval, no hidden errors)."
[ctx form]
(defn try-compile [] (backend/compile-and-eval ctx form))
(if (get (ctx :env) :compile?)
(if (array? form)
# A call/list: compile it unless its head is a stateful special form.
(let [hn (form-head-name form)]
(if (and hn (stateful-head? hn))
(eval-form ctx @{} form)
(try-compile)))
# A bare symbol or vector literal compiles; anything else interprets.
(if (or (and (struct? form) (= :symbol (form :jolt/type))) (tuple? form))
(try-compile)
(eval-form ctx @{} form)))
(eval-form ctx @{} form)))
(defn load-ns
"Load a Clojure namespace from a .clj file.
When ctx has :compile? enabled, forms are compiled to Janet source,
evaluated via Janet's evaluator, and cached.
"Load a Clojure namespace from a .clj file. Per-form routing (compile-or-
interpret, stateful forms interpret) is shared with eval-one via eval-toplevel.
(load-ns ctx filepath) → namespace symbol string"
[ctx filepath]
(let [env (ctx :env)
compile? (get env :compile?)
cache (get env :compiled-cache)]
(def source (slurp filepath))
(var ns-name nil)
(var remaining source)
(var forms @[])
# Parse all forms
(while (> (length (string/trim remaining)) 0)
(def [form rest] (parse-next remaining))
(set remaining rest)
(when (not (nil? form))
(array/push forms form)
# Extract ns name from the first ns form
(when (and (nil? ns-name)
(array? form)
(> (length form) 0)
(and (struct? (first form))
(= :symbol ((first form) :jolt/type))
(= "ns" ((first form) :name))))
(let [name-form (in form 1)]
(set ns-name (if (struct? name-form) (name-form :name) (string name-form)))))))
(when (nil? ns-name)
(error (string "No ns form found in " filepath)))
(if compile?
(do
# Compile each form and eval as Janet
(var cached (get cache ns-name))
(when (nil? cached)
(set cached @[])
(put cache ns-name cached))
(each form forms
(array/push cached form)
(compile-and-eval form ctx))
ns-name)
# Interpreter path
(do
(each form forms
(eval-form ctx @{} form))
ns-name))))
(def source (slurp filepath))
(var ns-name nil)
(var remaining source)
(var forms @[])
(defn compiled?
"Check if a namespace has been compiled and cached."
[ctx ns-name]
(let [cache (get (ctx :env) :compiled-cache)]
(not (nil? (get cache ns-name)))))
# Parse all forms
(while (> (length (string/trim remaining)) 0)
(def [form rest] (parse-next remaining))
(set remaining rest)
(when (not (nil? form))
(array/push forms form)
# Extract ns name from the first ns form
(when (and (nil? ns-name)
(array? form)
(> (length form) 0)
(and (struct? (first form))
(= :symbol ((first form) :jolt/type))
(= "ns" ((first form) :name))))
(let [name-form (in form 1)]
(set ns-name (if (struct? name-form) (name-form :name) (string name-form)))))))
(defn get-compiled-forms
"Get the compiled Janet source forms for a namespace."
[ctx ns-name]
(get (ctx :env) :compiled-cache ns-name))
(when (nil? ns-name)
(error (string "No ns form found in " filepath)))
(defn clear-compiled-cache
"Clear the compiled form cache for a namespace or all namespaces."
[ctx &opt ns-name]
(let [cache (get (ctx :env) :compiled-cache)]
(if ns-name
(put cache ns-name nil)
(loop [[k] :pairs cache] (put cache k nil)))))
(each form forms (eval-toplevel ctx form))
ns-name)

8
src/jolt/main.janet
View file

@ -11,7 +11,13 @@
(def jolt-version "0.1.0")
(def ctx (init))
# Compile by default: the shipped runtime runs each form through the self-hosted
# pipeline (portable Clojure analyzer -> IR -> Janet back end) to native bytecode
# (hybrid — forms the analyzer can't compile fall back to the interpreter, so the
# result always matches the interpreter; see backend.janet / loader/eval-toplevel).
# Set JOLT_INTERPRET=1 to force the tree-walking interpreter (debugging / A-B).
(def compile-default? (not (= "1" (os/getenv "JOLT_INTERPRET"))))
(def ctx (init {:compile? compile-default?}))
(ctx-set-current-ns ctx "user")
(defn read-line [prompt]

16
src/jolt/phm.janet
View file

@ -72,7 +72,11 @@
(defn phm-get [m k &opt default]
(default default nil)
(let [bucket (get (m :buckets) (phm-hash-key k))]
(if bucket (let [v (phm-bucket-find bucket k)] (if (nil? v) default v)) default)))
# presence-check, not nil-of-value: a key mapped to nil is still present,
# so return nil (not the default) when the key exists with a nil value.
(if (and bucket (phm-bucket-contains? bucket k))
(phm-bucket-find bucket k)
default)))
(defn phm-assoc [m k v]
(let [cnt (m :cnt) idx (phm-hash-key k)
@ -197,6 +201,16 @@
(set cur (if (nil? rt) nil (make-lazy-seq rt))))))
cnt)
# ============================================================
# Lazy combinator — primitive for building lazy sequences
# ============================================================
(defn lazy-cons
"Returns a LazySeq whose first element is x and whose rest is produced
by rest-thunk (a 0-arg function returning nil or a LazySeq)."
[x rest-thunk]
(make-lazy-seq (fn [] @[x rest-thunk])))
# ============================================================
# PersistentHashSet — backed by PersistentHashMap
# ============================================================

13
src/jolt/reader.janet
View file

@ -9,6 +9,7 @@
# Sets #{1 2} → tagged struct {:jolt/type :jolt/set :value [1 2]}
(use ./types)
(import ./phm :as phm)
# Forward declaration for mutual recursion
(var read-form nil)
@ -266,6 +267,16 @@
(read-vec-items s new-pos (array/push items form))))))))
(read-vec-items s (+ pos 1) @[]))
# A map-literal form. Janet structs drop nil keys/values, so when a key or value
# is nil (e.g. {:a nil}) build a phm — it preserves nil, matching Clojure. The
# common nil-free case stays a struct: fast, and what the downstream map-form
# handling (evaluator/analyzer) already expects. Collection keys are left to
# eval-time construction (build-map-literal/eval-form), which phm-ifies them.
(defn- reader-map [kvs]
(var has-nil false) (var i 0)
(while (< i (length kvs)) (when (nil? (in kvs i)) (set has-nil true) (break)) (++ i))
(if has-nil (phm/make-phm kvs) (struct ;kvs)))
(defn read-map [s pos]
# pos is at opening brace
(defn read-kvs [s pos kvs]
@ -273,7 +284,7 @@
(if (>= pos (length s))
(error "Unterminated map"))
(if (= (s pos) 125) # }
[(struct ;kvs) (+ pos 1)]
[(reader-map kvs) (+ pos 1)]
(let [[key new-pos] (read-form s pos)]
(if (and (struct? key) (= :jolt/skip (key :jolt/type)))
(read-kvs s new-pos kvs)

2
src/jolt/stdlib_embed.janet
View file

@ -30,4 +30,6 @@
(let [acc @{}]
(collect "src/jolt/clojure" "clojure/" acc)
(collect "src/jolt/jolt" "jolt/" acc)
# Portable Clojure core (analyzer/IR/…): jolt-core/jolt/foo.clj -> jolt.foo
(collect "jolt-core" "" acc)
acc))

75
src/jolt/types.janet
View file

@ -86,6 +86,10 @@
:name name
:root init-val
:meta m
# Generation: bumped on every root change (redefinition). Call
# sites / dispatch caches keyed on this can detect a redef and
# invalidate; direct-linked (sealed) sites can detect staleness.
:gen 0
:dynamic (if meta (get meta :dynamic) false)
:macro (if meta (get meta :macro) false)
:ns (if meta (get meta :ns) nil)}]
@ -125,19 +129,25 @@
"Deref the var. If the var is dynamic and has a thread-local binding, return that.
Otherwise return the root binding."
[v]
# walk binding stack top-down for this var
# Fast path: no dynamic bindings are active (the common case — the stack is
# only non-empty inside a `binding` block), so the value is just the root. This
# is the hot path for every global deref; skip building the walk otherwise.
(def bs (cur-binding-stack))
(var result nil)
(var i (dec (length bs)))
(while (>= i 0)
(let [frame (in bs i)
val (get frame v)]
(if (not (nil? val))
(do
(set result (if (var? val) (var-get val) val))
(set i -1))
(-- i))))
(if (not (nil? result)) result (v :root)))
(if (= 0 (length bs))
(v :root)
# walk binding stack top-down for this var
(do
(var result nil)
(var i (dec (length bs)))
(while (>= i 0)
(let [frame (in bs i)
val (get frame v)]
(if (not (nil? val))
(do
(set result (if (var? val) (var-get val) val))
(set i -1))
(-- i))))
(if (not (nil? result)) result (v :root)))))
(defn var-set
"Set a var's value. If the var has a thread-local binding on the stack, update
@ -152,14 +162,16 @@
(if (not (nil? (get frame v)))
(do (put bs i (merge frame {v val})) (set done true))
(-- i))))
(unless done (put v :root val))
(unless done (do (put v :root val) (put v :gen (+ 1 (or (v :gen) 0)))))
val)
(defn alter-var-root
"Atomically alter the root binding of v by applying f to current value plus args."
[v f & args]
(let [new-val (f (v :root) ;args)]
(put v :root new-val)))
(put v :root new-val)
(put v :gen (+ 1 (or (v :gen) 0)))
new-val))
(defn alter-meta!
"Atomically update a var's metadata via (apply f args)."
@ -244,14 +256,18 @@
:name (v :name)
:root (v :root)
:meta new-meta
:gen (or (v :gen) 0)
:dynamic (v :dynamic)
:macro (v :macro)
:ns (v :ns)}))
(defn bind-root
"Set the root binding (internal, same as var-set)."
"Set the root binding and bump the var's generation (the redefinition
chokepoint: def, ns-intern-with-val, and the root-set paths all route here)."
[v val]
(put v :root val))
(put v :root val)
(put v :gen (+ 1 (or (v :gen) 0)))
val)
# ============================================================
# Namespace
@ -297,7 +313,10 @@
(when (not (nil? val))
(bind-root existing val))
existing)
(let [v (make-var sym val {:ns ns :name sym})]
# Store the namespace *name*, not the ns table: a back-pointer to the ns
# would make the var cyclic (ns -> mappings -> var -> ns), and the compiler
# embeds var cells as constants, which can't be cyclic.
(let [v (make-var sym val {:ns (get ns :name) :name sym})]
(put mappings sym v)
v))))
@ -362,14 +381,23 @@
[&opt opts]
(default opts nil)
(let [compile? (if opts (get opts :compile?) false)
# Direct-linking (call-site/unit property, like Clojure). :aot-core?
# (default true; JOLT_AOT_CORE=0 disables) compiles the core tiers +
# compiler with direct-linking on. :direct-linking? is the per-unit flag
# the back end reads while emitting; it defaults to the user-code setting
# (off unless opted in) and load-core-overlay! flips it on around core.
aot-core? (let [o (if opts (get opts :aot-core?) nil)]
(if (nil? o) (not (= "0" (os/getenv "JOLT_AOT_CORE"))) o))
env @{:namespaces @{}
:class->opts @{}
:current-ns "user"
:compile? compile?
:aot-core? aot-core?
:direct-linking? (if opts (get opts :direct-linking?) nil)
# Ordered roots searched (after the stdlib) to resolve a namespace
# to a .clj/.cljc file. deps.edn resolution appends dep src dirs.
:source-paths @["src/jolt"]
:compiled-cache @{}
# to a .clj/.cljc file. jolt-core holds the portable Clojure layer
# (analyzer/IR/core); deps.edn resolution appends dep src dirs.
:source-paths @["jolt-core" "src/jolt"]
:type-registry @{}
:data-readers (let [dr @{}]
(put dr (keyword "#inst") (fn [s] s))
@ -472,12 +500,15 @@
(defn register-protocol-method
"Register a protocol method implementation for a type."
[ctx type-tag protocol-name method-name fn]
(let [registry (get (ctx :env) :type-registry)
(let [env (ctx :env)
registry (get env :type-registry)
type-impls (or (get registry type-tag)
(do (put registry type-tag @{}) (get registry type-tag)))
proto-impls (or (get type-impls protocol-name)
(do (put type-impls protocol-name @{}) (get type-impls protocol-name)))]
(put proto-impls method-name fn)))
(put proto-impls method-name fn)
# Bump the registry generation so any dispatch cache keyed on it invalidates.
(put env :type-registry-gen (+ 1 (or (get env :type-registry-gen) 0)))))
(defn find-protocol-method
"Find a protocol method implementation for a type."