diff --git a/jolt-core/jolt/analyzer.clj b/jolt-core/jolt/analyzer.clj new file mode 100644 index 0000000..c6266d6 --- /dev/null +++ b/jolt-core/jolt/analyzer.clj @@ -0,0 +1,141 @@ +(ns jolt.analyzer + "Portable Clojure analyzer: reader form -> host-neutral IR (see jolt.ir). + + Pure jolt-core — depends only on the host contract (jolt.host) for form + introspection and symbol/macro resolution, never on Janet. ctx is an opaque + host handle threaded to the contract fns; the analyzer never inspects it. + + Coverage grows toward compiler.janet; unsupported forms throw :jolt/uncompilable + so the caller falls back to the interpreter (the hybrid contract)." + (:require [jolt.ir :as ir] + [jolt.host :as h])) + +(declare analyze analyze-fn) + +;; Special forms the analyzer compiles itself. Anything else with a special head +;; (ns, deftype, defmacro, …) is left to the interpreter via uncompilable. +(def ^:private handled + #{"quote" "if" "do" "def" "fn*" "let*" "throw"}) + +(defn- uncompilable [why] + (throw (str "jolt/uncompilable: " why))) + +(defn- analyze-seq + "Analyze a body of forms into IR statements+ret (a :do, or the single node)." + [ctx forms locals] + (let [v (mapv #(analyze ctx % locals) forms) + n (count v)] + (cond + (zero? n) (ir/const nil) + (= 1 n) (first v) + :else (ir/do-node (subvec v 0 (dec n)) (peek v))))) + +(defn- analyze-special [ctx op items locals] + (case op + "quote" (ir/quote-node (second items)) + "if" (ir/if-node (analyze ctx (nth items 1) locals) + (analyze ctx (nth items 2) locals) + (if (> (count items) 3) + (analyze ctx (nth items 3) locals) + (ir/const nil))) + "do" (analyze-seq ctx (rest items) locals) + "throw" (ir/throw-node (analyze ctx (nth items 1) locals)) + "def" (let [name-sym (nth items 1) + nm (h/sym-name name-sym) + cur (h/current-ns ctx)] + (h/intern! ctx cur nm) + (ir/def-node cur nm (analyze ctx (nth items 2) locals))) + "let*" (let [bvec (vec (h/vector-items (nth items 1))) + locals* (atom locals) + pairs (loop [i 0 acc []] + (if (< i (count bvec)) + (let [bsym (nth bvec i) + _ (when-not (h/sym? bsym) + (uncompilable "destructuring let binding")) + nm (h/sym-name bsym) + init (analyze ctx (nth bvec (inc i)) @locals*)] + (swap! locals* conj nm) + (recur (+ i 2) (conj acc [nm init]))) + acc))] + (ir/let-node pairs (analyze-seq ctx (drop 2 items) @locals*))) + "fn*" (analyze-fn ctx items locals) + (uncompilable (str "special form " op)))) + +(defn- parse-params [pvec] + "Plain-symbol params only; & rest. Destructuring -> uncompilable." + (loop [i 0 fixed [] rest-name nil] + (if (< i (count pvec)) + (let [p (nth pvec i)] + (when-not (h/sym? p) (uncompilable "destructuring fn param")) + (if (= "&" (h/sym-name p)) + (let [r (nth pvec (inc i))] + (when-not (h/sym? r) (uncompilable "destructuring fn rest")) + (recur (+ i 2) fixed (h/sym-name r))) + (recur (inc i) (conj fixed (h/sym-name p)) rest-name))) + {:fixed fixed :rest rest-name}))) + +(defn- analyze-arity [ctx pvec body locals fn-name] + (let [{:keys [fixed rest]} (parse-params (vec (h/vector-items pvec))) + locals* (cond-> (reduce conj locals fixed) + rest (conj rest) + fn-name (conj fn-name))] + {:params fixed :rest rest :body (analyze-seq ctx body locals*)})) + +(defn- analyze-fn [ctx items locals] + ;; (fn* name? params body...) | (fn* name? ([params] body...) ...) + (let [named (h/sym? (nth items 1)) + fn-name (when named (h/sym-name (nth items 1))) + rest-items (if named (drop 2 items) (drop 1 items)) + first* (first rest-items)] + (cond + (h/vector? first*) + (ir/fn-node fn-name [(analyze-arity ctx first* (rest rest-items) locals fn-name)]) + (h/list? first*) + (ir/fn-node fn-name + (mapv (fn [clause] + (let [cl (vec (h/elements clause))] + (analyze-arity ctx (first cl) (rest cl) locals fn-name))) + rest-items)) + :else (uncompilable "fn: bad params")))) + +(defn- analyze-symbol [ctx form locals] + (let [nm (h/sym-name form) ns (h/sym-ns form)] + (if (and (nil? ns) (contains? locals nm)) + (ir/local nm) + (let [r (h/resolve-global ctx form)] + (case (:kind r) + :var (ir/var-ref (:ns r) (:name r)) + :host (ir/host-ref (:name r)) + ;; unresolved: a forward reference in the current ns; resolved at call time + (ir/var-ref (h/current-ns ctx) nm)))))) + +(defn- analyze-list [ctx form locals] + (let [items (vec (h/elements form))] + (if (zero? (count items)) + (ir/quote-node form) + (let [head (first items) + hname (when (and (h/sym? head) (nil? (h/sym-ns head))) (h/sym-name head)) + shadowed (and hname (contains? locals hname))] + (cond + (and hname (not shadowed) (contains? handled hname)) + (analyze-special ctx hname items locals) + (and (h/sym? head) (not shadowed) (h/macro? ctx head)) + (analyze ctx (h/expand-1 ctx form) locals) + :else + (ir/invoke (analyze ctx head locals) + (mapv #(analyze ctx % locals) (rest items)))))))) + +(defn analyze + "Analyze form to IR in context ctx with the given set of local names in scope." + ([ctx form] (analyze ctx form #{})) + ([ctx form locals] + (cond + (h/literal? form) (ir/const form) + (h/sym? form) (analyze-symbol ctx form locals) + (h/vector? form) (ir/vector-node (mapv #(analyze ctx % locals) (h/vector-items form))) + (h/map? form) (ir/map-node (mapv (fn [p] [(analyze ctx (first p) locals) + (analyze ctx (second p) locals)]) + (h/map-pairs form))) + (h/set? form) (ir/set-node (mapv #(analyze ctx % locals) (h/set-items form))) + (h/list? form) (analyze-list ctx form locals) + :else (ir/const form)))) diff --git a/jolt-core/jolt/ir.clj b/jolt-core/jolt/ir.clj index 01fd97a..0179755 100644 --- a/jolt-core/jolt/ir.clj +++ b/jolt-core/jolt/ir.clj @@ -19,6 +19,10 @@ ;; A runtime primitive (cons, +, get, apply, …) the back end maps to the host RT. (defn rt [name] {:op :rt :name name}) +;; A name that resolves only via the host's own environment (e.g. + or int? on +;; Janet) — the back end emits a host-appropriate reference. +(defn host-ref [name] {:op :host :name name}) + (defn if-node [test then else] {:op :if :test test :then then :else else}) (defn do-node [statements ret] {:op :do :statements statements :ret ret}) diff --git a/src/jolt/api.janet b/src/jolt/api.janet index 78580d7..d6fbe61 100644 --- a/src/jolt/api.janet +++ b/src/jolt/api.janet @@ -11,6 +11,7 @@ (use ./loader) (use ./async) (import ./stdlib_embed :as stdlib-embed) +(import ./host_iface :as host) (defn normalize-pvecs "Deep-convert any sequential (pvec/tuple/array) to a Janet tuple. Test helper @@ -53,6 +54,8 @@ # 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) ctx)) (defn eval-one diff --git a/src/jolt/backend.janet b/src/jolt/backend.janet new file mode 100644 index 0000000..f913c0d --- /dev/null +++ b/src/jolt/backend.janet @@ -0,0 +1,141 @@ +# 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) + +# Var late-binding: deref/set through the cell via a memoized closure so compiled +# code sees redefinition (Janet early-binds plain symbols). Same scheme as the +# bootstrap compiler. +(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- cell-for [ctx ns-name nm] + (ns-intern (ctx-find-ns ctx ns-name) nm)) + +# 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))]) + +(defn- emit-arity-fn [ctx ar] + (def ps @[]) + (each pn (vview (ar :params)) (array/push ps (symbol pn))) + (when (ar :rest) (array/push ps '&) (array/push ps (symbol (ar :rest)))) + ['fn (tuple/slice ps) (emit ctx (ar :body))]) + +(defn- emit-fn [ctx node] + (def arities (vview (node :arities))) + (if (= 1 (length arities)) + (emit-arity-fn ctx (first arities)) + # Multi-arity: dispatch on arg count; fixed arities match exactly, the + # variadic one matches >= its fixed count. apply spreads the captured args + # into the chosen arity fn (whose own & collects any rest). + (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 [apply (emit-arity-fn ctx ar) jargs])) + (array/push cf ['error "wrong number of args passed to fn"]) + ['fn ['& jargs] + ['do ['def nsym ['length jargs]] (tuple/slice cf)]]))) + +(defn- direct-call? [fnode] + (case (fnode :op) :var true :local true :fn true :host true false)) + +(defn- emit-invoke [ctx node] + (def f (emit ctx (node :fn))) + (def args (map |(emit ctx $) (vview (node :args)))) + (if (direct-call? (node :fn)) + (tuple f ;args) + (tuple jolt-call f ;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 node] + (case (node :op) + :const (node :val) + :local (symbol (node :name)) + :host (symbol (node :name)) + :var (tuple (var-getter (cell-for ctx (node :ns) (node :name)))) + :if ['if (emit ctx (node :test)) (emit ctx (node :then)) (emit ctx (node :else))] + :do (emit-seq ctx node) + :throw ['error (emit ctx (node :expr))] + :def (tuple (var-setter (cell-for ctx (node :ns) (node :name))) (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) --- + +(defn- ensure-analyzer [ctx] + # Load jolt.analyzer (and transitively jolt.ir) once; jolt.host is pre-installed + # by host/install! so its require is a no-op. + (when (= 0 (length ((ctx-find-ns ctx "jolt.analyzer") :mappings))) + (eval-form ctx @{} (r/parse-string "(require '[jolt.analyzer])")))) + +(defn analyze-form + "Run the portable Clojure analyzer (jolt.analyzer/analyze) on a reader form, + returning host-neutral IR." + [ctx form] + (ensure-analyzer ctx) + (def av (ns-find (ctx-find-ns ctx "jolt.analyzer") "analyze")) + ((var-get av) ctx form)) + +(defn compile-and-eval + "Self-hosted compile path: analyze (portable Clojure) -> IR -> Janet -> eval." + [ctx form] + (eval (emit-ir ctx (analyze-form ctx form)) (comp/ctx-janet-env ctx))) diff --git a/src/jolt/host_iface.janet b/src/jolt/host_iface.janet new file mode 100644 index 0000000..07213e4 --- /dev/null +++ b/src/jolt/host_iface.janet @@ -0,0 +1,101 @@ +# 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) + +# --------------------------------------------------------------------------- +# 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)) + +(defn h-list? [form] (array? form)) # a call / list (reader: array) +(defn h-vector? [form] (tuple? form)) # a vector literal (reader: tuple) +(defn h-map? [form] (and (struct? form) (nil? (form :jolt/type)))) +(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] + (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 +# --------------------------------------------------------------------------- + +(defn h-current-ns [ctx] (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. +# --------------------------------------------------------------------------- + +(def- exports + {"sym?" h-sym? "sym-name" h-sym-name "sym-ns" h-sym-ns + "list?" h-list? "vector?" h-vector? "map?" h-map? "set?" h-set? "char?" h-char? + "literal?" h-literal? "elements" h-elements "vector-items" h-vector-items + "map-pairs" h-map-pairs "set-items" h-set-items + "current-ns" h-current-ns "macro?" h-macro? "expand-1" h-expand-1 + "resolve-global" h-resolve-global "intern!" h-intern!}) + +(defn install! [ctx] + (def ns (ctx-find-ns ctx "jolt.host")) + (eachp [nm f] exports (ns-intern ns nm f)) + ns) diff --git a/test/integration/self-host-test.janet b/test/integration/self-host-test.janet new file mode 100644 index 0000000..49f0e22 --- /dev/null +++ b/test/integration/self-host-test.janet @@ -0,0 +1,48 @@ +# End-to-end proof of the self-hosting pipeline: a reader form is analyzed by the +# PORTABLE Clojure analyzer (jolt.analyzer, in jolt-core) into host-neutral IR, +# then the Janet back end lowers the IR to a Janet form and evaluates it. No use +# of compiler.janet's analyzer — this is the Clojure-in-Clojure front end. +(import ../../src/jolt/backend :as backend) +(use ../../src/jolt/api) +(use ../../src/jolt/reader) + +(defn ce [ctx s] (normalize-pvecs (backend/compile-and-eval ctx (parse-string s)))) + +(print "self-host pipeline (Clojure analyzer -> IR -> Janet)...") +(let [ctx (init)] + # primitives + control flow + (assert (= 3 (ce ctx "(+ 1 2)")) "+") + (assert (= 6 (ce ctx "(* 2 3)")) "*") + (assert (= :a (ce ctx "(if true :a :b)")) "if true") + (assert (= :b (ce ctx "(if false :a :b)")) "if false") + (assert (= 10 (ce ctx "(let [x 4 y 6] (+ x y))")) "let") + (assert (= 6 (ce ctx "(do 1 2 6)")) "do") + + # literals + (assert (= [2 3 4] (ce ctx "(map inc [1 2 3])")) "vector literal + core fn") + (assert (= 1 (ce ctx "(get {:a 1 :b 2} :a)")) "map literal") + (assert (= 42 (ce ctx "(quote 42)")) "quote literal") + + # def + global reference (name-based var resolution) + (ce ctx "(def base 100)") + (assert (= 142 (ce ctx "(+ base 42)")) "def + later ref") + + # fn / defn (defn is a macro -> expand -> def of fn*) + (ce ctx "(defn add [a b] (+ a b))") + (assert (= 7 (ce ctx "(add 3 4)")) "defn") + (assert (= 49 (ce ctx "((fn [x] (* x x)) 7)")) "anon fn") + + # recursion through the var cell (no recur needed) + (ce ctx "(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))") + (assert (= 55 (ce ctx "(fib 10)")) "recursive fib via var") + + # multi-arity + variadic + (ce ctx "(defn arity ([a] a) ([a b] (+ a b)) ([a b & more] (apply + a b more)))") + (assert (= 5 (ce ctx "(arity 5)")) "multi-arity 1") + (assert (= 7 (ce ctx "(arity 3 4)")) "multi-arity 2") + (assert (= 15 (ce ctx "(arity 1 2 3 4 5)")) "multi-arity variadic") + + # higher-order + nesting + (assert (= 15 (ce ctx "(reduce + (map inc [0 1 2 3 4]))")) "reduce+map")) + +(print "self-host pipeline passed!")