Dedup the two .method dot-dispatch arms into one dispatch-member (jolt-eos3)
eval-dot copy-pasted its entire dispatch chain across the (. obj method args...) and (. obj member) forms — string/number/object/tagged-shim lookup duplicated, hand-synced on every interop change. Extract one dispatch-member that takes the evaluated args plus a has-args flag. The shared head (string/number/object/ tagged) is single-sourced; the genuinely divergent tails (call form: record → native field → coll-interop(args); bare form: zero-arg coll-interop → field / zero-arg method) stay branched on has-args. The guards that differed between the arms (object-methods checks table? only; tagged dispatch checks table-or-struct; bare-form tagged dispatch requires the member present) are preserved verbatim, keyed off has-args, so behavior is identical. Adds a "dot dispatch arms" spec locking the divergent cases: zero-arg vs with-arg coll-interop, record/deftype zero-arg vs with-args methods, -field access. Full gate green.
This commit is contained in:
Yogthos
parent
6c0142e625
commit
0406b315a9
2 changed files with 132 additions and 105 deletions
|
|
@ -519,113 +519,121 @@
|
|||
ctor (if (string? ctor) (or (ctor-for-class-token ctor) ctor) ctor)]
|
||||
(apply ctor args)))
|
||||
|
||||
# Member dispatch shared by the two `.` forms (jolt-eos3). `args` is the
|
||||
# (possibly empty) tuple of already-evaluated arguments; `has-args` is true for
|
||||
# the call form `(. obj method arg...)` and false for the bare form
|
||||
# `(. obj member)`. The two forms agree on the string/number/object/tagged-shim
|
||||
# dispatch chain (single-sourced here, so an interop change touches one place)
|
||||
# but diverge in the tail: the call form tries record → native-field →
|
||||
# coll-interop(args); the bare form tries zero-arg coll-interop → field /
|
||||
# zero-arg method. The guards that differed between the old copy-pasted arms are
|
||||
# keyed off `has-args` so behavior is identical (note: the object-methods guard
|
||||
# checks `table?` only, while tagged dispatch checks table-or-struct — both kept
|
||||
# verbatim from the original arms).
|
||||
(defn dispatch-member [ctx bindings target member-raw member-name field-name args has-args]
|
||||
(cond
|
||||
# java.lang.String surface for string/buffer targets
|
||||
(or (string? target) (buffer? target))
|
||||
(let [m (get string-methods field-name)]
|
||||
(if m
|
||||
(m (string target) ;args)
|
||||
(if-let [om (get object-methods field-name)]
|
||||
(om (string target) ;args)
|
||||
(error (string "Unsupported String method ." field-name)))))
|
||||
# numeric methods
|
||||
(and (number? target) (get number-methods field-name))
|
||||
((get number-methods field-name) target ;args)
|
||||
# universal object methods — skipped when a shim tag-table owns the member.
|
||||
# Call form defers to tagged dispatch whenever a tag-table exists; bare form
|
||||
# only when the tag-table actually carries this member, so zero-arg
|
||||
# toString/hashCode still reach object-methods on shim objects.
|
||||
(and (get object-methods field-name)
|
||||
(not (and (table? target) (get tagged-methods (get target :jolt/type))
|
||||
(or has-args (get (get tagged-methods (get target :jolt/type)) field-name)))))
|
||||
((get object-methods field-name) target ;args)
|
||||
# registered shim objects (java.time etc.): tag-keyed method tables
|
||||
(and (or (table? target) (struct? target))
|
||||
(get tagged-methods (get target :jolt/type))
|
||||
(or has-args (get (get tagged-methods (get target :jolt/type)) field-name)))
|
||||
(let [m (get (get tagged-methods (get target :jolt/type)) field-name)]
|
||||
(if m
|
||||
(m target ;args)
|
||||
(error (string "Unsupported method ." field-name " on " (string (get target :jolt/type))))))
|
||||
# --- divergent tail ---
|
||||
has-args
|
||||
# (. obj method args...): record protocol dispatch, else native field/method
|
||||
(if (record-tag target)
|
||||
# deftype/reify methods live in the protocol registry (or the instance's
|
||||
# reified-fns table), not on the instance. get is safe on a shape-rec
|
||||
# tuple (returns nil for the method/protocol keys).
|
||||
(let [method-key (keyword field-name)
|
||||
own (get target method-key)
|
||||
reified (get (get target :jolt/protocol-methods) method-key)
|
||||
m (cond
|
||||
(or (function? own) (cfunction? own)) own
|
||||
(or (function? reified) (cfunction? reified)) reified
|
||||
(find-method-any-protocol ctx (record-tag target) field-name))]
|
||||
(if m
|
||||
(apply m target args)
|
||||
(error (string "No method ." field-name " on " (record-tag target)))))
|
||||
# Janet-native interop: try field lookup + call
|
||||
(if (or (table? target) (struct? target))
|
||||
(let [method (get target (keyword field-name))]
|
||||
(if (or (function? method) (cfunction? method))
|
||||
(method target ;args)
|
||||
# If stored as fn* form (array), compile to function then call
|
||||
(if (array? method)
|
||||
(let [method-fn (eval-form ctx bindings method)]
|
||||
(if (or (function? method-fn) (cfunction? method-fn))
|
||||
(method-fn target ;args)
|
||||
(error (string "Cannot call non-function " field-name " on " (type target)))))
|
||||
(let [r (if coll-interop (coll-interop target field-name args) :jolt/ci-none)]
|
||||
(if (= r :jolt/ci-none)
|
||||
(error (string "Cannot call non-function " field-name " on " (type target)))
|
||||
r)))))
|
||||
(error (string "Cannot call method " field-name " on " (type target)))))
|
||||
# (. obj member) with no extra args: a symbol member naming a function is a
|
||||
# zero-arg method call (receiver passed as self); a keyword or `-field`
|
||||
# member is plain field access.
|
||||
true
|
||||
# zero-arg Java collection interop (.count/.seq/… on a jolt collection)
|
||||
# before field lookup — coll-interop returns :jolt/ci-none if not its kind
|
||||
(let [ci (if coll-interop (coll-interop target field-name @[]) :jolt/ci-none)]
|
||||
(if (not= ci :jolt/ci-none) ci
|
||||
(let [v (if (record-tag target)
|
||||
(coll-lookup target (keyword field-name) nil)
|
||||
(get target (keyword field-name)))]
|
||||
(if (and (struct? member-raw) (= :symbol (member-raw :jolt/type))
|
||||
(not (string/has-prefix? "-" member-name)))
|
||||
(cond
|
||||
(or (function? v) (cfunction? v)) (v target)
|
||||
# zero-arg deftype/reify method via the protocol registry
|
||||
(record-tag target)
|
||||
(let [reified (get (get target :jolt/protocol-methods) (keyword field-name))
|
||||
m (if (or (function? reified) (cfunction? reified)) reified
|
||||
(find-method-any-protocol ctx (record-tag target) field-name))]
|
||||
(if m (m target) v))
|
||||
# value stored as an unevaluated fn* form: compile then call
|
||||
(array? v) (let [f (eval-form ctx bindings v)]
|
||||
(if (or (function? f) (cfunction? f)) (f target) f))
|
||||
v)
|
||||
v))))))
|
||||
|
||||
(defn eval-dot [ctx bindings form]
|
||||
(let [target (eval-form ctx bindings (in form 1))
|
||||
member-raw (in form 2)
|
||||
# Resolve member name: symbols have :name, keywords use string, strings as-is
|
||||
member-name (if (and (struct? member-raw) (= :symbol (member-raw :jolt/type)))
|
||||
(member-raw :name)
|
||||
(if (keyword? member-raw)
|
||||
(string member-raw)
|
||||
member-raw))
|
||||
field-name (if (and (string? member-name) (> (length member-name) 0) (= "-" (string/slice member-name 0 1)))
|
||||
(string/slice member-name 1)
|
||||
member-name)]
|
||||
(if (> (length form) 3)
|
||||
# method call: (. obj method args...)
|
||||
(let [args (map |(eval-form ctx bindings $) (tuple/slice form 3))]
|
||||
(if (or (string? target) (buffer? target))
|
||||
(let [m (get string-methods field-name)]
|
||||
(if m
|
||||
(m (string target) ;args)
|
||||
(if-let [om (get object-methods field-name)]
|
||||
(om (string target) ;args)
|
||||
(error (string "Unsupported String method ." field-name)))))
|
||||
(if (and (number? target) (get number-methods field-name))
|
||||
((get number-methods field-name) target ;args)
|
||||
(if (and (get object-methods field-name)
|
||||
(not (and (table? target) (get tagged-methods (get target :jolt/type)))))
|
||||
((get object-methods field-name) target ;args)
|
||||
# registered shim objects (java.time etc.): tag-keyed method tables
|
||||
(if (and (or (table? target) (struct? target))
|
||||
(get tagged-methods (get target :jolt/type)))
|
||||
(let [m (get (get tagged-methods (get target :jolt/type)) field-name)]
|
||||
(if m
|
||||
(m target ;args)
|
||||
(error (string "Unsupported method ." field-name " on " (string (get target :jolt/type))))))
|
||||
(if (record-tag target)
|
||||
# deftype/reify methods live in the protocol registry (or the
|
||||
# instance's reified-fns table), not on the instance. get is safe
|
||||
# on a shape-rec tuple (returns nil for the method/protocol keys).
|
||||
(let [method-key (keyword field-name)
|
||||
own (get target method-key)
|
||||
reified (get (get target :jolt/protocol-methods) method-key)
|
||||
m (cond
|
||||
(or (function? own) (cfunction? own)) own
|
||||
(or (function? reified) (cfunction? reified)) reified
|
||||
(find-method-any-protocol ctx (record-tag target) field-name))]
|
||||
(if m
|
||||
(apply m target args)
|
||||
(error (string "No method ." field-name " on " (record-tag target)))))
|
||||
# Janet-native interop: try field lookup + call
|
||||
(if (or (table? target) (struct? target))
|
||||
(let [method (get target (keyword field-name))]
|
||||
(if (or (function? method) (cfunction? method))
|
||||
(method target ;args)
|
||||
# If stored as fn* form (array), compile to function then call
|
||||
(if (array? method)
|
||||
(let [method-fn (eval-form ctx bindings method)]
|
||||
(if (or (function? method-fn) (cfunction? method-fn))
|
||||
(method-fn target ;args)
|
||||
(error (string "Cannot call non-function " field-name " on " (type target)))))
|
||||
(let [r (if coll-interop (coll-interop target field-name args) :jolt/ci-none)]
|
||||
(if (= r :jolt/ci-none)
|
||||
(error (string "Cannot call non-function " field-name " on " (type target)))
|
||||
r)))))
|
||||
(error (string "Cannot call method " field-name " on " (type target))))))))))
|
||||
# (. obj member) with no extra args: a symbol member naming a
|
||||
# function is a zero-arg method call (receiver passed as self);
|
||||
# a keyword or `-field` member is plain field access. Strings get
|
||||
# the java.lang.String surface (clj-compat: (.toLowerCase s) ...).
|
||||
(if (or (string? target) (buffer? target))
|
||||
(let [m (get string-methods field-name)]
|
||||
(if m
|
||||
(m (string target))
|
||||
(if-let [om (get object-methods field-name)]
|
||||
(om (string target))
|
||||
(error (string "Unsupported String method ." field-name)))))
|
||||
(if (and (number? target) (get number-methods field-name))
|
||||
((get number-methods field-name) target)
|
||||
(if (and (get object-methods field-name)
|
||||
(not (and (table? target) (get tagged-methods (get target :jolt/type))
|
||||
(get (get tagged-methods (get target :jolt/type)) field-name))))
|
||||
((get object-methods field-name) target)
|
||||
(if (and (or (table? target) (struct? target))
|
||||
(get tagged-methods (get target :jolt/type))
|
||||
(get (get tagged-methods (get target :jolt/type)) field-name))
|
||||
((get (get tagged-methods (get target :jolt/type)) field-name) target)
|
||||
# zero-arg Java collection interop (.count/.seq/… on a jolt collection)
|
||||
# before field lookup — coll-interop returns :jolt/ci-none if not its kind
|
||||
(let [ci (if coll-interop (coll-interop target field-name @[]) :jolt/ci-none)]
|
||||
(if (not= ci :jolt/ci-none) ci
|
||||
(let [v (if (record-tag target)
|
||||
(coll-lookup target (keyword field-name) nil)
|
||||
(get target (keyword field-name)))]
|
||||
(if (and (struct? member-raw) (= :symbol (member-raw :jolt/type))
|
||||
(not (string/has-prefix? "-" member-name)))
|
||||
(cond
|
||||
(or (function? v) (cfunction? v)) (v target)
|
||||
# zero-arg deftype/reify method via the protocol registry
|
||||
(record-tag target)
|
||||
(let [reified (get (get target :jolt/protocol-methods) (keyword field-name))
|
||||
m (if (or (function? reified) (cfunction? reified)) reified
|
||||
(find-method-any-protocol ctx (record-tag target) field-name))]
|
||||
(if m (m target) v))
|
||||
# value stored as an unevaluated fn* form: compile then call
|
||||
(array? v) (let [f (eval-form ctx bindings v)]
|
||||
(if (or (function? f) (cfunction? f)) (f target) f))
|
||||
v)
|
||||
v)))))))))))
|
||||
member-raw (in form 2)
|
||||
# Resolve member name: symbols have :name, keywords use string, strings as-is
|
||||
member-name (if (and (struct? member-raw) (= :symbol (member-raw :jolt/type)))
|
||||
(member-raw :name)
|
||||
(if (keyword? member-raw)
|
||||
(string member-raw)
|
||||
member-raw))
|
||||
field-name (if (and (string? member-name) (> (length member-name) 0) (= "-" (string/slice member-name 0 1)))
|
||||
(string/slice member-name 1)
|
||||
member-name)
|
||||
has-args (> (length form) 3)
|
||||
args (if has-args (map |(eval-form ctx bindings $) (tuple/slice form 3)) @[])]
|
||||
(dispatch-member ctx bindings target member-raw member-name field-name args has-args)))
|
||||
|
||||
(defn eval-list
|
||||
[ctx bindings form]
|
||||
|
|
|
|||
|
|
@ -9,6 +9,25 @@
|
|||
["field access .-" "41" "(.-value {:value 41})"]
|
||||
["dot field keyword" "41" "(. {:value 41} :value)"])
|
||||
|
||||
# Both `.` arms share one dispatch-member helper (jolt-eos3). These rows lock the
|
||||
# behaviors where the call form (args) and the bare form (zero-arg) diverge in
|
||||
# their tails: zero-arg coll-interop vs with-arg coll-interop, and record/deftype
|
||||
# zero-arg methods vs methods-with-args vs `-field` field access.
|
||||
(defspec "interop / dot dispatch arms"
|
||||
["zero-arg coll-interop .count" "3" "(.count [1 2 3])"]
|
||||
["zero-arg coll-interop .seq" "[1 2]" "(.seq [1 2])"]
|
||||
["explicit dot zero-arg interop" "3" "(. [1 2 3] count)"]
|
||||
["with-arg coll-interop .nth" "2" "(.nth [1 2 3] 1)"]
|
||||
["record zero-arg method" "10"
|
||||
"(do (defprotocol Pd (gm [this])) (defrecord Rd [x] Pd (gm [this] (* 2 x))) (.gm (->Rd 5)))"]
|
||||
["record method with args" "15"
|
||||
"(do (defprotocol Pa (am [this y])) (defrecord Ra [x] Pa (am [this y] (+ x y))) (.am (->Ra 5) 10))"]
|
||||
["deftype method with args" "7"
|
||||
"(do (defprotocol Pq (qq [this y])) (deftype Tq [x] Pq (qq [this y] (+ x y))) (.qq (Tq. 3) 4))"]
|
||||
["record -field is field access" "7"
|
||||
"(do (defrecord Rf [x]) (.-x (->Rf 7)))"]
|
||||
["object-method with args .equals" "true" "(.equals \"a\" \"a\")"])
|
||||
|
||||
# The `janet` namespace segment is the explicit Janet-stdlib bridge added for
|
||||
# the networking layer (and used by jolt.nrepl). `janet/<name>` resolves a Janet
|
||||
# root binding; `janet.<module>/<name>` resolves a module binding. The boundary
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue