diff --git a/host/chez/compile-eval.ss b/host/chez/compile-eval.ss index 6118e74..35b7160 100644 --- a/host/chez/compile-eval.ss +++ b/host/chez/compile-eval.ss @@ -54,17 +54,97 @@ (if (pair? (cdr items)) (cddr items) '()))) (else (for-each (lambda (x) (ce-scan-requires! x ns)) items)))))))) -;; Source string -> Scheme source string (read -> analyze -> emit, all on Chez). +;; Already-read FORM -> Scheme source string (analyze -> emit on Chez). ;; `ns` is the compile namespace unqualified symbols resolve against. -(define (jolt-analyze-emit src ns) - (let* ((form (jolt-ce-read src))) - (ce-scan-requires! form ns) - (let* ((ctx (make-analyze-ctx ns)) - (ir (jolt-ce-analyze ctx form))) - (jolt-ce-emit ir)))) +(define (jolt-analyze-emit-form form ns) + (ce-scan-requires! form ns) + (let* ((ctx (make-analyze-ctx ns)) + (ir (jolt-ce-analyze ctx form))) + (jolt-ce-emit ir))) -;; Source string -> value (compile on Chez, then eval the emitted Scheme in the +;; Source string -> Scheme source string (read then analyze -> emit, all on Chez). +(define (jolt-analyze-emit src ns) + (jolt-analyze-emit-form (jolt-ce-read src) ns)) + +;; --- runtime defmacro (jolt-r8ku) ------------------------------------------- +;; Shared with emit-image.ss (loaded after this). A defmacro lowers to a def of +;; its expander fn + a macro flag, exactly as the prelude emits build-time macros. + +;; Is `f` a (defmacro ...) / (definline ...) form? +(define (ce-macro-form? f) + (and (cseq? f) (cseq-list? f) + (let ((items (seq->list f))) + (and (pair? items) (symbol-t? (car items)) + (let ((h (symbol-t-name (car items)))) + (or (string=? h "defmacro") (string=? h "definline"))))))) + +;; (defmacro NAME [docstring] [attr-map] params body...) -> (values "NAME" (fn ...)). +;; Strips a leading docstring (native string) + attr-map (a non-symbol pmap), then +;; re-heads the rest with `fn` so a destructured macro arglist desugars. Emits the +;; BARE fn (the caller wraps it in def-var! + mark-macro!), never a (def NAME ...) — +;; interning NAME would make require skip the real macro (jolt-r9lm). +(define (ce-defmacro->fn f) + (let* ((items (seq->list f)) + (name-sym (cadr items)) + (after-name (cddr items)) + (a1 (if (and (pair? after-name) (string? (car after-name))) + (cdr after-name) after-name)) + (after-meta (if (and (pair? a1) (pmap? (car a1))) + (cdr a1) a1)) + (fn-sym (jolt-symbol #f "fn"))) + (values (symbol-t-name name-sym) + (apply jolt-list (cons fn-sym after-meta))))) + +;; A bare top-level (do ...) form — head is the unqualified `do` symbol. +(define (ce-top-do? form) + (and (cseq? form) (cseq-list? form) + (let ((h (seq-first form))) + (and (symbol-t? h) (jolt-nil? (hc-sym-ns h)) + (string=? (symbol-t-name h) "do"))))) + +;; Compile + eval ONE already-read form in compile ns `ns`; returns the value. +;; A top-level (do ...) is UNROLLED — each subform compiled+eval'd in turn, like +;; Clojure's top-level do — so a runtime defmacro/def in an earlier subform is +;; visible (macro flag set, var interned) before a later subform is analyzed. +(define (jolt-compile-eval-form form ns) + (cond + ((ce-top-do? form) + (let loop ((fs (cdr (seq->list form))) (result jolt-nil)) + (if (null? fs) + result + (loop (cdr fs) (jolt-compile-eval-form (car fs) ns))))) + ;; runtime defmacro: def the expander fn + mark the var a macro so subsequent + ;; forms expand it (hc-macro? reads var-macro-table). Mirrors emit-image.ss + ;; ei-emit-ns and the Janet seed eval-defmacro. + ((ce-macro-form? form) + (let-values (((nm fn-form) (ce-defmacro->fn form))) + (def-var! ns nm (jolt-compile-eval-form fn-form ns)) + (mark-macro! ns nm) + jolt-nil)) + (else + (eval (read (open-input-string (jolt-analyze-emit-form form ns))) + (interaction-environment))))) + +;; Source string -> value (read one form, compile + eval on Chez, in the ;; top-level environment where rt.ss's runtime procedures live). (define (jolt-compile-eval src ns) - (eval (read (open-input-string (jolt-analyze-emit src ns))) - (interaction-environment))) + (jolt-compile-eval-form (jolt-ce-read src) ns)) + +;; clojure.core/load-string: read every form from the source string and compile+ +;; eval each in the current ns, returning the last value (nil for blank input). +;; Mirrors src/jolt/api.janet load-string (the parse-next loop). jolt-r8ku. +(define (jolt-load-string s) + (let loop ((src s) (result jolt-nil)) + (let ((pn (jolt-parse-next src))) + (if (jolt-nil? pn) + result + (loop (jolt-nth pn 1) + (jolt-compile-eval-form (jolt-nth pn 0) (chez-current-ns))))))) + +;; eval / load-string are FUNCTIONS on the spine (the compiler image is resident +;; at runtime). eval takes an already-read FORM (e.g. from quote / list); it and +;; load-string compile+eval in the current ns. eval is removed from the analyzer's +;; special-symbol lists (host-contract.ss) so it resolves as an ordinary core var. +(def-var! "clojure.core" "eval" + (lambda (form) (jolt-compile-eval-form form (chez-current-ns)))) +(def-var! "clojure.core" "load-string" jolt-load-string) diff --git a/host/chez/emit-image.ss b/host/chez/emit-image.ss index 328bca8..ff62960 100644 --- a/host/chez/emit-image.ss +++ b/host/chez/emit-image.ss @@ -30,31 +30,8 @@ (and (pair? items) (symbol-t? (car items)) (string=? (symbol-t-name (car items)) "ns"))))) -;; Is `f` a (defmacro ...) / (definline ...) form? -(define (ei-macro-form? f) - (and (cseq? f) (cseq-list? f) - (let ((items (seq->list f))) - (and (pair? items) (symbol-t? (car items)) - (let ((h (symbol-t-name (car items)))) - (or (string=? h "defmacro") (string=? h "definline"))))))) - -;; (defmacro NAME [docstring] [attr-map] params body...) -> (values "NAME" (fn ...)). -;; Mirrors driver.janet defmacro->fn: strip a leading docstring (native string) and -;; an attr-map (a pmap that isn't a symbol), then re-head the rest with `fn` so a -;; destructured macro arglist desugars before lowering. We emit the BARE fn (the -;; caller wraps it in def-var! + mark-macro!), never a (def NAME ...) — interning -;; NAME would make require skip the real macro (jolt-r9lm). -(define (ei-defmacro->fn f) - (let* ((items (seq->list f)) - (name-sym (cadr items)) - (after-name (cddr items)) - (a1 (if (and (pair? after-name) (string? (car after-name))) - (cdr after-name) after-name)) - (after-meta (if (and (pair? a1) (pmap? (car a1))) - (cdr a1) a1)) - (fn-sym (jolt-symbol #f "fn"))) - (values (symbol-t-name name-sym) - (apply jolt-list (cons fn-sym after-meta))))) +;; ei-macro-form? / ei-defmacro->fn moved to compile-eval.ss (ce-macro-form? / +;; ce-defmacro->fn, loaded before this) — shared with the runtime defmacro spine. ;; Cross-compile one namespace's source to a list of guard-wrapped Scheme strings. ;; Mirrors driver.janet emit-ns-forms-list/emit-core-prelude + emit-form-scheme. @@ -70,8 +47,8 @@ (ce-scan-requires! f ns-name) (cond ((ei-ns-form? f) (loop (cdr forms) acc)) - ((ei-macro-form? f) - (let-values (((nm fn-form) (ei-defmacro->fn f))) + ((ce-macro-form? f) + (let-values (((nm fn-form) (ce-defmacro->fn f))) (let ((scm (guard (e (#t #f)) (let ((ctx (make-analyze-ctx ns-name))) (jolt-ce-emit (jolt-ce-analyze ctx fn-form)))))) diff --git a/host/chez/host-contract.ss b/host/chez/host-contract.ss index f5c9608..158a489 100644 --- a/host/chez/host-contract.ss +++ b/host/chez/host-contract.ss @@ -105,9 +105,12 @@ ;; --- special forms ---------------------------------------------------------- ;; Mirrors host_iface special-names + interop-head? — forms the analyzer marks ;; uncompilable (the handled specials are dispatched in analyze-list BEFORE this). +;; `eval` is NOT here: it is a clojure.core FUNCTION on the spine (compile-eval.ss +;; def-var!s it), so it must resolve as an ordinary var, not punt (jolt-r8ku). +;; `defmacro` stays special — the spine intercepts it before analysis. (define hc-special-names '("quote" "syntax-quote" "unquote" "unquote-splicing" "do" "if" "def" - "defmacro" "fn*" "let*" "loop*" "recur" "throw" "try" "set!" "eval" "new" + "defmacro" "fn*" "let*" "loop*" "recur" "throw" "try" "set!" "new" "." "gen-class" "monitor-enter" "monitor-exit" "letfn")) (define (hc-interop-head? name) (let ((n (string-length name))) @@ -180,7 +183,7 @@ ;; clojure.core / the compile ns; a foo# auto-gensym is stable within one `. (define hc-special-symbols '("quote" "syntax-quote" "unquote" "unquote-splicing" "do" "if" "def" - "defmacro" "fn*" "let*" "loop*" "recur" "throw" "try" "set!" "var" "eval" + "defmacro" "fn*" "let*" "loop*" "recur" "throw" "try" "set!" "var" "new" ".")) (define (hc-special-symbol? nm) (and (member nm hc-special-symbols) #t)) diff --git a/test/chez/cli-test.janet b/test/chez/cli-test.janet index 61451fb..4e0f5b8 100644 --- a/test/chez/cli-test.janet +++ b/test/chez/cli-test.janet @@ -36,7 +36,18 @@ ["(case 3 1 :a 2 :b :other)" ":other"] ["(reduce + (vals (reduce (fn [m k] (assoc m k (* k k))) {} [1 2 3])))" "14"] ["(map inc [1 2 3])" "(2 3 4)"] - ["nil" ""]]) + ["nil" ""] + # jolt-r8ku: runtime eval / load-string / defmacro on the Chez spine. + ["(eval (quote (+ 1 2)))" "3"] + ["(eval (list (quote +) 1 2 3))" "6"] + ["(eval (quote (let [a 2 b 3] (* a b))))" "6"] + ["(load-string \"(+ 1 2)\")" "3"] + ["(load-string \"(def y 5) (* y y)\")" "25"] + ["(load-string \"\")" ""] + ["(map eval [(quote (+ 1 1)) (quote (* 3 3))])" "(2 9)"] + ["(defmacro add1 [x] (list (quote +) x 1)) (add1 10)" "11"] + ["(defmacro twice [x] `(do ~x ~x)) (twice (+ 2 3))" "5"] + ["(defmacro m [x] `(+ ~x 1)) (m (m (m 0)))" "3"]]) (each [src want] cases (def [code out err] (joltc src)) diff --git a/test/chez/run-corpus-zero-janet.janet b/test/chez/run-corpus-zero-janet.janet index 23c619d..31ed6c7 100644 --- a/test/chez/run-corpus-zero-janet.janet +++ b/test/chez/run-corpus-zero-janet.janet @@ -166,7 +166,7 @@ # Regression floor: raise as the Chez-hosted compiler closes gaps. The gate fails # on any NEW divergence or if pass drops below the floor. Strided runs scale to 0. -(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_ZJ_FLOOR") "2534"))) +(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_ZJ_FLOOR") "2544"))) (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)))