diff --git a/jolt-core/jolt/backend_scheme.clj b/jolt-core/jolt/backend_scheme.clj index 906b109..fb5f338 100644 --- a/jolt-core/jolt/backend_scheme.clj +++ b/jolt-core/jolt/backend_scheme.clj @@ -15,9 +15,12 @@ (+ native-ops)/fn/def + the escaping/flonum/munge helpers. INCREMENT 2 (jolt-7jvp): collection literals (vector/map/set, emit-ordered) + quote (emit-quoted, walks the raw reader form via the portable jolt.host form-* - contract — same seam the analyzer uses, so it stays host-neutral). Quoted symbol - metadata, def-meta, try/throw, host interop, regex/inst/uuid and program - assembly land in later increments (they throw not-yet-ported so a hit is loud)." + contract — same seam the analyzer uses, so it stays host-neutral). + INCREMENT 3 (jolt-me6m): try/throw + host-call + regex/inst/uuid + def-meta + + quoted-symbol-meta. With this the emitter covers every op emit.janet handles. + emit-quoted now also reconstructs plain jolt VALUES (def/symbol :meta), enabled + by making :meta a portable struct at the host seam (h-sym-meta). Program + assembly + the prelude driver port land with compile-from-source (inc 4+)." (:require [clojure.string :as str] [jolt.host :refer [form-sym? form-sym-name form-sym-ns form-sym-meta form-list? form-vec? form-map? form-set? form-char? @@ -75,6 +78,11 @@ ;; but Scheme's < demands a number even there — special-case. (def ^:private cmp1-ops #{"<" ">" "<=" ">="}) +;; Host interop methods with a Chez RT shim (rt.ss jolt-host-call). A `.method` +;; call on any other method routes to record-method-dispatch (a reify/record +;; protocol method). Keep in sync with emit.janet's supported-host-methods. +(def ^:private supported-host-methods #{"isDirectory" "listFiles"}) + ;; 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 @@ -169,20 +177,36 @@ (str "(jolt-hash-map " (str/join " " (mapcat (fn [p] [(emit-quoted (nth p 0)) (emit-quoted (nth p 1))]) pairs)) ")")) +(defn- emit-quoted-map-value [m] + ;; a jolt map VALUE (def/symbol metadata is a value, not a reader form) + (str "(jolt-hash-map " + (str/join " " (mapcat (fn [k] [(emit-quoted k) (emit-quoted (get m k))]) (keys m))) + ")")) +;; emit-quoted reconstructs both raw reader forms (from :quote) AND plain jolt +;; values (def/symbol :meta). Reader forms are walked via the jolt.host form-* +;; contract; the native-predicate branches below catch genuine jolt collection +;; VALUES. The form-* branches come first so a reader form (a host-native struct/ +;; array that a native predicate might also match) is always handled as a form. (defn- emit-quoted [form] (cond (form-char? form) (emit-const form) (form-literal? form) (emit-const form) (form-sym? form) - (let [m (form-sym-meta form)] - (when (and m (pos? (count m))) - (throw (ex-info "emit-quoted: quoted symbol with metadata not yet ported (inc 3)" {}))) - (let [sns (form-sym-ns form) nm (form-sym-name form)] + (let [m (form-sym-meta form) sns (form-sym-ns form) nm (form-sym-name form)] + (if (and m (pos? (count m))) + ;; carry reader metadata (^:foo bar) onto the quoted symbol so (meta 'x) sees it + (str "(jolt-symbol/meta " (if sns (chez-str-lit sns) "#f") " " (chez-str-lit nm) " " + (emit-quoted m) ")") (str "(jolt-symbol " (if sns (chez-str-lit sns) "#f") " " (chez-str-lit nm) ")"))) (form-set? form) (str "(jolt-hash-set " (str/join " " (map emit-quoted (form-set-items form))) ")") (form-list? form) (str "(jolt-list " (str/join " " (map emit-quoted (form-elements form))) ")") (form-vec? form) (str "(jolt-vector " (str/join " " (map emit-quoted (form-vec-items form))) ")") (form-map? form) (emit-quoted-map (form-map-pairs form)) + ;; plain jolt VALUES (metadata maps and anything nested in them) + (map? form) (emit-quoted-map-value form) + (vector? form) (str "(jolt-vector " (str/join " " (map emit-quoted form)) ")") + (set? form) (str "(jolt-hash-set " (str/join " " (map emit-quoted form)) ")") + (seq? form) (str "(jolt-list " (str/join " " (map emit-quoted form)) ")") :else (throw (ex-info (str "emit-quoted: unsupported quoted form " (pr-str form)) {})))) ;; A def's :meta is a jolt map value. Non-empty? (a plain def carries {}). @@ -314,6 +338,19 @@ :else (str "(jolt-invoke " (emit fnode) " " (str/join " " args) ")")))) +;; try/catch/finally (jolt-vcsl). throw raises the jolt value RAW (jolt-throw = +;; Scheme `raise`); catch lowers to `guard` with an `else` clause (the IR drops +;; the class), finally to `dynamic-wind`'s after-thunk (runs on success, catch and +;; escape — Clojure finally semantics). Both keys optional on the node. +(defn- emit-try [node] + (let [core (if-let [cs (:catch-sym node)] + (str "(guard (" (munge-name cs) " (else " (emit (:catch-body node)) ")) " + (emit (:body node)) ")") + (emit (:body node)))] + (if-let [fin (:finally node)] + (str "(dynamic-wind (lambda () #f) (lambda () " core ") (lambda () " (emit fin) "))") + core))) + ;; 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] @@ -358,6 +395,23 @@ :map (emit-ordered "jolt-hash-map" (mapcat (fn [p] [(emit (nth p 0)) (emit (nth p 1))]) (:pairs node))) :quote (emit-quoted (:form node)) + :throw (str "(jolt-throw " (emit (:expr node)) ")") + :try (emit-try node) + ;; regex literal #"…" -> a jolt-regex value (regex.ss, vendored irregex). + :regex (str "(jolt-regex " (chez-str-lit (:source node)) ")") + ;; #inst / #uuid literals -> runtime inst / uuid values. + :inst (str "(jolt-inst-from-string " (chez-str-lit (:source node)) ")") + :uuid (str "(jolt-uuid-from-string " (chez-str-lit (:source node)) ")") + ;; (.method target arg*) -> jolt-host-call for an rt-shimmed method, else + ;; record-method-dispatch (a reify/record protocol method, jolt-jgoc). + :host-call (let [m (:method node) + target (emit (:target node)) + args (map emit (:args node))] + (if (supported-host-methods m) + (str "(jolt-host-call " (chez-str-lit m) " " target + (if (empty? args) "" (str " " (str/join " " args))) ")") + (str "(record-method-dispatch " target " " (chez-str-lit m) + " (jolt-vector" (if (empty? args) "" (str " " (str/join " " args))) "))"))) :let (emit-let node) :loop (emit-loop node) :recur (emit-recur node) @@ -368,7 +422,8 @@ (: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 3)" {})) + (str "(def-var-with-meta! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " " + (emit (:init node)) " " (emit-quoted (:meta node)) ")") :else (str "(def-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " " (emit (:init node)) ")")) diff --git a/src/jolt/host_iface.janet b/src/jolt/host_iface.janet index 42b0d2a..364b3d9 100644 --- a/src/jolt/host_iface.janet +++ b/src/jolt/host_iface.janet @@ -32,9 +32,19 @@ (defn h-sym-name [form] (form :name)) (defn h-sym-ns [form] (form :ns)) # Reader metadata on a symbol (e.g. ^:dynamic / ^:redef / ^:private on a def -# name). Returns the meta map or nil. Lets the analyzer carry def metadata that -# the back end applies to the var — without it, compiled defs drop all var meta. -(defn h-sym-meta [form] (form :meta)) +# name). Returns the meta map (a portable jolt map) or nil. Lets the analyzer +# carry def metadata that the back end applies to the var — without it, compiled +# defs drop all var meta. +# +# The reader builds meta as a Janet TABLE (mutable). Return it as an immutable +# STRUCT so it is a portable jolt value: the Janet back end's merge/get work on a +# struct, AND jolt's own count/map?/keys (used by the portable Clojure emitter, +# jolt.backend-scheme, to emit def metadata) work on a struct but NOT on a raw +# table. A table embedded in the IR is a host value (counter to jolt.ir's "no host +# values embedded") — struct keeps :meta host-neutral. (jolt-me6m) +(defn h-sym-meta [form] + (def m (form :meta)) + (if (table? m) (table/to-struct m) m)) (defn h-list? [form] (array? form)) # a call / list (reader: array) (defn h-vector? [form] (tuple? form)) # a vector literal (reader: tuple) diff --git a/test/chez/emit-parity.janet b/test/chez/emit-parity.janet index 67d3137..b013f40 100644 --- a/test/chez/emit-parity.janet +++ b/test/chez/emit-parity.janet @@ -157,6 +157,20 @@ (check "vector map filter" "(into [] (filter even? (map inc [1 2 3 4 5])))") (check "map over literal" "(reduce + (vals {:a 1 :b 2 :c 3}))") +# --- inc 3 subset: try/throw + def-meta + quoted-sym-meta + inst/uuid + regex ---- + +(check "try catch" `(try (throw (ex-info "boom" {})) (catch Throwable e 42))`) +(check "try catch value" `(+ (try (throw (ex-info "" {})) (catch Throwable e 10)) 5)`) +(check "try no throw" `(try 7 (catch Throwable e 0))`) +(check "try finally" `(try 1 (finally 2))`) +(check "try finally side" `(try (throw (ex-info "" {})) (catch Throwable e 3) (finally 9))`) +(check "def private runs" `(do (defn ^:private secret [] 99) (secret))`) +(check "def tagged runs" `(do (def ^:dynamic *q* 5) *q*)`) +(check "quoted sym meta eq" `(do (def x (quote ^:foo bar)) (= x x))`) +(check "inst eq" `(= #inst "2020-01-01" #inst "2020-01-01")`) +(check "uuid eq" `(= #uuid "00000000-0000-0000-0000-000000000000" #uuid "00000000-0000-0000-0000-000000000000")`) +(check "regex smoke" `(do (def r #"[0-9]+") true)`) + (check "mandelbrot run(20)" (string `` (defn count-point [cr ci cap] @@ -178,5 +192,16 @@ acc)))) `` "\n(run 20)")) +# Structural: a ^:private def must now take the def-var-with-meta! path (the meta +# is a portable struct after the h-sym-meta fix; before, map?/count failed on the +# raw table and it silently fell back to the lean def-var!, dropping the meta). +(let [scm (emit-clj (backend/analyze-form ctx (in (r/parse-next "(def ^:private p 1)") 0)))] + (ok "def ^:private emits def-var-with-meta!" + (truthy? (string/find "def-var-with-meta!" scm)) scm)) +(let [scm (emit-clj (backend/analyze-form ctx (in (r/parse-next "(def plain 1)") 0)))] + (ok "plain def stays lean def-var!" + (and (truthy? (string/find "(def-var! " scm)) + (not (string/find "with-meta" scm))) scm)) + (printf "\n%d/%d ok" (- total fails) total) (when (> fails 0) (os/exit 1))