From 1f96351acbd7d092efe82be00da5da0facbbf958 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Fri, 19 Jun 2026 00:32:30 -0400 Subject: [PATCH] Chez Phase 2 (inc R): . / .-field dot-form desugar (jolt-kuic) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The analyzer lowers the `.` special form (. target member arg*) and the .-field field-access head to a :host-call instead of leaving them uncompilable. Janet behaviour is unchanged — its back end punts :host-call to the interpreter, which re-runs the original `.` form via eval-dot. The Chez back end routes a non-shimmed :host-call through record-method-dispatch, extended by a new host/chez/dot-forms.ss with the arms dispatch-member covers but the record/string base did not, mirroring src/jolt/interop/collections.janet precedence: - collection interop first (count/seq/nth/get/valAt/containsKey on a vector/map/set), so (. {:count 9} count) is the entry count like the seed - field access for a "-name" member (records and maps) - the seed's universal object-methods (getMessage/getCause/toString/ hashCode/equals) on a non-record map, winning over a field lookup - non-record map member: a stored fn is a method called with self, else the field value Raw seqs are excluded from coll interop — the seed's behaviour there is representation-dependent (plain (seq v) vs a lazy-seq) and a normalized cseq can't mirror it. Also added getMessage/getLocalizedMessage/equals to the string method surface so a thrown string / Exception. ctor (which keeps the message string) answers .getMessage. Parity 2134 -> 2150, 0 new divergences. New test/chez/_dotform.janet 26/26; emit-test 331/331. --- host/chez/dot-forms.ss | 82 ++++++++++++++++++++++++++++++ host/chez/jolt-chez.janet | 2 +- host/chez/natives-str.ss | 5 ++ host/chez/rt.ss | 5 ++ jolt-core/jolt/analyzer.clj | 38 ++++++++++++++ test/chez/_dotform.janet | 70 +++++++++++++++++++++++++ test/chez/emit-test.janet | 15 ++++++ test/chez/run-corpus-prelude.janet | 9 +++- 8 files changed, 224 insertions(+), 2 deletions(-) create mode 100644 host/chez/dot-forms.ss create mode 100644 test/chez/_dotform.janet diff --git a/host/chez/dot-forms.ss b/host/chez/dot-forms.ss new file mode 100644 index 0000000..4b016e3 --- /dev/null +++ b/host/chez/dot-forms.ss @@ -0,0 +1,82 @@ +;; dot-forms.ss — generic dispatch for the `.` special-form / `.-field` desugar +;; (jolt-kuic). The analyzer lowers (. target member arg*) and (.-field target) +;; to a :host-call; the Chez emit routes a non-shimmed :host-call through +;; record-method-dispatch. This file extends that dispatcher with the collection +;; arms the interpreter's dispatch-member covers but the record/string base does +;; not, mirroring src/jolt/interop/collections.janet precedence exactly: +;; +;; * collection interop wins first — count/seq/nth/get/valAt/containsKey on a +;; vector/map/set/seq/record (so (. {:count 9} count) is the entry count, 1, +;; like the seed, NOT the :count field). +;; * field access — a "-name" member reads the field (records and maps). +;; * map member — a stored fn is a method (called with self + args); any +;; other value is returned as a field. +;; +;; Anything not recognized falls through to the previous dispatcher (jhost / +;; number / regex / jrec protocol / string). Loaded LAST (after host-static.ss). +;; A record (jrec) is jolt-map? here (records.ss makes it so) and a collection, +;; so its protocol method (no dash, not a coll method) lands in the base. + +(define %dot-rmd record-method-dispatch) + +;; Vectors / maps / sets only (records are jolt-map? here). Raw seqs are excluded: +;; the seed's coll-interop accepts some seq representations and not others (a +;; plain (seq v) returns nil from .count, a lazy-seq returns the count), an +;; inconsistency Chez's normalized cseq can't mirror — so a raw seq target falls +;; through to the base dispatcher rather than risk a divergence the corpus would +;; never exercise but a future case might. +(define (dot-coll? obj) + (or (jolt-vector? obj) (jolt-map? obj) (pset? obj))) + +;; Mirror coll-interop: return a one-element list boxing the result (so a jolt-nil +;; result is still distinguishable from "not a collection method"), or #f. +(define (dot-coll-method obj name args) + (cond + ((string=? name "count") (list (jolt-count obj))) + ((string=? name "seq") (list (jolt-seq obj))) + ((string=? name "nth") (list (apply jolt-nth obj args))) + ((or (string=? name "get") (string=? name "valAt")) + (list (apply jolt-get obj args))) + ((string=? name "containsKey") (list (jolt-contains? obj (car args)))) + (else #f))) + +;; Mirror the seed's universal object-methods (src/jolt/eval_resolve.janet): on a +;; non-record map these win OVER a field lookup, like dispatch-member. getMessage +;; on an ex-info reads its :message (the one the corpus exercises); getCause reads +;; :cause; toString/hashCode/equals round out the set. Returns a boxed result or +;; #f. Strings/numbers/records/jhost keep the base dispatcher (it shims them). +(define (dot-object-method obj name args) + (cond + ((string=? name "getMessage") + (list (if (jolt=2 (jolt-get obj jolt-kw-ex-type jolt-nil) jolt-kw-ex-info) + (jolt-get obj jolt-kw-message jolt-nil) + (jolt-str-render-one obj)))) + ((string=? name "getCause") (list (jolt-get obj jolt-kw-cause jolt-nil))) + ((string=? name "toString") (list (jolt-str-render-one obj))) + ((string=? name "hashCode") (list (jolt-hash obj))) + ((string=? name "equals") (list (if (jolt= obj (car args)) #t #f))) + (else #f))) + +(set! record-method-dispatch + (lambda (obj method-name rest-args) + (let* ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))) + (field? (and (> (string-length method-name) 0) + (char=? (string-ref method-name 0) #\-))) + (mname (if field? + (substring method-name 1 (string-length method-name)) + method-name))) + (cond + ;; collection interop first (entry count / seq / nth / get / containsKey). + ((and (dot-coll? obj) (dot-coll-method obj mname rest)) + => (lambda (box) (car box))) + ;; (.-field obj) / (. obj -field): field read on a record or map. + (field? (jolt-get obj (keyword #f mname) jolt-nil)) + ;; non-record map: a universal object-method (getMessage/...) wins first, + ;; then a stored procedure is a method (call with self), else the field. + ((and (jolt-map? obj) (not (jrec? obj))) + (cond + ((dot-object-method obj mname rest) => car) + (else + (let ((v (jolt-get obj (keyword #f mname) jolt-nil))) + (if (procedure? v) (apply jolt-invoke v obj rest) v))))) + (else (%dot-rmd obj method-name rest-args)))))) diff --git a/host/chez/jolt-chez.janet b/host/chez/jolt-chez.janet index 9dda80b..424c211 100644 --- a/host/chez/jolt-chez.janet +++ b/host/chez/jolt-chez.janet @@ -22,7 +22,7 @@ "host/chez/atoms.ss" "host/chez/predicates.ss" "host/chez/regex.ss" "host/chez/ns.ss" "host/chez/post-prelude.ss" "host/chez/natives-meta.ss" "host/chez/natives-str.ss" "host/chez/records.ss" - "host/chez/host-static.ss" + "host/chez/host-static.ss" "host/chez/dot-forms.ss" "src/jolt/clojure/string.clj"] (array/push parts (slurp f))) (string/slice (string (hash (string/join parts))) 0)) diff --git a/host/chez/natives-str.ss b/host/chez/natives-str.ss index 2f4f1a4..1e8bd12 100644 --- a/host/chez/natives-str.ss +++ b/host/chez/natives-str.ss @@ -124,6 +124,11 @@ ((string=? method "replaceFirst") (irregex-replace (str-irx (arg 0)) s (arg 1))) ((string=? method "split") (apply jolt-vector (str-split-drop-trailing (irregex-split (str-irx (arg 0)) s)))) + ;; universal object-methods that reach a string target (seed object-methods): + ;; a thrown string / Exception. ctor (which keeps the message string) answers + ;; getMessage with itself; equals is value equality. + ((or (string=? method "getMessage") (string=? method "getLocalizedMessage")) s) + ((string=? method "equals") (and (string? (arg 0)) (string=? s (arg 0)))) (else (error #f (string-append "No method " method " for value"))))) ;; --- clojure.core str-* primitives (the substrate clojure.string.clj calls) --- diff --git a/host/chez/rt.ss b/host/chez/rt.ss index d0c32f1..0d5600b 100644 --- a/host/chez/rt.ss +++ b/host/chez/rt.ss @@ -277,3 +277,8 @@ ;; record-method-dispatch (records.ss) and reuses natives-str helpers (str-trim, ;; ascii-string-down, re-split, str-split-drop-trailing) + the regex-t accessors. (load "host/chez/host-static.ss") + +;; generic dot-form dispatch (jolt-kuic): field access + map/vector member access +;; for the `.` / `.-field` desugar. Loads after host-static.ss so it wraps every +;; record-method-dispatch arm (jhost/number/regex/jrec/string) and falls through. +(load "host/chez/dot-forms.ss") diff --git a/jolt-core/jolt/analyzer.clj b/jolt-core/jolt/analyzer.clj index 7cfe8d0..ec597ef 100644 --- a/jolt-core/jolt/analyzer.clj +++ b/jolt-core/jolt/analyzer.clj @@ -308,6 +308,38 @@ (defn- analyze-ctor [ctx class args env] (host-new class (mapv #(analyze ctx % env) args))) +;; 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 Janet back end punts :host-call to the interpreter, which +;; re-runs the original `.` form via eval-dot — so Janet behavior is unchanged; +;; the Chez back end dispatches it through record-method-dispatch (jolt-kuic). +;; A non-symbol member (e.g. a keyword) stays punted — the interpreter handles it. +(defn- analyze-dot [ctx items env] + (when (< (count items) 3) + (throw (str "Malformed (. target member ...) form"))) + (let [member (nth items 2)] + (if (form-sym? member) + {:op :host-call + :method (form-sym-name member) + :target (analyze ctx (nth items 1) env) + :args (mapv #(analyze ctx % env) (drop 3 items))} + (uncompilable "special form . (non-symbol member)")))) + +;; A `.-field` head: `(.-field target)` is field access. Lowers to a :host-call +;; with the "-field" method (the dash signals field access to the dispatcher). +(defn- field-head? [nm] + (and (> (count nm) 2) (= ".-" (subs nm 0 2)))) + +(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 @@ -364,6 +396,12 @@ (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)) (and (form-sym? head) (not shadowed) (form-macro? ctx head)) diff --git a/test/chez/_dotform.janet b/test/chez/_dotform.janet new file mode 100644 index 0000000..f3fe2eb --- /dev/null +++ b/test/chez/_dotform.janet @@ -0,0 +1,70 @@ +# jolt-kuic — the `.` special form + `.-field` field-access desugar on Chez. The +# analyzer lowers (. target member arg*) and (.-field target) to a :host-call; +# the Chez emit routes a non-shimmed :host-call through record-method-dispatch, +# which dot-forms.ss extends with field access + map/vector member dispatch. +# Expectations are the build/jolt (seed) oracle, captured per case. +# +# janet test/chez/_dotform.janet +(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/jolt-chez")) + +(def exprs + [# strings: method calls via the String surface + "(. \"HI\" toLowerCase)" + "(. \"abc\" length)" + "(. \"abc\" toUpperCase)" + # vectors / maps: collection interop (count/nth/get/containsKey) + "(. [1 2 3] count)" + "(. [10 20 30] nth 1)" + "(. {:a 1 :b 2} count)" + "(. {:a 1 :b 2} get :b)" + "(. {:a 1} containsKey :a)" + "(. {:count 99} count)" + # map member: stored fn called with self (+ args), else field value + "(. {:value 41 :describe (fn [self] (str \"v=\" (:value self)))} describe)" + "(. {:greet (fn [self n] (str \"Hello \" n))} greet \"Alice\")" + "(. {:value 41} value)" + # field access via .-field head + "(.-value {:value 41})" + "(.-x {:x 7 :y 9})" + # field access via (. obj -field) + "(. {:value 41} -value)" + # records: .-field reads a field, .method dispatches the protocol method + "(do (defrecord Rf [x]) (.-x (->Rf 7)))" + "(do (defrecord Rg [a b]) (.-b (->Rg 1 2)))" + "(do (defprotocol Greet (hi [_])) (defrecord Rh [nm] Greet (hi [_] (str \"hi \" nm))) (. (->Rh \"x\") hi))" + # universal object-methods on a non-record map win over a field lookup + "(try (throw (ex-info \"bad\" {})) (catch Throwable e (.getMessage e)))" + "(try (throw (ex-info \"bad\" {:k 1})) (catch Throwable e (.getMessage e)))" + "(try (throw \"boom\") (catch Throwable e (.getMessage e)))" + "(try (throw (Exception. \"boom\")) (catch Throwable e (.getMessage e)))" + "(try (throw (IllegalArgumentException. \"bad\")) (catch Exception e (.getMessage e)))" + "(.equals \"a\" \"a\")" + "(.equals \"a\" \"b\")" + "(. {:value 41 :describe (fn [self] (str \"v=\" (:value self)))} describe)"]) + +(defn run-capture [bin expr] + (def proc (os/spawn [bin "-e" expr] :p {:out :pipe :err :pipe})) + (def out (ev/read (proc :out) 0x100000)) + (def err (ev/read (proc :err) 0x100000)) + (def code (os/proc-wait proc)) + (def lines (filter (fn [l] (not (empty? l))) + (string/split "\n" (string/trim (if out (string out) ""))))) + [code (if (empty? lines) "" (last lines)) (string/trim (if err (string err) ""))]) + +(var pass 0) +(def fails @[]) +(each expr exprs + (def [ocode oracle _] (run-capture "build/jolt" expr)) + (def [code got err] (run-capture jolt-bin expr)) + (cond + (not= ocode 0) (array/push fails [expr (string "ORACLE FAILED exit " ocode)]) + (not= code 0) (array/push fails [expr (string "exit " code "; err: " err)]) + (= got oracle) (++ pass) + (array/push fails [expr (string "want `" oracle "`, got `" got "`")]))) + +(printf "\n_dotform parity [%s]: %d/%d passed" jolt-bin pass (length exprs)) +(when (> (length fails) 0) + (printf "%d FAIL(s):" (length fails)) + (each [e m] fails (printf " FAIL %s\n %s" e m))) +(flush) +(os/exit (if (empty? fails) 0 1)) diff --git a/test/chez/emit-test.janet b/test/chez/emit-test.janet index 2f526ee..96ef2c3 100644 --- a/test/chez/emit-test.janet +++ b/test/chez/emit-test.janet @@ -336,6 +336,21 @@ (let [scm (protect (emit/emit (backend/analyze-form ctx (in (r/parse-next src) 0))))] (ok label (and (scm 0) (string/find needle (scm 1))) (string/format "%p" scm)))) +# 3l'') the `.` special form + `.-field` desugar (jolt-kuic). (. target member +# arg*) and (.-field target) lower to a :host-call routed through +# record-method-dispatch (a non-shimmed method); the dash on a field member +# survives in the method name so dot-forms.ss reads it as a field access. The +# Janet back end punts :host-call (interpreter re-runs the original `.` form); +# runtime behaviour is covered by test/chez/_dotform.janet. +(each [label src needle] + [["emit (. obj method) -> record-method-dispatch" "(fn [o] (. o frob))" "record-method-dispatch"] + ["emit (. obj method) keeps method name" "(fn [o] (. o frob))" "\"frob\""] + ["emit (. obj method arg) passes args" "(fn [o a] (. o frob a))" "record-method-dispatch"] + ["emit (.-field obj) keeps dash" "(fn [o] (.-value o))" "\"-value\""] + ["emit (. obj -field) keeps dash" "(fn [o] (. o -value))" "\"-value\""]] + (let [scm (protect (emit/emit (backend/analyze-form ctx (in (r/parse-next src) 0))))] + (ok label (and (scm 0) (string/find needle (scm 1))) (string/format "%p" scm)))) + # 3m) regex (jolt-i0s3): the #"…" literal lowers to a jolt-regex value over the # vendored irregex; re-pattern/re-matches/re-find/re-seq/regex? are def-var!'d # into clojure.core (not subset native-ops — irregex's Unicode/property diff --git a/test/chez/run-corpus-prelude.janet b/test/chez/run-corpus-prelude.janet index 62d8755..69ec7ca 100644 --- a/test/chez/run-corpus-prelude.janet +++ b/test/chez/run-corpus-prelude.janet @@ -233,8 +233,15 @@ # exception constructors. Also emit now evaluates collection-literal elements # left-to-right (emit-ordered), which un-allowlisted the 6 eval-order cases. # java.time formatting / edn-read-over-readers / slurp-over-readers deferred) 2134. +# jolt-kuic (the `.` special form + `.-field` desugar — the analyzer lowers +# (. target member arg*) and (.-field target) to :host-call; the Chez RT +# dispatches them through record-method-dispatch, extended by dot-forms.ss with +# collection interop (count/nth/get/valAt/containsKey), field access, non-record +# map member dispatch, and the seed's universal object-methods getMessage/getCause/ +# toString/hashCode/equals. Also added getMessage/getLocalizedMessage/equals to the +# string method surface so a thrown string / Exception. ctor answers .getMessage) 2150. # Strided runs scale down. -(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_PRELUDE_FLOOR") "2134"))) +(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_PRELUDE_FLOOR") "2150"))) (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)))