diff --git a/host/chez/driver.janet b/host/chez/driver.janet index f075071..d9c2f75 100644 --- a/host/chez/driver.janet +++ b/host/chez/driver.janet @@ -158,6 +158,47 @@ (and (indexed? f) (> (length f) 0) (let [h (sym-name (in f 0))] (and h (or (= h "defmacro") (= h "definline")))))) +# Extract [name-string fn-form] from (defmacro NAME ...rest): the macro's expander +# as a bare (fn ...rest), docstring/attr-map stripped. Mirrors eval_special.janet/ +# eval-defmacro's parsing — bare name (no metadata on the name in core/stdlib), +# optional docstring, optional attr-map, then a params vector + body (single arity) +# OR arity clauses. Uses the `fn` MACRO (not fn*) so a destructured macro arglist +# desugars before lowering, like api/macro-compile-hook. +# +# We emit the BARE fn (not (def NAME ...)) on purpose: analyzing a def would +# host-intern! NAME in the Janet build ctx as a non-macro nil-root stub, and that +# stub makes a later (require '[stdlib-ns]) skip loading the REAL macro — so the +# Janet-hosted analyzer (the parity oracle) would treat e.g. with-pprint-dispatch +# as a fn and return its unexpanded template. The caller wraps the emitted lambda +# in def-var! manually, so NAME is never interned and require still works (jolt-r9lm). +(defn- defmacro->fn [f] + (def name-sym (in f 1)) + (def after-name (tuple/slice f 2)) + (def a1 (if (and (> (length after-name) 0) (string? (first after-name))) + (tuple/slice after-name 1) after-name)) + (def after-meta (if (and (> (length a1) 0) (struct? (first a1)) + (not= :symbol (get (first a1) :jolt/type))) + (tuple/slice a1 1) a1)) + (def fn-sym {:jolt/type :symbol :ns nil :name "fn"}) + [(sym-name name-sym) (array fn-sym ;after-meta)]) + +# Cross-compile one top-level form to its guard-wrapped Scheme string, or nil if it +# doesn't emit (out of subset). A defmacro emits as (def-var! ns name ) +# plus (mark-macro! ns name) so the on-Chez analyzer expands it (jolt-r9lm). The +# caller handles ns forms (alias registration only) before calling this. +(defn- emit-form-scheme [ctx ns-name f] + (defn- jts [x] (string/format "%j" x)) + (if (macro-form? f) + (let [[nm fn-form] (defmacro->fn f)] + (when nm + (def res (protect (cemit ctx (backend/analyze-form ctx fn-form)))) + (when (res 0) + (string "(guard (e (#t #f))\n (def-var! " (jts ns-name) " " (jts nm) "\n " + (res 1) ")\n (mark-macro! " (jts ns-name) " " (jts nm) "))")))) + (let [res (protect (cemit ctx (backend/analyze-form ctx f)))] + (when (res 0) + (string "(guard (e (#t #f))\n " (res 1) ")"))))) + (defn- form-label [f] (if (and (indexed? f) (> (length f) 1)) (let [h (or (sym-name (in f 0)) "?") n (sym-name (in f 1))] (if n (string h " " n) h)) @@ -205,19 +246,17 @@ (if ns-form? (protect (api/eval-one ctx f)) (scan-eval-requires! ctx f)) # Skip emitting ns forms: their only role here is alias registration, and a # runtime ns-switch would leak into the prelude's trailing *ns* (the def-var!s - # already carry explicit ns names). Macros have no runtime value either. - (unless (or ns-form? (macro-form? f)) + # already carry explicit ns names). Macros ARE emitted now (jolt-r9lm): each + # defmacro becomes a def of its expander fn + (mark-macro! ns name) so the + # on-Chez analyzer (inc6b) can expand it — previously skipped (the Janet + # analyzer expanded them at analyze time, before they reached the prelude). + # Tolerant load guard (inside emit-form-scheme): a form that fails to LOAD + # (the 8 Phase-2 multimethod print-method forms in 50-io) is swallowed so it + # doesn't break the rest of the prelude — it becomes a lazy gap. + (unless ns-form? (++ total) - (def res (protect (cemit ctx (backend/analyze-form ctx f)))) - (when (res 0) - (++ emitted) - # Tolerant load guard: a form that fails to LOAD (currently only the 8 - # Phase-2 multimethod print-method forms in 50-io) is swallowed so it - # doesn't break the rest of the prelude — it becomes a lazy gap (the var - # cell stays nil; calling it surfaces in the parity gate's crash bucket). - # Silent to keep a real -e's stderr clean; the known set is documented. - (array/push out - (string "(guard (e (#t #f))\n " (res 1) ")")))))) + (def scm (emit-form-scheme ctx ns-name f)) + (when scm (++ emitted) (array/push out scm))))) (each tf core-tier-files (emit-ns-forms "clojure.core" (slurp (string core-dir tf ".clj")))) # stdlib namespaces beyond clojure.core that are pure Clojure over core/host @@ -249,10 +288,11 @@ (each f (parse-all src) (def ns-form? (and (indexed? f) (> (length f) 0) (= "ns" (sym-name (in f 0))))) (if ns-form? (protect (api/eval-one ctx f)) (scan-eval-requires! ctx f)) - (unless (or ns-form? (macro-form? f)) - (def res (protect (cemit ctx (backend/analyze-form ctx f)))) - (when (res 0) - (array/push out (string "(guard (e (#t #f))\n " (res 1) ")"))))) + # The compiler namespaces define no macros, but route through the shared helper + # anyway (a defmacro would emit as a def + mark-macro!, jolt-r9lm). + (unless ns-form? + (def scm (emit-form-scheme ctx ns-name f)) + (when scm (array/push out scm)))) out) (def compiler-ns-files diff --git a/host/chez/host-contract.ss b/host/chez/host-contract.ss index f08bc94..0e7b970 100644 --- a/host/chez/host-contract.ss +++ b/host/chez/host-contract.ss @@ -41,7 +41,12 @@ (define (hc-list? x) (or (empty-list-t? x) (and (cseq? x) (cseq-list? x)))) (define (hc-vec? x) (pvec? x)) (define (hc-map? x) (and (pmap? x) (jolt-nil? (jolt-get x hc-kw-jolt-type)))) -(define (hc-set? x) (and (pmap? x) (eq? (jolt-get x hc-kw-jolt-type) hc-kw-jolt-set))) +;; A set form is the reader's tagged map {:jolt/type :jolt/set :value } OR a +;; real pset value — a macro template's #{...} expansion (syntax-quote.ss jolt-sqset) +;; produces a pset, which the analyzer must still read as a set literal (jolt-r9lm). +(define (hc-set? x) + (or (pset? x) + (and (pmap? x) (eq? (jolt-get x hc-kw-jolt-type) hc-kw-jolt-set)))) (define (hc-char? x) (char? x)) (define (hc-literal? x) (or (jolt-nil? x) (boolean? x) (number? x) (string? x) (keyword-t? x) (char? x))) @@ -72,7 +77,10 @@ ((cseq? x) (make-pvec (list->vector (seq->list x)))) (else empty-pvec))) (define (hc-vec-items x) x) ; already a pvec -(define (hc-set-items x) (jolt-get x hc-kw-value)) +(define (hc-set-items x) + (if (pset? x) + (apply jolt-vector (pset-fold x cons '())) + (jolt-get x hc-kw-value))) (define (hc-map-pairs x) (let loop ((ks (if (jolt-nil? (jolt-seq (jolt-keys x))) '() (seq->list (jolt-seq (jolt-keys x))))) (acc '())) @@ -104,13 +112,33 @@ (define (hc-current-ns ctx) (chez-actx-cns ctx)) (define (hc-late-bind? ctx) #t) ; Chez has no interpreter to punt to -;; Runtime macros land in inc6b (jolt-r8ku): no macro is emitted as a runtime -;; value yet, so nothing is a macro. form-macro? is only ever asked about a -;; non-handled, non-special head (e.g. +, a user fn) — all non-macros today. -(define (hc-macro? ctx sym) #f) +;; Resolve a global symbol to its var cell against the compile ns then clojure.core +;; (a qualified ns wins). Shared by resolve-global / form-macro? / form-expand-1. +;; Normalizes the reader's unqualified-ns sentinel (#f / '() / jolt-nil) like +;; hc-sym-ns, so an unqualified symbol never looks up a bogus "#f" namespace. +(define (hc-resolve-cell ctx sym) + (let* ((nm (symbol-t-name sym)) + (sns (symbol-t-ns sym)) + (qualified (and sns (not (jolt-nil? sns)) (not (null? sns)) sns))) + (if qualified + (var-cell-lookup qualified nm) + (or (var-cell-lookup (chez-actx-cns ctx) nm) + (var-cell-lookup "clojure.core" nm))))) + +;; Runtime macros (jolt-r9lm, inc6b): a defmacro is emitted into the prelude as a +;; def-var! of its cross-compiled expander fn plus (mark-macro! ns name), so the +;; var cell is flagged a macro (rt.ss var-macro-table). form-macro? checks the +;; flag; form-expand-1 applies the expander to the unevaluated arg forms (the rest +;; of the list), and the analyzer re-analyzes the returned form. Mirrors +;; host_iface.janet h-macro?/h-expand-1. +(define (hc-macro? ctx sym) + (macro-var? (hc-resolve-cell ctx sym))) (define (hc-expand-1 ctx form) - (jolt-throw (jolt-ex-info "form-expand-1: runtime macros not on Chez yet (jolt-r8ku)" - (jolt-hash-map)))) + (let* ((items (seq->list form)) + (head (car items)) + (args (cdr items)) + (expander (var-cell-root (hc-resolve-cell ctx head)))) + (apply jolt-invoke expander args))) ;; Classify a global (non-local) symbol reference against the var registry: ;; {:kind :var :ns NS :name NAME} — a defined var (compile ns / clojure.core) @@ -121,12 +149,7 @@ ;; they classify as :var and the emitter's native-op path lowers them. (define (hc-resolve-global ctx sym) (let* ((nm (symbol-t-name sym)) - (sns (symbol-t-ns sym)) - (qualified (and (not (jolt-nil? sns)) sns)) - (cell (if qualified - (var-cell-lookup qualified nm) - (or (var-cell-lookup (chez-actx-cns ctx) nm) - (var-cell-lookup "clojure.core" nm))))) + (cell (hc-resolve-cell ctx sym))) (if (and cell (var-cell-defined? cell)) (jolt-hash-map hc-kw-kind hc-kw-var hc-kw-ns (var-cell-ns cell) diff --git a/host/chez/jolt-chez.janet b/host/chez/jolt-chez.janet index fafcefa..44a12b8 100644 --- a/host/chez/jolt-chez.janet +++ b/host/chez/jolt-chez.janet @@ -25,6 +25,7 @@ "host/chez/natives-str.ss" "host/chez/records.ss" "host/chez/host-class.ss" "host/chez/io.ss" "host/chez/inst-time.ss" "host/chez/reader.ss" "host/chez/math.ss" + "host/chez/syntax-quote.ss" "host/chez/host-static.ss" "host/chez/dot-forms.ss" "src/jolt/clojure/string.clj" "src/jolt/clojure/walk.clj" "src/jolt/clojure/template.clj" "src/jolt/clojure/edn.clj" diff --git a/host/chez/rt.ss b/host/chez/rt.ss index 6972916..b2c7716 100644 --- a/host/chez/rt.ss +++ b/host/chez/rt.ss @@ -92,6 +92,17 @@ (define jolt-kw-var-name (keyword #f "name")) (define (def-var-with-meta! ns name v m) (let ((c (def-var! ns name v))) (hashtable-set! var-meta-table c m) c)) +;; runtime-macro registry (jolt-r9lm, inc6b): a var whose root holds a macro +;; expander fn is flagged here, so the ON-CHEZ analyzer's form-macro?/form-expand-1 +;; (host-contract.ss) expand it. The prelude emits each core/stdlib defmacro as a +;; def-var! of its (cross-compiled) expander followed by (mark-macro! ns name). +;; Keyed by cell (eq), like var-meta-table — survives a later (def name ...) that +;; replaces the expander but keeps the same cell, matching Clojure (a defmacro IS a +;; def whose var carries :macro). +(define var-macro-table (make-eq-hashtable)) +(define (mark-macro! ns name) + (let ((c (jolt-var ns name))) (hashtable-set! var-macro-table c #t) c)) +(define (macro-var? cell) (and cell (hashtable-ref var-macro-table cell #f) #t)) ;; declare / (def name) with no init: reserve the cell ONLY if absent. An ;; existing root is left intact — Clojure's (def x) with no init does not clobber ;; a prior binding (do (def x 7) (def x) x) => 7. Returns the cell either way. @@ -308,3 +319,9 @@ ;; clojure.math (jolt-22vo): native flonum-math shims def-var!'d into the ;; clojure.math ns. Self-contained (only def-var! + Chez math), order-independent. (load "host/chez/math.ss") + +;; syntax-quote form builders (jolt-r9lm, inc6b): __sqcat/__sqvec/__sqmap/__sqset/ +;; __sq1, def-var!'d into clojure.core. A cross-compiled macro expander (analyzer +;; on Chez, inc6b) calls these to build its expansion as reader forms. Needs the +;; collection/seq layer + def-var!; order-independent past those. +(load "host/chez/syntax-quote.ss") diff --git a/host/chez/syntax-quote.ss b/host/chez/syntax-quote.ss new file mode 100644 index 0000000..3a284c3 --- /dev/null +++ b/host/chez/syntax-quote.ss @@ -0,0 +1,51 @@ +;; syntax-quote form builders (jolt-r9lm, inc6b) — the Chez analogs of +;; core_types.janet's core-sq*. A cross-compiled macro expander whose body was a +;; syntax-quote template (lowered by jolt.host/form-syntax-quote-lower at Janet +;; cross-compile time) calls these at RUNTIME on Chez to build the EXPANSION as +;; Chez READER forms (cseq list / pvec / pmap / tagged-set pmap) so the on-Chez +;; analyzer can re-analyze it. def-var!'d into clojure.core, so the lowered body's +;; unqualified __sqcat/__sqvec/__sqmap/__sqset/__sq1 refs (which lower to var-deref +;; in prelude mode) resolve here. +;; +;; A list/vector/set template lowers to (__sqcat part ...) where each part is +;; either (__sq1 x) — a single non-spliced item — or a ~@ expr that evaluates to a +;; seqable spliced in place. Both kinds are seqables, so __sqcat just flattens each +;; part's jolt-seq in order. A map template lowers to (__sqmap k v ...) with no +;; splicing (alternating key/value, already lowered). +;; +;; Loaded by rt.ss after collections.ss/seq.ss (jolt-list/jolt-vector/jolt-hash-map/ +;; jolt-seq) and def-var!. + +;; flatten the __sqcat/__sqvec/__sqset parts (each a seqable) into a Scheme list. +(define (sq-flatten parts) + (let loop ((ps parts) (acc '())) + (if (null? ps) + (reverse acc) + (loop (cdr ps) + (let inner ((s (jolt-seq (car ps))) (a acc)) + (if (jolt-nil? s) + a + (inner (jolt-seq (seq-more s)) (cons (seq-first s) a)))))))) + +;; single non-spliced item -> a one-element seqable (__sqcat flattens it). +(define (jolt-sq1 x) (jolt-list x)) +;; list FORM: cseq with list?=#t, so the analyzer's form-list? sees a list. +(define (jolt-sqcat . parts) (apply jolt-list (sq-flatten parts))) +;; vector FORM: pvec. +(define (jolt-sqvec . parts) (apply jolt-vector (sq-flatten parts))) +;; set: a REAL set value (pset). A syntax-quote builds VALUES, and the cseq/pvec/ +;; pmap that __sqcat/__sqvec/__sqmap build double as their own form rep — but a set +;; value (pset) differs from the reader's set FORM ({:jolt/type :jolt/set :value +;; }), so building the tagged form here would make a runtime `#{~@xs} a map, +;; not a set (jolt-r9lm regression). Build the value; the analyzer's form-set? +;; (host-contract.ss) additionally recognizes a pset, so a macro template's #{...} +;; expansion still re-analyzes as a set literal. +(define (jolt-sqset . parts) (apply jolt-hash-set (sq-flatten parts))) +;; map FORM: a plain pmap (the analyzer's form-map? = pmap with no :jolt/type). +(define (jolt-sqmap . parts) (apply jolt-hash-map parts)) + +(def-var! "clojure.core" "__sq1" jolt-sq1) +(def-var! "clojure.core" "__sqcat" jolt-sqcat) +(def-var! "clojure.core" "__sqvec" jolt-sqvec) +(def-var! "clojure.core" "__sqset" jolt-sqset) +(def-var! "clojure.core" "__sqmap" jolt-sqmap) diff --git a/test/chez/run-corpus-prelude.janet b/test/chez/run-corpus-prelude.janet index f7c0a1d..4880795 100644 --- a/test/chez/run-corpus-prelude.janet +++ b/test/chez/run-corpus-prelude.janet @@ -281,8 +281,12 @@ # missing `long` coercion def-var!'d (converters.ss). pprint's 2-arity dropped its # (binding [*out* writer] ...) (uncompilable on the no-fallback Chez back end — # *out* isn't a bindable var). 2280, crashes 191->170, 0 new divergences. +# Phase-3 inc6b (jolt-r9lm): runtime macros — each core/stdlib defmacro now emits +# into the prelude as an expander fn + mark-macro!, so syntax-quote VALUE forms +# (`(...)/`[...]/`{...}/`#{...} via __sqcat/__sqvec/__sqmap/__sqset) run at runtime. +# 2280->2295, 0 new divergences. # Strided runs scale down. -(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_PRELUDE_FLOOR") "2280"))) +(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_PRELUDE_FLOOR") "2295"))) (def floor (if (os/getenv "JOLT_CORPUS_LIMIT") 0 base-floor)) (when (or (> (length diverged) 0) (< pass floor)) (printf "REGRESSION: pass %d < floor %d or %d new divergence(s)" pass floor (length diverged))) diff --git a/test/chez/spine-test.janet b/test/chez/spine-test.janet index 789656a..a08b3ec 100644 --- a/test/chez/spine-test.janet +++ b/test/chez/spine-test.janet @@ -67,5 +67,31 @@ "(= 5 5)"] (check src)) +# inc6b (jolt-r9lm): runtime macros — the on-Chez analyzer expands core macros +# (emitted into the prelude as expander fns + a macro flag). Same oracle: the +# Janet analyzer expands them at analyze time, the value must match. +(each src + ["(when true 1)" + "(when false 1)" + "(when true 1 2 3)" + "(when-not false 5)" + "(let [a 1] (+ a 2))" + "(let [a 1 b 2] (+ a b))" + "(let [a 1 b (+ a 1)] (* a b))" + "(-> 1 inc inc)" + "(-> 5 (- 2))" + "(->> 3 (- 10))" + "(and 1 2 3)" + "(and 1 false 3)" + "(or nil 5)" + "(or false nil 7)" + "(cond false 1 true 2)" + "(cond false 1 :else 3)" + "(if-not false :a :b)" + "(do (defn f [x] (* x x)) (f 6))" + "(do (defn g [x y] (+ x y 1)) (g 3 4))" + "(let [a 1] (when (< a 5) (-> a inc inc)))"] + (check src)) + (printf "\n%d/%d ok" (- total fails) total) (when (> fails 0) (os/exit 1))