Route deftype/reify interface dispatch through one seam
The "does value V declare method M; if so call it" decision was re-derived in a dozen places with two different lookup helpers — records.ss jrec-cl and collections.ss rec-coll-method were a byte-for-byte duplicate — and reduce only honored a reify's own reduce method, not a deftype's: (reduce + 100 (->Rng 5)) ; Rng deftype implementing IReduceInit => "not seqable" ; JVM: 110 Add iface-method / iface-call: one lookup that resolves a method for a deftype OR a reify, with arity, and is the seam a core fn's interface arm collapses to. jrec-cl now aliases rec-coll-method (the duplicate is gone). reduce routes its IReduceInit arm through iface-method, so a deftype's reduce drives the reduction like a reify's, reduced short-circuit included. Runtime only, no re-mint. make test green (0 new/stale), +2 corpus rows.
This commit is contained in:
parent
0b07b376bb
commit
01f98c2e89
3 changed files with 25 additions and 5 deletions
|
|
@ -304,7 +304,25 @@
|
||||||
;; implements a clojure.lang collection interface carries the op as an inline
|
;; implements a clojure.lang collection interface carries the op as an inline
|
||||||
;; method — prefer that method, else fall back to the field/map behavior. (jrec-cl
|
;; method — prefer that method, else fall back to the field/map behavior. (jrec-cl
|
||||||
;; finds the method; find-method-any-protocol / jolt-invoke resolve at call time.)
|
;; finds the method; find-method-any-protocol / jolt-invoke resolve at call time.)
|
||||||
(define (jrec-cl coll name) (and (jrec? coll) (find-method-any-protocol (jrec-tag coll) name)))
|
;; Same lookup as collections.ss rec-coll-method — one definition, aliased here.
|
||||||
|
(define jrec-cl rec-coll-method)
|
||||||
|
|
||||||
|
;; iface-method: the single deftype/reify interface-method lookup. Returns the
|
||||||
|
;; impl fn for METHOD declared by V (a deftype/record OR a reify), or #f. NARGS
|
||||||
|
;; (including `this`) selects the matching arity for a deftype; #f means any
|
||||||
|
;; arity. Core fns route interface dispatch through this instead of each
|
||||||
|
;; re-deriving jrec-vs-reify lookup and arity handling.
|
||||||
|
(define (iface-method v method nargs)
|
||||||
|
(cond ((jrec? v)
|
||||||
|
(if nargs (find-method-any-protocol-arity (jrec-tag v) method nargs)
|
||||||
|
(find-method-any-protocol (jrec-tag v) method)))
|
||||||
|
((jreify? v) (let ((rm (reified-methods v))) (and rm (hashtable-ref rm method #f))))
|
||||||
|
(else #f)))
|
||||||
|
;; Call METHOD on V with ARGS (a list, `this` excluded) if V declares it, else run
|
||||||
|
;; FALLBACK. The one seam a core fn's deftype/reify arm collapses to.
|
||||||
|
(define (iface-call v method args fallback)
|
||||||
|
(let ((m (iface-method v method (+ 1 (length args)))))
|
||||||
|
(if m (apply jolt-invoke m v args) (fallback))))
|
||||||
(define %r-jolt-count jolt-count)
|
(define %r-jolt-count jolt-count)
|
||||||
(set! jolt-count (lambda (coll)
|
(set! jolt-count (lambda (coll)
|
||||||
(cond ((jrec-cl coll "count") => (lambda (m) (jolt-invoke m coll)))
|
(cond ((jrec-cl coll "count") => (lambda (m) (jolt-invoke m coll)))
|
||||||
|
|
|
||||||
|
|
@ -421,11 +421,11 @@
|
||||||
(if (jolt-nil? s) (jolt-invoke f) ; (reduce f []) -> (f)
|
(if (jolt-nil? s) (jolt-invoke f) ; (reduce f []) -> (f)
|
||||||
(reduce-seq f (seq-first s) (jolt-seq (seq-more s))))))
|
(reduce-seq f (seq-first s) (jolt-seq (seq-more s))))))
|
||||||
((f init coll)
|
((f init coll)
|
||||||
;; IReduceInit: a reify/record with its own `reduce` method drives the
|
;; IReduceInit: a deftype/record OR reify with its own `reduce` method drives
|
||||||
;; reduction (reduce f init (reify clojure.lang.IReduceInit (reduce [_ f i] ...))).
|
;; the reduction, e.g. (reduce f init (reify clojure.lang.IReduceInit
|
||||||
|
;; (reduce [_ f i] ...))) or the same on a deftype.
|
||||||
(cond
|
(cond
|
||||||
((and (jreify? coll) (reified-methods coll)
|
((iface-method coll "reduce" 3)
|
||||||
(hashtable-ref (reified-methods coll) "reduce" #f))
|
|
||||||
=> (lambda (m) (let ((r (jolt-invoke m coll f init)))
|
=> (lambda (m) (let ((r (jolt-invoke m coll f init)))
|
||||||
(if (jolt-reduced? r) (jolt-reduced-val r) r))))
|
(if (jolt-reduced? r) (jolt-reduced-val r) r))))
|
||||||
(else (reduce-seq f init (jolt-seq coll)))))))
|
(else (reduce-seq f init (jolt-seq coll)))))))
|
||||||
|
|
|
||||||
|
|
@ -3509,4 +3509,6 @@
|
||||||
{:suite "protocols / instance? matches dispatch" :label "instance? agrees with what a value's class implements" :expected "[true true false true true]" :actual "[(instance? clojure.lang.Associative [1 2]) (instance? clojure.lang.IFn :k) (instance? java.util.Map [1 2]) (instance? clojure.lang.Seqable (map inc [1 2])) (instance? clojure.lang.IPersistentVector [1 2])]"}
|
{:suite "protocols / instance? matches dispatch" :label "instance? agrees with what a value's class implements" :expected "[true true false true true]" :actual "[(instance? clojure.lang.Associative [1 2]) (instance? clojure.lang.IFn :k) (instance? java.util.Map [1 2]) (instance? clojure.lang.Seqable (map inc [1 2])) (instance? clojure.lang.IPersistentVector [1 2])]"}
|
||||||
{:suite "class / hierarchy views agree" :label "isa?/supers see the modeled exception + collection hierarchy" :expected "[true true true true]" :actual "[(isa? clojure.lang.ExceptionInfo java.lang.RuntimeException) (contains? (supers java.lang.NumberFormatException) java.lang.RuntimeException) (isa? clojure.lang.Keyword clojure.lang.IFn) (contains? (ancestors clojure.lang.PersistentVector) java.util.List)]"}
|
{:suite "class / hierarchy views agree" :label "isa?/supers see the modeled exception + collection hierarchy" :expected "[true true true true]" :actual "[(isa? clojure.lang.ExceptionInfo java.lang.RuntimeException) (contains? (supers java.lang.NumberFormatException) java.lang.RuntimeException) (isa? clojure.lang.Keyword clojure.lang.IFn) (contains? (ancestors clojure.lang.PersistentVector) java.util.List)]"}
|
||||||
{:suite "host-interop / getClass" :label ".getClass is a universal Object method, reached on every value type" :expected "[\"java.util.Date\" \"java.io.File\"]" :actual "[(.getName (.getClass (java.util.Date.))) (.getName (.getClass (java.io.File. \"x\")))]"}
|
{:suite "host-interop / getClass" :label ".getClass is a universal Object method, reached on every value type" :expected "[\"java.util.Date\" \"java.io.File\"]" :actual "[(.getName (.getClass (java.util.Date.))) (.getName (.getClass (java.io.File. \"x\")))]"}
|
||||||
|
{:suite "reduce / IReduceInit" :label "reduce drives a deftype's own reduce method (init arity)" :expected "110" :actual "(do (deftype Rng [n] clojure.lang.IReduceInit (reduce [_ f init] (loop [i 0 acc init] (if (< i n) (recur (inc i) (f acc i)) acc)))) (reduce + 100 (->Rng 5)))"}
|
||||||
|
{:suite "reduce / IReduceInit" :label "a deftype reduce honors reduced short-circuit" :expected "3" :actual "(do (deftype Rng [n] clojure.lang.IReduceInit (reduce [_ f init] (loop [i 0 acc init] (if (< i n) (let [a (f acc i)] (if (reduced? a) @a (recur (inc i) a))) acc)))) (reduce (fn [acc x] (if (= x 3) (reduced acc) (+ acc x))) 0 (->Rng 10)))"}
|
||||||
]
|
]
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue