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

@@ -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))
+  (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)))

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"}
 ]