Host shims and protocol fixes shaken out by aws-api

Running cognitect aws-api's pure test namespaces (signing/shapes/protocols/
util/retry/endpoints) surfaced general gaps:

- extend-protocol/extend-type accept a computed class type, e.g.
  (Class/forName "[B") for the byte-array class — the byte-array idiom data.json
  and aws-api use. The macro grouping handled only symbol/nil heads (it crashed on
  a list type); type->name resolves a Class value via .getName; a byte-array
  dispatches on the "[B" host tag.
- java.nio.ByteBuffer over a jolt byte-array (wrap/allocate/get/put/array/
  remaining/position/limit/duplicate/flip), plus extend-protocol to it.
- java.util.Arrays (equals/copyOf/copyOfRange/fill) and java.util.Random
  (nextBytes/nextInt/…).
- java.net.URI/create and clojure.lang.RT/baseLoader statics.
- clojure.core.async/promise-chan (deliver-once, peek-don't-pop).
- a failed java.time parse throws DateTimeParseException (typed), so
  (catch DateTimeParseException …) matches it instead of leaking an untyped
  condition.

The XML side lives in the jolt-lang/xml library (libxml2 over jolt.ffi); ByteBuffer
stays in core as a generic java.nio primitive.

Gate: make test green (corpus +6 JVM-certified rows, 0 NEW divergence; unit
553/553; SCI 211).
This commit is contained in:
Yogthos 2026-06-25 16:56:48 -04:00
parent 05f29d1bcb
commit 829c251bca
12 changed files with 762 additions and 549 deletions

View file

@ -113,6 +113,11 @@
(else (else
(case (async-chan-kind ch) (case (async-chan-kind ch)
((dropping sliding) (ac-buf-give! ch v) #t) ((dropping sliding) (ac-buf-give! ch v) #t)
;; a promise channel takes ONE value, delivered to every taker; further
;; puts are dropped. Never blocks.
((promise) (when (ac-qempty? ch)
(ac-qpush! ch (cons v #f)) (condition-broadcast (async-chan-cv ch)))
#t)
(else (else
(if (> (async-chan-cap ch) 0) (if (> (async-chan-cap ch) 0)
(let loop () ; buffered fixed: wait for room (let loop () ; buffered fixed: wait for room
@ -135,11 +140,22 @@
(condition-broadcast (async-chan-cv ch)) (condition-broadcast (async-chan-cv ch))
v)) v))
;; peek the front value without removing it (promise channels keep their value).
(define (ac-peek ch)
(let ((q (async-chan-items ch)))
(ac-qfront! q)
(car (car (vector-ref q 0)))))
;; <! / <!! — take, blocking. Drains buffered values, then nil once closed + empty. ;; <! / <!! — take, blocking. Drains buffered values, then nil once closed + empty.
;; A promise channel PEEKS — its one value stays for every taker.
(define (jolt-async-take ch) (define (jolt-async-take ch)
(with-mutex (async-chan-mu ch) (with-mutex (async-chan-mu ch)
(let loop () (let loop ()
(cond ((not (ac-qempty? ch)) (ac-take-head! ch)) (cond ((eq? (async-chan-kind ch) 'promise)
(cond ((not (ac-qempty? ch)) (ac-peek ch))
((async-chan-closed? ch) jolt-nil)
(else (condition-wait (async-chan-cv ch) (async-chan-mu ch)) (loop))))
((not (ac-qempty? ch)) (ac-take-head! ch))
((async-chan-closed? ch) jolt-nil) ((async-chan-closed? ch) jolt-nil)
(else (condition-wait (async-chan-cv ch) (async-chan-mu ch)) (loop)))))) (else (condition-wait (async-chan-cv ch) (async-chan-mu ch)) (loop))))))
@ -147,7 +163,8 @@
(define ac-poll-empty (list 'empty)) (define ac-poll-empty (list 'empty))
(define (ac-poll! ch) (define (ac-poll! ch)
(with-mutex (async-chan-mu ch) (with-mutex (async-chan-mu ch)
(cond ((not (ac-qempty? ch)) (ac-take-head! ch)) (cond ((and (eq? (async-chan-kind ch) 'promise) (not (ac-qempty? ch))) (ac-peek ch))
((not (ac-qempty? ch)) (ac-take-head! ch))
((async-chan-closed? ch) jolt-nil) ((async-chan-closed? ch) jolt-nil)
(else ac-poll-empty)))) (else ac-poll-empty))))
@ -224,6 +241,7 @@
;; --- install clojure.core.async --------------------------------------------- ;; --- install clojure.core.async ---------------------------------------------
(define (cca-def! name v) (def-var! "clojure.core.async" name v)) (define (cca-def! name v) (def-var! "clojure.core.async" name v))
(cca-def! "chan" jolt-async-chan) (cca-def! "chan" jolt-async-chan)
(cca-def! "promise-chan" (lambda args (ac-make 1 'promise #f)))
(cca-def! "chan?" async-chan?) (cca-def! "chan?" async-chan?)
(cca-def! "buffer" jolt-async-buffer) (cca-def! "buffer" jolt-async-buffer)
(cca-def! "dropping-buffer" jolt-async-dropping-buffer) (cca-def! "dropping-buffer" jolt-async-dropping-buffer)

85
host/chez/byte-buffer.ss Normal file
View file

@ -0,0 +1,85 @@
;; byte-buffer.ss — java.nio.ByteBuffer over a jolt byte-array. A buffer is a
;; jhost tagged "byte-buffer" with mutable #(backing-array position limit); the
;; backing is a jolt byte-array (vector of 0..255). Covers the slice of the API
;; portable code reaches for — wrap / get(byte[]) / array / remaining / position /
;; limit / duplicate / flip / rewind — e.g. cognitect aws-api wrapping blob bytes.
(define (make-byte-buffer backing pos limit) (make-jhost "byte-buffer" (vector backing pos limit)))
(define (bb? x) (and (jhost? x) (string=? (jhost-tag x) "byte-buffer")))
(define (bb-backing b) (vector-ref (jhost-state b) 0))
(define (bb-pos b) (vector-ref (jhost-state b) 1))
(define (bb-limit b) (vector-ref (jhost-state b) 2))
(define (bb-pos! b n) (vector-set! (jhost-state b) 1 n))
(define (bb-limit! b n) (vector-set! (jhost-state b) 2 n))
(define (bb-capacity b) (vector-length (jolt-array-vec (bb-backing b))))
;; (ByteBuffer/wrap ba) | (ByteBuffer/wrap ba off len) | (ByteBuffer/allocate n)
(register-class-statics! "ByteBuffer"
(list
(cons "wrap" (lambda (ba . rest)
(let ((cap (vector-length (jolt-array-vec ba))))
(if (pair? rest)
(let ((off (jnum->exact (car rest))) (len (jnum->exact (cadr rest))))
(make-byte-buffer ba off (+ off len)))
(make-byte-buffer ba 0 cap)))))
(cons "allocate" (lambda (n)
(let ((cap (jnum->exact n)))
(make-byte-buffer (make-jolt-array (make-vector cap 0) 'byte) 0 cap))))
;; jolt has one heap; a direct buffer is just a buffer here.
(cons "allocateDirect" (lambda (n)
(let ((cap (jnum->exact n)))
(make-byte-buffer (make-jolt-array (make-vector cap 0) 'byte) 0 cap))))))
(register-host-methods! "byte-buffer"
(list
(cons "remaining" (lambda (self) (->num (- (bb-limit self) (bb-pos self)))))
(cons "hasRemaining" (lambda (self) (> (bb-limit self) (bb-pos self))))
;; position / limit are getters with no arg, setters (returning the buffer) with one
(cons "position" (lambda (self . a)
(if (pair? a) (begin (bb-pos! self (jnum->exact (car a))) self) (->num (bb-pos self)))))
(cons "limit" (lambda (self . a)
(if (pair? a) (begin (bb-limit! self (jnum->exact (car a))) self) (->num (bb-limit self)))))
(cons "capacity" (lambda (self) (->num (bb-capacity self))))
(cons "hasArray" (lambda (self) #t))
(cons "array" (lambda (self) (bb-backing self)))
(cons "duplicate" (lambda (self) (make-byte-buffer (bb-backing self) (bb-pos self) (bb-limit self))))
(cons "rewind" (lambda (self) (bb-pos! self 0) self))
(cons "flip" (lambda (self) (bb-limit! self (bb-pos self)) (bb-pos! self 0) self))
(cons "clear" (lambda (self) (bb-pos! self 0) (bb-limit! self (bb-capacity self)) self))
;; (.get dst) | (.get dst off len): bulk copy from position into a byte-array,
;; advancing position. Returns the buffer like the JVM.
;; (.put src): copy bytes into the buffer at position, advancing it. src is
;; another ByteBuffer (its remaining bytes), a byte-array, or a single byte.
(cons "put" (lambda (self src . rest)
(let ((dv (jolt-array-vec (bb-backing self))) (dp (bb-pos self)))
(cond
((bb? src)
(let* ((sv (jolt-array-vec (bb-backing src))) (sp (bb-pos src))
(n (- (bb-limit src) sp)))
(do ((i 0 (fx+ i 1))) ((fx=? i n))
(vector-set! dv (+ dp i) (vector-ref sv (+ sp i))))
(bb-pos! src (bb-limit src)) (bb-pos! self (+ dp n))))
((jolt-array? src)
(let* ((sv (jolt-array-vec src)) (n (vector-length sv)))
(do ((i 0 (fx+ i 1))) ((fx=? i n))
(vector-set! dv (+ dp i) (vector-ref sv i)))
(bb-pos! self (+ dp n))))
(else (vector-set! dv dp (jnum->exact src)) (bb-pos! self (+ dp 1))))
self)))
(cons "get" (lambda (self dst . rest)
(let* ((src (jolt-array-vec (bb-backing self)))
(dv (jolt-array-vec dst))
(off (if (pair? rest) (jnum->exact (car rest)) 0))
(len (if (and (pair? rest) (pair? (cdr rest))) (jnum->exact (cadr rest)) (vector-length dv)))
(p (bb-pos self)))
(do ((i 0 (+ i 1))) ((= i len))
(vector-set! dv (+ off i) (vector-ref src (+ p i))))
(bb-pos! self (+ p len))
self)))))
(register-class-arm! bb? (lambda (x) "java.nio.ByteBuffer"))
(register-instance-check-arm!
(lambda (type-sym val)
(if (and (symbol-t? type-sym) (bb? val)
(member (last-dot (symbol-t-name type-sym)) '("ByteBuffer")))
#t 'pass)))

View file

@ -744,6 +744,51 @@
;; (jolt.host/table? x) — is x a host tagged-table? ;; (jolt.host/table? x) — is x a host tagged-table?
(def-var! "jolt.host" "table?" (lambda (x) (if (htable? x) #t #f))) (def-var! "jolt.host" "table?" (lambda (x) (if (htable? x) #t #f)))
;; --- java.util.Arrays -------------------------------------------------------
(let ((arrays-statics
(list
(cons "equals" (lambda (a b)
(cond ((and (jolt-nil? a) (jolt-nil? b)) #t)
((or (jolt-nil? a) (jolt-nil? b)) #f)
(else (equal? (jolt-array-vec a) (jolt-array-vec b))))))
(cons "fill" (lambda (a v) (vector-fill! (jolt-array-vec a) v) jolt-nil))
(cons "copyOf" (lambda (a n)
(let* ((src (jolt-array-vec a)) (len (jnum->exact n))
(out (make-vector len 0)))
(do ((i 0 (fx+ i 1))) ((fx=? i (min len (vector-length src))))
(vector-set! out i (vector-ref src i)))
(make-jolt-array out (jolt-array-kind a)))))
(cons "copyOfRange" (lambda (a from to)
(let* ((src (jolt-array-vec a)) (f (jnum->exact from)) (tt (jnum->exact to))
(len (- tt f)) (out (make-vector len 0)))
(do ((i 0 (fx+ i 1))) ((fx=? i len))
(vector-set! out i (vector-ref src (+ f i))))
(make-jolt-array out (jolt-array-kind a)))))
(cons "toString" (lambda (a) (jolt-pr-str (apply jolt-vector (vector->list (jolt-array-vec a)))))))))
(register-class-statics! "Arrays" arrays-statics)
(register-class-statics! "java.util.Arrays" arrays-statics))
;; --- java.util.Random -------------------------------------------------------
;; A non-cryptographic PRNG over Chez's `random`. A seed argument is accepted but
;; not honored for reproducibility (jolt has no seedable Random state); callers
;; that need determinism use SecureRandom or their own generator.
(for-each
(lambda (nm) (register-class-ctor! nm (lambda args (make-jhost "random" (vector)))))
'("Random" "java.util.Random"))
(register-host-methods! "random"
(list
(cons "nextBytes" (lambda (self ba)
(let ((v (jolt-array-vec ba)))
(do ((i 0 (fx+ i 1))) ((fx=? i (vector-length v)))
(vector-set! v i (random 256))))
jolt-nil))
(cons "nextInt" (lambda (self . a)
(->num (if (pair? a) (random (jnum->exact (car a))) (- (random 4294967296) 2147483648)))))
(cons "nextLong" (lambda (self) (->num (- (random 18446744073709551616) 9223372036854775808))))
(cons "nextDouble" (lambda (self) (random 1.0)))
(cons "nextFloat" (lambda (self) (random 1.0)))
(cons "nextBoolean" (lambda (self) (fx=? 0 (random 2))))))
;; --- minimal JVM class/interface ancestry ----------------------------------- ;; --- minimal JVM class/interface ancestry -----------------------------------
;; A handful of libraries reflect over the class hierarchy — e.g. core.memoize ;; A handful of libraries reflect over the class hierarchy — e.g. core.memoize
;; validates its first argument with (some #{IFn AFn Runnable Callable} ;; validates its first argument with (some #{IFn AFn Runnable Callable}

View file

@ -180,7 +180,11 @@
(define (parse-ms pattern input) (define (parse-ms pattern input)
(let ((pn (string-length pattern)) (inn (string-length input)) (let ((pn (string-length pattern)) (inn (string-length input))
(y 1970) (mo 1) (d 1) (hh 0) (mi 0) (ss 0) (pm 'none)) (y 1970) (mo 1) (d 1) (hh 0) (mi 0) (ss 0) (pm 'none))
(define (pfail) (error #f (string-append "ParseException: unparseable date \"" input "\""))) ;; a parse failure is a java.time.format.DateTimeParseException (typed, so a
;; (catch DateTimeParseException …) over a bad date matches), like the JVM.
(define (pfail)
(jolt-throw (jolt-host-throwable "java.time.format.DateTimeParseException"
(string-append "unparseable date \"" input "\"") jolt-nil)))
(define (run-len i c) (let loop ((j i)) (if (and (< j pn) (char=? (string-ref pattern j) c)) (loop (+ j 1)) (- j i)))) (define (run-len i c) (let loop ((j i)) (if (and (< j pn) (char=? (string-ref pattern j) c)) (loop (+ j 1)) (- j i))))
;; read up to `maxw` digits (#f = unbounded). A fixed-width field (k>=2, e.g. ;; read up to `maxw` digits (#f = unbounded). A fixed-width field (k>=2, e.g.
;; HHmm) caps the read at its run length so adjacent numeric fields split. ;; HHmm) caps the read at its run length so adjacent numeric fields split.

View file

@ -457,6 +457,10 @@
(if (jolt-nil? u) jolt-nil (host-new "StringReader" (jolt-slurp (url-strip-scheme (url-spec u)))))))))) (if (jolt-nil? u) jolt-nil (host-new "StringReader" (jolt-slurp (url-strip-scheme (url-spec u))))))))))
(register-class-statics! "ClassLoader" (list (cons "getSystemClassLoader" (lambda () the-classloader)))) (register-class-statics! "ClassLoader" (list (cons "getSystemClassLoader" (lambda () the-classloader))))
(register-class-statics! "java.lang.ClassLoader" (list (cons "getSystemClassLoader" (lambda () the-classloader)))) (register-class-statics! "java.lang.ClassLoader" (list (cons "getSystemClassLoader" (lambda () the-classloader))))
;; clojure.lang.RT/baseLoader — the resource-resolving class loader (RT/baseLoader
;; is how libraries reach Clojure's base loader, e.g. aws-api's resources ns).
(register-class-statics! "RT" (list (cons "baseLoader" (lambda () the-classloader))))
(register-class-statics! "clojure.lang.RT" (list (cons "baseLoader" (lambda () the-classloader))))
;; Thread/currentThread -> a fresh thread jhost wrapping THIS thread's interrupt ;; Thread/currentThread -> a fresh thread jhost wrapping THIS thread's interrupt
;; flag (the box from current-interrupt-box, host-static.ss), so .interrupt from ;; flag (the box from current-interrupt-box, host-static.ss), so .interrupt from
;; any thread sets the target thread's flag and .isInterrupted reads it without ;; any thread sets the target thread's flag and .isInterrupted reads it without
@ -583,6 +587,9 @@
(define (uri-field u k) (let ((p (assq k (jhost-state u)))) (if p (cdr p) jolt-nil))) (define (uri-field u k) (let ((p (assq k (jhost-state u)))) (if p (cdr p) jolt-nil)))
(register-class-ctor! "URI" (lambda (s) (uri-parse (jolt-str-render-one s)))) (register-class-ctor! "URI" (lambda (s) (uri-parse (jolt-str-render-one s))))
(register-class-ctor! "java.net.URI" (lambda (s) (uri-parse (jolt-str-render-one s)))) (register-class-ctor! "java.net.URI" (lambda (s) (uri-parse (jolt-str-render-one s))))
;; URI/create — the static factory, same as the (URI. s) constructor.
(register-class-statics! "URI" (list (cons "create" (lambda (s) (uri-parse (jolt-str-render-one s))))))
(register-class-statics! "java.net.URI" (list (cons "create" (lambda (s) (uri-parse (jolt-str-render-one s))))))
(register-host-methods! "uri" (register-host-methods! "uri"
(list (cons "toString" (lambda (u) (uri-field u 'string))) (list (cons "toString" (lambda (u) (uri-field u 'string)))
(cons "toASCIIString" (lambda (u) (uri-field u 'string))) (cons "toASCIIString" (lambda (u) (uri-field u 'string)))

View file

@ -26,6 +26,8 @@
("ConcurrentModificationException" . "RuntimeException") ("ConcurrentModificationException" . "RuntimeException")
("NoSuchElementException" . "RuntimeException") ("NoSuchElementException" . "RuntimeException")
("UncheckedIOException" . "RuntimeException") ("UncheckedIOException" . "RuntimeException")
("DateTimeException" . "RuntimeException")
("DateTimeParseException" . "DateTimeException")
("InterruptedException" . "Exception") ("InterruptedException" . "Exception")
("IOException" . "Exception") ("IOException" . "Exception")
("FileNotFoundException" . "IOException") ("FileNotFoundException" . "IOException")

View file

@ -203,6 +203,13 @@
((or (cseq? obj) (empty-list-t? obj)) '("ASeq" "ISeq" "IPersistentCollection" "Sequential" "Collection" "Iterable" "java.lang.Iterable" "Object")) ((or (cseq? obj) (empty-list-t? obj)) '("ASeq" "ISeq" "IPersistentCollection" "Sequential" "Collection" "Iterable" "java.lang.Iterable" "Object"))
;; java.net.URI jhost — extend-protocol java.net.URI (hiccup ToURI/ToStr). ;; java.net.URI jhost — extend-protocol java.net.URI (hiccup ToURI/ToStr).
((and (jhost? obj) (string=? (jhost-tag obj) "uri")) '("URI" "java.net.URI" "Object")) ((and (jhost? obj) (string=? (jhost-tag obj) "uri")) '("URI" "java.net.URI" "Object"))
;; a ByteBuffer — extend-protocol java.nio.ByteBuffer (aws-api util).
((and (jhost? obj) (string=? (jhost-tag obj) "byte-buffer")) '("ByteBuffer" "java.nio.ByteBuffer" "Object"))
;; arrays dispatch by their JVM array-class name — extend-protocol to
;; (Class/forName "[B") for byte[] (data.json, aws-api), "[C" for char[].
((and (jolt-array? obj) (eq? (jolt-array-kind obj) 'byte)) '("[B" "Object"))
((and (jolt-array? obj) (eq? (jolt-array-kind obj) 'char)) '("[C" "Object"))
((jolt-array? obj) '("[Ljava.lang.Object;" "Object"))
;; a regex VALUE — extend-protocol java.util.regex.Pattern (core.match.regex). ;; a regex VALUE — extend-protocol java.util.regex.Pattern (core.match.regex).
((regex-t? obj) '("Pattern" "java.util.regex.Pattern" "Object")) ((regex-t? obj) '("Pattern" "java.util.regex.Pattern" "Object"))
;; host value types a library may extend a protocol to by class (data.json ;; host value types a library may extend a protocol to by class (data.json
@ -288,7 +295,10 @@
"Duration" "Period" "LocalDate" "LocalTime" "LocalDateTime" "Duration" "Period" "LocalDate" "LocalTime" "LocalDateTime"
"ZonedDateTime" "OffsetDateTime" "OffsetTime" "ZoneId" "ZoneOffset" "ZonedDateTime" "OffsetDateTime" "OffsetTime" "ZoneId" "ZoneOffset"
"Clock" "Year" "YearMonth" "Month" "DayOfWeek" "Clock" "Year" "YearMonth" "Month" "DayOfWeek"
"ChronoUnit" "ChronoField" "TemporalAmount" "TemporalUnit" "TemporalField")) "ChronoUnit" "ChronoField" "TemporalAmount" "TemporalUnit" "TemporalField"
;; ByteBuffer + JVM array classes (extend-protocol to (Class/forName "[B"))
"ByteBuffer" "java.nio.ByteBuffer"
"[B" "[C" "[I" "[J" "[D" "[Ljava.lang.Object;"))
h)) h))
(define (strip-prefix s p) (define (strip-prefix s p)
(let ((pl (string-length p))) (let ((pl (string-length p)))

View file

@ -333,6 +333,7 @@
(load "host/chez/host-static.ss") ; registries + jhost + coercion helpers (load "host/chez/host-static.ss") ; registries + jhost + coercion helpers
(load "host/chez/host-static-methods.ss") ; Class/member static methods + fields (load "host/chez/host-static-methods.ss") ; Class/member static methods + fields
(load "host/chez/host-static-classes.ss") ; instantiable host object classes (load "host/chez/host-static-classes.ss") ; instantiable host object classes
(load "host/chez/byte-buffer.ss") ; java.nio.ByteBuffer over a byte-array
;; generic dot-form dispatch: field access + map/vector member access ;; generic dot-form dispatch: field access + map/vector member access
;; for the `.` / `.-field` desugar. Loads after host-static.ss so it wraps every ;; for the `.` / `.-field` desugar. Loads after host-static.ss so it wraps every

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

View file

@ -462,12 +462,23 @@
(or (= tn want) (suffix? tn want) (suffix? want tn)))) (or (= tn want) (suffix? tn want) (suffix? want tn))))
(extenders protocol))))) (extenders protocol)))))
;; The canonical name for a protocol-extension type: a symbol/keyword via name, a
;; string as-is, nil as "nil" (extends on nil values), and a Class VALUE — e.g.
;; (Class/forName "[B") for the byte-array class — via .getName. Lets a library
;; extend a protocol to a class it computes rather than names with a symbol.
(defn type->name [t]
(cond (nil? t) "nil"
(string? t) t
(symbol? t) (name t)
(keyword? t) (name t)
:else (.getName t)))
;; extend, the FUNCTION (extend-type's runtime sibling): protocol + method-map ;; extend, the FUNCTION (extend-type's runtime sibling): protocol + method-map
;; pairs, methods registered under the type's (canonicalized) name — so ;; pairs, methods registered under the type's (canonicalized) name — so
;; (extend 'String P {:m (fn [x] ...)}) dispatches exactly like extend-type. ;; (extend 'String P {:m (fn [x] ...)}) dispatches exactly like extend-type.
(defn extend [atype & proto+mmaps] (defn extend [atype & proto+mmaps]
;; nil extends on nil values; its host tag is the string "nil" (as extend-type). ;; nil extends on nil values; its host tag is the string "nil" (as extend-type).
(let [tname (if (nil? atype) "nil" (name atype))] (let [tname (type->name atype)]
(loop [s (seq proto+mmaps)] (loop [s (seq proto+mmaps)]
(when s (when s
(let [proto (first s) (let [proto (first s)
@ -484,21 +495,41 @@
;; `body` is one or more protocols, each followed by its method specs: ;; `body` is one or more protocols, each followed by its method specs:
;; (extend-type T P1 (m1 [_] ..) P2 (m2 [_] ..)) — a bare symbol switches the ;; (extend-type T P1 (m1 [_] ..) P2 (m2 [_] ..)) — a bare symbol switches the
;; current protocol (like reify), so multiple protocols extend in one form. ;; current protocol (like reify), so multiple protocols extend in one form.
(let [tname (if (nil? tsym) "nil" (name tsym))] ;; tsym may be a symbol/nil (name resolved at compile time) or a computed class
(loop [items (seq body) proto nil forms []] ;; expression like (Class/forName "[B") — bind its runtime name once.
(if (empty? items) (let [literal? (or (nil? tsym) (symbol? tsym))
`(do ~@forms) tn (gensym "tname")
(let [x (first items)] tref (if literal? (if (nil? tsym) "nil" (name tsym)) tn)
(if (symbol? x) emit (fn []
(recur (rest items) (name x) forms) (loop [items (seq body) proto nil forms []]
(recur (rest items) proto (if (empty? items)
(conj forms forms
`(register-method ~tname ~proto ~(name (first x)) (let [x (first items)]
(fn ~(nth x 1) ~@(drop 2 x))))))))))) (if (symbol? x)
(recur (rest items) (name x) forms)
(recur (rest items) proto
(conj forms
`(register-method ~tref ~proto ~(name (first x))
(fn ~(nth x 1) ~@(drop 2 x))))))))))]
(if literal?
`(do ~@(emit))
`(let [~tn (type->name ~tsym)] ~@(emit) nil))))
;; Group an extend-protocol body into [type method-spec*] groups: the type is the
;; first item and its method specs are the seqs that follow it (up to the next
;; type — a symbol/nil — or end). Handles a computed class type (a seq like
;; (Class/forName "[B")) positionally, matching Clojure's parse-impls.
(defn- parse-extend-impls [items]
(loop [s (seq items) groups []]
(if (empty? s)
groups
(let [after (rest s)]
(recur (drop-while seq? after)
(conj groups (vec (cons (first s) (take-while seq? after)))))))))
(defmacro extend-protocol [psym & type-impls] (defmacro extend-protocol [psym & type-impls]
`(do ~@(map (fn [g] `(extend-type ~(first g) ~psym ~@(rest g))) `(do ~@(map (fn [g] `(extend-type ~(first g) ~psym ~@(rest g)))
(group-by-head type-impls)))) (parse-extend-impls type-impls))))
;; extend is a real FUNCTION — defined above extend-type. ;; extend is a real FUNCTION — defined above extend-type.
;; JVM proxies are unsupported. ;; JVM proxies are unsupported.

View file

@ -24,6 +24,12 @@
{:suite "try / multi-catch" :label "a host condition is caught by its RuntimeException subclass" :expected ":arith" :actual "(try (/ 1 0) (catch ArithmeticException _ :arith) (catch Throwable _ :other))"} {:suite "try / multi-catch" :label "a host condition is caught by its RuntimeException subclass" :expected ":arith" :actual "(try (/ 1 0) (catch ArithmeticException _ :arith) (catch Throwable _ :other))"}
{:suite "locking" :label "returns the body value" :expected "42" :actual "(let [o (Object.)] (locking o 42))"} {:suite "locking" :label "returns the body value" :expected "42" :actual "(let [o (Object.)] (locking o 42))"}
{:suite "locking" :label "reentrant on the same object" :expected "42" :actual "(let [o (Object.)] (locking o (locking o 42)))"} {:suite "locking" :label "reentrant on the same object" :expected "42" :actual "(let [o (Object.)] (locking o (locking o 42)))"}
{:suite "extend-protocol / class value" :label "extend to (Class/forName \"[B\") dispatches a byte-array" :expected "[:ba :str]" :actual "(do (defprotocol P (m [x])) (extend-protocol P (Class/forName \"[B\") (m [bs] :ba) String (m [s] :str)) [(m (byte-array 1)) (m \"x\")])"}
{:suite "interop / ByteBuffer" :label "wrap then remaining + array" :expected "[3 [1 2 3]]" :actual "(let [bb (java.nio.ByteBuffer/wrap (byte-array [1 2 3]))] [(.remaining bb) (vec (.array bb))])"}
{:suite "interop / ByteBuffer" :label "get drains into a byte-array" :expected "[1 2]" :actual "(let [bb (java.nio.ByteBuffer/wrap (byte-array [1 2])) d (byte-array 2)] (.get bb d) (vec d))"}
{:suite "interop / Arrays" :label "equals on byte arrays" :expected "true" :actual "(java.util.Arrays/equals (byte-array [1 2 3]) (byte-array [1 2 3]))"}
{:suite "interop / Arrays" :label "equals on unequal byte arrays" :expected "false" :actual "(java.util.Arrays/equals (byte-array [1 2]) (byte-array [1 9]))"}
{:suite "interop / URI" :label "URI/create static factory" :expected "\"x.com\"" :actual "(.getHost (java.net.URI/create \"http://x.com/p\"))"}
{:suite "interop / Thread" :label "start + join runs the thunk" :expected "7" :actual "(let [a (atom 0) t (Thread. (fn [] (reset! a 7)))] (.start t) (.join t) (deref a))"} {:suite "interop / Thread" :label "start + join runs the thunk" :expected "7" :actual "(let [a (atom 0) t (Thread. (fn [] (reset! a 7)))] (.start t) (.join t) (deref a))"}
{:suite "interop / CountDownLatch" :label "countDown to zero, await returns" :expected "0" :actual "(let [l (java.util.concurrent.CountDownLatch. 1)] (.countDown l) (.await l) (.getCount l))"} {:suite "interop / CountDownLatch" :label "countDown to zero, await returns" :expected "0" :actual "(let [l (java.util.concurrent.CountDownLatch. 1)] (.countDown l) (.await l) (.getCount l))"}
{:suite "interop / SoftReference" :label "get returns the referent" :expected ":v" :actual "(.get (java.lang.ref.SoftReference. :v))"} {:suite "interop / SoftReference" :label "get returns the referent" :expected ":v" :actual "(.get (java.lang.ref.SoftReference. :v))"}