diff --git a/host/chez/records.ss b/host/chez/records.ss index 5001755..46275a3 100644 --- a/host/chez/records.ss +++ b/host/chez/records.ss @@ -176,11 +176,29 @@ ((and (> (string-length type-name) 10) (string=? (substring type-name 0 10) "java.util.")) (substring type-name 10 (string-length type-name))) (else type-name)))) (and (hashtable-ref host-type-set base #f) base))) +;; An extend/extend-type/extend-protocol registration marks the tag as an +;; extender of the protocol (recorded inside type-registry so the per-case prune +;; restores it). deftype/defrecord inline impls go through register-inline-method +;; and skip the mark: the JVM compiles inline protocol methods into the class, so +;; extenders excludes them. +(define extend-mark "__jolt_extend__") +(define (mark-extend! tag proto-name) + (let ((ti (hashtable-ref type-registry tag #f))) + (when ti (let ((pi (hashtable-ref ti proto-name #f))) + (when pi (hashtable-set! pi extend-mark #t)))))) (define (register-method type-name proto-name method-name fn) - (let ((host (canonical-host-tag type-name))) - (register-protocol-method (or host (string-append (chez-current-ns) "." type-name)) proto-name method-name fn) + (let* ((host (canonical-host-tag type-name)) + (tag (or host (string-append (chez-current-ns) "." type-name)))) + (register-protocol-method tag proto-name method-name fn) + (mark-extend! tag proto-name) jolt-nil)) +;; register-inline-method: a deftype/defrecord inline impl. Registers for dispatch +;; under the ns-qualified record tag but does NOT mark it as an extender. +(define (register-inline-method type-name proto-name method-name fn) + (register-protocol-method (string-append (chez-current-ns) "." type-name) proto-name method-name fn) + jolt-nil) + ;; protocol-dispatch: look up the impl by the value's type tag (record) or host ;; candidates, invoke it; reified objects carry instance-local methods. (define (protocol-dispatch proto-name method-name obj rest-args) @@ -245,14 +263,19 @@ (cond ((< i 0) s) ((char=? (string-ref s i) #\.) (substring s (+ i 1) (string-length s))) (else (loop (- i 1)))))) (define (memp pred lst) (cond ((null? lst) #f) ((pred (car lst)) lst) (else (memp pred (cdr lst))))) -;; extenders: type-tags implementing a protocol, as symbols (extends? reads this). +;; extenders: type-tags that extend a protocol via extend/extend-type/extend- +;; protocol, as symbols (extends? reads this). Inline deftype/defrecord impls are +;; excluded — only tags carrying the extend mark count, matching the JVM. (define (extenders proto) (let* ((pn (jolt-get proto (keyword #f "name") jolt-nil)) (pn-str (if (symbol-t? pn) (symbol-t-name pn) pn)) (out '())) (vector-for-each - (lambda (tag) (when (let ((ti (hashtable-ref type-registry tag #f))) (and ti (hashtable-ref ti pn-str #f))) - (set! out (cons (jolt-symbol jolt-nil tag) out)))) + (lambda (tag) + (let ((ti (hashtable-ref type-registry tag #f))) + (when ti (let ((pi (hashtable-ref ti pn-str #f))) + (when (and pi (hashtable-ref pi extend-mark #f)) + (set! out (cons (jolt-symbol jolt-nil tag) out))))))) (hashtable-keys type-registry)) (if (null? out) jolt-nil (list->cseq out)))) @@ -305,6 +328,7 @@ (def-var! "clojure.core" "make-protocol" make-protocol) (def-var! "clojure.core" "register-protocol-methods!" register-protocol-methods!) (def-var! "clojure.core" "register-method" register-method) +(def-var! "clojure.core" "register-inline-method" register-inline-method) (def-var! "clojure.core" "protocol-dispatch" (lambda (pn mn obj rest) (protocol-dispatch pn mn obj rest))) (def-var! "clojure.core" "satisfies?" jolt-satisfies?) (def-var! "clojure.core" "extenders" extenders) diff --git a/host/chez/run-corpus.ss b/host/chez/run-corpus.ss index 0f74ef1..eb0f0fc 100644 --- a/host/chez/run-corpus.ss +++ b/host/chez/run-corpus.ss @@ -11,7 +11,7 @@ ;; reset between cases so there is no leakage — same isolation a fresh process gives. ;; ;; chez --script host/chez/run-corpus.ss -;; JOLT_CHEZ_ZJ_FLOOR=N override the regression floor (default 2720) +;; JOLT_CHEZ_ZJ_FLOOR=N override the regression floor (default 2722) ;; JOLT_CORPUS_LIMIT=N every-Nth stride (fast iteration; floor drops to 0) ;; JOLT_DUMP_CRASH_LABELS=1 list crash + allowlisted labels (import (chezscheme)) @@ -89,7 +89,6 @@ '("getMessage on a thrown string" "type of record" "chunked-seq? always false" "^Type tag on var" - "lists extended type" "seq of tags" "close on throw" "macroexpand-1" "bean is the map" "proxy resolves nil" "*in* is bound" "*in* bound" @@ -193,7 +192,7 @@ ;; Regression floor: fail on any NEW divergence or if pass drops below the floor. (define base-floor (let ((s (getenv "JOLT_CHEZ_ZJ_FLOOR"))) - (if s (string->number s) 2720))) + (if s (string->number s) 2722))) (define floor (if limit 0 base-floor)) (when (or (> (length diverged) 0) (< pass floor)) (printf "REGRESSION: pass ~a < floor ~a or ~a new divergence(s)\n" diff --git a/host/chez/seed/prelude.ss b/host/chez/seed/prelude.ss index b962166..58da5f3 100644 --- a/host/chez/seed/prelude.ss +++ b/host/chez/seed/prelude.ss @@ -880,7 +880,7 @@ (def-var! "clojure.core" "group-by-head" (letrec ((group-by-head (lambda (items) (let fnrec453 ((items items)) (jolt-reduce (lambda (acc x) (let fnrec454 ((acc acc) (x x)) (if (jolt-truthy? (let* ((or__14__auto (jolt-invoke (var-deref "clojure.core" "symbol?") x))) (if (jolt-truthy? or__14__auto) or__14__auto (jolt-invoke (var-deref "clojure.core" "nil?") x)))) (jolt-conj acc (jolt-vector x)) (jolt-conj (jolt-pop acc) (jolt-conj (jolt-peek acc) x))))) (jolt-vector) items))))) group-by-head))) (guard (e (#t #f)) (def-var! "clojure.core" "deftype" - (lambda (tname fields . body) (let fnrec455 ((tname tname) (fields fields) (body (list->cseq body))) (let* ((unwrap (lambda (x) (let fnrec457 ((x x)) (if (jolt-truthy? (let* ((and__13__auto (jolt-invoke (var-deref "clojure.core" "seq?") x))) (if (jolt-truthy? and__13__auto) (let* ((and__13__auto (jolt-invoke (var-deref "clojure.core" "symbol?") (jolt-first x)))) (if (jolt-truthy? and__13__auto) (jolt= "with-meta" (jolt-invoke (var-deref "clojure.core" "name") (jolt-first x))) and__13__auto)) and__13__auto))) (jolt-invoke (var-deref "clojure.core" "second") x) x)))) (tname (jolt-invoke unwrap tname)) (fields (jolt-map unwrap fields)) (arrow (jolt-invoke (var-deref "clojure.core" "symbol") (jolt-invoke (var-deref "clojure.core" "str") "->" (jolt-invoke (var-deref "clojure.core" "name") tname)))) (field-kws (jolt-map (lambda (f) (let fnrec458 ((f f)) (jolt-invoke (var-deref "clojure.core" "keyword") (jolt-invoke (var-deref "clojure.core" "name") f)))) fields)) (field-tags (jolt-map (lambda (f) (let fnrec459 ((f f)) (let* ((mt (jolt-invoke (var-deref "clojure.core" "meta") f))) (if (jolt-truthy? (let* ((and__13__auto mt)) (if (jolt-truthy? and__13__auto) (jolt-get mt (keyword #f "tag")) and__13__auto))) (jolt-get mt (keyword #f "tag")) (if (jolt-truthy? (let* ((and__13__auto mt)) (if (jolt-truthy? and__13__auto) (jolt-get mt (keyword #f "num")) and__13__auto))) "num" (if (jolt-truthy? (keyword #f "else")) jolt-nil jolt-nil)))))) fields)) (field-muts (jolt-map (lambda (f) (let fnrec460 ((f f)) (let* ((mt (jolt-invoke (var-deref "clojure.core" "meta") f))) (if (jolt-truthy? (let* ((and__13__auto mt)) (if (jolt-truthy? and__13__auto) (let* ((or__14__auto (jolt-get mt (keyword #f "unsynchronized-mutable")))) (if (jolt-truthy? or__14__auto) or__14__auto (jolt-get mt (keyword #f "volatile-mutable")))) and__13__auto))) #t #f)))) fields)) (impl (lambda (proto specs) (let fnrec461 ((proto proto) (specs specs)) (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "extend-type")) (jolt-invoke (var-deref "clojure.core" "__sq1") tname) (jolt-invoke (var-deref "clojure.core" "__sq1") proto) (jolt-map (lambda (spec) (let fnrec462 ((spec spec)) (let* ((argv (jolt-nth spec 1)) (inst (jolt-first argv)) (binds (jolt-invoke (var-deref "clojure.core" "vec") (jolt-invoke (var-deref "clojure.core" "mapcat") (lambda (f) (let fnrec463 ((f f)) (let* ((_o$464 f) (_o$465 (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "get")) (jolt-invoke (var-deref "clojure.core" "__sq1") inst) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "keyword") (jolt-invoke (var-deref "clojure.core" "name") f)))))) (jolt-vector _o$464 _o$465)))) fields)))) (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-first spec)) (jolt-invoke (var-deref "clojure.core" "__sq1") argv) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "let")) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqvec") binds)) (jolt-drop 2 spec))))))) specs)))))) (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "do")) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "def")) (jolt-invoke (var-deref "clojure.core" "__sq1") tname) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "make-deftype-ctor")) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "quote")) (jolt-invoke (var-deref "clojure.core" "__sq1") tname))) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqvec") field-kws)) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqvec") field-tags)) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqvec") field-muts)))))) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "def")) (jolt-invoke (var-deref "clojure.core" "__sq1") arrow) (jolt-invoke (var-deref "clojure.core" "__sq1") tname))) (jolt-map (lambda (g) (let fnrec456 ((g g)) (jolt-invoke impl (jolt-first g) (jolt-rest g)))) (jolt-invoke (var-deref "clojure.core" "group-by-head") body)) (jolt-invoke (var-deref "clojure.core" "__sq1") tname)))))) + (lambda (tname fields . body) (let fnrec455 ((tname tname) (fields fields) (body (list->cseq body))) (let* ((unwrap (lambda (x) (let fnrec457 ((x x)) (if (jolt-truthy? (let* ((and__13__auto (jolt-invoke (var-deref "clojure.core" "seq?") x))) (if (jolt-truthy? and__13__auto) (let* ((and__13__auto (jolt-invoke (var-deref "clojure.core" "symbol?") (jolt-first x)))) (if (jolt-truthy? and__13__auto) (jolt= "with-meta" (jolt-invoke (var-deref "clojure.core" "name") (jolt-first x))) and__13__auto)) and__13__auto))) (jolt-invoke (var-deref "clojure.core" "second") x) x)))) (tname (jolt-invoke unwrap tname)) (fields (jolt-map unwrap fields)) (arrow (jolt-invoke (var-deref "clojure.core" "symbol") (jolt-invoke (var-deref "clojure.core" "str") "->" (jolt-invoke (var-deref "clojure.core" "name") tname)))) (field-kws (jolt-map (lambda (f) (let fnrec458 ((f f)) (jolt-invoke (var-deref "clojure.core" "keyword") (jolt-invoke (var-deref "clojure.core" "name") f)))) fields)) (field-tags (jolt-map (lambda (f) (let fnrec459 ((f f)) (let* ((mt (jolt-invoke (var-deref "clojure.core" "meta") f))) (if (jolt-truthy? (let* ((and__13__auto mt)) (if (jolt-truthy? and__13__auto) (jolt-get mt (keyword #f "tag")) and__13__auto))) (jolt-get mt (keyword #f "tag")) (if (jolt-truthy? (let* ((and__13__auto mt)) (if (jolt-truthy? and__13__auto) (jolt-get mt (keyword #f "num")) and__13__auto))) "num" (if (jolt-truthy? (keyword #f "else")) jolt-nil jolt-nil)))))) fields)) (field-muts (jolt-map (lambda (f) (let fnrec460 ((f f)) (let* ((mt (jolt-invoke (var-deref "clojure.core" "meta") f))) (if (jolt-truthy? (let* ((and__13__auto mt)) (if (jolt-truthy? and__13__auto) (let* ((or__14__auto (jolt-get mt (keyword #f "unsynchronized-mutable")))) (if (jolt-truthy? or__14__auto) or__14__auto (jolt-get mt (keyword #f "volatile-mutable")))) and__13__auto))) #t #f)))) fields)) (impl (lambda (proto specs) (let fnrec461 ((proto proto) (specs specs)) (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "do")) (jolt-map (lambda (spec) (let fnrec462 ((spec spec)) (let* ((argv (jolt-nth spec 1)) (inst (jolt-first argv)) (binds (jolt-invoke (var-deref "clojure.core" "vec") (jolt-invoke (var-deref "clojure.core" "mapcat") (lambda (f) (let fnrec463 ((f f)) (let* ((_o$464 f) (_o$465 (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "get")) (jolt-invoke (var-deref "clojure.core" "__sq1") inst) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "keyword") (jolt-invoke (var-deref "clojure.core" "name") f)))))) (jolt-vector _o$464 _o$465)))) fields)))) (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "register-inline-method")) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "name") tname)) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "name") proto)) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "name") (jolt-first spec))) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "fn")) (jolt-invoke (var-deref "clojure.core" "__sq1") argv) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "let")) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqvec") binds)) (jolt-drop 2 spec))))))))) specs)))))) (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "do")) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "def")) (jolt-invoke (var-deref "clojure.core" "__sq1") tname) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "make-deftype-ctor")) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "quote")) (jolt-invoke (var-deref "clojure.core" "__sq1") tname))) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqvec") field-kws)) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqvec") field-tags)) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqvec") field-muts)))))) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "def")) (jolt-invoke (var-deref "clojure.core" "__sq1") arrow) (jolt-invoke (var-deref "clojure.core" "__sq1") tname))) (jolt-map (lambda (g) (let fnrec456 ((g g)) (jolt-invoke impl (jolt-first g) (jolt-rest g)))) (jolt-invoke (var-deref "clojure.core" "group-by-head") body)) (jolt-invoke (var-deref "clojure.core" "__sq1") tname)))))) (mark-macro! "clojure.core" "deftype")) (guard (e (#t #f)) (def-var! "clojure.core" "defprotocol" @@ -916,7 +916,7 @@ (mark-macro! "clojure.core" "reify")) (guard (e (#t #f)) (def-var! "clojure.core" "defrecord" - (lambda (name-sym fields . body) (let fnrec487 ((name-sym name-sym) (fields fields) (body (list->cseq body))) (let* ((tn (jolt-invoke (var-deref "clojure.core" "name") name-sym)) (arrow (jolt-invoke (var-deref "clojure.core" "symbol") (jolt-invoke (var-deref "clojure.core" "str") "->" tn))) (mapf (jolt-invoke (var-deref "clojure.core" "symbol") (jolt-invoke (var-deref "clojure.core" "str") "map->" tn))) (m (jolt-invoke (var-deref "clojure.core" "fresh-sym") )) (impl (lambda (proto specs) (let fnrec490 ((proto proto) (specs specs)) (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "extend-type")) (jolt-invoke (var-deref "clojure.core" "__sq1") name-sym) (jolt-invoke (var-deref "clojure.core" "__sq1") proto) (jolt-map (lambda (spec) (let fnrec491 ((spec spec)) (let* ((argv (jolt-nth spec 1)) (inst (jolt-first argv)) (hinted (jolt-assoc argv 0 (jolt-invoke (var-deref "clojure.core" "vary-meta") inst jolt-assoc (keyword #f "tag") (jolt-invoke (var-deref "clojure.core" "name") name-sym)))) (binds (jolt-invoke (var-deref "clojure.core" "vec") (jolt-invoke (var-deref "clojure.core" "mapcat") (lambda (f) (let fnrec492 ((f f)) (let* ((_o$493 f) (_o$494 (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "get")) (jolt-invoke (var-deref "clojure.core" "__sq1") inst) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "keyword") (jolt-invoke (var-deref "clojure.core" "name") f)))))) (jolt-vector _o$493 _o$494)))) fields)))) (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-first spec)) (jolt-invoke (var-deref "clojure.core" "__sq1") hinted) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "let")) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqvec") binds)) (jolt-drop 2 spec))))))) specs)))))) (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "do")) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "deftype")) (jolt-invoke (var-deref "clojure.core" "__sq1") name-sym) (jolt-invoke (var-deref "clojure.core" "__sq1") fields))) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "def")) (jolt-invoke (var-deref "clojure.core" "__sq1") mapf) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "fn*")) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqvec") (jolt-invoke (var-deref "clojure.core" "__sq1") m))) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") arrow) (jolt-map (lambda (f) (let fnrec488 ((f f)) (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "get")) (jolt-invoke (var-deref "clojure.core" "__sq1") m) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "keyword") (jolt-invoke (var-deref "clojure.core" "name") f)))))) fields))))))) (jolt-map (lambda (g) (let fnrec489 ((g g)) (jolt-invoke impl (jolt-first g) (jolt-rest g)))) (jolt-invoke (var-deref "clojure.core" "group-by-head") body))))))) + (lambda (name-sym fields . body) (let fnrec487 ((name-sym name-sym) (fields fields) (body (list->cseq body))) (let* ((tn (jolt-invoke (var-deref "clojure.core" "name") name-sym)) (arrow (jolt-invoke (var-deref "clojure.core" "symbol") (jolt-invoke (var-deref "clojure.core" "str") "->" tn))) (mapf (jolt-invoke (var-deref "clojure.core" "symbol") (jolt-invoke (var-deref "clojure.core" "str") "map->" tn))) (m (jolt-invoke (var-deref "clojure.core" "fresh-sym") )) (impl (lambda (proto specs) (let fnrec490 ((proto proto) (specs specs)) (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "do")) (jolt-map (lambda (spec) (let fnrec491 ((spec spec)) (let* ((argv (jolt-nth spec 1)) (inst (jolt-first argv)) (hinted (jolt-assoc argv 0 (jolt-invoke (var-deref "clojure.core" "vary-meta") inst jolt-assoc (keyword #f "tag") (jolt-invoke (var-deref "clojure.core" "name") name-sym)))) (binds (jolt-invoke (var-deref "clojure.core" "vec") (jolt-invoke (var-deref "clojure.core" "mapcat") (lambda (f) (let fnrec492 ((f f)) (let* ((_o$493 f) (_o$494 (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "get")) (jolt-invoke (var-deref "clojure.core" "__sq1") inst) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "keyword") (jolt-invoke (var-deref "clojure.core" "name") f)))))) (jolt-vector _o$493 _o$494)))) fields)))) (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "register-inline-method")) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "name") name-sym)) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "name") proto)) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "name") (jolt-first spec))) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "fn")) (jolt-invoke (var-deref "clojure.core" "__sq1") hinted) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "let")) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqvec") binds)) (jolt-drop 2 spec))))))))) specs)))))) (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "do")) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "deftype")) (jolt-invoke (var-deref "clojure.core" "__sq1") name-sym) (jolt-invoke (var-deref "clojure.core" "__sq1") fields))) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "def")) (jolt-invoke (var-deref "clojure.core" "__sq1") mapf) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "fn*")) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqvec") (jolt-invoke (var-deref "clojure.core" "__sq1") m))) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") arrow) (jolt-map (lambda (f) (let fnrec488 ((f f)) (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "get")) (jolt-invoke (var-deref "clojure.core" "__sq1") m) (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "keyword") (jolt-invoke (var-deref "clojure.core" "name") f)))))) fields))))))) (jolt-map (lambda (g) (let fnrec489 ((g g)) (jolt-invoke impl (jolt-first g) (jolt-rest g)))) (jolt-invoke (var-deref "clojure.core" "group-by-head") body))))))) (mark-macro! "clojure.core" "defrecord")) (guard (e (#t #f)) (def-var! "clojure.core" "memfn" diff --git a/jolt-core/clojure/core/30-macros.clj b/jolt-core/clojure/core/30-macros.clj index f6bc038..4982a99 100644 --- a/jolt-core/clojure/core/30-macros.clj +++ b/jolt-core/clojure/core/30-macros.clj @@ -307,13 +307,17 @@ (:volatile-mutable mt))) true false))) fields) + ;; inline impls register for dispatch but are NOT extenders of the + ;; protocol (the JVM compiles them into the class) — register-inline-method, + ;; not extend-type. impl (fn [proto specs] - `(extend-type ~tname ~proto + `(do ~@(map (fn [spec] (let [argv (nth spec 1) inst (first argv) binds (vec (mapcat (fn [f] [f `(get ~inst ~(keyword (name f)))]) fields))] - `(~(first spec) ~argv (let [~@binds] ~@(drop 2 spec))))) + `(register-inline-method ~(name tname) ~(name proto) ~(name (first spec)) + (fn ~argv (let [~@binds] ~@(drop 2 spec)))))) specs)))] `(do (def ~tname (make-deftype-ctor (quote ~tname) [~@field-kws] [~@field-tags] [~@field-muts])) @@ -445,8 +449,11 @@ ;; each method body sees the record fields, bound from the instance (the ;; method's first param), matching Clojure's defrecord method scope. vec the ;; spliced binding seq so ~@ splices its elements, not the lazy-seq itself. + ;; inline impls register for dispatch but are NOT extenders of the + ;; protocol (the JVM compiles them into the class) — register-inline-method, + ;; not extend-type. impl (fn [proto specs] - `(extend-type ~name-sym ~proto + `(do ~@(map (fn [spec] (let [argv (nth spec 1) inst (first argv) @@ -455,7 +462,8 @@ ;; instead of going through the runtime tag guard. hinted (assoc argv 0 (vary-meta inst assoc :tag (name name-sym))) binds (vec (mapcat (fn [f] [f `(get ~inst ~(keyword (name f)))]) fields))] - `(~(first spec) ~hinted (let [~@binds] ~@(drop 2 spec))))) + `(register-inline-method ~(name name-sym) ~(name proto) ~(name (first spec)) + (fn ~hinted (let [~@binds] ~@(drop 2 spec)))))) specs)))] `(do ;; deftype already defines ->name (= the ctor); no (name. …) interop needed,