Chez Phase 3 inc 1: port emit.janet core ops to jolt.backend-scheme (Clojure)
First spine increment of self-hosting the compiler on Chez. The IR->Scheme emitter is host/chez/emit.janet (Janet); to get the analyzer emitting its own code on Chez with no Janet, the emitter logic has to be portable Clojure that cross-compiles and runs on Chez itself. jolt-core/jolt/backend-scheme.clj ports the core ops: const/local/var/the-var/ if/do/let/loop/recur/invoke (+ native-ops)/fn/def, plus the chez-str-lit/flonum/ munge/truthy-elision helpers and prelude-mode. Output is Scheme source text, op- for-op with emit.janet. recur-target/known-procs are dynamic vars (auto-restore, no throw-leak). Quote, collection literals, try/throw, host interop, regex/inst/ uuid and program assembly come in later increments (they throw not-yet-ported). Gate: test/chez/emit-parity.janet loads the Clojure emitter interpreted on the Janet host and runs each case through it -> Chez -> compares to the Janet CLI oracle. 18/18 incl fib, factorial loop, multi-arity, variadic, higher-order, #() shorthand, the mandelbrot kernel. emit-test 331/331 (emit.janet path untouched), conformance 355x3. jolt-hg7z.
This commit is contained in:
Yogthos
parent
109bfcd09d
commit
d6847b3ba4
2 changed files with 460 additions and 0 deletions
322
jolt-core/jolt/backend_scheme.clj
Normal file
322
jolt-core/jolt/backend_scheme.clj
Normal file
|
|
@ -0,0 +1,322 @@
|
||||||
|
(ns jolt.backend-scheme
|
||||||
|
"Portable Clojure IR -> Chez Scheme emitter (Chez Phase 3, jolt-cf1q.4).
|
||||||
|
|
||||||
|
The no-Janet replacement for host/chez/emit.janet: consumes the same
|
||||||
|
host-neutral IR (jolt.ir, see jolt-core/jolt/ir.clj) the analyzer produces and
|
||||||
|
emits Chez Scheme source TEXT. Pure jolt-core (clojure.core + clojure.string
|
||||||
|
only) so that, once cross-compiled, it runs ON Chez and the analyzer can emit
|
||||||
|
its own code with no Janet in the loop — the bootstrap spine.
|
||||||
|
|
||||||
|
Output is a STRING of Scheme source; `host/compile` on Chez is `(eval (read
|
||||||
|
...))`. Mirrors emit.janet op-for-op so the value-parity gate holds against the
|
||||||
|
Janet emitter while the port is in flight.
|
||||||
|
|
||||||
|
INCREMENT 1 (jolt-hg7z): const/local/var/the-var/if/do/let/loop/recur/invoke
|
||||||
|
(+ native-ops)/fn/def + the escaping/flonum/munge helpers — enough to compile
|
||||||
|
fib/mandelbrot-shaped code end to end. Quote, collection literals, try/throw,
|
||||||
|
host interop, regex/inst/uuid and program assembly land in later increments
|
||||||
|
(they throw `:not-yet-ported` here so an accidental hit is loud)."
|
||||||
|
(:require [clojure.string :as str]))
|
||||||
|
|
||||||
|
;; Hot clojure.core primitives lowered to native Scheme, mirroring the Janet
|
||||||
|
;; backend's native-ops. `=` is the exactness-aware jolt= from values.ss; inc/dec/
|
||||||
|
;; not are rt shims; mod/rem/quot map to Scheme's (Scheme has all three).
|
||||||
|
(def ^:private native-ops
|
||||||
|
{"+" "+" "-" "-" "*" "*" "/" "/"
|
||||||
|
"<" "<" ">" ">" "<=" "<=" ">=" ">="
|
||||||
|
"=" "jolt=" "inc" "jolt-inc" "dec" "jolt-dec" "not" "jolt-not"
|
||||||
|
"min" "min" "max" "max"
|
||||||
|
"mod" "modulo" "rem" "remainder" "quot" "quotient"
|
||||||
|
"vector" "jolt-vector" "hash-map" "jolt-hash-map" "hash-set" "jolt-hash-set"
|
||||||
|
"conj" "jolt-conj" "get" "jolt-get" "nth" "jolt-nth" "count" "jolt-count"
|
||||||
|
"assoc" "jolt-assoc" "dissoc" "jolt-dissoc" "contains?" "jolt-contains?"
|
||||||
|
"empty?" "jolt-empty?" "peek" "jolt-peek" "pop" "jolt-pop"
|
||||||
|
"first" "jolt-first" "rest" "jolt-rest" "next" "jolt-next" "seq" "jolt-seq"
|
||||||
|
"cons" "jolt-cons" "list" "jolt-list" "reverse" "jolt-reverse" "last" "jolt-last"
|
||||||
|
"map" "jolt-map" "filter" "jolt-filter" "remove" "jolt-remove"
|
||||||
|
"reduce" "jolt-reduce" "into" "jolt-into" "concat" "jolt-concat" "apply" "jolt-apply"
|
||||||
|
"range" "jolt-range" "take" "jolt-take" "drop" "jolt-drop"
|
||||||
|
"keys" "jolt-keys" "vals" "jolt-vals"
|
||||||
|
"even?" "jolt-even?" "odd?" "jolt-odd?" "pos?" "jolt-pos?" "neg?" "jolt-neg?"
|
||||||
|
"zero?" "jolt-zero?" "identity" "jolt-identity"
|
||||||
|
"ex-info" "jolt-ex-info"})
|
||||||
|
|
||||||
|
;; Value-position resolution for a clojure.core ref passed AS A VALUE (to map /
|
||||||
|
;; filter / reduce / apply). Arithmetic is the exception — Scheme's +/-/*// return
|
||||||
|
;; EXACT results for exact/zero-arg inputs, breaking the all-double model in
|
||||||
|
;; higher-order use, so value-position arithmetic routes to the flonum wrappers.
|
||||||
|
(def ^:private core-value-procs
|
||||||
|
(merge native-ops {"+" "jolt-add" "-" "jolt-sub" "*" "jolt-mul" "/" "jolt-div"}))
|
||||||
|
|
||||||
|
;; Per-op arity gate: only lower when the Scheme prim and the jolt fn agree at
|
||||||
|
;; this arity. Ops absent from the table are variadic (legal at any arity).
|
||||||
|
(def ^:private op-arity
|
||||||
|
{"inc" #(= % 1) "dec" #(= % 1) "not" #(= % 1)
|
||||||
|
"count" #(= % 1) "empty?" #(= % 1) "peek" #(= % 1) "pop" #(= % 1)
|
||||||
|
"mod" #(= % 2) "rem" #(= % 2) "quot" #(= % 2) "contains?" #(= % 2)
|
||||||
|
"get" #(or (= % 2) (= % 3)) "nth" #(or (= % 2) (= % 3))
|
||||||
|
"assoc" #(and (>= % 3) (odd? %)) "dissoc" #(>= % 1) "conj" #(>= % 1)
|
||||||
|
"first" #(= % 1) "rest" #(= % 1) "next" #(= % 1) "seq" #(= % 1)
|
||||||
|
"reverse" #(= % 1) "last" #(= % 1) "keys" #(= % 1) "vals" #(= % 1)
|
||||||
|
"even?" #(= % 1) "odd?" #(= % 1) "pos?" #(= % 1) "neg?" #(= % 1)
|
||||||
|
"zero?" #(= % 1) "identity" #(= % 1)
|
||||||
|
"cons" #(= % 2) "filter" #(= % 2) "remove" #(= % 2) "into" #(= % 2)
|
||||||
|
"take" #(= % 2) "drop" #(= % 2) "map" #(>= % 2) "apply" #(>= % 2)
|
||||||
|
"reduce" #(or (= % 2) (= % 3)) "range" #(and (>= % 0) (<= % 3))
|
||||||
|
"ex-info" #(or (= % 2) (= % 3))})
|
||||||
|
|
||||||
|
;; jolt's comparison ops are vacuously true at arity 1 and DON'T inspect the arg,
|
||||||
|
;; but Scheme's < demands a number even there — special-case.
|
||||||
|
(def ^:private cmp1-ops #{"<" ">" "<=" ">="})
|
||||||
|
|
||||||
|
;; Native-op Scheme procedures that return a genuine Scheme boolean (#t/#f), so an
|
||||||
|
;; :if test built from them needs no jolt-truthy? wrapper (jolt-nkcb).
|
||||||
|
(def ^:private bool-returning-ops
|
||||||
|
#{"<" "<=" ">" ">=" "jolt=" "jolt-not"
|
||||||
|
"jolt-even?" "jolt-odd?" "jolt-pos?" "jolt-neg?"
|
||||||
|
"jolt-zero?" "jolt-empty?" "jolt-contains?"})
|
||||||
|
|
||||||
|
;; PRELUDE MODE (inc 3d). The default (subset) mode rejects any clojure.core ref
|
||||||
|
;; that isn't a native-op — a clean "out of subset" signal for user-facing `-e`.
|
||||||
|
;; When emitting clojure.core ITSELF as a prelude, core fns reference each other
|
||||||
|
;; constantly; those lower to var-deref (resolved at runtime).
|
||||||
|
(def prelude-mode? (atom false))
|
||||||
|
(defn set-prelude-mode! [on] (reset! prelude-mode? on))
|
||||||
|
|
||||||
|
;; recur-target and the set of munged local names known to hold a procedure (a
|
||||||
|
;; named fn's self-recursion name) are lexically scoped — dynamic vars so the
|
||||||
|
;; recursion auto-restores them (no manual save/restore, no throw-leak).
|
||||||
|
(def ^:dynamic *recur-target* nil)
|
||||||
|
(def ^:dynamic *known-procs* #{})
|
||||||
|
|
||||||
|
(def ^:private gensym-counter (atom 0))
|
||||||
|
(defn- fresh-label [prefix] (str prefix (swap! gensym-counter inc)))
|
||||||
|
|
||||||
|
;; Most jolt names are already valid Scheme identifiers. The one that isn't is
|
||||||
|
;; `#`, which jolt auto-gensyms use as a suffix (p1__0000X4# from #(...)) — `#`
|
||||||
|
;; starts a datum in Scheme, so replace it with `_`.
|
||||||
|
(defn- munge-name [s] (str/replace s "#" "_"))
|
||||||
|
|
||||||
|
(declare emit)
|
||||||
|
|
||||||
|
;; A Chez string literal (jolt-x0os). Every char outside printable ASCII becomes a
|
||||||
|
;; codepoint hex escape \x<cp>; ; the named escapes (\n \t \r \" \\) match what
|
||||||
|
;; Chez's reader accepts. For pure printable ASCII this is byte-identical to %j.
|
||||||
|
(defn- char-escape [cp]
|
||||||
|
(cond
|
||||||
|
(= cp 34) "\\\""
|
||||||
|
(= cp 92) "\\\\"
|
||||||
|
(= cp 10) "\\n"
|
||||||
|
(= cp 9) "\\t"
|
||||||
|
(= cp 13) "\\r"
|
||||||
|
(and (>= cp 32) (< cp 127)) (str (char cp))
|
||||||
|
:else (str "\\x" (format "%x" cp) ";")))
|
||||||
|
|
||||||
|
(defn- chez-str-lit [s]
|
||||||
|
(str "\"" (apply str (map (fn [c] (char-escape (int c))) s)) "\""))
|
||||||
|
|
||||||
|
(defn- emit-const [v]
|
||||||
|
(cond
|
||||||
|
(nil? v) "jolt-nil"
|
||||||
|
(boolean? v) (if v "#t" "#f")
|
||||||
|
;; jolt models every number as a double. Emit flonums so arithmetic matches
|
||||||
|
;; the Janet host and Chez doesn't fall into exploding exact rationals.
|
||||||
|
;; ##Inf/##-Inf/##NaN -> Chez's flonum literals (Janet stringifies them as
|
||||||
|
;; inf/-inf/nan, unbound symbols in Chez).
|
||||||
|
(number? v) (cond
|
||||||
|
(= v ##Inf) "+inf.0"
|
||||||
|
(= v ##-Inf) "-inf.0"
|
||||||
|
(not= v v) "+nan.0"
|
||||||
|
:else (let [s (str v)]
|
||||||
|
(if (or (str/includes? s ".") (str/includes? s "e")) s (str s ".0"))))
|
||||||
|
(string? v) (chez-str-lit v)
|
||||||
|
;; keyword literal -> (keyword ns name)
|
||||||
|
(keyword? v) (if-let [kns (namespace v)]
|
||||||
|
(str "(keyword " (chez-str-lit kns) " " (chez-str-lit (name v)) ")")
|
||||||
|
(str "(keyword #f " (chez-str-lit (name v)) ")"))
|
||||||
|
;; jolt char value {:ch <codepoint> :jolt/type :jolt/char}
|
||||||
|
(and (map? v) (= :jolt/char (:jolt/type v)))
|
||||||
|
(str "(integer->char " (:ch v) ")")
|
||||||
|
:else (throw (ex-info (str "emit-const: unsupported literal " (pr-str v)) {}))))
|
||||||
|
|
||||||
|
;; A def's :meta is a jolt map value. Non-empty? (a plain def carries {}).
|
||||||
|
(defn- jmeta-nonempty? [m] (and (map? m) (pos? (count m))))
|
||||||
|
|
||||||
|
(defn- emit-binding [b]
|
||||||
|
(str "(" (munge-name (nth b 0)) " " (emit (nth b 1)) ")"))
|
||||||
|
|
||||||
|
;; letfn lowers to a :let flagged :letrec (mutually-recursive named local fns):
|
||||||
|
;; Scheme `letrec*` binds them so each sees its siblings. A plain let uses let*.
|
||||||
|
(defn- emit-let [node]
|
||||||
|
(let [kw (if (:letrec node) "letrec*" "let*")]
|
||||||
|
(str "(" kw " (" (str/join " " (map emit-binding (:bindings node))) ") "
|
||||||
|
(emit (:body node)) ")")))
|
||||||
|
|
||||||
|
(defn- emit-loop [node]
|
||||||
|
(let [label (fresh-label "loop")
|
||||||
|
pairs (:bindings node)
|
||||||
|
names (map #(munge-name (nth % 0)) pairs)
|
||||||
|
;; inits evaluate in the OUTER scope (recur-target unchanged) and, like
|
||||||
|
;; Clojure loop/let, SEQUENTIALLY — wrap a let* around the named let.
|
||||||
|
inits (map #(emit (nth % 1)) pairs)
|
||||||
|
seq-bs (str/join " " (map (fn [n i] (str "(" n " " i ")")) names inits))
|
||||||
|
rebinds (str/join " " (map (fn [n] (str "(" n " " n ")")) names))
|
||||||
|
body (binding [*recur-target* label] (emit (:body node)))]
|
||||||
|
(str "(let* (" seq-bs ") (let " label " (" rebinds ") " body "))")))
|
||||||
|
|
||||||
|
(defn- emit-recur [node]
|
||||||
|
(when-not *recur-target* (throw (ex-info "emit: recur outside a loop/fn target" {})))
|
||||||
|
(str "(" *recur-target* " " (str/join " " (map emit (:args node))) ")"))
|
||||||
|
|
||||||
|
;; One arity -> a Scheme lambda param-list + a named-let-wrapped body. The named
|
||||||
|
;; let lets fn-level `recur` rebind this arity's params. A variadic arity takes a
|
||||||
|
;; Scheme rest arg coerced to a jolt seq (nil when empty); recur carries the rest
|
||||||
|
;; seq directly, and the named let's init only runs on first entry.
|
||||||
|
(defn- emit-arity-clause [a]
|
||||||
|
(let [params (map munge-name (:params a))
|
||||||
|
restp (when-let [r (:rest a)] (munge-name r))
|
||||||
|
label (fresh-label "fnrec")
|
||||||
|
body (binding [*recur-target* label] (emit (:body a)))
|
||||||
|
paramlist (cond
|
||||||
|
(and restp (empty? params)) restp
|
||||||
|
restp (str "(" (str/join " " params) " . " restp ")")
|
||||||
|
:else (str "(" (str/join " " params) ")"))
|
||||||
|
binds (if restp
|
||||||
|
(concat (map (fn [p] (str "(" p " " p ")")) params)
|
||||||
|
[(str "(" restp " (list->cseq " restp "))")])
|
||||||
|
(map (fn [p] (str "(" p " " p ")")) params))]
|
||||||
|
[paramlist (str "(let " label " (" (str/join " " binds) ") " body ")")]))
|
||||||
|
|
||||||
|
(defn- emit-fn [node]
|
||||||
|
(let [arities (:arities node)
|
||||||
|
;; a named fn binds its own name as a known-procedure local across ALL
|
||||||
|
;; arities, so self-calls emit directly rather than via jolt-invoke.
|
||||||
|
self (when-let [nm (:name node)] (munge-name nm))
|
||||||
|
clauses (binding [*known-procs* (if self (conj *known-procs* self) *known-procs*)]
|
||||||
|
(mapv emit-arity-clause arities))
|
||||||
|
lambda (if (= 1 (count clauses))
|
||||||
|
(let [c (first clauses)] (str "(lambda " (nth c 0) " " (nth c 1) ")"))
|
||||||
|
(str "(case-lambda "
|
||||||
|
(str/join " " (map (fn [c] (str "(" (nth c 0) " " (nth c 1) ")")) clauses))
|
||||||
|
")"))]
|
||||||
|
;; A named fn references itself by name — the analyzer binds that name as a
|
||||||
|
;; :local in the body. letrec makes the name visible to the lambda.
|
||||||
|
(if-let [nm (:name node)]
|
||||||
|
(let [m (munge-name nm)] (str "(letrec ((" m " " lambda ")) " m ")"))
|
||||||
|
lambda)))
|
||||||
|
|
||||||
|
;; If fnode is a clojure.core (or host) ref to a native-op primitive, return the
|
||||||
|
;; Scheme op string — only at an arity where the Scheme op and the jolt fn agree.
|
||||||
|
(defn- native-op [fnode nargs]
|
||||||
|
(let [nm (case (:op fnode)
|
||||||
|
:var (when (= "clojure.core" (:ns fnode)) (:name fnode))
|
||||||
|
:host (:name fnode)
|
||||||
|
nil)
|
||||||
|
op (when nm (native-ops nm))
|
||||||
|
arity-ok (when nm (op-arity nm))]
|
||||||
|
(cond
|
||||||
|
(nil? op) nil
|
||||||
|
(and arity-ok (not (arity-ok nargs))) nil
|
||||||
|
:else op)))
|
||||||
|
|
||||||
|
;; IFn dispatch for a LITERAL callee (Clojure's "value as fn"): a keyword looks
|
||||||
|
;; itself up in its arg; a map/set/vector literal looks up its arg.
|
||||||
|
(defn- ifn-kind [fnode]
|
||||||
|
(case (:op fnode)
|
||||||
|
:const (when (keyword? (:val fnode)) :keyword)
|
||||||
|
(:map :set :vector) :coll
|
||||||
|
nil))
|
||||||
|
|
||||||
|
;; A reference into the Clojure stdlib (clojure.*) with no impl on Chez yet.
|
||||||
|
(defn- stdlib-var? [n]
|
||||||
|
(and (= :var (:op n)) (str/starts-with? (or (:ns n) "") "clojure.")))
|
||||||
|
|
||||||
|
(defn- emit-invoke [node]
|
||||||
|
(let [fnode (:fn node)
|
||||||
|
args (mapv emit (:args node))
|
||||||
|
nop (native-op fnode (count args))
|
||||||
|
kind (ifn-kind fnode)
|
||||||
|
default (if (> (count args) 1) (str " " (nth args 1)) "")]
|
||||||
|
(cond
|
||||||
|
;; zero-arg + / * : flonum identity to keep the all-double model.
|
||||||
|
(and nop (empty? args) (= nop "+")) "0.0"
|
||||||
|
(and nop (empty? args) (= nop "*")) "1.0"
|
||||||
|
(and nop (= 1 (count args)) (cmp1-ops nop)) (str "(begin " (first args) " #t)")
|
||||||
|
nop (str "(" nop " " (str/join " " args) ")")
|
||||||
|
;; (:k coll [default]) -> (jolt-get coll :k [default])
|
||||||
|
(= kind :keyword) (str "(jolt-get " (first args) " " (emit fnode) default ")")
|
||||||
|
;; (coll k [default]) -> (jolt-get coll k [default])
|
||||||
|
(= kind :coll) (str "(jolt-get " (emit fnode) " " (first args) default ")")
|
||||||
|
(and (stdlib-var? fnode) (not (deref prelude-mode?)))
|
||||||
|
(throw (ex-info (str "emit: unsupported stdlib fn `" (:ns fnode) "/" (:name fnode)
|
||||||
|
"` (no core on Chez yet)") {}))
|
||||||
|
;; static method call (Class/method arg*) -> (host-static-call ...).
|
||||||
|
(= :host-static (:op fnode))
|
||||||
|
(str "(host-static-call " (chez-str-lit (:class fnode)) " " (chez-str-lit (:member fnode))
|
||||||
|
(if (empty? args) "" (str " " (str/join " " args))) ")")
|
||||||
|
(= :host (:op fnode))
|
||||||
|
(throw (ex-info (str "emit: unsupported host call `" (:name fnode) "`") {}))
|
||||||
|
;; a :local callee that isn't a known procedure -> dynamic IFn dispatch.
|
||||||
|
(and (= :local (:op fnode)) (not (*known-procs* (munge-name (:name fnode)))))
|
||||||
|
(str "(jolt-invoke " (emit fnode) " " (str/join " " args) ")")
|
||||||
|
;; a late-bound :var call head can hold a procedure OR a non-applicable
|
||||||
|
;; value the RT dispatches (multimethod, keyword/coll IFn) — route via
|
||||||
|
;; jolt-invoke (transparent for a procedure).
|
||||||
|
(= :var (:op fnode))
|
||||||
|
(str "(jolt-invoke " (emit fnode) " " (str/join " " args) ")")
|
||||||
|
;; a computed callee can yield ANY IFn — route through jolt-invoke.
|
||||||
|
:else
|
||||||
|
(str "(jolt-invoke " (emit fnode) " " (str/join " " args) ")"))))
|
||||||
|
|
||||||
|
;; Does this IR node emit to an expression that yields a Scheme boolean? Used to
|
||||||
|
;; drop the redundant jolt-truthy? on an :if test.
|
||||||
|
(defn- returns-scheme-bool? [node]
|
||||||
|
(cond
|
||||||
|
(and (= :const (:op node)) (boolean? (:val node))) true
|
||||||
|
(= :invoke (:op node))
|
||||||
|
(let [nop (native-op (:fn node) (count (:args node)))]
|
||||||
|
(if (and nop (bool-returning-ops nop)) true false))
|
||||||
|
:else false))
|
||||||
|
|
||||||
|
(defn emit [node]
|
||||||
|
(case (:op node)
|
||||||
|
:const (emit-const (:val node))
|
||||||
|
:local (munge-name (:name node))
|
||||||
|
;; late-bound var: read the cell's current root at use time. A value-position
|
||||||
|
;; ref to a clojure.core fn the RT provides lowers to the RT procedure.
|
||||||
|
:var (let [core-proc (and (= "clojure.core" (:ns node)) (core-value-procs (:name node)))]
|
||||||
|
(cond
|
||||||
|
core-proc core-proc
|
||||||
|
(and (stdlib-var? node) (not (deref prelude-mode?)))
|
||||||
|
(throw (ex-info (str "emit: unsupported stdlib ref `" (:ns node) "/" (:name node)
|
||||||
|
"` (no core on Chez yet)") {}))
|
||||||
|
:else (str "(var-deref " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) ")")))
|
||||||
|
:the-var (str "(jolt-var " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) ")")
|
||||||
|
:host (throw (ex-info (str "emit: unsupported host ref `" (:name node) "`") {}))
|
||||||
|
:host-static (str "(host-static-ref " (chez-str-lit (:class node)) " "
|
||||||
|
(chez-str-lit (:member node)) ")")
|
||||||
|
:host-new (str "(host-new " (chez-str-lit (:class node))
|
||||||
|
(let [args (map emit (:args node))]
|
||||||
|
(if (empty? args) "" (str " " (str/join " " args)))) ")")
|
||||||
|
:if (let [test (:test node)
|
||||||
|
t (if (returns-scheme-bool? test) (emit test)
|
||||||
|
(str "(jolt-truthy? " (emit test) ")"))]
|
||||||
|
(str "(if " t " " (emit (:then node)) " " (emit (:else node)) ")"))
|
||||||
|
:do (str "(begin " (str/join " " (map emit (:statements node)))
|
||||||
|
(if (empty? (:statements node)) "" " ") (emit (:ret node)) ")")
|
||||||
|
:invoke (emit-invoke node)
|
||||||
|
:let (emit-let node)
|
||||||
|
:loop (emit-loop node)
|
||||||
|
:recur (emit-recur node)
|
||||||
|
:fn (emit-fn node)
|
||||||
|
;; (def name) with no init (declare): reserve the cell. A def with non-empty
|
||||||
|
;; reader metadata lowers to def-var-with-meta! (ported in a later increment).
|
||||||
|
:def (cond
|
||||||
|
(:no-init node)
|
||||||
|
(str "(declare-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) ")")
|
||||||
|
(jmeta-nonempty? (:meta node))
|
||||||
|
(throw (ex-info "emit: def with non-empty meta not yet ported (inc 2)" {}))
|
||||||
|
:else
|
||||||
|
(str "(def-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " "
|
||||||
|
(emit (:init node)) ")"))
|
||||||
|
(throw (ex-info (str "emit: op not yet ported / unhandled: " (pr-str (:op node))) {}))))
|
||||||
138
test/chez/emit-parity.janet
Normal file
138
test/chez/emit-parity.janet
Normal file
|
|
@ -0,0 +1,138 @@
|
||||||
|
# Chez Phase 3 inc 1 (jolt-hg7z) — value-parity gate for the PORTABLE Clojure
|
||||||
|
# emitter (jolt.backend-scheme) vs the Janet host oracle.
|
||||||
|
#
|
||||||
|
# The new emitter is jolt-core Clojure; here it runs interpreted ON THE JANET HOST
|
||||||
|
# (loaded via bootstrap-load-source) as a drop-in for host/chez/emit.janet. Each
|
||||||
|
# case is analyzed to IR, emitted to Scheme by the CLOJURE emitter, run on Chez,
|
||||||
|
# and compared to the same program evaluated by the Janet host (jolt's own oracle).
|
||||||
|
# This isolates "is the translation correct" from "does it run on Chez" — the
|
||||||
|
# emitter's logic is validated before it has to execute on Chez itself.
|
||||||
|
#
|
||||||
|
# janet test/chez/emit-parity.janet (from repo root)
|
||||||
|
(import ../../src/jolt/api :as api)
|
||||||
|
(import ../../src/jolt/backend :as backend)
|
||||||
|
(import ../../src/jolt/reader :as r)
|
||||||
|
(import ../../src/jolt/evaluator :as evlr)
|
||||||
|
(import ../../host/chez/driver :as d)
|
||||||
|
(import ../../host/chez/emit :as emit)
|
||||||
|
(import ../../src/jolt/types_ctx :as tctx)
|
||||||
|
(import ../../src/jolt/types_ns :as tns)
|
||||||
|
(import ../../src/jolt/types_var :as tvar)
|
||||||
|
|
||||||
|
(unless (d/chez-available?)
|
||||||
|
(print "skip: chez not on PATH")
|
||||||
|
(os/exit 0))
|
||||||
|
|
||||||
|
(var total 0) (var fails 0)
|
||||||
|
(defn ok [name pred &opt extra]
|
||||||
|
(++ total)
|
||||||
|
(if pred (printf "ok: %s" name)
|
||||||
|
(do (++ fails) (printf "FAIL: %s %s" name (or extra "")))))
|
||||||
|
|
||||||
|
# ctx with the analyzer pipeline + late-bind (same as the driver), plus the
|
||||||
|
# Clojure emitter loaded interpreted so we can call jolt.backend-scheme/emit.
|
||||||
|
(def ctx (d/make-ctx))
|
||||||
|
(def bs-src (get (get (ctx :env) :embedded-sources) "jolt.backend-scheme"))
|
||||||
|
(assert bs-src "jolt.backend-scheme not embedded — check stdlib_embed collect")
|
||||||
|
(backend/bootstrap-load-source ctx "jolt.backend-scheme" bs-src)
|
||||||
|
(def emit-clj-var (tns/ns-find (tctx/ctx-find-ns ctx "jolt.backend-scheme") "emit"))
|
||||||
|
(assert emit-clj-var "jolt.backend-scheme/emit not found after load")
|
||||||
|
(defn emit-clj [ir] (string ((tvar/var-get emit-clj-var) ir)))
|
||||||
|
|
||||||
|
# Janet host oracle, via the real CLI (-e), exactly like run-corpus.janet: take the
|
||||||
|
# last non-empty stdout line so collection values use jolt's real printer.
|
||||||
|
(defn cli-oracle [src]
|
||||||
|
(def proc (os/spawn ["build/jolt" "-e" src] :p {:out :pipe :err :pipe}))
|
||||||
|
(def out (ev/read (proc :out) 0x100000))
|
||||||
|
(ev/read (proc :err) 0x100000)
|
||||||
|
(os/proc-wait proc)
|
||||||
|
(def lines (filter (fn [l] (not (empty? l))) (string/split "\n" (string/trim (if out (string out) "")))))
|
||||||
|
(if (empty? lines) "" (last lines)))
|
||||||
|
|
||||||
|
(defn- parse-all [src]
|
||||||
|
(def out @[])
|
||||||
|
(var s src)
|
||||||
|
(while (> (length (string/trim s)) 0)
|
||||||
|
(def parsed (r/parse-next s))
|
||||||
|
(set s (in parsed 1))
|
||||||
|
(def f (in parsed 0))
|
||||||
|
(unless (nil? f) (array/push out f)))
|
||||||
|
out)
|
||||||
|
|
||||||
|
# Drain a pipe to EOF (a stdout side effect can flush in >1 write).
|
||||||
|
(defn- drain [pipe]
|
||||||
|
(def b @"")
|
||||||
|
(var c (ev/read pipe 0x10000))
|
||||||
|
(while c (buffer/push b c) (set c (ev/read pipe 0x10000)))
|
||||||
|
(string b))
|
||||||
|
|
||||||
|
# Compile `src` to a Chez program using the CLOJURE emitter, run it, return
|
||||||
|
# [code stdout stderr]. Mirrors driver/compile-program + run-on-chez but swaps
|
||||||
|
# emit/emit -> emit-clj.
|
||||||
|
(defn run-clj [src]
|
||||||
|
(def forms (parse-all src))
|
||||||
|
(def n (length forms))
|
||||||
|
(def def-scm @[])
|
||||||
|
(for i 0 (- n 1)
|
||||||
|
(def f (in forms i))
|
||||||
|
(array/push def-scm (emit-clj (backend/analyze-form ctx f)))
|
||||||
|
(evlr/eval-form ctx @{} f))
|
||||||
|
(def final-scm (emit-clj (backend/analyze-form ctx (in forms (- n 1)))))
|
||||||
|
(def prog (emit/program def-scm final-scm))
|
||||||
|
(def path (string "/tmp/jolt-chez-parity-" (os/getpid) ".ss"))
|
||||||
|
(spit path prog)
|
||||||
|
(def proc (os/spawn ["chez" "--script" path] :p {:out :pipe :err :pipe}))
|
||||||
|
(def out (drain (proc :out)))
|
||||||
|
(def err (drain (proc :err)))
|
||||||
|
(def code (os/proc-wait proc))
|
||||||
|
[code (string/trim out) (string/trim err)])
|
||||||
|
|
||||||
|
# A case passes when the Clojure emitter's Chez output equals the Janet oracle.
|
||||||
|
(defn check [name src]
|
||||||
|
(def want (cli-oracle src))
|
||||||
|
(def [code out err] (run-clj src))
|
||||||
|
(ok name (and (= code 0) (= out want))
|
||||||
|
(string "chez=" out " oracle=" want " code=" code " | " err)))
|
||||||
|
|
||||||
|
# --- inc 1 subset: const/local/var/if/do/let/loop/recur/invoke/fn/def ----------
|
||||||
|
|
||||||
|
(check "(+ 1 2)" "(+ 1 2)")
|
||||||
|
(check "arith mixed" "(- (* 3 4) (/ 10 2))")
|
||||||
|
(check "nested let" "(let [a 1 b (+ a 10) c (* b 2)] (- c a))")
|
||||||
|
(check "let sequential" "(loop [a 1 b (+ a 10)] (+ a b))")
|
||||||
|
(check "if comparison" "(if (< 3 5) 100 200)")
|
||||||
|
(check "if =" "(if (= 2 2) :y :n)")
|
||||||
|
(check "do side-effect ret" "(do 1 2 3)")
|
||||||
|
(check "fib 30" "(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (fib 30)")
|
||||||
|
(check "factorial loop" "(defn fact [n] (loop [i n acc 1] (if (< i 2) acc (recur (- i 1) (* acc i))))) (fact 10)")
|
||||||
|
(check "multi-arity" "(defn g ([x] (g x 10)) ([x y] (+ x y))) (g 5)")
|
||||||
|
(check "variadic" "(defn s [& xs] (reduce + 0 xs)) (s 1 2 3 4)")
|
||||||
|
(check "higher-order inc" "(reduce + 0 (map inc (range 5)))")
|
||||||
|
(check "anon fn invoke" "((fn [x] (* x x)) 7)")
|
||||||
|
(check "shorthand fn" "(#(+ %1 %2) 3 4)")
|
||||||
|
(check "truthy local" "(defn t [x] (if x 1 2)) (t false)")
|
||||||
|
(check "mod rem quot" "(+ (mod 17 5) (rem 17 5) (quot 17 5))")
|
||||||
|
(check "min max" "(+ (min 3 1 2) (max 3 1 2))")
|
||||||
|
(check "mandelbrot run(20)"
|
||||||
|
(string ``
|
||||||
|
(defn count-point [cr ci cap]
|
||||||
|
(loop [i 0 zr 0.0 zi 0.0]
|
||||||
|
(if (or (>= i cap) (> (+ (* zr zr) (* zi zi)) 4.0))
|
||||||
|
i
|
||||||
|
(recur (inc i) (+ (- (* zr zr) (* zi zi)) cr) (+ (* 2.0 (* zr zi)) ci)))))
|
||||||
|
(defn run [n]
|
||||||
|
(let [cap 200 nd (* 1.0 n)]
|
||||||
|
(loop [y 0 acc 0]
|
||||||
|
(if (< y n)
|
||||||
|
(let [ci (- (/ (* 2.0 y) nd) 1.0)
|
||||||
|
row (loop [x 0 a 0]
|
||||||
|
(if (< x n)
|
||||||
|
(let [cr (- (/ (* 2.0 x) nd) 1.5)]
|
||||||
|
(recur (inc x) (+ a (count-point cr ci cap))))
|
||||||
|
a))]
|
||||||
|
(recur (inc y) (+ acc row)))
|
||||||
|
acc))))
|
||||||
|
`` "\n(run 20)"))
|
||||||
|
|
||||||
|
(printf "\n%d/%d ok" (- total fails) total)
|
||||||
|
(when (> fails 0) (os/exit 1))
|
||||||
Loading…
Add table
Add a link
Reference in a new issue