ec9fde9e7e
The host/chez directory mixed jolt's own runtime (value model, seq, reader, vars, ns, multimethods) with the shims that emulate the JVM: java.* / javax.* classes, clojure.lang interfaces, and the host-class registry they hang off. Move that JVM-emulation layer into host/chez/java/ so it reads as a distinct unit instead of being interleaved with the platform runtime. Moved (content unchanged): host-static, host-static-methods, host-static-classes, host-class, dot-forms, records-interop, byte-buffer, io, io-streams, inst-time, java-time, bigdec, natives-queue, natives-str, natives-array, math, concurrency, async, ffi. The load paths in rt.ss/cli.ss and the build.ss runtime manifest are updated to point at java/; the build inliner follows the (load ...) strings, so the AOT path needs no other change. All runtime shims, no seed source touched (the three .clj edits are doc comments), so no re-mint. Gate green: make test (selfhost fixpoint, certify 0-new, sci 211, infer), shakesmoke (4 apps byte-identical).
697 lines
37 KiB
Clojure
697 lines
37 KiB
Clojure
(ns jolt.analyzer
|
|
"Portable Clojure analyzer: reader form -> host-neutral IR (see jolt.ir).
|
|
|
|
Depends only on the host contract (jolt.host) and IR
|
|
constructors (jolt.ir). The contract fns are referred unqualified
|
|
(host form predicates are `form-*` to avoid colliding with clojure.core), so the
|
|
bootstrap can compile this namespace via its plain :var path. ctx is an opaque
|
|
host handle threaded to the contract fns; the analyzer never inspects it.
|
|
|
|
Unsupported forms throw :jolt/uncompilable
|
|
so the caller falls back to the interpreter (the hybrid contract).
|
|
|
|
`env` carries lexical state: {:locals #{names} :recur recur-target-name|nil}.
|
|
Definitions are ordered so only `analyze` (mutually recursive) is forward
|
|
declared — the bootstrap compiles forward refs through var cells, but keeping
|
|
them to one keeps the compiled namespace simple."
|
|
(:require [jolt.ir :refer [const local var-ref the-var host-ref if-node do-node invoke
|
|
def-node let-node fn-node vector-node map-node set-node
|
|
quote-node throw-node host-static host-new]]
|
|
[jolt.host :refer [form-sym? form-sym-name form-sym-ns form-list?
|
|
form-vec? form-map? form-set?
|
|
form-literal? form-keyword? form-elements form-vec-items
|
|
form-map-pairs form-set-items form-special? compile-ns
|
|
form-regex? form-regex-source
|
|
form-inst? form-inst-source form-uuid? form-uuid-source
|
|
form-bigdec? form-bigdec-source
|
|
form-ns-value? form-ns-value-name
|
|
form-macro? form-expand-1 resolve-global
|
|
form-sym-meta form-coll-meta host-intern! form-syntax-quote-lower
|
|
record-type? record-ctor-key form-position late-bind?
|
|
resolve-class-hint]]))
|
|
|
|
(declare analyze)
|
|
|
|
;; Special forms analyze-special has a dispatch arm for — the subset of the host
|
|
;; contract's reserved words (jolt.host/form-special?) the analyzer lowers itself.
|
|
;; The two differ deliberately (e.g. interop heads like `new`/`.` are reserved but
|
|
;; analyzed in analyze-list), so keep them in sync by intent, not by equality.
|
|
(def ^:private handled
|
|
#{"quote" "if" "do" "def" "fn*" "let*" "loop*" "recur" "throw" "try"
|
|
"syntax-quote" "var" "letfn" "set!" "defmacro"})
|
|
|
|
(defn- uncompilable [why]
|
|
(throw (str "jolt/uncompilable: " why)))
|
|
|
|
(def ^:private gensym-counter (atom 0))
|
|
(defn- gen-name [prefix]
|
|
(let [n @gensym-counter]
|
|
(swap! gensym-counter inc)
|
|
(str "_r$" prefix n)))
|
|
|
|
(defn- empty-env [] {:locals #{} :hints {}})
|
|
(defn- local? [env nm] (contains? (:locals env) nm))
|
|
(defn- add-locals [env names] (update env :locals #(reduce conj % names)))
|
|
(defn- with-recur [env name] (assoc env :recur name))
|
|
|
|
;; Type hints. The reader keeps ^hint metadata on the binding symbol.
|
|
;; Two hints resolve to the :struct fast path (a constant-keyword lookup skips
|
|
;; the :jolt/type guard and emits a bare get): ^:struct (a plain struct/record
|
|
;; map) and ^TypeName where TypeName is a defrecord/deftype (its instances are
|
|
;; tagged :jolt/deftype, not :jolt/type, so a raw get is correct). Every other
|
|
;; hint (^String, ^long, ...) parses and is ignored, as before.
|
|
(defn- hint-of [ctx sym]
|
|
(let [m (form-sym-meta sym)]
|
|
(cond
|
|
(nil? m) nil
|
|
(get m :struct) :struct
|
|
:else (let [t (get m :tag)]
|
|
(when (and t (record-type? ctx t)) :struct)))))
|
|
(defn- add-hint [env nm h]
|
|
(if h (assoc env :hints (assoc (:hints env) nm h)) env))
|
|
|
|
;; The resolved record ctor-key ("ns/->Name") for a ^Type param hint, or nil.
|
|
;; Unlike hint-of (which collapses any record hint to the coarse :struct guard-
|
|
;; skip marker), this carries the SPECIFIC record type — cross-namespace aware —
|
|
;; so the inference can seed the param's type and read its fields shaped/typed,
|
|
;; not just :any (the lever for a typed multi-namespace program without whole-
|
|
;; program inference).
|
|
(defn- phint-of [ctx sym]
|
|
(let [m (form-sym-meta sym)]
|
|
(when m (let [t (get m :tag)] (when t (record-ctor-key ctx t))))))
|
|
|
|
;; A ^long / ^double tag -> :long / :double, else nil. The tag is a string on the
|
|
;; data reader; tolerate a symbol from macroexpansion too.
|
|
(defn- tag->nkind [t]
|
|
(let [s (cond (form-sym? t) (form-sym-name t) (string? t) t :else nil)]
|
|
(cond (= s "double") :double (= s "long") :long :else nil)))
|
|
|
|
;; A primitive numeric hint (^long / ^double) on a binding symbol. Drives the
|
|
;; fl*/fx* fast path (jolt.passes.numeric).
|
|
(defn- nhint-of [ctx sym]
|
|
(let [m (form-sym-meta sym)] (when m (tag->nkind (get m :tag)))))
|
|
|
|
;; Push a numeric return hint (from ^double/^long on a defn's name) onto each arity
|
|
;; of its fn, so the back end coerces the body's value to that kind on return —
|
|
;; making the hint a contract a caller's arithmetic can trust.
|
|
(defn- with-ret-nhint [node kind]
|
|
(if (and kind (= :fn (:op node)))
|
|
(assoc node :arities (mapv (fn [a] (if (:ret-nhint a) a (assoc a :ret-nhint kind)))
|
|
(:arities node)))
|
|
node))
|
|
|
|
(defn- analyze-seq [ctx forms env]
|
|
(let [v (mapv #(analyze ctx % env) forms)
|
|
n (count v)]
|
|
(cond
|
|
(zero? n) (const nil)
|
|
(= 1 n) (first v)
|
|
:else (do-node (subvec v 0 (dec n)) (peek v)))))
|
|
|
|
(defn- analyze-bindings [ctx bvec env]
|
|
(loop [i 0 env env pairs []]
|
|
(if (< i (count bvec))
|
|
(let [bsym (nth bvec i)]
|
|
(when-not (form-sym? bsym) (uncompilable "destructuring binding"))
|
|
(let [nm (form-sym-name bsym)
|
|
init (analyze ctx (nth bvec (inc i)) env)]
|
|
(recur (+ i 2) (add-hint (add-locals env [nm]) nm (hint-of ctx bsym))
|
|
(conj pairs [nm init]))))
|
|
[pairs env])))
|
|
|
|
(defn- parse-params [ctx pvec]
|
|
;; :hints is a vector of [name hint] pairs (vector, not a map, so the caller
|
|
;; folds it with a plain reduce — no reduce-over-map in the kernel subset).
|
|
;; :phints is the parallel vector of [name ctor-key] for record param hints,
|
|
;; carrying the specific type for the inference to seed.
|
|
(loop [i 0 fixed [] rest-name nil hints [] phints [] nhints []]
|
|
(if (< i (count pvec))
|
|
(let [p (nth pvec i)]
|
|
(when-not (form-sym? p) (uncompilable "destructuring fn param"))
|
|
(if (= "&" (form-sym-name p))
|
|
(let [r (nth pvec (inc i))]
|
|
(when-not (form-sym? r) (uncompilable "destructuring fn rest"))
|
|
(recur (+ i 2) fixed (form-sym-name r) hints phints nhints))
|
|
(let [nm (form-sym-name p) h (hint-of ctx p) ph (phint-of ctx p) nh (nhint-of ctx p)]
|
|
(recur (inc i) (conj fixed nm) rest-name
|
|
(if h (conj hints [nm h]) hints)
|
|
(if ph (conj phints [nm ph]) phints)
|
|
(if nh (conj nhints [nm nh]) nhints)))))
|
|
{:fixed fixed :rest rest-name :hints hints :phints phints :nhints nhints})))
|
|
|
|
;; Clojure lets a later param shadow an earlier same-named one (a macro expander
|
|
;; uses _ for both its &form and &env slots, so its param list is (_ _ …)); the
|
|
;; body binds the LAST occurrence. Chez rejects duplicate formals, so rename every
|
|
;; earlier duplicate to a fresh name — it is shadowed and unreferenceable.
|
|
(defn- uniquify-params [names]
|
|
(let [n (count names)]
|
|
(loop [i 0 out []]
|
|
(if (< i n)
|
|
(let [nm (nth names i)
|
|
dup? (loop [j (inc i)]
|
|
(cond (>= j n) false
|
|
(= nm (nth names j)) true
|
|
:else (recur (inc j))))]
|
|
(recur (inc i) (conj out (if dup? (gen-name (str nm "_")) nm))))
|
|
out))))
|
|
|
|
(defn- analyze-arity [ctx pvec body env fn-name]
|
|
(let [pp (parse-params ctx (vec (form-vec-items pvec)))
|
|
fixed (uniquify-params (:fixed pp))
|
|
rst (:rest pp)
|
|
;; Always a recur target, variadic included: the back end gives the rest
|
|
;; param an ordinary positional slot (holding the collected seq), so recur
|
|
;; is a self-call carrying the rest seq directly — Clojure semantics.
|
|
;; The recur target doubles as the COMPILED FN'S NAME, which is what a
|
|
;; host stack trace shows — so carry the Clojure ns/fn-name:
|
|
;; an error inside app.deep/level3 traces as _r$app.deep/level3--N
|
|
;; (report-error demangles the _r$/--N wrapper). gen-name's counter
|
|
;; keeps recur targets unique per compilation unit.
|
|
rname (gen-name (str (compile-ns ctx) "/" (or fn-name "fn") "--"))
|
|
names (cond-> (vec fixed) rst (conj rst) fn-name (conj fn-name))
|
|
env0 (-> (add-locals env names) (with-recur rname))
|
|
env* (reduce (fn [e pr] (add-hint e (nth pr 0) (nth pr 1))) env0 (:hints pp))
|
|
arity {:params fixed :recur-name rname
|
|
:body (analyze-seq ctx body env*)}
|
|
;; carry record param hints (name -> ctor-key) for the inference to seed
|
|
;; the param type; only when present so a hintless arity stays a struct.
|
|
arity (if (seq (:phints pp)) (assoc arity :phints (:phints pp)) arity)
|
|
;; numeric param hints (name -> :long/:double) for jolt.passes.numeric.
|
|
arity (if (seq (:nhints pp)) (assoc arity :nhints (:nhints pp)) arity)]
|
|
;; :rest only when variadic — an absent :rest reads back nil, same as before,
|
|
;; but keeps a fixed arity a nil-free struct rather than a phm.
|
|
(if rst (assoc arity :rest rst) arity)))
|
|
|
|
;; A reader that lowers ^meta on a collection to a runtime (with-meta <coll> <meta>)
|
|
;; form (the Chez data reader) wraps an arglist vector carrying a return-type hint
|
|
;; (^bytes [b] / ^String [x y]). Unwrap to the underlying vector so fn parsing sees
|
|
;; the params — the hint is ignored at runtime. Only the (with-meta <vec> _) shape
|
|
;; matches, so a real arity clause (head is a vector) and a
|
|
;; meta-on-vector arglist pass through unchanged.
|
|
(defn- strip-arglist-meta [form]
|
|
(if (form-list? form)
|
|
(let [es (vec (form-elements form))]
|
|
(if (and (= 3 (count es))
|
|
(form-sym? (first es))
|
|
(= "with-meta" (form-sym-name (first es)))
|
|
(form-vec? (nth es 1)))
|
|
(nth es 1)
|
|
form))
|
|
form))
|
|
|
|
(defn- analyze-fn [ctx items env]
|
|
(let [named (form-sym? (nth items 1))
|
|
fn-name (when named (form-sym-name (nth items 1)))
|
|
rest-items (if named (drop 2 items) (drop 1 items))
|
|
first* (strip-arglist-meta (first rest-items))]
|
|
(cond
|
|
(form-vec? first*)
|
|
(fn-node fn-name [(analyze-arity ctx first* (rest rest-items) env fn-name)])
|
|
(form-list? first*)
|
|
(fn-node fn-name
|
|
(mapv (fn [clause]
|
|
(let [cl (vec (form-elements clause))]
|
|
(analyze-arity ctx (strip-arglist-meta (first cl)) (rest cl) env fn-name)))
|
|
rest-items))
|
|
:else (uncompilable "fn: bad params"))))
|
|
|
|
;; class names that catch everything (the JVM root types); a (catch Throwable e …)
|
|
;; clause matches any thrown value unconditionally.
|
|
(def ^:private catch-all-names #{"Throwable" "java.lang.Throwable" "Object" "java.lang.Object"})
|
|
|
|
(defn- analyze-try [ctx items env]
|
|
(let [clauses (rest items)
|
|
body (atom [])
|
|
catches (atom []) ; ordered vector of (catch class binding body*) clauses
|
|
finally-body (atom nil)]
|
|
(doseq [c clauses]
|
|
(let [head (when (form-list? c) (first (vec (form-elements c))))
|
|
hname (when (and head (form-sym? head)) (form-sym-name head))]
|
|
(cond
|
|
(= hname "catch")
|
|
(let [cl (vec (form-elements c))]
|
|
;; (catch class binding body*) — binding (3rd elem) MUST be a symbol.
|
|
;; Validate eagerly (plain throw, NOT uncompilable, so it's a real
|
|
;; error rather than a compile->interpret punt) instead of letting
|
|
;; form-sym-name crash on a non-symbol.
|
|
(when (or (< (count cl) 3) (not (form-sym? (nth cl 2))))
|
|
(throw "Unable to parse catch clause; expected (catch class binding body*)"))
|
|
(swap! catches conj cl))
|
|
(= hname "finally")
|
|
(reset! finally-body (rest (vec (form-elements c))))
|
|
:else (swap! body conj c))))
|
|
;; Multiple catch clauses dispatch on the thrown value's class, in order. Lower
|
|
;; them to ONE guard binding a fresh local, then a nested-if chain testing each
|
|
;; clause's class with (instance? C e) — which respects the exception supertype
|
|
;; hierarchy — plus __catch-broad? for an untyped host condition. No match
|
|
;; re-throws. (The earlier single-catch IR ignored the class and caught
|
|
;; everything; this gives real per-class dispatch.) :catch-sym/:catch-body/
|
|
;; :finally are added only when present — an absent key must stay absent (a
|
|
;; nil-valued key would make the node a phm and force back-end densification).
|
|
(let [n {:op :try :body (analyze-seq ctx @body env)}
|
|
n (if (seq @catches)
|
|
(let [evar-name (gen-name "catch")
|
|
evar (symbol evar-name)
|
|
dispatch
|
|
(reduce
|
|
(fn [else cl]
|
|
(let [cform (nth cl 1)
|
|
bindsym (nth cl 2)
|
|
bodyf (drop 3 cl)
|
|
letform (cons 'let (cons (vector bindsym evar) bodyf))
|
|
fullname (when (form-sym? cform) (form-sym-name cform))
|
|
catch-all? (or (not (form-sym? cform))
|
|
(contains? catch-all-names fullname))]
|
|
(if catch-all?
|
|
letform
|
|
(list 'if (list 'or
|
|
(list 'instance? cform evar)
|
|
(list '__catch-broad? fullname evar))
|
|
letform else))))
|
|
(list 'throw evar)
|
|
(reverse @catches))]
|
|
(assoc n :catch-sym evar-name
|
|
:catch-body (analyze-seq ctx (list dispatch)
|
|
(add-locals env [evar-name]))))
|
|
n)
|
|
n (if @finally-body
|
|
(assoc n :finally (analyze-seq ctx @finally-body env))
|
|
n)]
|
|
n)))
|
|
|
|
;; letfn: (letfn [(name [params] body*)...] body*). The named local fns are
|
|
;; MUTUALLY recursive, so bind every name into the env BEFORE analyzing any spec
|
|
;; — each spec then resolves its siblings (and itself) as locals. Emitted as a
|
|
;; :let flagged :letrec so the back end knows the bindings forward-reference each
|
|
;; other: Chez lowers it to `letrec*`. The interpreter's shared mutable env already
|
|
;; gives the letrec semantics that a
|
|
;; compiled sequential let* lacks — the reason letfn was uncompilable before.
|
|
(defn- analyze-letfn [ctx items env]
|
|
(let [specs (vec (form-vec-items (nth items 1)))
|
|
names (mapv #(form-sym-name (first (vec (form-elements %)))) specs)
|
|
env* (add-locals env names)
|
|
binds (mapv (fn [spec]
|
|
(let [cl (vec (form-elements spec))]
|
|
;; Build (fn name [params] body*) and analyze through the fn
|
|
;; MACRO so destructuring params desugar (the fn* primitive
|
|
;; would not — same trick defmacro uses). The named fn means
|
|
;; self- and sibling-calls resolve and it carries its own name.
|
|
[(form-sym-name (first cl))
|
|
(analyze ctx (cons (symbol "fn") cl) env*)]))
|
|
specs)]
|
|
{:op :let :letrec true :bindings binds
|
|
:body (analyze-seq ctx (drop 2 items) env*)}))
|
|
|
|
;; A `.-field` head: `(.-field target)` is field access (the dash signals field
|
|
;; access to the host-call dispatcher). Defined above analyze-special so its set!
|
|
;; arm and analyze-list both reach it without a forward reference.
|
|
(defn- field-head? [nm]
|
|
(and (> (count nm) 2) (= ".-" (subs nm 0 2))))
|
|
|
|
;; Clojure evaluates def metadata values as expressions: ^{:k (f)} stores the
|
|
;; result of (f), ^{:a some-fn} stores the fn value. Build an IR map that evaluates
|
|
;; each value at def time. :tag keeps the resolved class-name string (jolt models a
|
|
;; type hint as its class name, not a runtime expression). nil when there's no
|
|
;; metadata, so a plain def keeps the cheap static path.
|
|
(defn- def-meta-expr [ctx base env]
|
|
(when (pos? (count base))
|
|
(map-node (mapv (fn [p]
|
|
(let [k (first p) v (second p)]
|
|
;; :tag stays a literal (a resolved class-name string or a
|
|
;; primitive-hint symbol like `double`) — quote it rather
|
|
;; than evaluate it. Everything else is evaluated.
|
|
[(const k)
|
|
(if (= k :tag) (quote-node v) (analyze ctx v env))]))
|
|
(seq base)))))
|
|
|
|
(defn- analyze-def [ctx items env]
|
|
(let [name-sym (nth items 1)]
|
|
;; ^{:map} metadata reads as (def (with-meta name m) v): the metadata is a
|
|
;; runtime expression, so the interpreter evaluates the whole def.
|
|
(when-not (form-sym? name-sym)
|
|
(uncompilable "def name with map metadata"))
|
|
(if (< (count items) 3)
|
|
;; (def name) with no init (declare): intern + reserve the cell so a forward
|
|
;; reference resolves; the back end keys on :no-init.
|
|
(let [nm (form-sym-name name-sym) cur (compile-ns ctx)]
|
|
(host-intern! ctx cur nm)
|
|
{:op :def :ns cur :name nm :no-init true})
|
|
;; (def name docstring value): docstring is form 2, value form 3 — matching
|
|
;; the interpreter, else the docstring is taken as the value.
|
|
(let [nm (form-sym-name name-sym)
|
|
cur (compile-ns ctx)
|
|
has-doc (and (> (count items) 3) (string? (nth items 2)))
|
|
val-form (nth items (if has-doc 3 2))
|
|
base0 (or (form-sym-meta name-sym) {})
|
|
;; resolve a ^Type hint to its canonical class name at def time, as the
|
|
;; JVM compiler does (^String -> java.lang.String); unknown hints pass.
|
|
tag (get base0 :tag)
|
|
tag-name (cond (form-sym? tag) (form-sym-name tag)
|
|
(string? tag) tag
|
|
:else nil)
|
|
base-meta (if tag-name
|
|
(let [c (resolve-class-hint tag-name)]
|
|
(if c (assoc base0 :tag c) base0))
|
|
base0)
|
|
node-meta (if has-doc (assoc base-meta :doc (nth items 2)) base-meta)]
|
|
(host-intern! ctx cur nm)
|
|
;; a ^double/^long return hint on the name applies to all arities of the fn.
|
|
(let [node (def-node cur nm (with-ret-nhint (analyze ctx val-form env) (tag->nkind tag)) node-meta)
|
|
me (def-meta-expr ctx node-meta env)]
|
|
(if me (assoc node :meta-expr me) node))))))
|
|
|
|
;; (set! (.-field obj) v) mutates a deftype instance field in place; (set! *var* v)
|
|
;; sets the var's innermost thread binding, else its root. A local target (jolt
|
|
;; binds fields immutably) or any other shape is uncompilable.
|
|
(defn- analyze-set! [ctx items env]
|
|
(let [target (nth items 1)
|
|
val-node (analyze ctx (nth items 2) env)
|
|
ti (when (form-list? target) (vec (form-elements target)))
|
|
thead (when (and ti (pos? (count ti)) (form-sym? (first ti)))
|
|
(form-sym-name (first ti)))]
|
|
(cond
|
|
(and thead (field-head? thead))
|
|
{:op :set-field :obj (analyze ctx (nth ti 1) env)
|
|
:field (subs thead 2) :val val-node}
|
|
;; (set! (. Class member) val) — a host static-field set. clojure.spec.alpha
|
|
;; toggles clojure.lang.RT/checkSpecAsserts this way. Lowered to a runtime
|
|
;; jolt.host/set-static-field! call (the read side is a :host-static ref).
|
|
(and (= thead ".") (>= (count ti) 3) (form-sym? (nth ti 1)) (form-sym? (nth ti 2))
|
|
(= :class (:kind (resolve-global ctx (nth ti 1)))))
|
|
(invoke (var-ref "jolt.host" "set-static-field!")
|
|
[(const (:name (resolve-global ctx (nth ti 1))))
|
|
(const (form-sym-name (nth ti 2))) val-node])
|
|
(form-sym? target)
|
|
(do (when (local? env (form-sym-name target)) (uncompilable "set! of a local"))
|
|
(let [r (resolve-global ctx target)]
|
|
(when-not (= :var (:kind r)) (uncompilable "set! of a non-var"))
|
|
{:op :set-var :the-var (the-var (:ns r) (:name r)) :val val-node}))
|
|
:else (uncompilable "set! of an unsupported target"))))
|
|
|
|
(defn- analyze-special [ctx op items env]
|
|
(case op
|
|
"quote" (quote-node (second items))
|
|
"if" (do
|
|
;; 2 or 3 argument forms only (spec 03-special-forms X1)
|
|
(when (or (< (count items) 3) (> (count items) 4))
|
|
(throw (str "Wrong number of args (" (dec (count items)) ") passed to: if")))
|
|
(if-node (analyze ctx (nth items 1) env)
|
|
(analyze ctx (nth items 2) env)
|
|
(if (> (count items) 3)
|
|
(analyze ctx (nth items 3) env)
|
|
(const nil))))
|
|
"do" (analyze-seq ctx (rest items) env)
|
|
"throw" (throw-node (analyze ctx (nth items 1) env))
|
|
"def" (analyze-def ctx items env)
|
|
"let*" (let [bvec (vec (form-vec-items (nth items 1)))
|
|
r (analyze-bindings ctx bvec env)]
|
|
(let-node (first r) (analyze-seq ctx (drop 2 items) (second r))))
|
|
"loop*" (let [bvec (vec (form-vec-items (nth items 1)))
|
|
rname (gen-name "loop")
|
|
r (analyze-bindings ctx bvec env)
|
|
env** (with-recur (second r) rname)]
|
|
{:op :loop :recur-name rname :bindings (first r)
|
|
:body (analyze-seq ctx (drop 2 items) env**)})
|
|
"recur" (let [rt (:recur env)]
|
|
(when-not rt (uncompilable "recur outside loop/fn"))
|
|
{:op :recur :recur-name rt
|
|
:args (mapv #(analyze ctx % env) (rest items))})
|
|
"try" (analyze-try ctx items env)
|
|
"letfn" (analyze-letfn ctx items env)
|
|
"fn*" (analyze-fn ctx items env)
|
|
;; Lower the backtick to construction code (zero runtime cost), then analyze
|
|
;; it — the macroexpand/compile-time step, per read -> macroexpand -> compile.
|
|
"syntax-quote" (analyze ctx (form-syntax-quote-lower ctx (second items)) env)
|
|
"var" (let [sym (second items)
|
|
r (resolve-global ctx sym)]
|
|
(if (= :var (:kind r))
|
|
(the-var (:ns r) (:name r))
|
|
(uncompilable (str "var of non-var " (form-sym-name sym)))))
|
|
;; (set! *var* val): set the var's innermost thread binding, else its root
|
|
;; (jolt-var-set). A local target is a deftype mutable field — not yet
|
|
;; supported (jolt binds fields immutably); an interop (.-field) target too.
|
|
;; A defmacro that is not top-level (the spine intercepts those) — e.g. one
|
|
;; produced by a macro like (when … (defmacro …)). Lower it the way the spine
|
|
;; does: def the expander fn, then mark the var a macro at runtime so later
|
|
;; forms expand it. Strip a leading docstring / attr-map, as defmacro allows.
|
|
"defmacro" (let [name-sym (nth items 1)
|
|
nm (form-sym-name name-sym)
|
|
cur (compile-ns ctx)
|
|
after (drop 2 items)
|
|
after (if (string? (first after)) (rest after) after)
|
|
after (if (form-map? (first after)) (rest after) after)
|
|
;; build (fn params body…) and analyze it through the fn MACRO
|
|
;; so a destructuring macro arglist desugars (the fn* primitive
|
|
;; would not), then def it and mark the var a macro.
|
|
fn-form (cons (symbol "fn") after)]
|
|
(host-intern! ctx cur nm)
|
|
{:op :defmacro :ns cur :name nm
|
|
:fn (analyze ctx fn-form env)})
|
|
"set!" (analyze-set! ctx items env)
|
|
(uncompilable (str "special form " op))))
|
|
|
|
;; Host interop method call. `(.method target arg*)` — a head that
|
|
;; starts with "." but not ".-" (field access stays punted). Analyzes to a
|
|
;; :host-call node; the Chez back end lowers it to a jolt-host-call dispatch.
|
|
(defn- method-head? [nm]
|
|
(and (> (count nm) 1)
|
|
(= "." (subs nm 0 1))
|
|
(not (= "-" (subs nm 1 2))) ; .-field is field access
|
|
(not (= "." (subs nm 1 2))))) ; .. is the threading macro, not .method
|
|
|
|
(defn- analyze-host-call [ctx hname items env]
|
|
(when (< (count items) 2)
|
|
(throw (str "Malformed member expression, expecting (.method target ...): " hname)))
|
|
{:op :host-call
|
|
:method (subs hname 1)
|
|
:target (analyze ctx (nth items 1) env)
|
|
:args (mapv #(analyze ctx % env) (drop 2 items))})
|
|
|
|
;; A constructor head: `Class.` — a symbol ending in "." (but not the member
|
|
;; access `.method` / `..` forms). `(Class. args*)` builds an instance.
|
|
(defn- ctor-head? [nm]
|
|
(and (> (count nm) 1)
|
|
(= "." (subs nm (dec (count nm)) (count nm)))
|
|
(not (= "." (subs nm 0 1)))))
|
|
|
|
;; `(Class. args*)` and `(new Class args*)` -> a :host-new node carrying the class
|
|
;; token and the analyzed args. The Chez back end lowers it to a runtime
|
|
;; constructor dispatch.
|
|
(defn- analyze-ctor [ctx class args env]
|
|
(host-new class (mapv #(analyze ctx % env) args)))
|
|
|
|
;; jolt.ffi/__cfn: the low-level foreign-function form a jolt library
|
|
;; uses (via the jolt.ffi/foreign-fn macro) to bind native code. Shape:
|
|
;; (jolt.ffi/__cfn "c_symbol" [:argtype ...] :rettype) ; non-blocking
|
|
;; (jolt.ffi/__cfn "c_symbol" [:argtype ...] :rettype :blocking) ; may block
|
|
;; The C symbol is a string literal and the types are literal keywords, read here
|
|
;; at compile time; the Chez back end lowers it to a real `foreign-procedure`
|
|
;; (typed marshaling, no runtime eval). A :blocking call is emitted __collect_safe
|
|
;; so it deactivates the thread for the call — a blocking call (accept/recv/...)
|
|
;; must not pin the stop-the-world collector. A leaf IR node.
|
|
(defn- analyze-ffi-fn [ctx items env]
|
|
(when-not (<= 4 (count items) 5)
|
|
(throw (str "jolt.ffi/foreign-fn expects (foreign-fn \"sym\" [argtypes] rettype [:blocking])")))
|
|
{:op :ffi-fn
|
|
:csym (nth items 1)
|
|
:argtypes (mapv name (form-vec-items (nth items 2)))
|
|
:rettype (name (nth items 3))
|
|
:blocking (and (= 5 (count items)) (= "blocking" (name (nth items 4))))})
|
|
|
|
;; jolt.ffi/__ccallable: the foreign-CALLBACK form (via the jolt.ffi/foreign-callable
|
|
;; macro) — the inverse of __cfn. It wraps a jolt fn as a C-callable function
|
|
;; pointer so C can call back INTO jolt (GTK signal handlers, qsort comparators).
|
|
;; Shape:
|
|
;; (jolt.ffi/__ccallable f [:argtype ...] :rettype) ; thread stays active
|
|
;; (jolt.ffi/__ccallable f [:argtype ...] :rettype :collect-safe) ; may be invoked
|
|
;; ; while the thread is
|
|
;; ; parked in a :blocking call
|
|
;; Unlike __cfn, the fn is a CHILD expression (analyzed + walked by the passes);
|
|
;; the types are literal keywords read at compile time. The Chez back end lowers
|
|
;; it to a locked `foreign-callable` and returns its entry-point address (a jolt
|
|
;; pointer). :collect-safe is required when C invokes the callback from a thread
|
|
;; that is deactivated inside a :blocking foreign call (e.g. a GTK main loop).
|
|
(defn- analyze-ffi-callable [ctx items env]
|
|
(when-not (<= 4 (count items) 5)
|
|
(throw (str "jolt.ffi/foreign-callable expects (foreign-callable f [argtypes] rettype [:collect-safe])")))
|
|
{:op :ffi-callable
|
|
:fn (analyze ctx (nth items 1) env)
|
|
:argtypes (mapv name (form-vec-items (nth items 2)))
|
|
:rettype (name (nth items 3))
|
|
:collect-safe (and (= 5 (count items)) (= "collect-safe" (name (nth items 4))))})
|
|
|
|
;; The `.` special form: `(. target member arg*)` — member access / method call.
|
|
;; A symbol member whose name starts with "-" is a field read; otherwise it is a
|
|
;; method (call with the trailing args). Both lower to a :host-call carrying the
|
|
;; member name verbatim (the leading "-" survives so the runtime dispatcher reads
|
|
;; it as a field). The Chez back end dispatches it through record-method-dispatch.
|
|
(defn- analyze-dot [ctx items env]
|
|
(when (< (count items) 3)
|
|
(throw (str "Malformed (. target member ...) form")))
|
|
(let [target (nth items 1)
|
|
member (nth items 2)
|
|
;; (. Class method args*) with a class target is a static call —
|
|
;; equivalent to (Class/method args*). resolve-global tags a class
|
|
;; symbol :kind :class; a local of the same name shadows it.
|
|
class-target (when (and (form-sym? target)
|
|
(not (local? env (form-sym-name target))))
|
|
(let [r (resolve-global ctx target)]
|
|
(when (= :class (:kind r)) (:name r))))]
|
|
(cond
|
|
(and class-target (form-sym? member))
|
|
(invoke (host-static class-target (form-sym-name member))
|
|
(mapv #(analyze ctx % env) (drop 3 items)))
|
|
(form-sym? member)
|
|
{:op :host-call
|
|
:method (form-sym-name member)
|
|
:target (analyze ctx target env)
|
|
:args (mapv #(analyze ctx % env) (drop 3 items))}
|
|
;; (. obj :kw) is a keyword lookup — invoke the keyword on the target.
|
|
(form-keyword? member)
|
|
(invoke (analyze ctx member env) [(analyze ctx (nth items 1) env)])
|
|
:else (uncompilable "special form . (non-symbol member)"))))
|
|
|
|
(defn- analyze-field [ctx hname items env]
|
|
(when (< (count items) 2)
|
|
(throw (str "Malformed (.-field target) form")))
|
|
{:op :host-call
|
|
:method (subs hname 1) ; ".-field" -> "-field"
|
|
:target (analyze ctx (nth items 1) env)
|
|
:args []})
|
|
|
|
(defn- analyze-symbol [ctx form env]
|
|
(let [nm (form-sym-name form) ns (form-sym-ns form)]
|
|
(cond
|
|
(and (nil? ns) (local? env nm))
|
|
(let [h (get (:hints env) nm)] (if h (assoc (local nm) :hint h) (local nm)))
|
|
ns (let [r (resolve-global ctx form)]
|
|
(if (= :var (:kind r))
|
|
(cond-> (var-ref (:ns r) (:name r)) (:num-ret r) (assoc :num-ret (:num-ret r)))
|
|
;; A non-var qualified ref `Class/member` is a host class static
|
|
;; (Math/sqrt, Long/MAX_VALUE, System/getenv). The Chez back end
|
|
;; lowers it to a runtime static dispatch.
|
|
(host-static ns nm)))
|
|
:else (let [r (resolve-global ctx form)]
|
|
(case (:kind r)
|
|
;; :num-ret (a ^double/^long declared return) rides on the var node so
|
|
;; jolt.passes.numeric types a call to it (an accumulator over the result).
|
|
:var (cond-> (var-ref (:ns r) (:name r)) (:num-ret r) (assoc :num-ret (:num-ret r)))
|
|
:host (host-ref (:name r))
|
|
;; a class-name symbol (java.util.Map) self-evaluates to its name
|
|
;; string — jolt models a class as its name, with no JVM classes.
|
|
:class (const (:name r))
|
|
;; :unresolved — emitting a var-ref here would auto-intern an
|
|
;; UNBOUND var, so a typo'd symbol would die later as 'Cannot call
|
|
;; nil as a function' with no hint which symbol.
|
|
;; Punt to the interpreter: its resolver raises Clojure's
|
|
;; 'Unable to resolve symbol' when the form actually runs (at
|
|
;; eval for top-level forms, at call for fn bodies). A punt
|
|
;; rather than a hard throw because runtime-interning forms
|
|
;; (defmulti's setup call) legitimately reference the var they
|
|
;; are about to create when nested in a non-top-level do. Real
|
|
;; forward references want (declare ...), as in Clojure.
|
|
;; Under late-bind? (the Chez back end, which has no interpreter
|
|
;; to punt to) an unresolved symbol instead lowers to a var-ref
|
|
;; against the compile ns — resolved at runtime, the open-world
|
|
;; semantics of -e — so defmulti/defmethod forward references work.
|
|
(if (late-bind? ctx)
|
|
(var-ref (compile-ns ctx) nm)
|
|
(uncompilable (str "Unable to resolve symbol: " nm " in this context"))))))))
|
|
|
|
(defn- analyze-list [ctx form env]
|
|
(let [items (vec (form-elements form))]
|
|
(if (zero? (count items))
|
|
(quote-node form)
|
|
(let [head (first items)
|
|
hname (when (and (form-sym? head) (nil? (form-sym-ns head))) (form-sym-name head))
|
|
shadowed (and hname (local? env hname))]
|
|
(cond
|
|
;; Canonical order (Clojure/CLJS analyze-seq): macroexpand FIRST, then
|
|
;; dispatch special forms / interop / invoke. A local shadows the macro.
|
|
;; A true special form is NOT shadowable by a same-named macro, matching
|
|
;; the reference macroexpand1's isSpecial check — so a ns that redefs a
|
|
;; macro `def`/`and`/`or` (clojure.spec.alpha) keeps the special form `def`.
|
|
(and (form-sym? head) (not shadowed)
|
|
(not (contains? handled hname)) (form-macro? ctx head))
|
|
(analyze ctx (form-expand-1 ctx form) env)
|
|
;; jolt.ffi/__cfn — the foreign-function special form (always emitted
|
|
;; fully-qualified by the jolt.ffi/foreign-fn macro, so aliases resolve).
|
|
(and (form-sym? head) (= "jolt.ffi" (form-sym-ns head))
|
|
(= "__cfn" (form-sym-name head)))
|
|
(analyze-ffi-fn ctx items env)
|
|
;; jolt.ffi/__ccallable — the foreign-callback special form (the fn is a
|
|
;; child expression, analyzed here).
|
|
(and (form-sym? head) (= "jolt.ffi" (form-sym-ns head))
|
|
(= "__ccallable" (form-sym-name head)))
|
|
(analyze-ffi-callable ctx items env)
|
|
;; special-form heads are NOT shadowable (unlike macros): a local named
|
|
;; `if` does not change the meaning of (if …) in operator position, per
|
|
;; spec §3 and the reference. No (not shadowed) guard here.
|
|
(and hname (contains? handled hname))
|
|
(analyze-special ctx hname items env)
|
|
(and hname (not shadowed) (method-head? hname))
|
|
(analyze-host-call ctx hname items env)
|
|
;; (Class. args*) — trailing-dot constructor sugar.
|
|
(and hname (not shadowed) (ctor-head? hname))
|
|
(analyze-ctor ctx (subs hname 0 (dec (count hname))) (rest items) env)
|
|
;; (new Class args*) — explicit constructor.
|
|
(and (= hname "new") (not shadowed) (>= (count items) 2)
|
|
(form-sym? (nth items 1)))
|
|
(analyze-ctor ctx (form-sym-name (nth items 1)) (drop 2 items) env)
|
|
;; (. target member arg*) — the `.` special form.
|
|
(and (= hname ".") (not shadowed))
|
|
(analyze-dot ctx items env)
|
|
;; (.-field target) — field-access head.
|
|
(and hname (not shadowed) (field-head? hname))
|
|
(analyze-field ctx hname items env)
|
|
(and hname (not shadowed) (form-special? hname))
|
|
(uncompilable (str "special form " hname))
|
|
:else
|
|
;; stamp the list form's source offset onto the :invoke
|
|
;; so the success checker can report file:line:col. nil when the
|
|
;; reader did not record it (synthetic/macro-built forms).
|
|
(let [n (invoke (analyze ctx head env)
|
|
(mapv #(analyze ctx % env) (rest items)))
|
|
p (form-position form)]
|
|
(if p (assoc n :pos p) n)))))))
|
|
|
|
;; A vector/map/set literal carrying reader metadata (^:foo {…}, ^{:tag :int} [1])
|
|
;; keeps it as a runtime value: wrap the collection node in (with-meta coll meta).
|
|
;; The metadata is itself a form (its values may be expressions, ^{:a (f)}), so
|
|
;; analyze it. nil meta passes the node through. Arglist vectors never reach here —
|
|
;; analyze-arity reads their items directly — so a ^Type [args] hint is not wrapped.
|
|
(defn- with-coll-meta [ctx form env node]
|
|
(let [m (form-coll-meta form)]
|
|
(if (nil? m)
|
|
node
|
|
(invoke (var-ref "clojure.core" "with-meta") [node (analyze ctx m env)]))))
|
|
|
|
(defn analyze
|
|
([ctx form] (analyze ctx form (empty-env)))
|
|
([ctx form env]
|
|
(cond
|
|
(form-literal? form) (const form)
|
|
(form-sym? form) (analyze-symbol ctx form env)
|
|
(form-vec? form) (with-coll-meta ctx form env
|
|
(vector-node (mapv #(analyze ctx % env) (form-vec-items form))))
|
|
(form-map? form) (with-coll-meta ctx form env
|
|
(map-node (mapv (fn [p] [(analyze ctx (first p) env)
|
|
(analyze ctx (second p) env)])
|
|
(form-map-pairs form))))
|
|
(form-set? form) (with-coll-meta ctx form env
|
|
(set-node (mapv #(analyze ctx % env) (form-set-items form))))
|
|
(form-list? form) (analyze-list ctx form env)
|
|
;; regex literal #"…" -> a :regex IR node (leaf). The Chez back end emits a
|
|
;; jolt-regex value over the vendored irregex.
|
|
(form-regex? form) {:op :regex :source (form-regex-source form)}
|
|
;; #inst / #uuid literals -> :inst / :uuid IR leaves. The Chez back
|
|
;; end emits a runtime inst/uuid value (host/chez/java/inst-time.ss).
|
|
(form-inst? form) {:op :inst :source (form-inst-source form)}
|
|
(form-uuid? form) {:op :uuid :source (form-uuid-source form)}
|
|
;; bigdecimal literal (1.5M) -> a :bigdec leaf; the back end emits a runtime
|
|
;; jbigdec built from the numeric text.
|
|
(form-bigdec? form) {:op :bigdec :source (form-bigdec-source form)}
|
|
;; a live namespace value spliced into a form (~*ns* in a macro) -> a
|
|
;; :the-ns leaf the back end reconstructs by name at the call site.
|
|
(form-ns-value? form) {:op :the-ns :name (form-ns-value-name form)}
|
|
:else (uncompilable "unsupported form"))))
|