From 8c6623503f110888a465275a33e8744717ea68ae Mon Sep 17 00:00:00 2001 From: Yogthos Date: Mon, 22 Jun 2026 13:06:12 -0400 Subject: [PATCH] Host hooks for library class shims: __register-class-methods! + __register-instance-check! clj-http-lite drives java.net URL/HttpURLConnection and java.io byte streams through .method interop. The Chez host had __register-class-ctor!/-statics! (what router/reitit needs) but no way to register instance methods on a shim object or to extend instance?. Add both, plus jolt.host/table?: - tagged-table .method dispatch: an htable-arm on record-method-dispatch routes (.m obj a*) through a per-tag method registry keyed off the table's jolt/type; unregistered methods fall through (sorted colls are htables too). - __register-instance-check! installs (fn [class-name val] -> true|false|nil), nil = fall through; chained ahead of the base instance-check. Runtime .ss shims, no re-mint. Unit covers dispatch, args, instance? both ways. --- host/chez/host-static.ss | 55 +++++++++++++++++++++++++++++++++++++++- test/chez/unit.edn | 6 +++++ 2 files changed, 60 insertions(+), 1 deletion(-) diff --git a/host/chez/host-static.ss b/host/chez/host-static.ss index 6ca69dd..1ae92a5 100644 --- a/host/chez/host-static.ss +++ b/host/chez/host-static.ss @@ -657,4 +657,57 @@ (def-var! "clojure.core" "__register-class-ctor!" (lambda (name proc) (register-class-ctor! name proc) jolt-nil)) (def-var! "clojure.core" "__register-class-statics!" - (lambda (name members) (register-class-statics! name (jmap->static-alist members)) jolt-nil)) \ No newline at end of file + (lambda (name members) (register-class-statics! name (jmap->static-alist members)) jolt-nil)) + +;; ---- tagged-table method dispatch + pluggable instance? -------------------- +;; A jolt library can build stateful host objects with (jolt.host/tagged-table +;; tag) and dispatch (.method obj ...) to handlers registered here, keyed by the +;; table's "jolt/type" tag — the htable analogue of the jhost method registry +;; above. jolt-lang/http-client uses this to emulate java.net URL / +;; HttpURLConnection / java.io byte streams so clj-http-lite runs unchanged. +(define tagged-methods-tbl (make-hashtable string-hash string=?)) ; tag-key -> (method-ht) +(define (tag->method-key tag) + (if (keyword-t? tag) + (let ((ns (keyword-t-ns tag))) + (if (and ns (not (jolt-nil? ns))) (string-append ns "/" (keyword-t-name tag)) (keyword-t-name tag))) + (jolt-str-render-one tag))) +(define (register-tagged-methods! tag members) + (let* ((key (tag->method-key tag)) + (h (or (hashtable-ref tagged-methods-tbl key #f) + (let ((nh (make-hashtable string-hash string=?))) + (hashtable-set! tagged-methods-tbl key nh) nh)))) + (for-each (lambda (p) (hashtable-set! h (car p) (cdr p))) members))) + +;; 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 + (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)))))) + +(def-var! "clojure.core" "__register-class-methods!" + (lambda (tag members) (register-tagged-methods! tag (jmap->static-alist members)) jolt-nil)) + +;; Pluggable instance? — a library registers (fn [class-name-string val] -> true +;; | false | nil); nil means "not my class, fall through". First non-nil wins. +(define user-instance-checks '()) +(define %hs-instance-check instance-check) +(set! instance-check + (lambda (type-sym val) + (let ((tname (symbol-t-name type-sym))) + (let loop ((fs user-instance-checks)) + (if (null? fs) + (%hs-instance-check type-sym val) + (let ((r ((car fs) tname val))) + (if (jolt-nil? r) (loop (cdr fs)) (if (jolt-truthy? r) #t #f)))))))) +(def-var! "clojure.core" "instance-check" instance-check) +(def-var! "clojure.core" "__register-instance-check!" + (lambda (f) (set! user-instance-checks (append user-instance-checks (list f))) jolt-nil)) + +;; (jolt.host/table? x) — is x a host tagged-table (the Janet-table replacement)? +(def-var! "jolt.host" "table?" (lambda (x) (if (htable? x) #t #f))) \ No newline at end of file diff --git a/test/chez/unit.edn b/test/chez/unit.edn index b94695f..53d2f2f 100644 --- a/test/chez/unit.edn +++ b/test/chez/unit.edn @@ -459,4 +459,10 @@ {:suite "deftype-mutable" :expr "(do (defprotocol IB (gv [_]) (sv [_ v])) (deftype B [^:unsynchronized-mutable val] IB (gv [_] val) (sv [_ v] (set! val v))) (let [b (->B 1)] (sv b 42) (gv b)))" :expected "42"} {:suite "deftype-mutable" :expr "(do (defprotocol IC (bump [_]) (cur [_])) (deftype C [^:unsynchronized-mutable n] IC (bump [this] (set! n (inc n)) n) (cur [_] n)) (let [c (->C 5)] (bump c) (bump c) (bump c) (cur c)))" :expected "8"} {:suite "deftype-mutable" :expr "(do (defprotocol IH (g [_]) (s [_ v])) (deftype H [^:volatile-mutable st] IH (g [_] st) (s [this v] (set! (.-st this) v))) (let [h (->H :old)] (s h :new) (g h)))" :expected ":new"} + {:suite "hostshim" :expr "(do (__register-class-ctor! \"Box1\" (fn [v] (let [t (jolt.host/tagged-table :my/box)] (jolt.host/ref-put! t :v v) t))) (__register-class-methods! :my/box {\"getV\" (fn [self] (jolt.host/ref-get self :v))}) (.getV (Box1. 42)))" :expected "42"} + {:suite "hostshim" :expr "(do (__register-class-ctor! \"Box2\" (fn [v] (let [t (jolt.host/tagged-table :my/box2)] (jolt.host/ref-put! t :v v) t))) (__register-class-methods! :my/box2 {\"add\" (fn [self n] (+ n (jolt.host/ref-get self :v)))}) (.add (Box2. 10) 5))" :expected "15"} + {:suite "hostshim" :expr "(do (__register-class-ctor! \"Box3\" (fn [] (jolt.host/tagged-table :my/box3))) (__register-instance-check! (fn [cn val] (if (= cn \"Box3\") (= :my/box3 (jolt.host/ref-get val :jolt/type)) nil))) (instance? Box3 (Box3.)))" :expected "true"} + {:suite "hostshim" :expr "(do (__register-class-ctor! \"Box4\" (fn [] (jolt.host/tagged-table :my/box4))) (__register-instance-check! (fn [cn val] (if (= cn \"Box4\") (= :my/box4 (jolt.host/ref-get val :jolt/type)) nil))) (instance? Box4 \"not-a-box\"))" :expected "false"} + {:suite "hostshim" :expr "(jolt.host/table? (jolt.host/tagged-table :t))" :expected "true"} + {:suite "hostshim" :expr "(jolt.host/table? \"x\")" :expected "false"} ]