diff --git a/host/chez/java/dot-forms.ss b/host/chez/java/dot-forms.ss index 0ec81ad..3adac4c 100644 --- a/host/chez/java/dot-forms.ss +++ b/host/chez/java/dot-forms.ss @@ -17,8 +17,6 @@ ;; 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: ;; coll-interop accepts some seq representations and not others (a ;; plain (seq v) returns nil from .count, a lazy-seq returns the count), an @@ -84,7 +82,7 @@ ((string=? name "equals") (list (if (jolt= obj (car args)) #t #f))) (else #f))) -(set! record-method-dispatch +(register-method-arm! 30 (lambda (obj method-name rest-args) (let* ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))) (field? (and (> (string-length method-name) 0) @@ -93,9 +91,6 @@ (substring method-name 1 (string-length method-name)) method-name))) (cond - ;; (.getClass x) universal — the class token for any value, before the - ;; collection/map field-lookup arms below would read it as a missing key. - ((string=? method-name "getClass") (jolt-class obj)) ;; clojure.lang.MultiFn .dispatchFn / .getMethod — clojure.spec.alpha's ;; multi-spec walks a multimethod through these. ((jolt-multifn? obj) @@ -107,7 +102,7 @@ (mm-find-isa obj dv) (hashtable-ref methods (jolt-multifn-default obj) #f) jolt-nil))) - (else (%dot-rmd obj method-name rest-args)))) + (else 'pass))) ;; (.applyTo f args): apply a fn to a seq of args (clojure.spec instrument). ((and (procedure? obj) (string=? mname "applyTo")) (apply jolt-invoke obj (seq->list (jolt-seq (car rest))))) @@ -119,7 +114,7 @@ ((or (string=? mname "valAt") (string=? mname "get")) (t-get obj (car rest) (if (null? (cdr rest)) jolt-nil (cadr rest)))) ((string=? mname "count") (t-count obj)) - (else (%dot-rmd obj method-name rest-args)))) + (else 'pass))) ;; a deftype/record's OWN declared method (matched by name AND arity) wins ;; over the generic collection interop below — e.g. data.priority-map ;; declares both seq[this] (Seqable) and seq[this ascending] (Sorted), and @@ -145,4 +140,4 @@ (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)))))) + (else 'pass))))) diff --git a/host/chez/java/host-static-classes.ss b/host/chez/java/host-static-classes.ss index f9656fa..253b775 100644 --- a/host/chez/java/host-static-classes.ss +++ b/host/chez/java/host-static-classes.ss @@ -642,8 +642,7 @@ ;; record-method-dispatch already routes string? -> jolt-string-method. Add a ;; regex-t arm (Pattern .split / .matcher-less surface used by corpus) by wrapping ;; once more — a regex-t isn't a jhost. -(define %hs-rmd2 record-method-dispatch) -(set! record-method-dispatch +(register-method-arm! 42 (lambda (obj method-name rest-args) (let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args)))) (cond @@ -667,7 +666,7 @@ ((string=? method-name "group") (apply jolt-matcher-group obj rest)) ((string=? method-name "groupCount") (jolt-matcher-group-count obj)) (else (error #f (string-append "No method " method-name " on Matcher"))))) - (else (%hs-rmd2 obj method-name rest-args)))))) + (else 'pass))))) ;; ---- def-var! the registry entry points so emit can also reach them --------- (def-var! "clojure.core" "host-static-ref" host-static-ref) @@ -709,15 +708,14 @@ ;; htable arm: dispatch (.method obj a*) through the table's tag method registry; ;; an unregistered method falls through (sorted colls are htables too). -(define %hs-rmd-htable record-method-dispatch) -(set! record-method-dispatch +(register-method-arm! 43 (lambda (obj method-name rest-args) (let ((tag (and (htable? obj) (hashtable-ref (htable-h obj) "jolt/type" #f)))) (let* ((mh (and tag (hashtable-ref tagged-methods-tbl (tag->method-key tag) #f))) (f (and mh (hashtable-ref mh method-name #f)))) (if f (apply f obj (if (jolt-nil? rest-args) '() (seq->list rest-args))) - (%hs-rmd-htable obj method-name rest-args)))))) + 'pass))))) (def-var! "clojure.core" "__register-class-methods!" (lambda (tag members) (register-tagged-methods! tag (jmap->static-alist members)) jolt-nil)) diff --git a/host/chez/java/host-static.ss b/host/chez/java/host-static.ss index 2f59bf6..00cfd42 100644 --- a/host/chez/java/host-static.ss +++ b/host/chez/java/host-static.ss @@ -90,13 +90,9 @@ (list->cseq (if asc keep (reverse keep))))) (else (error #f (string-append "No method " method " on sorted collection"))))) -(define %hs-record-method-dispatch record-method-dispatch) -(set! record-method-dispatch +(register-method-arm! 44 (lambda (obj method-name rest-args) (cond - ;; (.getClass x) is universal — the class token for any value (incl. numbers - ;; / jhost) — before the per-type arms that would otherwise reject it. - ((string=? method-name "getClass") (jolt-class obj)) ((jhost? obj) (let ((mh (hashtable-ref host-methods-tbl (jhost-tag obj) #f))) (let ((f (and mh (hashtable-ref mh method-name #f)))) @@ -104,7 +100,7 @@ (apply f obj (if (jolt-nil? rest-args) '() (seq->list rest-args))) (error #f (string-append "No method " method-name " on host " (jhost-tag obj))))))) ((number? obj) (apply number-method method-name obj (if (jolt-nil? rest-args) '() (seq->list rest-args)))) - (else (%hs-record-method-dispatch obj method-name rest-args))))) + (else 'pass)))) ;; java.lang.Number method surface (the boxed-number methods cljc code calls). The ;; integer projections wrap modulo their width (ring-codec relies on byteValue diff --git a/host/chez/java/inst-time.ss b/host/chez/java/inst-time.ss index dfb6752..4b2937f 100644 --- a/host/chez/java/inst-time.ss +++ b/host/chez/java/inst-time.ss @@ -562,8 +562,7 @@ (cons "format" (lambda (self d) (format-ms (vector-ref (jhost-state self) 0) (ms-of d)))))) ;; a jinst's java.util.Date method surface (record-method-dispatch arm). -(define %it-rmd record-method-dispatch) -(set! record-method-dispatch +(register-method-arm! 40 (lambda (obj method-name rest-args) (cond ((jinst? obj) @@ -586,7 +585,7 @@ ((string=? method-name "before") (< (jinst-ms obj) (ms-of (car (seq->list rest-args))))) ((string=? method-name "after") (> (jinst-ms obj) (ms-of (car (seq->list rest-args))))) (else (error #f (string-append "No method " method-name " on Date"))))) - (else (%it-rmd obj method-name rest-args))))) + (else 'pass)))) ;; Clojure's built-in data readers, so a library that merges default-data-readers ;; or binds *data-readers* (e.g. aero's reader opts) resolves #inst / #uuid. diff --git a/host/chez/java/io.ss b/host/chez/java/io.ss index ab1c511..68a2d22 100644 --- a/host/chez/java/io.ss +++ b/host/chez/java/io.ss @@ -240,14 +240,13 @@ (else (loop (- i 1)))))) (else #f)))) -(define %io-rmd record-method-dispatch) -(set! record-method-dispatch +(register-method-arm! 41 (lambda (obj method-name rest-args) (if (jfile? obj) (let* ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))) (r (jfile-method obj method-name rest))) (if r (car r) (error #f "no File method" method-name))) - (%io-rmd obj method-name rest-args)))) + 'pass))) ;; .isDirectory / .listFiles emit to jolt-host-call (rt.ss), not record-method- ;; dispatch — the shims there assume a path STRING target. Make them jfile-aware diff --git a/host/chez/records.ss b/host/chez/records.ss index ca7e9f5..c0593d9 100644 --- a/host/chez/records.ss +++ b/host/chez/records.ss @@ -797,14 +797,9 @@ ;; "#". (def-var! "jolt.host" "condition-message" (lambda (c) (if (condition? c) (condition->message-string c) jolt-nil))) -(define (record-method-dispatch obj method-name rest-args) +(define (record-method-dispatch-base obj method-name rest-args) (let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args)))) (cond - ;; (.getClass x): universal Object method — the class token for any value - ;; (jolt has no Class objects; the token is the canonical name string, on - ;; which .getName/.getSimpleName work via the String method shim). - ((and (string=? method-name "getClass") (not (jrec? obj)) (not (jreify? obj))) - (jolt-class obj)) ((and (jrec? obj) (find-method-any-protocol-arity (jrec-tag obj) method-name (+ 1 (length rest)))) => (lambda (f) (apply jolt-invoke f obj rest))) ;; (.field inst): a deftype/record field read with no matching method. @@ -936,6 +931,36 @@ (else (error #f (string-append "No method " method-name " for value: " (jolt-pr-str obj))))))) +;; ---- method-dispatch arm registry ------------------------------------------ +;; A .method call (record-method-dispatch) is resolved by an ordered list of arms +;; (ascending priority), each (obj method-name rest-args) -> result | 'pass. +;; This replaces a stack of (set! record-method-dispatch ...) rebindings across +;; six files whose precedence was implicit in load order — priority is now +;; explicit data. record-method-dispatch-base is the final fallback (the +;; string/keyword/symbol/Object-method surface). A host shim / library registers +;; an arm with register-method-arm! instead of set!-wrapping the dispatcher. +(define method-dispatch-arms '()) ; list of (priority . arm), ascending priority +(define (register-method-arm! priority arm) + (set! method-dispatch-arms + (let ins ((as method-dispatch-arms)) + (cond ((null? as) (list (cons priority arm))) + ((< priority (caar as)) (cons (cons priority arm) as)) + (else (cons (car as) (ins (cdr as)))))))) +(define (record-method-dispatch obj method-name rest-args) + (let loop ((as method-dispatch-arms)) + (if (null? as) + (record-method-dispatch-base obj method-name rest-args) + (let ((r ((cdar as) obj method-name rest-args))) + (if (eq? r 'pass) (loop (cdr as)) r))))) + +;; (.getClass x): a universal Object method reached by EVERY value before any +;; per-type arm — the class token for the value (jolt has no Class objects; the +;; token is the canonical name string, on which .getName/.getSimpleName work). +;; One arm, so a type arm that only whitelists its own methods can't steal it. +(register-method-arm! 5 + (lambda (obj method-name rest-args) + (if (string=? method-name "getClass") (jolt-class obj) 'pass))) + ;; reify: instance-local method table. obj is a jreify carrying a method ht + ;; the protocol short-names it implements (for satisfies?/instance?). (define-record-type jreify (fields methods protos) (nongenerative chez-jreify-v1)) diff --git a/test/chez/corpus.edn b/test/chez/corpus.edn index 69840f4..74eb5f4 100644 --- a/test/chez/corpus.edn +++ b/test/chez/corpus.edn @@ -3508,4 +3508,5 @@ {:suite "protocols / interface dispatch" :label "extend-protocol to an interface a builtin implements dispatches (instance? and protocol dispatch agree)" :expected "[:assoc :ifn :seqable]" :actual "(do (defprotocol PA (ma [_])) (extend-protocol PA clojure.lang.Associative (ma [_] :assoc)) (defprotocol PF (mf [_])) (extend-protocol PF clojure.lang.IFn (mf [_] :ifn)) (defprotocol PS (ms [_])) (extend-protocol PS clojure.lang.Seqable (ms [_] :seqable)) [(ma [1 2]) (mf :k) (ms (map inc [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 "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\")))]"} ]