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

Host shims and protocol fixes shaken out by aws-api

Browse source 
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
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