simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge pull request #213 from jolt-lang/conformance/aws-api-host-shims

Browse source 
Host shims and protocol fixes shaken out by aws-api
This commit is contained in:
Dmitri Sotnikov 2026-06-25 21:03:37 +00:00 • committed by GitHub
commit 60e129a95c
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
12 changed files with 762 additions and 549 deletions
Download patch file Download diff file Expand all files Collapse all files

22
host/chez/async.ss
View file

@ -113,6 +113,11 @@
(else
(case (async-chan-kind ch)
((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
(if (> (async-chan-cap ch) 0)
(let loop () ; buffered fixed: wait for room
@ -135,11 +140,22 @@
(condition-broadcast (async-chan-cv ch))
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.
;; A promise channel PEEKS — its one value stays for every taker.
(define (jolt-async-take ch)
(with-mutex (async-chan-mu ch)
(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)
(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! 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)
(else ac-poll-empty))))
@ -224,6 +241,7 @@
;; --- install clojure.core.async ---------------------------------------------
(define (cca-def! name v) (def-var! "clojure.core.async" name v))
(cca-def! "chan" jolt-async-chan)
(cca-def! "promise-chan" (lambda args (ac-make 1 'promise #f)))
(cca-def! "chan?" async-chan?)
(cca-def! "buffer" jolt-async-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)))

45
host/chez/host-static-classes.ss
View file

@ -744,6 +744,51 @@
;; (jolt.host/table? x) — is x a host tagged-table?
(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 -----------------------------------
;; A handful of libraries reflect over the class hierarchy — e.g. core.memoize
;; validates its first argument with (some #{IFn AFn Runnable Callable}

6
host/chez/inst-time.ss
View file

@ -180,7 +180,11 @@
(define (parse-ms pattern input)
(let ((pn (string-length pattern)) (inn (string-length input))
(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))))
;; 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.

7
host/chez/io.ss
View file

@ -457,6 +457,10 @@
(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! "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
;; 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
@ -583,6 +587,9 @@
(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! "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"
(list (cons "toString" (lambda (u) (uri-field u 'string)))
(cons "toASCIIString" (lambda (u) (uri-field u 'string)))

2
host/chez/records-interop.ss
View file

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

12
host/chez/records.ss
View file

@ -203,6 +203,13 @@
((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).
((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).
((regex-t? obj) '("Pattern" "java.util.regex.Pattern" "Object"))
;; host value types a library may extend a protocol to by class (data.json
@ -288,7 +295,10 @@
"Duration" "Period" "LocalDate" "LocalTime" "LocalDateTime"
"ZonedDateTime" "OffsetDateTime" "OffsetTime" "ZoneId" "ZoneOffset"
"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))
(define (strip-prefix s p)
(let ((pl (string-length p)))

1
host/chez/rt.ss
View file

@ -333,6 +333,7 @@
(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-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
;; for the `.` / `.-field` desugar. Loads after host-static.ss so it wraps every

516
host/chez/seed/image.ss
View file

File diff suppressed because one or more lines are too long

552
host/chez/seed/prelude.ss
View file

File diff suppressed because one or more lines are too long

43
jolt-core/clojure/core/30-macros.clj
View file

@ -462,12 +462,23 @@
(or (= tn want) (suffix? tn want) (suffix? want tn))))
(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
;; pairs, methods registered under the type's (canonicalized) name — so
;; (extend 'String P {:m (fn [x] ...)}) dispatches exactly like extend-type.
(defn extend [atype & proto+mmaps]
;; 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)]
(when s
(let [proto (first s)
@ -484,21 +495,41 @@
;; `body` is one or more protocols, each followed by its method specs:
;; (extend-type T P1 (m1 [_] ..) P2 (m2 [_] ..)) — a bare symbol switches the
;; 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
;; expression like (Class/forName "[B") — bind its runtime name once.
(let [literal? (or (nil? tsym) (symbol? tsym))
tn (gensym "tname")
tref (if literal? (if (nil? tsym) "nil" (name tsym)) tn)
emit (fn []
(loop [items (seq body) proto nil forms []]
(if (empty? items)
`(do ~@forms)
forms
(let [x (first items)]
(if (symbol? x)
(recur (rest items) (name x) forms)
(recur (rest items) proto
(conj forms
`(register-method ~tname ~proto ~(name (first x))
(fn ~(nth x 1) ~@(drop 2 x)))))))))))
`(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]
`(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.
;; JVM proxies are unsupported.

6
test/chez/corpus.edn
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 "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 "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 / 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))"}