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

Host shims and protocol fixes shaken out by aws-api

host/chez/async.ss

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

host/chez/byte-buffer.ss

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

host/chez/host-static-classes.ss

@@ -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}

host/chez/inst-time.ss

@@ -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.

host/chez/io.ss

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

host/chez/records-interop.ss

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

host/chez/records.ss

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

host/chez/rt.ss

@@ -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

jolt-core/clojure/core/30-macros.clj

@@ -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
-    (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]
   `(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.

test/chez/corpus.edn

@@ -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))"}