Group the JVM interop shims under host/chez/java/
The host/chez directory mixed jolt's own runtime (value model, seq, reader, vars, ns, multimethods) with the shims that emulate the JVM: java.* / javax.* classes, clojure.lang interfaces, and the host-class registry they hang off. Move that JVM-emulation layer into host/chez/java/ so it reads as a distinct unit instead of being interleaved with the platform runtime. Moved (content unchanged): host-static, host-static-methods, host-static-classes, host-class, dot-forms, records-interop, byte-buffer, io, io-streams, inst-time, java-time, bigdec, natives-queue, natives-str, natives-array, math, concurrency, async, ffi. The load paths in rt.ss/cli.ss and the build.ss runtime manifest are updated to point at java/; the build inliner follows the (load ...) strings, so the AOT path needs no other change. All runtime shims, no seed source touched (the three .clj edits are doc comments), so no re-mint. Gate green: make test (selfhost fixpoint, certify 0-new, sci 211, infer), shakesmoke (4 apps byte-identical).
This commit is contained in:
Yogthos
parent
5b77efa499
commit
ec9fde9e7e
26 changed files with 24 additions and 24 deletions
259
host/chez/java/async.ss
Normal file
259
host/chez/java/async.ss
Normal file
|
|
@ -0,0 +1,259 @@
|
|||
;; async.ss — clojure.core.async on real OS threads for the Chez host.
|
||||
;;
|
||||
;; A `go` block is an OS thread and a channel is a mutex+condition blocking
|
||||
;; queue: <! / >! are the blocking <!! / >!! (they "park" by blocking the thread).
|
||||
;; <! / >! work ANYWHERE — no CPS transform — because they are ordinary blocking
|
||||
;; calls. Real parallelism, shared heap. Trade-off: one OS thread per go block
|
||||
;; (fine for typical use, not for thousands of simultaneous go blocks).
|
||||
;;
|
||||
;; Channel: an unbuffered channel is a rendezvous (the putter blocks until its
|
||||
;; value is taken); a buffered (chan n) put blocks only when full; dropping/sliding
|
||||
;; buffers never block the putter. A transducer is applied on the put side.
|
||||
;;
|
||||
;; The fns are def-var!'d into clojure.core.async; go/go-loop/thread are macros
|
||||
;; (mark-macro!) expanding to go-spawn. Loaded after
|
||||
;; concurrency.ss (reuses ms->duration). Requires a threaded Chez build.
|
||||
|
||||
;; --- buffers ----------------------------------------------------------------
|
||||
(define-record-type async-buffer (fields n kind) (nongenerative async-buffer-v1))
|
||||
(define (jolt-async-buffer n) (make-async-buffer n 'fixed))
|
||||
(define (jolt-async-dropping-buffer n) (make-async-buffer n 'dropping))
|
||||
(define (jolt-async-sliding-buffer n) (make-async-buffer n 'sliding))
|
||||
|
||||
;; --- channels ---------------------------------------------------------------
|
||||
;; items: an amortized-O(1) FIFO held as a mutable #(out in len) — `out` is the
|
||||
;; front (pop from its head), `in` holds pushed entries reversed onto it, `len` is
|
||||
;; the count (an append-to-a-list FIFO is O(n) per push and O(n) to measure).
|
||||
;; Each entry is (value . box); box is #f for a buffered value or a 1-slot vector
|
||||
;; for an unbuffered rendezvous put (set #t when taken, waking the putter).
|
||||
;; cap 0 + kind 'unbuffered = rendezvous; cap>0 with kind fixed/dropping/sliding.
|
||||
(define-record-type async-chan
|
||||
(fields mu cv (mutable items) cap kind (mutable closed?) (mutable xrf))
|
||||
(nongenerative async-chan-v1))
|
||||
|
||||
(define (ac-qnew) (vector '() '() 0))
|
||||
(define (ac-qlen ch) (vector-ref (async-chan-items ch) 2))
|
||||
(define (ac-qempty? ch) (fx=? 0 (vector-ref (async-chan-items ch) 2)))
|
||||
(define (ac-qpush! ch entry)
|
||||
(let ((q (async-chan-items ch)))
|
||||
(vector-set! q 1 (cons entry (vector-ref q 1)))
|
||||
(vector-set! q 2 (fx+ 1 (vector-ref q 2)))))
|
||||
(define (ac-qfront! q) ; ensure `out` is non-empty: out := reverse in
|
||||
(when (null? (vector-ref q 0))
|
||||
(vector-set! q 0 (reverse (vector-ref q 1)))
|
||||
(vector-set! q 1 '())))
|
||||
(define (ac-qpop! ch)
|
||||
(let ((q (async-chan-items ch)))
|
||||
(ac-qfront! q)
|
||||
(let ((out (vector-ref q 0)))
|
||||
(vector-set! q 0 (cdr out))
|
||||
(vector-set! q 2 (fx- (vector-ref q 2) 1))
|
||||
(car out))))
|
||||
(define (ac-qdrop-oldest! ch)
|
||||
(let ((q (async-chan-items ch)))
|
||||
(ac-qfront! q)
|
||||
(vector-set! q 0 (cdr (vector-ref q 0)))
|
||||
(vector-set! q 2 (fx- (vector-ref q 2) 1))))
|
||||
|
||||
;; enqueue honoring the buffer kind (used by the transducer step + buffered puts).
|
||||
(define (ac-buf-give! ch v)
|
||||
(case (async-chan-kind ch)
|
||||
((dropping) (when (< (ac-qlen ch) (async-chan-cap ch)) (ac-qpush! ch (cons v #f))))
|
||||
((sliding) (when (>= (ac-qlen ch) (async-chan-cap ch)) (ac-qdrop-oldest! ch))
|
||||
(ac-qpush! ch (cons v #f)))
|
||||
(else (ac-qpush! ch (cons v #f)))) ; fixed: caller ensured room
|
||||
(condition-broadcast (async-chan-cv ch)))
|
||||
|
||||
;; A transducer is a jolt fn (xform); (xform add-rf) yields the channel's reducing
|
||||
;; fn. add-rf: 0-arg init, 1-arg completion, 2-arg step (enqueue the output). A
|
||||
;; `reduced` step result closes the channel.
|
||||
(define (ac-make-add-rf ch)
|
||||
(lambda args
|
||||
(cond ((null? args) ch) ; init
|
||||
((null? (cdr args)) (car args)) ; completion
|
||||
(else (ac-buf-give! ch (cadr args)) (car args))))) ; step
|
||||
|
||||
(define (ac-make cap kind xrf) (make-async-chan (make-mutex) (make-condition) (ac-qnew) cap kind #f xrf))
|
||||
|
||||
;; (chan) | (chan n) | (chan buf) | (chan n|buf xform)
|
||||
(define (jolt-async-chan . args)
|
||||
(let ((buf (if (pair? args) (car args) jolt-nil))
|
||||
(xform (if (and (pair? args) (pair? (cdr args))) (cadr args) jolt-nil)))
|
||||
(let-values (((cap kind)
|
||||
(cond ((async-buffer? buf) (values (async-buffer-n buf) (async-buffer-kind buf)))
|
||||
((and (number? buf) (> buf 0)) (values buf 'fixed))
|
||||
(else (values 0 'unbuffered)))))
|
||||
(let ((ch (ac-make cap kind #f)))
|
||||
(unless (jolt-nil? xform)
|
||||
(async-chan-xrf-set! ch (jolt-invoke xform (ac-make-add-rf ch))))
|
||||
ch))))
|
||||
|
||||
;; close! (idempotent): mark closed, flush a stateful transducer's completion, and
|
||||
;; wake everyone. ac-close! assumes the lock is held; the public form takes it.
|
||||
(define (ac-close! ch)
|
||||
(unless (async-chan-closed? ch)
|
||||
(async-chan-closed?-set! ch #t)
|
||||
(when (async-chan-xrf ch) (guard (e (#t #f)) (jolt-invoke (async-chan-xrf ch) ch)))
|
||||
(condition-broadcast (async-chan-cv ch)))
|
||||
jolt-nil)
|
||||
(define (jolt-async-close! ch) (with-mutex (async-chan-mu ch) (ac-close! ch)))
|
||||
|
||||
;; >! / >!! — put, blocking. false if closed; nil may not be put. With a
|
||||
;; transducer the value is run through it (one put -> zero or more channel values);
|
||||
;; a `reduced` result closes the channel.
|
||||
(define (jolt-async-give ch v)
|
||||
(when (jolt-nil? v) (jolt-throw (jolt-ex-info "Can't put nil on a channel" (jolt-hash-map))))
|
||||
(with-mutex (async-chan-mu ch)
|
||||
(cond
|
||||
((async-chan-closed? ch) #f)
|
||||
((async-chan-xrf ch)
|
||||
(let ((r (jolt-invoke (async-chan-xrf ch) ch v)))
|
||||
(when (jolt-reduced? r) (ac-close! ch))
|
||||
#t))
|
||||
(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
|
||||
(cond ((async-chan-closed? ch) #f)
|
||||
((< (ac-qlen ch) (async-chan-cap ch))
|
||||
(ac-qpush! ch (cons v #f)) (condition-broadcast (async-chan-cv ch)) #t)
|
||||
(else (condition-wait (async-chan-cv ch) (async-chan-mu ch)) (loop))))
|
||||
(let ((box (vector #f))) ; unbuffered: rendezvous
|
||||
(ac-qpush! ch (cons v box))
|
||||
(condition-broadcast (async-chan-cv ch))
|
||||
(let loop ()
|
||||
(cond ((vector-ref box 0) #t)
|
||||
((async-chan-closed? ch) #f)
|
||||
(else (condition-wait (async-chan-cv ch) (async-chan-mu ch)) (loop))))))))))))
|
||||
|
||||
;; remove + return the head value, waking a parked rendezvous putter.
|
||||
(define (ac-take-head! ch)
|
||||
(let* ((entry (ac-qpop! ch)) (v (car entry)) (box (cdr entry)))
|
||||
(when box (vector-set! box 0 #t))
|
||||
(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 ((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))))))
|
||||
|
||||
;; non-blocking take for alts!: a value, jolt-nil (closed+empty), or ac-poll-empty.
|
||||
(define ac-poll-empty (list 'empty))
|
||||
(define (ac-poll! ch)
|
||||
(with-mutex (async-chan-mu 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))))
|
||||
|
||||
;; (alts! [ch ...]) — take from whichever channel is ready first; returns
|
||||
;; [value channel] (value nil if that channel closed). Take-only: every port must
|
||||
;; be a channel — put specs [ch val] and the :default option are not supported, so
|
||||
;; reject them with a clear error instead of crashing inside ac-poll!.
|
||||
;; Polls with a 1ms backoff — no cross-channel wait-set yet.
|
||||
(define ac-1ms (make-time 'time-duration 1000000 0))
|
||||
(define (jolt-async-alts chans)
|
||||
(let ((cs (seq->list (jolt-seq chans))))
|
||||
(for-each (lambda (c)
|
||||
(unless (async-chan? c)
|
||||
(jolt-throw (jolt-ex-info
|
||||
"alts! supports channel ports only (put specs [ch val] and :default are not supported)"
|
||||
(jolt-hash-map)))))
|
||||
cs)
|
||||
(let loop ()
|
||||
(let try ((rest cs))
|
||||
(if (null? rest)
|
||||
(begin (sleep ac-1ms) (loop))
|
||||
(let ((r (ac-poll! (car rest))))
|
||||
(if (eq? r ac-poll-empty)
|
||||
(try (cdr rest))
|
||||
(jolt-vector r (car rest)))))))))
|
||||
|
||||
;; (timeout ms) — a channel that closes after ms milliseconds.
|
||||
(define (jolt-async-timeout ms)
|
||||
(let ((w (ac-make 0 'unbuffered #f)))
|
||||
(fork-thread (lambda () (sleep (ms->duration ms)) (jolt-async-close! w)))
|
||||
w))
|
||||
|
||||
;; (put! ch v [cb]) / (take! ch cb) — async put/take on a thread, optional callback.
|
||||
(define (jolt-async-put! ch v . cb)
|
||||
(fork-thread (lambda ()
|
||||
(let ((ok (jolt-async-give ch v)))
|
||||
(when (and (pair? cb) (not (jolt-nil? (car cb)))) (jolt-invoke (car cb) ok)))))
|
||||
jolt-nil)
|
||||
(define (jolt-async-take! ch cb)
|
||||
(fork-thread (lambda ()
|
||||
(let ((v (jolt-async-take ch)))
|
||||
(unless (jolt-nil? cb) (jolt-invoke cb v)))))
|
||||
jolt-nil)
|
||||
|
||||
;; (go-spawn thunk) — run thunk on a thread; return a buffered(1) channel that
|
||||
;; conveys its value once then closes (a nil result just closes). Dynamic bindings
|
||||
;; are conveyed (Chez inherits the thread-parameter at fork; we install explicitly).
|
||||
(define (async-go-spawn thunk)
|
||||
(let ((w (ac-make 1 'fixed #f)) (snap (dyn-binding-stack)))
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(dyn-binding-stack snap)
|
||||
(let ((r (guard (e (#t (cons #f e))) (cons #t (jolt-invoke thunk)))))
|
||||
(when (and (car r) (not (jolt-nil? (cdr r)))) (jolt-async-give w (cdr r)))
|
||||
(jolt-async-close! w))))
|
||||
w))
|
||||
|
||||
;; --- macros (expander fns over the reader forms) ----------------------------
|
||||
(define cca-go-spawn-sym (jolt-symbol "clojure.core.async" "go-spawn"))
|
||||
(define cca-go-sym (jolt-symbol "clojure.core.async" "go"))
|
||||
(define cca-fn*-sym (jolt-symbol #f "fn*"))
|
||||
(define cca-loop-sym (jolt-symbol #f "loop"))
|
||||
|
||||
;; (go body...) -> (clojure.core.async/go-spawn (fn* [] body...))
|
||||
(define (cca-go-macro . body)
|
||||
(jolt-list cca-go-spawn-sym (apply jolt-list cca-fn*-sym empty-pvec body)))
|
||||
;; (go-loop bindings body...) -> (go (loop bindings body...))
|
||||
(define (cca-go-loop-macro bindings . body)
|
||||
(jolt-list cca-go-sym (apply jolt-list cca-loop-sym bindings body)))
|
||||
;; (thread body...) — a real OS thread (same shape as go here).
|
||||
(define (cca-thread-macro . body)
|
||||
(jolt-list cca-go-spawn-sym (apply jolt-list cca-fn*-sym empty-pvec body)))
|
||||
|
||||
;; --- 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)
|
||||
(cca-def! "sliding-buffer" jolt-async-sliding-buffer)
|
||||
(cca-def! "close!" jolt-async-close!)
|
||||
(cca-def! "<!" jolt-async-take) (cca-def! "<!!" jolt-async-take)
|
||||
(cca-def! ">!" jolt-async-give) (cca-def! ">!!" jolt-async-give)
|
||||
(cca-def! "alts!" jolt-async-alts) (cca-def! "alts!!" jolt-async-alts)
|
||||
(cca-def! "timeout" jolt-async-timeout)
|
||||
(cca-def! "put!" jolt-async-put!)
|
||||
(cca-def! "take!" jolt-async-take!)
|
||||
(cca-def! "go-spawn" async-go-spawn)
|
||||
(cca-def! "go" cca-go-macro) (mark-macro! "clojure.core.async" "go")
|
||||
(cca-def! "go-loop" cca-go-loop-macro) (mark-macro! "clojure.core.async" "go-loop")
|
||||
(cca-def! "thread" cca-thread-macro) (mark-macro! "clojure.core.async" "thread")
|
||||
74
host/chez/java/bigdec.ss
Normal file
74
host/chez/java/bigdec.ss
Normal file
|
|
@ -0,0 +1,74 @@
|
|||
;; BigDecimal. A jbigdec is {unscaled, scale} over Chez arbitrary-precision exact
|
||||
;; integers; its value is unscaled * 10^-scale (1.5M = {15,1}, 1.00M = {100,2},
|
||||
;; 3M = {3,0}). M-suffix literals read to a :bigdec form that the back end lowers
|
||||
;; to jolt-bigdec-from-string; bigdec coerces a number/string. Equality is by
|
||||
;; value (1.0M = 1.00M), str drops the M, pr keeps it, class is
|
||||
;; java.math.BigDecimal. Arithmetic contagion is not modelled.
|
||||
|
||||
(define-record-type jbigdec (fields unscaled scale) (nongenerative chez-jbigdec-v1))
|
||||
|
||||
(define (bd-index-char s ch)
|
||||
(let loop ((i 0))
|
||||
(cond ((>= i (string-length s)) #f)
|
||||
((char=? (string-ref s i) ch) i)
|
||||
(else (loop (+ i 1))))))
|
||||
|
||||
;; "1.50" -> {150,2}; "3" -> {3,0}; "-0.0" -> {0,1}; ".5" -> {5,1}.
|
||||
(define (jolt-bigdec-from-string s)
|
||||
(let* ((neg (and (> (string-length s) 0) (char=? (string-ref s 0) #\-)))
|
||||
(sgn (and (> (string-length s) 0) (or neg (char=? (string-ref s 0) #\+))))
|
||||
(s1 (if sgn (substring s 1 (string-length s)) s))
|
||||
(sign (if neg -1 1))
|
||||
(dot (bd-index-char s1 #\.)))
|
||||
(if dot
|
||||
(let* ((intp (substring s1 0 dot))
|
||||
(fracp (substring s1 (+ dot 1) (string-length s1)))
|
||||
(digs (string-append intp fracp))
|
||||
(unscaled (if (= 0 (string-length digs)) 0 (string->number digs))))
|
||||
(make-jbigdec (* sign unscaled) (string-length fracp)))
|
||||
(make-jbigdec (* sign (string->number s1)) 0))))
|
||||
|
||||
;; bigdec coercion: a bigdec is itself; an exact integer keeps scale 0; a string
|
||||
;; or any other number routes through its decimal text.
|
||||
(define (jolt-bigdec x)
|
||||
(cond
|
||||
((jbigdec? x) x)
|
||||
((and (number? x) (exact? x) (integer? x)) (make-jbigdec x 0))
|
||||
((string? x) (jolt-bigdec-from-string x))
|
||||
((number? x) (jolt-bigdec-from-string (jolt-num->string x)))
|
||||
(else (error #f "bigdec: cannot coerce" x))))
|
||||
|
||||
;; value equality: unscaled_a * 10^scale_b == unscaled_b * 10^scale_a.
|
||||
(define (jbigdec=? a b)
|
||||
(= (* (jbigdec-unscaled a) (expt 10 (jbigdec-scale b)))
|
||||
(* (jbigdec-unscaled b) (expt 10 (jbigdec-scale a)))))
|
||||
|
||||
;; render the decimal text (no M): insert the point `scale` digits from the right.
|
||||
(define (jbigdec->string bd)
|
||||
(let* ((u (jbigdec-unscaled bd)) (sc (jbigdec-scale bd))
|
||||
(neg (< u 0)) (digs (number->string (abs u))))
|
||||
(string-append
|
||||
(if neg "-" "")
|
||||
(if (<= sc 0)
|
||||
digs
|
||||
(let* ((padded (if (<= (string-length digs) sc)
|
||||
(string-append (make-string (- (+ sc 1) (string-length digs)) #\0) digs)
|
||||
digs))
|
||||
(pl (string-length padded)))
|
||||
(string-append (substring padded 0 (- pl sc)) "." (substring padded (- pl sc) pl)))))))
|
||||
|
||||
;; --- wire into the value model ----------------------------------------------
|
||||
(def-var! "clojure.core" "bigdec" jolt-bigdec)
|
||||
|
||||
;; equality: a bigdec equals only another bigdec, by value (matching (= 3M 3) = false).
|
||||
(register-eq-arm! (lambda (a b) (or (jbigdec? a) (jbigdec? b)))
|
||||
(lambda (a b) (and (jbigdec? a) (jbigdec? b) (jbigdec=? a b))))
|
||||
|
||||
;; str drops the M; pr/pr-str keep it.
|
||||
(register-str-render! jbigdec? jbigdec->string)
|
||||
(register-pr-arm! jbigdec? (lambda (x) (string-append (jbigdec->string x) "M")))
|
||||
|
||||
;; class / decimal?
|
||||
(register-class-arm! jbigdec? (lambda (x) "java.math.BigDecimal"))
|
||||
(set! jolt-decimal? (lambda (x) (jbigdec? x)))
|
||||
(def-var! "clojure.core" "decimal?" jolt-decimal?)
|
||||
85
host/chez/java/byte-buffer.ss
Normal file
85
host/chez/java/byte-buffer.ss
Normal 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)))
|
||||
400
host/chez/java/concurrency.ss
Normal file
400
host/chez/java/concurrency.ss
Normal file
|
|
@ -0,0 +1,400 @@
|
|||
;; concurrency.ss — real OS-thread futures + promises for the Chez host.
|
||||
;;
|
||||
;; SHARED-HEAP semantics, like JVM Clojure: a future body runs on a native thread
|
||||
;; (fork-thread) over the SAME heap, so a captured atom is shared and the body's
|
||||
;; mutations are visible to the parent. deref blocks on a mutex+condition latch.
|
||||
;;
|
||||
;; future / future-call / future-cancel / future? / future-done? / future-cancelled?
|
||||
;; promise / deliver, and the deref extension for both, are bound here (some
|
||||
;; re-asserted in post-prelude.ss over the overlay's versions).
|
||||
;;
|
||||
;; pmap / pcalls / pvalues live in the clojure.core overlay (40-lazy) expressed
|
||||
;; over `future`, so they light up for free once future-call exists.
|
||||
;;
|
||||
;; Loaded near the end of rt.ss — after atoms.ss (jolt-deref, the atom lock) and
|
||||
;; dyn-binding.ss (the thread-local binding stack we convey into the worker).
|
||||
;; Requires a threaded Chez build (fork-thread / make-mutex / make-condition).
|
||||
|
||||
;; --- time helpers -----------------------------------------------------------
|
||||
;; A relative duration / absolute deadline from a millisecond count (a jolt number).
|
||||
(define (ms->duration ms)
|
||||
(let* ((ms* (exact (floor ms)))
|
||||
(secs (quotient ms* 1000))
|
||||
(nanos (* (remainder ms* 1000) 1000000)))
|
||||
(make-time 'time-duration nanos secs)))
|
||||
(define (ms->deadline ms) (add-duration (current-time 'time-utc) (ms->duration ms)))
|
||||
|
||||
;; --- futures ----------------------------------------------------------------
|
||||
;; A future is a mutable cell guarded by `mu`; workers/derefs coordinate on `cv`.
|
||||
;; done? — result (or cancellation) is final; derefs may proceed
|
||||
;; cancelled? — future-cancel won before the body finished
|
||||
;; ok? — payload is a value (else payload is a raised condition/value)
|
||||
;; payload — the result value, or the captured throw
|
||||
(define-record-type jolt-future
|
||||
(fields (mutable done?) (mutable cancelled?) (mutable ok?) (mutable payload) mu cv)
|
||||
(nongenerative jolt-future-v1))
|
||||
|
||||
;; (future-call thunk): spawn a thread running (thunk). The dynamic bindings in
|
||||
;; effect now are conveyed into the worker (Chez inherits thread-parameters at
|
||||
;; fork; we also install an explicit snapshot for certainty). The result — value
|
||||
;; or thrown condition — is latched and broadcast; a cancel that already finalized
|
||||
;; the future makes the late result a no-op.
|
||||
(define (jolt-future-call thunk)
|
||||
(let ((f (make-jolt-future #f #f #f jolt-nil (make-mutex) (make-condition)))
|
||||
(snap (dyn-binding-stack)))
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(dyn-binding-stack snap)
|
||||
(let ((r (guard (e (#t (cons #f e))) (cons #t (jolt-invoke thunk)))))
|
||||
(with-mutex (jolt-future-mu f)
|
||||
(unless (jolt-future-done? f) ; not already cancelled
|
||||
(jolt-future-ok?-set! f (car r))
|
||||
(jolt-future-payload-set! f (cdr r))
|
||||
(jolt-future-done?-set! f #t))
|
||||
(condition-broadcast (jolt-future-cv f))))))
|
||||
f))
|
||||
|
||||
;; Final value of a settled future (called OUTSIDE the lock): re-raise a captured
|
||||
;; throw, signal a cancellation, else the value.
|
||||
(define (jolt-future-finish f)
|
||||
(cond
|
||||
((jolt-future-cancelled? f)
|
||||
(jolt-throw (jolt-ex-info "Future cancelled" (jolt-hash-map))))
|
||||
((jolt-future-ok? f) (jolt-future-payload f))
|
||||
(else (raise (jolt-future-payload f)))))
|
||||
|
||||
(define (jolt-future-deref f)
|
||||
(with-mutex (jolt-future-mu f)
|
||||
(let loop ()
|
||||
(unless (jolt-future-done? f)
|
||||
(condition-wait (jolt-future-cv f) (jolt-future-mu f))
|
||||
(loop))))
|
||||
(jolt-future-finish f))
|
||||
|
||||
;; (deref f timeout-ms timeout-val): wait up to timeout-ms; return timeout-val if
|
||||
;; it has not settled by the absolute deadline.
|
||||
(define (jolt-future-deref-timed f ms timeout-val)
|
||||
(let* ((deadline (ms->deadline ms))
|
||||
(settled (with-mutex (jolt-future-mu f)
|
||||
(let loop ()
|
||||
(cond ((jolt-future-done? f) #t)
|
||||
((condition-wait (jolt-future-cv f) (jolt-future-mu f) deadline)
|
||||
(loop)) ; woken — recheck
|
||||
(else (jolt-future-done? f))))))) ; timed out: final check
|
||||
(if settled (jolt-future-finish f) timeout-val)))
|
||||
|
||||
;; future-cancel: the running thread can't be interrupted, but the future object
|
||||
;; reflects the cancellation — if not already settled, mark it cancelled+done so
|
||||
;; derefs raise and the predicates flip. Returns true iff this call cancelled it.
|
||||
(define (jolt-future-cancel f)
|
||||
(let ((cancelled (with-mutex (jolt-future-mu f)
|
||||
(if (jolt-future-done? f)
|
||||
#f
|
||||
(begin (jolt-future-cancelled?-set! f #t)
|
||||
(jolt-future-done?-set! f #t)
|
||||
(condition-broadcast (jolt-future-cv f))
|
||||
#t)))))
|
||||
cancelled))
|
||||
|
||||
(define (jolt-native-future-done? x)
|
||||
(if (jolt-future? x) (jolt-future-done? x)
|
||||
(jolt-throw (jolt-ex-info "future-done? requires a future" (jolt-hash-map)))))
|
||||
(define (jolt-native-future-cancelled? x)
|
||||
(and (jolt-future? x) (jolt-future-cancelled? x)))
|
||||
|
||||
;; --- promises ---------------------------------------------------------------
|
||||
;; A blocking promise (like the JVM): deref parks until deliver, then caches the
|
||||
;; value. deliver wins once; later delivers return nil.
|
||||
(define-record-type jolt-promise
|
||||
(fields (mutable delivered?) (mutable value) mu cv)
|
||||
(nongenerative jolt-promise-v1))
|
||||
|
||||
(define (jolt-promise-new) (make-jolt-promise #f jolt-nil (make-mutex) (make-condition)))
|
||||
|
||||
(define (jolt-deliver p v)
|
||||
(if (jolt-promise? p)
|
||||
(let ((won (with-mutex (jolt-promise-mu p)
|
||||
(if (jolt-promise-delivered? p)
|
||||
#f
|
||||
(begin (jolt-promise-value-set! p v)
|
||||
(jolt-promise-delivered?-set! p #t)
|
||||
(condition-broadcast (jolt-promise-cv p))
|
||||
#t)))))
|
||||
(if won p jolt-nil))
|
||||
(jolt-throw (jolt-ex-info "deliver requires a promise" (jolt-hash-map)))))
|
||||
|
||||
(define (jolt-promise-deref p)
|
||||
(with-mutex (jolt-promise-mu p)
|
||||
(let loop ()
|
||||
(unless (jolt-promise-delivered? p)
|
||||
(condition-wait (jolt-promise-cv p) (jolt-promise-mu p))
|
||||
(loop))))
|
||||
(jolt-promise-value p))
|
||||
|
||||
(define (jolt-promise-deref-timed p ms timeout-val)
|
||||
(let* ((deadline (ms->deadline ms))
|
||||
(got (with-mutex (jolt-promise-mu p)
|
||||
(let loop ()
|
||||
(cond ((jolt-promise-delivered? p) #t)
|
||||
((condition-wait (jolt-promise-cv p) (jolt-promise-mu p) deadline)
|
||||
(loop))
|
||||
(else (jolt-promise-delivered? p)))))))
|
||||
(if got (jolt-promise-value p) timeout-val)))
|
||||
|
||||
;; --- agents (async, per-agent serialized dispatch) --------------------------
|
||||
;; JVM semantics: send/send-off enqueue an action and a single worker thread
|
||||
;; applies them to the state IN ORDER; deref reads the
|
||||
;; (possibly not-yet-updated) state without blocking; await blocks until the queue
|
||||
;; drains. An action error is captured (agent-error) and stops the queue.
|
||||
(define-record-type jolt-agent
|
||||
(fields (mutable state) (mutable err) (mutable validator)
|
||||
(mutable queue) (mutable running?) mu cv)
|
||||
(nongenerative jolt-agent-v1))
|
||||
|
||||
;; (agent state) / (agent state :validator f :error-mode m :meta x): only :validator
|
||||
;; has runtime behaviour here; other opts are accepted/ignored.
|
||||
(define (jolt-agent-new state . opts)
|
||||
(let loop ((o opts) (validator jolt-nil))
|
||||
(cond
|
||||
((or (null? o) (null? (cdr o)))
|
||||
(make-jolt-agent state jolt-nil validator (vector '() '()) #f (make-mutex) (make-condition)))
|
||||
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "validator"))
|
||||
(loop (cddr o) (cadr o)))
|
||||
(else (loop (cddr o) validator)))))
|
||||
|
||||
;; The action queue is an amortized-O(1) FIFO held as a mutable #(out in): `out` is
|
||||
;; the front, `in` holds sends reversed onto it (an append-to-a-list send was O(n)).
|
||||
;; All three helpers run under the agent mutex.
|
||||
(define (jagent-q-empty? a)
|
||||
(let ((q (jolt-agent-queue a))) (and (null? (vector-ref q 0)) (null? (vector-ref q 1)))))
|
||||
(define (jagent-q-push! a entry)
|
||||
(let ((q (jolt-agent-queue a))) (vector-set! q 1 (cons entry (vector-ref q 1)))))
|
||||
(define (jagent-q-pop! a)
|
||||
(let ((q (jolt-agent-queue a)))
|
||||
(when (null? (vector-ref q 0))
|
||||
(vector-set! q 0 (reverse (vector-ref q 1))) (vector-set! q 1 '()))
|
||||
(let ((out (vector-ref q 0))) (vector-set! q 0 (cdr out)) (car out))))
|
||||
|
||||
;; Drain the queue, applying each action (f state arg*) outside the lock (an action
|
||||
;; may send/deref the same agent). A validator rejection or a thrown action puts the
|
||||
;; agent in an error state and halts the queue (JVM :fail mode).
|
||||
(define (jolt-agent-worker a)
|
||||
(let loop ()
|
||||
(let ((act (with-mutex (jolt-agent-mu a)
|
||||
(if (or (not (jolt-nil? (jolt-agent-err a))) (jagent-q-empty? a))
|
||||
(begin (jolt-agent-running?-set! a #f)
|
||||
(condition-broadcast (jolt-agent-cv a)) #f)
|
||||
(jagent-q-pop! a)))))
|
||||
(when act
|
||||
(guard (e (#t (with-mutex (jolt-agent-mu a)
|
||||
(jolt-agent-err-set! a e)
|
||||
(condition-broadcast (jolt-agent-cv a)))))
|
||||
(let ((nv (apply jolt-invoke (car act) (jolt-agent-state a) (cdr act))))
|
||||
(let ((vf (jolt-agent-validator a)))
|
||||
(when (and (not (jolt-nil? vf)) (jolt-not (jolt-invoke vf nv)))
|
||||
(error #f "Invalid reference state")))
|
||||
(jolt-agent-state-set! a nv)))
|
||||
(loop)))))
|
||||
|
||||
;; send / send-off: enqueue the action, start the worker if idle. (jolt treats them
|
||||
;; identically — one serialized worker per agent — which is observably a superset of
|
||||
;; the JVM's fixed/cached pool split.)
|
||||
(define (jolt-agent-send a f . args)
|
||||
(with-mutex (jolt-agent-mu a)
|
||||
(jagent-q-push! a (cons f args))
|
||||
(unless (jolt-agent-running? a)
|
||||
(jolt-agent-running?-set! a #t)
|
||||
(fork-thread (lambda () (jolt-agent-worker a)))))
|
||||
a)
|
||||
|
||||
;; (await & agents): block until each agent's queue has drained.
|
||||
(define (jolt-agent-await . agents)
|
||||
(for-each
|
||||
(lambda (a)
|
||||
(with-mutex (jolt-agent-mu a)
|
||||
(let loop ()
|
||||
(when (or (jolt-agent-running? a) (not (jagent-q-empty? a)))
|
||||
(condition-wait (jolt-agent-cv a) (jolt-agent-mu a)) (loop)))))
|
||||
agents)
|
||||
jolt-nil)
|
||||
|
||||
(define (jolt-agent-error a) (jolt-agent-err a))
|
||||
(define (jolt-agent-restart a new-state . _opts)
|
||||
(jolt-agent-err-set! a jolt-nil)
|
||||
(jolt-agent-state-set! a new-state)
|
||||
a)
|
||||
|
||||
;; --- delay (lazy once-forced computation) -----------------------------------
|
||||
;; (delay body) -> (make-delay (fn [] body)) (overlay macro); force/deref run the
|
||||
;; thunk once under a lock and cache the value (JVM delays are thread-safe). force
|
||||
;; (overlay) is (if (delay? x) (deref x) x), so it works once delay?/deref do.
|
||||
(define-record-type jolt-delay (fields thunk (mutable realized?) (mutable value) (mutable exn) mu)
|
||||
(nongenerative jolt-delay-v1))
|
||||
(define (jolt-make-delay thunk) (make-jolt-delay thunk #f jolt-nil #f (make-mutex)))
|
||||
;; run the thunk once, like Clojure's Delay: if it throws, cache the exception
|
||||
;; (the delay IS realized) and re-throw it on every deref — do NOT re-run the
|
||||
;; body (so value-fns memoize and there is no cache-stampede / retried side
|
||||
;; effect). Store the exception inside the lock, re-raise outside it so the mutex
|
||||
;; is always released.
|
||||
(define (jolt-delay-force d)
|
||||
(with-mutex (jolt-delay-mu d)
|
||||
(unless (jolt-delay-realized? d)
|
||||
(guard (e (#t (jolt-delay-exn-set! d e) (jolt-delay-realized?-set! d #t)))
|
||||
(jolt-delay-value-set! d (jolt-invoke (jolt-delay-thunk d)))
|
||||
(jolt-delay-realized?-set! d #t))))
|
||||
(if (jolt-delay-exn d) (raise (jolt-delay-exn d)) (jolt-delay-value d)))
|
||||
|
||||
;; --- deref extension --------------------------------------------------------
|
||||
;; Chain the fully-built jolt-deref (atoms/vars/volatiles/reduced) with futures,
|
||||
;; promises, agents, and delays; accept the timed (deref ref ms val) arity for the
|
||||
;; blocking ref types.
|
||||
(define %pre-conc-deref jolt-deref)
|
||||
(set! jolt-deref
|
||||
(lambda (x . opts)
|
||||
(cond
|
||||
((jolt-future? x)
|
||||
(if (null? opts) (jolt-future-deref x)
|
||||
(jolt-future-deref-timed x (car opts) (cadr opts))))
|
||||
((jolt-promise? x)
|
||||
(if (null? opts) (jolt-promise-deref x)
|
||||
(jolt-promise-deref-timed x (car opts) (cadr opts))))
|
||||
((jolt-agent? x) (jolt-agent-state x))
|
||||
((jolt-delay? x) (jolt-delay-force x))
|
||||
;; a record/reify implementing clojure.lang.IDeref: @x calls its `deref`
|
||||
;; method with the value itself as the leading `this`.
|
||||
((and (jrec? x) (find-method-any-protocol (jrec-tag x) "deref"))
|
||||
=> (lambda (m) (jolt-invoke m x)))
|
||||
((and (reified-methods x) (hashtable-ref (reified-methods x) "deref" #f))
|
||||
=> (lambda (m) (jolt-invoke m x)))
|
||||
(else (apply %pre-conc-deref x opts)))))
|
||||
|
||||
;; realized? for a future/promise/delay. Wrapped over the overlay version in
|
||||
;; post-prelude.ss.
|
||||
(define (jolt-conc-realized? x)
|
||||
(cond ((jolt-future? x) (jolt-future-done? x))
|
||||
((jolt-promise? x) (jolt-promise-delivered? x))
|
||||
((jolt-delay? x) (jolt-delay-realized? x))
|
||||
(else #f)))
|
||||
|
||||
;; --- bind into clojure.core -------------------------------------------------
|
||||
(def-var! "clojure.core" "future-call" jolt-future-call)
|
||||
(def-var! "clojure.core" "future-cancel" jolt-future-cancel)
|
||||
(def-var! "clojure.core" "future?" jolt-future?)
|
||||
(def-var! "clojure.core" "future-done?" jolt-native-future-done?)
|
||||
(def-var! "clojure.core" "future-cancelled?" jolt-native-future-cancelled?)
|
||||
(def-var! "clojure.core" "promise" jolt-promise-new)
|
||||
(def-var! "clojure.core" "deliver" jolt-deliver)
|
||||
(def-var! "clojure.core" "agent" jolt-agent-new)
|
||||
(def-var! "clojure.core" "agent?" jolt-agent?)
|
||||
(def-var! "clojure.core" "send" jolt-agent-send)
|
||||
(def-var! "clojure.core" "send-off" jolt-agent-send)
|
||||
(def-var! "clojure.core" "await" jolt-agent-await)
|
||||
(def-var! "clojure.core" "agent-error" jolt-agent-error)
|
||||
(def-var! "clojure.core" "restart-agent" jolt-agent-restart)
|
||||
(def-var! "clojure.core" "make-delay" jolt-make-delay)
|
||||
(def-var! "clojure.core" "delay?" jolt-delay?)
|
||||
(def-var! "clojure.core" "deref" jolt-deref)
|
||||
|
||||
;; --- object monitors (locking) ----------------------------------------------
|
||||
;; (locking obj body…) takes obj's monitor for the body — a real per-object lock
|
||||
;; now that futures/agents/threads share one heap. Each object gets a recursive
|
||||
;; Chez mutex (a thread may re-enter a monitor it already holds, like the JVM),
|
||||
;; held in an identity-keyed weak table so monitors are reclaimed with their
|
||||
;; objects. dynamic-wind releases on normal, exceptional, and continuation exit.
|
||||
(define monitor-table (make-weak-eq-hashtable))
|
||||
(define monitor-table-lock (make-mutex))
|
||||
(define (object-monitor obj)
|
||||
(with-mutex monitor-table-lock
|
||||
(or (hashtable-ref monitor-table obj #f)
|
||||
(let ((m (make-mutex))) (hashtable-set! monitor-table obj m) m))))
|
||||
(define (jolt-with-monitor obj thunk)
|
||||
(let ((m (object-monitor obj)))
|
||||
(dynamic-wind
|
||||
(lambda () (mutex-acquire m))
|
||||
thunk
|
||||
(lambda () (mutex-release m)))))
|
||||
(def-var! "jolt.host" "with-monitor" jolt-with-monitor)
|
||||
|
||||
;; --- cooperative thread interrupt -------------------------------------------
|
||||
;; Chez has no force-kill, but its engine timer (set-timer + timer-interrupt-
|
||||
;; handler, thread-local) is polled at procedure-call / loop back-edges — so a
|
||||
;; running computation, even a tight Scheme loop, can be aborted from another
|
||||
;; thread. An interrupt TOKEN is a shared box; run-interruptible arms a periodic
|
||||
;; timer in the eval thread whose handler escapes (via call/cc) when the token is
|
||||
;; set; interrupt! sets the token from any thread. The aborted eval throws a jolt
|
||||
;; ex-info {:jolt/interrupted true}, so the thread is REUSED, not abandoned.
|
||||
;;
|
||||
;; Caveat: a thread blocked in a __collect_safe foreign call (socket recv/accept,
|
||||
;; sleep) only sees the interrupt when it returns to Scheme — like the JVM not
|
||||
;; killing native code.
|
||||
(define interrupt-check-ticks 100000) ; ~poll interval; responsive + low overhead
|
||||
(define interrupt-sentinel (cons 'jolt 'interrupted))
|
||||
(define jolt-kw-interrupted (keyword "jolt" "interrupted"))
|
||||
(define (jolt-make-interrupt) (box #f))
|
||||
(define (jolt-interrupt! token) (when (box? token) (set-box! token #t)) jolt-nil)
|
||||
(define (jolt-interrupted? token) (and (box? token) (unbox token) #t))
|
||||
(define (jolt-run-interruptible token thunk)
|
||||
(let ((prev-handler (timer-interrupt-handler)))
|
||||
(let ((r (call/cc
|
||||
(lambda (k)
|
||||
(timer-interrupt-handler
|
||||
(lambda ()
|
||||
(if (and (box? token) (unbox token))
|
||||
(k interrupt-sentinel)
|
||||
(begin (set-timer interrupt-check-ticks) (void)))))
|
||||
(set-timer interrupt-check-ticks)
|
||||
(let ((v (thunk))) (set-timer 0) v)))))
|
||||
;; restore the prior timer state regardless of outcome.
|
||||
(set-timer 0)
|
||||
(timer-interrupt-handler prev-handler)
|
||||
(if (eq? r interrupt-sentinel)
|
||||
(jolt-throw (jolt-ex-info "Evaluation interrupted" (jolt-hash-map jolt-kw-interrupted #t)))
|
||||
r))))
|
||||
(def-var! "jolt.host" "make-interrupt" jolt-make-interrupt)
|
||||
(def-var! "jolt.host" "interrupt!" jolt-interrupt!)
|
||||
(def-var! "jolt.host" "interrupted?" jolt-interrupted?)
|
||||
(def-var! "jolt.host" "run-interruptible" jolt-run-interruptible)
|
||||
|
||||
;; --- java.lang.Thread / java.util.concurrent.CountDownLatch -----------------
|
||||
;; Real OS threads over Chez fork-thread (shared heap — a captured atom/var is
|
||||
;; shared). A Thread runs its Runnable thunk; start forks, join waits on a
|
||||
;; condition latched at completion. CountDownLatch is a counting barrier.
|
||||
(define (make-jthread thunk) (make-jhost "user-thread" (vector thunk #f (make-mutex) (make-condition))))
|
||||
(for-each (lambda (nm) (register-class-ctor! nm (lambda (thunk . _) (make-jthread thunk))))
|
||||
'("Thread" "java.lang.Thread"))
|
||||
(register-host-methods! "user-thread"
|
||||
(list (cons "start" (lambda (self)
|
||||
(let ((st (jhost-state self)) (snap (dyn-binding-stack)))
|
||||
(fork-thread (lambda ()
|
||||
(dyn-binding-stack snap)
|
||||
(guard (e (#t #f)) (jolt-invoke (vector-ref st 0)))
|
||||
(with-mutex (vector-ref st 2)
|
||||
(vector-set! st 1 #t)
|
||||
(condition-broadcast (vector-ref st 3)))))
|
||||
jolt-nil)))
|
||||
(cons "run" (lambda (self) (jolt-invoke (vector-ref (jhost-state self) 0)) jolt-nil))
|
||||
(cons "join" (lambda (self . _)
|
||||
(let ((st (jhost-state self)))
|
||||
(with-mutex (vector-ref st 2)
|
||||
(let loop () (unless (vector-ref st 1) (condition-wait (vector-ref st 3) (vector-ref st 2)) (loop)))))
|
||||
jolt-nil))
|
||||
(cons "isAlive" (lambda (self) (not (vector-ref (jhost-state self) 1))))
|
||||
(cons "interrupt" (lambda (self . _) jolt-nil))
|
||||
(cons "setDaemon" (lambda (self . _) jolt-nil))))
|
||||
|
||||
(define (make-jlatch n) (make-jhost "count-down-latch" (vector n (make-mutex) (make-condition))))
|
||||
(for-each (lambda (nm) (register-class-ctor! nm (lambda (n . _) (make-jlatch (jnum->exact n)))))
|
||||
'("CountDownLatch" "java.util.concurrent.CountDownLatch"))
|
||||
(register-host-methods! "count-down-latch"
|
||||
(list (cons "countDown" (lambda (self)
|
||||
(let ((st (jhost-state self)))
|
||||
(with-mutex (vector-ref st 1)
|
||||
(when (> (vector-ref st 0) 0) (vector-set! st 0 (- (vector-ref st 0) 1)))
|
||||
(when (= (vector-ref st 0) 0) (condition-broadcast (vector-ref st 2)))))
|
||||
jolt-nil))
|
||||
(cons "await" (lambda (self . _)
|
||||
(let ((st (jhost-state self)))
|
||||
(with-mutex (vector-ref st 1)
|
||||
(let loop () (when (> (vector-ref st 0) 0) (condition-wait (vector-ref st 2) (vector-ref st 1)) (loop)))))
|
||||
jolt-nil))
|
||||
(cons "getCount" (lambda (self) (vector-ref (jhost-state self) 0)))))
|
||||
101
host/chez/java/dot-forms.ss
Normal file
101
host/chez/java/dot-forms.ss
Normal file
|
|
@ -0,0 +1,101 @@
|
|||
;; dot-forms.ss — generic dispatch for the `.` special-form / `.-field` desugar.
|
||||
;; The analyzer lowers (. target member arg*) and (.-field target)
|
||||
;; to a :host-call; the Chez emit routes a non-shimmed :host-call through
|
||||
;; record-method-dispatch. This file extends that dispatcher with the collection
|
||||
;; arms the interpreter's dispatch-member covers but the record/string base does
|
||||
;; not, with this precedence:
|
||||
;;
|
||||
;; * collection interop wins first — count/seq/nth/get/valAt/containsKey on a
|
||||
;; vector/map/set/seq/record (so (. {:count 9} count) is the entry count, 1,
|
||||
;; NOT the :count field).
|
||||
;; * field access — a "-name" member reads the field (records and maps).
|
||||
;; * map member — a stored fn is a method (called with self + args); any
|
||||
;; other value is returned as a field.
|
||||
;;
|
||||
;; Anything not recognized falls through to the previous dispatcher (jhost /
|
||||
;; number / regex / jrec protocol / string). Loaded LAST (after host-static.ss).
|
||||
;; A record (jrec) is jolt-map? here (records.ss makes it so) and a collection,
|
||||
;; so its protocol method (no dash, not a coll method) lands in the base.
|
||||
|
||||
(define %dot-rmd record-method-dispatch)
|
||||
|
||||
;; Vectors / maps / sets only (records are jolt-map? here). Raw seqs are excluded:
|
||||
;; coll-interop accepts some seq representations and not others (a
|
||||
;; plain (seq v) returns nil from .count, a lazy-seq returns the count), an
|
||||
;; inconsistency Chez's normalized cseq can't mirror — so a raw seq target falls
|
||||
;; through to the base dispatcher rather than risk a divergence the corpus would
|
||||
;; never exercise but a future case might.
|
||||
(define (dot-coll? obj)
|
||||
(or (jolt-vector? obj) (jolt-map? obj) (pset? obj)))
|
||||
|
||||
;; Mirror coll-interop: return a one-element list boxing the result (so a jolt-nil
|
||||
;; result is still distinguishable from "not a collection method"), or #f.
|
||||
(define (dot-coll-method obj name args)
|
||||
(cond
|
||||
((string=? name "count") (list (jolt-count obj)))
|
||||
((string=? name "seq") (list (jolt-seq obj)))
|
||||
((string=? name "nth") (list (apply jolt-nth obj args)))
|
||||
((or (string=? name "get") (string=? name "valAt"))
|
||||
(list (apply jolt-get obj args)))
|
||||
((string=? name "containsKey") (list (jolt-contains? obj (car args))))
|
||||
((string=? name "size") (list (jolt-count obj)))
|
||||
((string=? name "isEmpty") (list (jolt-empty? obj)))
|
||||
;; java.util.Map views: keySet (a Set), values (a Collection), entrySet.
|
||||
((and (jolt-map? obj) (string=? name "keySet"))
|
||||
(list (apply jolt-hash-set (seq->list (jolt-keys obj)))))
|
||||
((and (jolt-map? obj) (string=? name "values"))
|
||||
(list (apply jolt-vector (seq->list (jolt-vals obj)))))
|
||||
((and (jolt-map? obj) (string=? name "entrySet")) (list (jolt-seq obj)))
|
||||
;; (.iterator coll): a java.util.Iterator over the seq — for a map this is the
|
||||
;; entry iterator. Without this a map's .iterator falls into the map-as-object
|
||||
;; branch and is mis-read as a missing :iterator key (nil). Some libraries
|
||||
;; (e.g. malli's -vmap) iterate a map this way.
|
||||
((string=? name "iterator") (list (make-jiterator (jolt-seq obj))))
|
||||
(else #f)))
|
||||
|
||||
;; Universal object-methods: on a
|
||||
;; non-record map these win OVER a field lookup, like dispatch-member. getMessage
|
||||
;; on an ex-info reads its :message (the one the corpus exercises); getCause reads
|
||||
;; :cause; toString/hashCode/equals round out the set. Returns a boxed result or
|
||||
;; #f. Strings/numbers/records/jhost keep the base dispatcher (it shims them).
|
||||
(define (dot-object-method obj name args)
|
||||
(cond
|
||||
((string=? name "getMessage")
|
||||
(list (if (jolt=2 (jolt-get obj jolt-kw-ex-type jolt-nil) jolt-kw-ex-info)
|
||||
(jolt-get obj jolt-kw-message jolt-nil)
|
||||
(jolt-str-render-one obj))))
|
||||
((string=? name "getCause") (list (jolt-get obj jolt-kw-cause jolt-nil)))
|
||||
;; java.sql.SQLException chaining — ex-info / host throwables don't chain.
|
||||
((string=? name "getNextException") (list jolt-nil))
|
||||
((string=? name "getStackTrace") (list (jolt-vector)))
|
||||
((string=? name "toString") (list (jolt-str-render-one obj)))
|
||||
((string=? name "hashCode") (list (jolt-hash obj)))
|
||||
((string=? name "equals") (list (if (jolt= obj (car args)) #t #f)))
|
||||
(else #f)))
|
||||
|
||||
(set! record-method-dispatch
|
||||
(lambda (obj method-name rest-args)
|
||||
(let* ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args)))
|
||||
(field? (and (> (string-length method-name) 0)
|
||||
(char=? (string-ref method-name 0) #\-)))
|
||||
(mname (if field?
|
||||
(substring method-name 1 (string-length method-name))
|
||||
method-name)))
|
||||
(cond
|
||||
;; (.getClass x) universal — the class token for any value, before the
|
||||
;; collection/map field-lookup arms below would read it as a missing key.
|
||||
((string=? method-name "getClass") (jolt-class obj))
|
||||
;; collection interop first (entry count / seq / nth / get / containsKey).
|
||||
((and (dot-coll? obj) (dot-coll-method obj mname rest))
|
||||
=> (lambda (box) (car box)))
|
||||
;; (.-field obj) / (. obj -field): field read on a record or map.
|
||||
(field? (jolt-get obj (keyword #f mname) jolt-nil))
|
||||
;; non-record map: a universal object-method (getMessage/...) wins first,
|
||||
;; then a stored procedure is a method (call with self), else the field.
|
||||
((and (jolt-map? obj) (not (jrec? obj)))
|
||||
(cond
|
||||
((dot-object-method obj mname rest) => car)
|
||||
(else
|
||||
(let ((v (jolt-get obj (keyword #f mname) jolt-nil)))
|
||||
(if (procedure? v) (apply jolt-invoke v obj rest) v)))))
|
||||
(else (%dot-rmd obj method-name rest-args))))))
|
||||
167
host/chez/java/ffi.ss
Normal file
167
host/chez/java/ffi.ss
Normal file
|
|
@ -0,0 +1,167 @@
|
|||
;; ffi.ss — the runtime side of jolt's foreign-function interface (jolt.ffi).
|
||||
;;
|
||||
;; A jolt LIBRARY binds native code itself: it loads a shared object and declares
|
||||
;; typed foreign functions, then exposes a Clojure API. The TYPED CALL is lowered
|
||||
;; at compile time to a Chez `foreign-procedure` by the backend (the
|
||||
;; `jolt.ffi/foreign-fn` special form) — this file provides everything that does
|
||||
;; NOT need compile-time types: loading libraries, allocating/reading/writing
|
||||
;; foreign memory, and string/pointer marshaling. All exposed under `jolt.ffi`.
|
||||
;;
|
||||
;; A foreign pointer is a Chez machine address (an exact integer / uptr), the same
|
||||
;; representation `void*` arguments and results use, so pointers flow between
|
||||
;; foreign-fn calls and these helpers transparently.
|
||||
|
||||
;; --- loading shared objects --------------------------------------------------
|
||||
;; (jolt.ffi/load-library name) loads a .so/.dylib by name (resolved by the OS
|
||||
;; loader against the standard search paths). A library typically calls this once
|
||||
;; at load with a platform-specific name. (load-library) with no name (or #f)
|
||||
;; loads the running process's own symbols (libc, sockets).
|
||||
(define (ffi-load-library . args)
|
||||
(if (or (null? args) (jolt-nil? (car args)))
|
||||
(begin (load-shared-object #f) jolt-nil)
|
||||
(begin (load-shared-object (jolt-str-render-one (car args))) jolt-nil)))
|
||||
|
||||
(define (ffi-loaded? name)
|
||||
(guard (e (#t #f)) (load-shared-object (jolt-str-render-one name)) #t))
|
||||
|
||||
;; --- foreign type keywords ---------------------------------------------------
|
||||
;; The keyword type names jolt.ffi accepts (in foreign-fn signatures and the
|
||||
;; memory accessors) map to Chez foreign types. Kept in one place so the backend
|
||||
;; (compile-time, for foreign-procedure) and these accessors (runtime, for
|
||||
;; foreign-ref/set!) agree.
|
||||
(define (ffi-type->chez kw)
|
||||
(let ((n (if (keyword-t? kw) (keyword-t-name kw) (jolt-str-render-one kw))))
|
||||
(cond
|
||||
((string=? n "int") 'int)
|
||||
((string=? n "uint") 'unsigned-int)
|
||||
((string=? n "long") 'long)
|
||||
((string=? n "ulong") 'unsigned-long)
|
||||
((string=? n "int64") 'integer-64)
|
||||
((string=? n "uint64") 'unsigned-64)
|
||||
((string=? n "size_t") 'size_t)
|
||||
((string=? n "ssize_t") 'ssize_t)
|
||||
((string=? n "iptr") 'iptr)
|
||||
((string=? n "uptr") 'uptr)
|
||||
((string=? n "double") 'double)
|
||||
((string=? n "float") 'float)
|
||||
((or (string=? n "pointer") (string=? n "void*")) 'void*)
|
||||
((string=? n "string") 'string)
|
||||
((string=? n "void") 'void)
|
||||
((or (string=? n "uint8") (string=? n "u8") (string=? n "byte")) 'unsigned-8)
|
||||
((string=? n "char") 'char)
|
||||
(else (error #f (string-append "jolt.ffi: unknown foreign type :" n))))))
|
||||
|
||||
;; --- foreign memory ----------------------------------------------------------
|
||||
;; alloc returns a pointer (integer address). The caller frees it. read/write take
|
||||
;; a type keyword and an optional byte offset.
|
||||
(define (ffi-alloc nbytes) (foreign-alloc (jnum->exact nbytes)))
|
||||
(define (ffi-free ptr) (foreign-free (jnum->exact ptr)) jolt-nil)
|
||||
(define (ffi-read ptr ty . off)
|
||||
(foreign-ref (ffi-type->chez ty) (jnum->exact ptr) (if (pair? off) (jnum->exact (car off)) 0)))
|
||||
(define (ffi-write ptr ty off val)
|
||||
(foreign-set! (ffi-type->chez ty) (jnum->exact ptr) (jnum->exact off) val) jolt-nil)
|
||||
;; sizeof a foreign type (for laying out structs / arrays).
|
||||
(define (ffi-sizeof ty) (foreign-sizeof (ffi-type->chez ty)))
|
||||
(define (ffi-null? ptr) (and (number? ptr) (= (jnum->exact ptr) 0)))
|
||||
(define ffi-null 0)
|
||||
|
||||
;; --- buffer I/O (known length) ----------------------------------------------
|
||||
;; read n bytes at ptr as a string (UTF-8, falling back to latin1 for invalid
|
||||
;; sequences) — for a socket recv buffer and similar fixed-length reads.
|
||||
(define (ffi-read-bytes ptr n)
|
||||
(let* ((n (jnum->exact n)) (p (jnum->exact ptr)) (bv (make-bytevector n)))
|
||||
(do ((i 0 (+ i 1))) ((= i n)) (bytevector-u8-set! bv i (foreign-ref 'unsigned-8 p i)))
|
||||
(guard (e (#t (list->string (map integer->char (bytevector->u8-list bv))))) (utf8->string bv))))
|
||||
;; write a string's UTF-8 bytes into ptr (no NUL terminator); return the count.
|
||||
(define (ffi-write-bytes ptr s)
|
||||
(let* ((bv (string->utf8 (jolt-str-render-one s))) (n (bytevector-length bv)) (p (jnum->exact ptr)))
|
||||
(do ((i 0 (+ i 1))) ((= i n)) (foreign-set! 'unsigned-8 p i (bytevector-u8-ref bv i)))
|
||||
n))
|
||||
(def-var! "jolt.ffi" "read-bytes" ffi-read-bytes)
|
||||
(def-var! "jolt.ffi" "write-bytes" ffi-write-bytes)
|
||||
|
||||
;; --- byte-array buffer I/O (binary-faithful) --------------------------------
|
||||
;; Move raw bytes between a jolt byte-array (jolt-array kind 'byte) and foreign
|
||||
;; memory, byte-exact (no UTF-8 / latin1 decode) — for socket recv/send and the
|
||||
;; zlib / OpenSSL buffers an HTTP client passes through. read-array returns a
|
||||
;; fresh byte-array of n bytes; write-array copies a byte-array's bytes into ptr
|
||||
;; and returns the count.
|
||||
(define (ffi-read-array ptr n)
|
||||
(let* ((n (jnum->exact n)) (p (jnum->exact ptr)) (v (make-vector n 0)))
|
||||
(do ((i 0 (+ i 1))) ((= i n)) (vector-set! v i (foreign-ref 'unsigned-8 p i)))
|
||||
(make-jolt-array v 'byte)))
|
||||
(define (ffi-write-array ptr arr)
|
||||
(let* ((v (jolt-array-vec arr)) (n (vector-length v)) (p (jnum->exact ptr)))
|
||||
(do ((i 0 (+ i 1))) ((= i n)) (foreign-set! 'unsigned-8 p i (bitwise-and (exact (vector-ref v i)) #xff)))
|
||||
n))
|
||||
(def-var! "jolt.ffi" "read-array" ffi-read-array)
|
||||
(def-var! "jolt.ffi" "write-array" ffi-write-array)
|
||||
|
||||
;; --- string / bytevector marshaling ------------------------------------------
|
||||
;; A C string result already comes back as a jolt string (the `string` foreign
|
||||
;; type). For a `void*` that points at a NUL-terminated C string, read it here.
|
||||
(define (ffi-ptr->string ptr)
|
||||
(if (ffi-null? ptr) jolt-nil
|
||||
(let ((p (jnum->exact ptr)))
|
||||
(let loop ((i 0) (acc '()))
|
||||
(let ((b (foreign-ref 'unsigned-8 p i)))
|
||||
(if (= b 0) (utf8->string (u8-list->bytevector (reverse acc)))
|
||||
(loop (+ i 1) (cons b acc))))))))
|
||||
;; Copy a jolt string's UTF-8 bytes into a freshly alloc'd NUL-terminated buffer;
|
||||
;; the caller frees it. Returns the pointer.
|
||||
(define (ffi-string->ptr s)
|
||||
(let* ((bv (string->utf8 (jolt-str-render-one s))) (n (bytevector-length bv))
|
||||
(p (foreign-alloc (+ n 1))))
|
||||
(do ((i 0 (+ i 1))) ((= i n)) (foreign-set! 'unsigned-8 p i (bytevector-u8-ref bv i)))
|
||||
(foreign-set! 'unsigned-8 p n 0)
|
||||
p))
|
||||
|
||||
;; --- callbacks: receive calls FROM C ----------------------------------------
|
||||
;; jolt.ffi/foreign-callable lowers to (jolt-ffi-register-callable! (foreign-callable …)).
|
||||
;; A foreign-callable code object must be LOCKED (so the collector neither moves
|
||||
;; nor reclaims it) and RETAINED while C may still call through its entry point.
|
||||
;; Register it keyed by that entry-point address (a jolt pointer integer) — which
|
||||
;; is what the caller hands to C; free-callable unlocks and drops it. A callback
|
||||
;; left registered lives for the process (the GTK-signal-handler common case).
|
||||
(define ffi-callable-table (make-eqv-hashtable)) ; entry-point addr -> code object
|
||||
(define (jolt-ffi-register-callable! co)
|
||||
(lock-object co)
|
||||
(let ((addr (foreign-callable-entry-point co)))
|
||||
(hashtable-set! ffi-callable-table addr co)
|
||||
addr))
|
||||
(define (ffi-free-callable addr)
|
||||
(let* ((a (jnum->exact addr)) (co (hashtable-ref ffi-callable-table a #f)))
|
||||
(when co (unlock-object co) (hashtable-delete! ffi-callable-table a))
|
||||
jolt-nil))
|
||||
|
||||
;; --- native libraries for a standalone binary -------------------------------
|
||||
;; `jolt build` bakes a project's deps.edn :jolt/native declarations into the
|
||||
;; launcher, which loads them at startup (load-shared-object isn't part of the
|
||||
;; saved heap, so it must run in the built process, not at heap build). process?
|
||||
;; loads the running binary's own symbols (libc sockets); otherwise try each
|
||||
;; platform candidate in turn and fail unless the spec is optional.
|
||||
(define (jolt-build-load-native cands optional? process?)
|
||||
(if process?
|
||||
(begin (load-shared-object #f) #t)
|
||||
(let loop ((cs cands))
|
||||
(cond
|
||||
((null? cs)
|
||||
(unless optional?
|
||||
(error 'jolt-build "required native library not found" cands))
|
||||
#f)
|
||||
((guard (e (#t #f)) (load-shared-object (car cs)) #t) #t)
|
||||
(else (loop (cdr cs)))))))
|
||||
|
||||
;; --- expose under jolt.ffi ---------------------------------------------------
|
||||
(def-var! "jolt.ffi" "free-callable" ffi-free-callable)
|
||||
(def-var! "jolt.ffi" "load-library" ffi-load-library)
|
||||
(def-var! "jolt.ffi" "loaded?" (lambda (n) (if (ffi-loaded? n) #t #f)))
|
||||
(def-var! "jolt.ffi" "alloc" ffi-alloc)
|
||||
(def-var! "jolt.ffi" "free" ffi-free)
|
||||
(def-var! "jolt.ffi" "read" ffi-read)
|
||||
(def-var! "jolt.ffi" "write" ffi-write)
|
||||
(def-var! "jolt.ffi" "sizeof" ffi-sizeof)
|
||||
(def-var! "jolt.ffi" "null?" (lambda (p) (if (ffi-null? p) #t #f)))
|
||||
(def-var! "jolt.ffi" "null" ffi-null)
|
||||
(def-var! "jolt.ffi" "ptr->string" ffi-ptr->string)
|
||||
(def-var! "jolt.ffi" "string->ptr" ffi-string->ptr)
|
||||
135
host/chez/java/host-class.ss
Normal file
135
host/chez/java/host-class.ss
Normal file
|
|
@ -0,0 +1,135 @@
|
|||
;; host class tokens — a bare class name (String, Keyword, File...)
|
||||
;; evaluates to its JVM canonical-name STRING, the same value (class instance)
|
||||
;; returns, so (= String (class "x")) holds and a (defmethod m String ...) keys
|
||||
;; against a (class …) dispatch (ring.util.request does this).
|
||||
;; The analyzer resolves these names to clojure.core vars, so the back end emits
|
||||
;; (var-deref "clojure.core" "String") — def-var!'ing the canonical strings here is
|
||||
;; all that's needed at runtime.
|
||||
;;
|
||||
;; Loaded after natives-meta.ss (jolt-type) + the printer (jolt-str-render-one).
|
||||
|
||||
;; (class x) — Clojure's class of a value. Scalars map to their JVM class name,
|
||||
;; matching core-class. Collections/seqs have no JVM class on this host;
|
||||
;; (str (type x)) is the clean host taxonomy and
|
||||
;; is never compared against a class token in the corpus. Records yield their
|
||||
;; ns-qualified class name (= (str (type x))). Total — never crashes.
|
||||
;; A host shim (bigdec, queue, host-table) registers its type's class name via
|
||||
;; register-class-arm! instead of set!-wrapping jolt-class (cf. register-hash-arm!).
|
||||
;; The entry is stable, so the var cell bound below stays current as arms register.
|
||||
(define jolt-class-arms '())
|
||||
(define (register-class-arm! pred handler)
|
||||
(set! jolt-class-arms (cons (cons pred handler) jolt-class-arms)))
|
||||
(define (jolt-class-base x)
|
||||
(cond
|
||||
((jolt-nil? x) jolt-nil)
|
||||
((boolean? x) "java.lang.Boolean")
|
||||
;; per-type number classes, like the JVM: integer -> Long, flonum -> Double,
|
||||
;; exact non-integer -> Ratio.
|
||||
((and (number? x) (flonum? x)) "java.lang.Double")
|
||||
((and (number? x) (exact? x) (integer? x)) "java.lang.Long")
|
||||
((and (number? x) (exact? x) (rational? x)) "clojure.lang.Ratio")
|
||||
((number? x) "java.lang.Number")
|
||||
((string? x) "java.lang.String")
|
||||
((keyword? x) "clojure.lang.Keyword")
|
||||
((symbol-t? x) "clojure.lang.Symbol")
|
||||
((jolt-atom? x) "clojure.lang.Atom")
|
||||
((char? x) "java.lang.Character")
|
||||
((regex-t? x) "java.util.regex.Pattern")
|
||||
((procedure? x) "clojure.lang.IFn")
|
||||
;; an exception value (ex-info / host-constructed throwable) reports its JVM
|
||||
;; class, so (= clojure.lang.ExceptionInfo (class e)) and clojure.test's
|
||||
;; (thrown? Class …) match (records.ss ex-info-map?/ex-info-class).
|
||||
((ex-info-map? x) (ex-info-class x))
|
||||
(else (jolt-str-render-one (jolt-type x)))))
|
||||
;; the class NAME of x (string), or nil for nil. (class x) wraps it in a Class
|
||||
;; value (make-class-obj, host-static-classes.ss) so it renders like a JVM Class
|
||||
;; while staying = its name string.
|
||||
(define (jolt-class-name x)
|
||||
(let loop ((as jolt-class-arms))
|
||||
(cond ((null? as) (jolt-class-base x))
|
||||
(((caar as) x) ((cdar as) x))
|
||||
(else (loop (cdr as))))))
|
||||
(define (jolt-class x)
|
||||
(let ((n (jolt-class-name x)))
|
||||
(if (jolt-nil? n) jolt-nil (make-class-obj n))))
|
||||
|
||||
(def-var! "clojure.core" "class" jolt-class)
|
||||
|
||||
;; bare class-name tokens -> canonical JVM class-name strings.
|
||||
(define class-token-alist
|
||||
'(("String" . "java.lang.String") ("Number" . "java.lang.Number")
|
||||
("Boolean" . "java.lang.Boolean") ("Long" . "java.lang.Long")
|
||||
("Integer" . "java.lang.Integer") ("Double" . "java.lang.Double")
|
||||
("Object" . "java.lang.Object") ("Character" . "java.lang.Character")
|
||||
("InputStream" . "java.io.InputStream") ("OutputStream" . "java.io.OutputStream")
|
||||
("File" . "java.io.File") ("Reader" . "java.io.Reader") ("Writer" . "java.io.Writer")
|
||||
("ISeq" . "clojure.lang.ISeq") ("Keyword" . "clojure.lang.Keyword")
|
||||
("Symbol" . "clojure.lang.Symbol") ("MapEntry" . "clojure.lang.MapEntry")
|
||||
("StringReader" . "java.io.StringReader") ("StringWriter" . "java.io.StringWriter")
|
||||
("StringBuilder" . "java.lang.StringBuilder")
|
||||
("StringTokenizer" . "java.util.StringTokenizer")
|
||||
("Charset" . "java.nio.charset.Charset") ("Base64" . "java.util.Base64")
|
||||
("Exception" . "java.lang.Exception")
|
||||
("IllegalArgumentException" . "java.lang.IllegalArgumentException")
|
||||
("IllegalStateException" . "java.lang.IllegalStateException")
|
||||
("RuntimeException" . "java.lang.RuntimeException")
|
||||
("UnsupportedOperationException" . "java.lang.UnsupportedOperationException")
|
||||
("InterruptedException" . "java.lang.InterruptedException")
|
||||
("IOException" . "java.io.IOException")
|
||||
("UnknownHostException" . "java.net.UnknownHostException")
|
||||
("ConnectException" . "java.net.ConnectException")
|
||||
("SocketTimeoutException" . "java.net.SocketTimeoutException")
|
||||
("MalformedURLException" . "java.net.MalformedURLException")
|
||||
("SSLException" . "javax.net.ssl.SSLException")
|
||||
("ExceptionInfo" . "clojure.lang.ExceptionInfo")
|
||||
("IExceptionInfo" . "clojure.lang.IExceptionInfo")
|
||||
("Pattern" . "java.util.regex.Pattern")
|
||||
("URI" . "java.net.URI") ("UUID" . "java.util.UUID")
|
||||
("ArrayList" . "java.util.ArrayList") ("PersistentQueue" . "clojure.lang.PersistentQueue")
|
||||
("NumberFormatException" . "java.lang.NumberFormatException")
|
||||
("ArithmeticException" . "java.lang.ArithmeticException")
|
||||
("NullPointerException" . "java.lang.NullPointerException")
|
||||
("ClassCastException" . "java.lang.ClassCastException")
|
||||
("IndexOutOfBoundsException" . "java.lang.IndexOutOfBoundsException")
|
||||
("UnsupportedEncodingException" . "java.io.UnsupportedEncodingException")
|
||||
("FileNotFoundException" . "java.io.FileNotFoundException")
|
||||
("Throwable" . "java.lang.Throwable")))
|
||||
(for-each
|
||||
(lambda (pair) (def-var! "clojure.core" (car pair) (cdr pair)))
|
||||
class-token-alist)
|
||||
|
||||
;; resolve a ^Type hint symbol-name to its canonical class name at def time:
|
||||
;; "String" -> "java.lang.String", matching the JVM compiler. An
|
||||
;; already-canonical name maps to itself; an unknown name yields #f (left as-is).
|
||||
(define class-hint-table (make-hashtable string-hash string=?))
|
||||
(for-each (lambda (p) (hashtable-set! class-hint-table (car p) (cdr p))) class-token-alist)
|
||||
(for-each (lambda (p) (hashtable-set! class-hint-table (cdr p) (cdr p))) class-token-alist)
|
||||
(define (resolve-class-hint name) (hashtable-ref class-hint-table name #f))
|
||||
(def-var! "jolt.host" "resolve-class-hint" resolve-class-hint)
|
||||
|
||||
;; fully-qualified canonical class names self-evaluate to their own name string,
|
||||
;; so (= (class 1) java.lang.Long) and (instance? clojure.lang.Atom x) resolve the
|
||||
;; class token (= what jolt-class / instance-check key on).
|
||||
;; Value classes only — NOT the collection interfaces (ISeq/IPersistentMap/...),
|
||||
;; which downstream code (e.g. SCI) references as protocols/interfaces.
|
||||
(for-each
|
||||
(lambda (nm) (def-var! "clojure.core" nm nm))
|
||||
'("java.lang.Long" "java.lang.Integer" "java.lang.Double" "java.lang.Float"
|
||||
"java.lang.Number" "java.lang.String" "java.lang.Boolean" "java.lang.Character"
|
||||
"java.lang.Object"
|
||||
;; exception classes compared against (class e): (= java.net.SocketTimeoutException (class e))
|
||||
"java.lang.Exception" "java.lang.Throwable" "java.lang.RuntimeException"
|
||||
"java.lang.IllegalArgumentException" "java.lang.IllegalStateException"
|
||||
"java.lang.UnsupportedOperationException" "java.io.IOException"
|
||||
"java.net.UnknownHostException" "java.net.ConnectException"
|
||||
"java.net.SocketTimeoutException" "java.net.MalformedURLException"
|
||||
"javax.net.ssl.SSLException"
|
||||
"java.lang.NumberFormatException" "java.lang.ArithmeticException"
|
||||
"java.lang.NullPointerException" "java.lang.ClassCastException"
|
||||
"java.lang.IndexOutOfBoundsException" "java.io.FileNotFoundException"
|
||||
"java.io.UnsupportedEncodingException"
|
||||
;; clojure.lang.ExceptionInfo / IExceptionInfo compared against (class e)
|
||||
"clojure.lang.ExceptionInfo" "clojure.lang.IExceptionInfo"
|
||||
"java.util.regex.Pattern" "java.net.URI" "java.util.UUID"
|
||||
"clojure.lang.PersistentQueue"
|
||||
"clojure.lang.Keyword" "clojure.lang.Symbol" "clojure.lang.Ratio" "clojure.lang.Atom"))
|
||||
835
host/chez/java/host-static-classes.ss
Normal file
835
host/chez/java/host-static-classes.ss
Normal file
|
|
@ -0,0 +1,835 @@
|
|||
;; host-static-classes.ss — instantiable host object classes: ArrayList, HashMap,
|
||||
;; the String/Reader/Writer/Tokenizer shims, BigInteger/MapEntry ctors, and URL
|
||||
;; codecs. Holds the tagged-table method dispatch (the (.method ...) arm on a jhost)
|
||||
;; and the pluggable instance? hook. Loaded after host-static-methods.ss; the
|
||||
;; `Class/member` static methods live there, the registry core in host-static.ss.
|
||||
|
||||
;; ---- java.util.ArrayList ----------------------------------------------------
|
||||
;; A mutable list backed by a growable Scheme vector. State is #(backing count);
|
||||
;; .add amortizes O(1) and .get is O(1) (a list backing made both O(n)). medley's
|
||||
;; stateful transducers (window / partition-between) build one with .add / .size /
|
||||
;; .toArray / .clear / .remove. (ArrayList.) | (ArrayList. n) | (ArrayList. coll).
|
||||
(define al-min-cap 8)
|
||||
(define (al-vec self) (vector-ref (jhost-state self) 0))
|
||||
(define (al-cnt self) (vector-ref (jhost-state self) 1))
|
||||
(define (al-cnt! self n) (vector-set! (jhost-state self) 1 n))
|
||||
(define (make-arraylist xs) ; xs: a Scheme list of initial elements
|
||||
(let* ((n (length xs)) (cap (fxmax al-min-cap n)) (v (make-vector cap jolt-nil)))
|
||||
(let loop ((i 0) (xs xs)) (when (pair? xs) (vector-set! v i (car xs)) (loop (fx+ i 1) (cdr xs))))
|
||||
(make-jhost "arraylist" (vector v n))))
|
||||
(define (al-ensure! self need) ; grow the backing vector (doubling) to fit `need`
|
||||
(let ((v (al-vec self)))
|
||||
(when (fx>? need (vector-length v))
|
||||
(let grow ((cap (fxmax al-min-cap (vector-length v))))
|
||||
(if (fx<? cap need) (grow (fx* cap 2))
|
||||
(let ((nv (make-vector cap jolt-nil)))
|
||||
(let cp ((i 0)) (when (fx<? i (al-cnt self)) (vector-set! nv i (vector-ref v i)) (cp (fx+ i 1))))
|
||||
(vector-set! (jhost-state self) 0 nv)))))))
|
||||
(define (al-push! self x)
|
||||
(let ((n (al-cnt self))) (al-ensure! self (fx+ n 1)) (vector-set! (al-vec self) n x) (al-cnt! self (fx+ n 1))))
|
||||
(define (al-insert-at! self i x)
|
||||
(let ((n (al-cnt self)))
|
||||
(al-ensure! self (fx+ n 1))
|
||||
(let ((v (al-vec self)))
|
||||
(let shift ((j n)) (when (fx>? j i) (vector-set! v j (vector-ref v (fx- j 1))) (shift (fx- j 1))))
|
||||
(vector-set! v i x) (al-cnt! self (fx+ n 1)))))
|
||||
(define (al-remove-at! self i)
|
||||
(let ((n (al-cnt self)) (v (al-vec self)))
|
||||
(let shift ((j i)) (when (fx<? j (fx- n 1)) (vector-set! v j (vector-ref v (fx+ j 1))) (shift (fx+ j 1))))
|
||||
(vector-set! v (fx- n 1) jolt-nil) (al-cnt! self (fx- n 1))))
|
||||
(define (al->list self) ; first `count` elements as a Scheme list
|
||||
(let ((v (al-vec self)))
|
||||
(let loop ((i (fx- (al-cnt self) 1)) (acc '())) (if (fx<? i 0) acc (loop (fx- i 1) (cons (vector-ref v i) acc))))))
|
||||
(register-class-ctor! "ArrayList"
|
||||
(lambda args
|
||||
(cond ((null? args) (make-arraylist '()))
|
||||
((number? (car args)) (make-arraylist '())) ; initial capacity, ignored
|
||||
(else (make-arraylist (seq->list (jolt-seq (car args))))))))
|
||||
(register-class-ctor! "java.util.ArrayList"
|
||||
(lambda args
|
||||
(cond ((null? args) (make-arraylist '()))
|
||||
((number? (car args)) (make-arraylist '()))
|
||||
(else (make-arraylist (seq->list (jolt-seq (car args))))))))
|
||||
(register-host-methods! "arraylist"
|
||||
(list
|
||||
(cons "add" (lambda (self . a)
|
||||
;; (.add x) -> append+true; (.add i x) -> insert at i, returns nil.
|
||||
(if (= 1 (length a))
|
||||
(begin (al-push! self (car a)) #t)
|
||||
(begin (al-insert-at! self (jnum->exact (car a)) (cadr a)) jolt-nil))))
|
||||
(cons "add!" (lambda (self x) (al-push! self x) #t))
|
||||
(cons "get" (lambda (self i) (vector-ref (al-vec self) (jnum->exact i))))
|
||||
(cons "set" (lambda (self i x)
|
||||
(let* ((idx (jnum->exact i)) (old (vector-ref (al-vec self) idx)))
|
||||
(vector-set! (al-vec self) idx x) old)))
|
||||
(cons "size" (lambda (self) (->num (al-cnt self))))
|
||||
(cons "isEmpty" (lambda (self) (fx=? 0 (al-cnt self))))
|
||||
(cons "remove" (lambda (self i)
|
||||
(let* ((idx (jnum->exact i)) (old (vector-ref (al-vec self) idx)))
|
||||
(al-remove-at! self idx) old)))
|
||||
(cons "clear" (lambda (self) (vector-set! (jhost-state self) 0 (make-vector al-min-cap jolt-nil)) (al-cnt! self 0) jolt-nil))
|
||||
(cons "contains" (lambda (self x) (and (memp (lambda (e) (jolt=2 e x)) (al->list self)) #t)))
|
||||
(cons "toArray" (lambda (self . _) (apply jolt-vector (al->list self))))
|
||||
(cons "iterator" (lambda (self) (make-jiterator (list->cseq (al->list self)))))
|
||||
(cons "toString" (lambda (self) (jolt-pr-str (list->cseq (al->list self)))))))
|
||||
|
||||
;; Appendable.append text: append(x) renders x; append(csq,start,end) appends the
|
||||
;; subsequence csq[start,end) (data.json's writer appends string runs this way).
|
||||
(define (append-text x rest)
|
||||
(if (null? rest)
|
||||
(render-piece x)
|
||||
(substring (render-piece x) (jnum->exact (car rest)) (jnum->exact (cadr rest)))))
|
||||
|
||||
(register-class-ctor! "StringBuilder"
|
||||
(lambda args (make-jhost "string-builder"
|
||||
;; a numeric first arg is a CAPACITY hint, not content.
|
||||
(vector (if (and (pair? args) (not (number? (car args)))) (render-piece (car args)) "")))))
|
||||
(register-host-methods! "string-builder"
|
||||
(list (cons "append" (lambda (self x . rest) (sb-set! self (string-append (sb-str self) (append-text x rest))) self))
|
||||
(cons "toString" (lambda (self) (sb-str self)))
|
||||
(cons "length" (lambda (self) (->num (string-length (sb-str self)))))
|
||||
(cons "charAt" (lambda (self i) (string-ref (sb-str self) (jnum->exact i))))
|
||||
(cons "setLength" (lambda (self n)
|
||||
(let ((cur (sb-str self)) (n (jnum->exact n)))
|
||||
(sb-set! self (if (< n (string-length cur))
|
||||
(substring cur 0 n)
|
||||
(string-append cur (make-string (- n (string-length cur)) #\nul)))))
|
||||
jolt-nil))))
|
||||
;; (str sb) / print a StringBuilder -> its accumulated content, like the JVM
|
||||
;; (str calls toString). Without this str renders the opaque host object.
|
||||
(register-str-render! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "string-builder"))) sb-str)
|
||||
|
||||
;; ---- StringWriter -----------------------------------------------------------
|
||||
;; Writer.write(int) writes the CHAR for that code; append(char) appends the char.
|
||||
(define (writer-piece x) (if (number? x) (string (integer->char (jnum->exact x))) (render-piece x)))
|
||||
(register-class-ctor! "StringWriter" (lambda args (make-jhost "writer" (vector ""))))
|
||||
(register-host-methods! "writer"
|
||||
(list (cons "write" (lambda (self x) (sb-set! self (string-append (sb-str self) (writer-piece x))) jolt-nil))
|
||||
(cons "append" (lambda (self x . rest) (sb-set! self (string-append (sb-str self) (append-text x rest))) self))
|
||||
(cons "flush" (lambda (self) jolt-nil))
|
||||
(cons "close" (lambda (self) jolt-nil))
|
||||
(cons "toString" (lambda (self) (sb-str self)))))
|
||||
|
||||
;; a file-backed writer (clojure.java.io/writer of a File/path): accumulates like
|
||||
;; StringWriter, then persists to the path on flush/close, so
|
||||
;; (with-open [w (io/writer "f")] (.write w …)) writes the file. State #(path buf).
|
||||
(define (fw-path self) (vector-ref (jhost-state self) 0))
|
||||
(define (fw-buf self) (vector-ref (jhost-state self) 1))
|
||||
(define (fw-append! self s) (vector-set! (jhost-state self) 1 (string-append (fw-buf self) s)))
|
||||
(define (fw-flush! self) (jolt-spit (fw-path self) (fw-buf self))) ; jolt-spit: io.ss
|
||||
(register-host-methods! "file-writer"
|
||||
(list (cons "write" (lambda (self x) (fw-append! self (writer-piece x)) jolt-nil))
|
||||
(cons "append" (lambda (self x . rest) (fw-append! self (append-text x rest)) self))
|
||||
(cons "flush" (lambda (self) (fw-flush! self) jolt-nil))
|
||||
(cons "close" (lambda (self) (fw-flush! self) jolt-nil))
|
||||
(cons "toString" (lambda (self) (fw-buf self)))))
|
||||
|
||||
;; a writer over a real Chez port — the values *out* / *err* hold. write/append
|
||||
;; push to the port (so (.write *out* s) and (binding [*out* *err*] …) work);
|
||||
;; it isn't a buffer, so toString is empty. Lets libraries that touch *out*/*err*
|
||||
;; (tools.logging, selmer) compile and run.
|
||||
(register-host-methods! "port-writer"
|
||||
(list (cons "write" (lambda (self x) (display (writer-piece x) (vector-ref (jhost-state self) 0)) jolt-nil))
|
||||
(cons "append" (lambda (self x . rest) (display (append-text x rest) (vector-ref (jhost-state self) 0)) self))
|
||||
(cons "flush" (lambda (self) (flush-output-port (vector-ref (jhost-state self) 0)) jolt-nil))
|
||||
(cons "close" (lambda (self) jolt-nil))
|
||||
(cons "toString" (lambda (self) ""))))
|
||||
(def-var! "clojure.core" "*out*" (make-jhost "port-writer" (vector (current-output-port))))
|
||||
(def-var! "clojure.core" "*err*" (make-jhost "port-writer" (vector (current-error-port))))
|
||||
|
||||
;; PrintWriter — a thin wrapper over a target writer. write/append/print forward
|
||||
;; the rendered text to the target. clojure.data.json's pretty printer builds
|
||||
;; (PrintWriter. *out*) where *out* is bound to clojure.pprint's pretty-writer (a
|
||||
;; jolt record), so forwarding routes column-aware through clojure.pprint/-write;
|
||||
;; for a host writer target it falls back to that writer's own write.
|
||||
(define (pw-forward target s)
|
||||
(cond
|
||||
((and (jhost? target) (string=? (jhost-tag target) "port-writer"))
|
||||
(display s (vector-ref (jhost-state target) 0)))
|
||||
((and (jhost? target) (memv #t (list (string=? (jhost-tag target) "writer")
|
||||
(string=? (jhost-tag target) "string-builder"))))
|
||||
(sb-set! target (string-append (sb-str target) s)))
|
||||
(else
|
||||
(jolt-invoke (var-deref "clojure.pprint" "-write") target s))))
|
||||
(register-class-ctor! "PrintWriter"
|
||||
(lambda args (make-jhost "print-writer" (vector (if (pair? args) (car args) jolt-nil)))))
|
||||
(register-class-ctor! "java.io.PrintWriter"
|
||||
(lambda args (make-jhost "print-writer" (vector (if (pair? args) (car args) jolt-nil)))))
|
||||
(register-host-methods! "print-writer"
|
||||
(list (cons "write" (lambda (self x . rest) (pw-forward (vector-ref (jhost-state self) 0) (append-text x rest)) jolt-nil))
|
||||
(cons "print" (lambda (self x) (pw-forward (vector-ref (jhost-state self) 0) (render-piece x)) jolt-nil))
|
||||
(cons "append" (lambda (self x . rest) (pw-forward (vector-ref (jhost-state self) 0) (append-text x rest)) self))
|
||||
(cons "flush" (lambda (self) jolt-nil))
|
||||
(cons "close" (lambda (self) jolt-nil))
|
||||
(cons "toString" (lambda (self) ""))))
|
||||
|
||||
;; ---- java.util.HashMap ------------------------------------------------------
|
||||
;; A mutable map keyed by jolt values (jolt-hash / jolt=2). State #(chez-hashtable).
|
||||
;; Constructors: () | (capacity) | (capacity load-factor) [sizing args ignored] |
|
||||
;; (Map m) [copy]. Enough of the Map surface for libraries that build a fast lookup
|
||||
;; (malli's fast-registry: (doto (HashMap. 1024 0.25) (.putAll m)) then .get).
|
||||
(define (hm-hash k) (let ((h (jolt-hash k)))
|
||||
(bitwise-and (if (and (integer? h) (exact? h)) (abs h) 0) #x3FFFFFFF)))
|
||||
(define (hm-tbl self) (vector-ref (jhost-state self) 0))
|
||||
(define (hm-hashmap? x) (and (jhost? x) (string=? (jhost-tag x) "hashmap")))
|
||||
(define (hm-copy-into! ht src) ; src: a jolt map or another hashmap
|
||||
(if (hm-hashmap? src)
|
||||
(vector-for-each (lambda (k) (hashtable-set! ht k (hashtable-ref (hm-tbl src) k jolt-nil)))
|
||||
(hashtable-keys (hm-tbl src)))
|
||||
(for-each (lambda (e) (hashtable-set! ht (jolt-nth e 0) (jolt-nth e 1)))
|
||||
(seq->list (jolt-seq src)))))
|
||||
(register-class-ctor! "HashMap"
|
||||
(lambda args
|
||||
(let ((ht (make-hashtable hm-hash jolt=2)))
|
||||
(when (and (pair? args) (or (pmap? (car args)) (hm-hashmap? (car args))))
|
||||
(hm-copy-into! ht (car args)))
|
||||
(make-jhost "hashmap" (vector ht)))))
|
||||
(define (hm->pmap self)
|
||||
(let ((m (jolt-hash-map)))
|
||||
(vector-for-each (lambda (k) (set! m (jolt-assoc m k (hashtable-ref (hm-tbl self) k jolt-nil))))
|
||||
(hashtable-keys (hm-tbl self)))
|
||||
m))
|
||||
(register-host-methods! "hashmap"
|
||||
(list (cons "put" (lambda (self k v) (let ((old (hashtable-ref (hm-tbl self) k jolt-nil)))
|
||||
(hashtable-set! (hm-tbl self) k v) old)))
|
||||
(cons "get" (lambda (self k) (hashtable-ref (hm-tbl self) k jolt-nil)))
|
||||
(cons "getOrDefault" (lambda (self k d) (hashtable-ref (hm-tbl self) k d)))
|
||||
(cons "containsKey" (lambda (self k) (if (hashtable-contains? (hm-tbl self) k) #t #f)))
|
||||
(cons "containsValue" (lambda (self v)
|
||||
(let ((found #f))
|
||||
(vector-for-each (lambda (k) (when (jolt=2 v (hashtable-ref (hm-tbl self) k jolt-nil)) (set! found #t)))
|
||||
(hashtable-keys (hm-tbl self))) found)))
|
||||
(cons "size" (lambda (self) (hashtable-size (hm-tbl self))))
|
||||
(cons "isEmpty" (lambda (self) (= 0 (hashtable-size (hm-tbl self)))))
|
||||
(cons "remove" (lambda (self k) (let ((old (hashtable-ref (hm-tbl self) k jolt-nil)))
|
||||
(hashtable-delete! (hm-tbl self) k) old)))
|
||||
(cons "clear" (lambda (self) (hashtable-clear! (hm-tbl self)) jolt-nil))
|
||||
(cons "putAll" (lambda (self m) (hm-copy-into! (hm-tbl self) m) jolt-nil))
|
||||
(cons "keySet" (lambda (self) (apply jolt-hash-set (vector->list (hashtable-keys (hm-tbl self))))))
|
||||
(cons "values" (lambda (self) (apply jolt-vector
|
||||
(map (lambda (k) (hashtable-ref (hm-tbl self) k jolt-nil))
|
||||
(vector->list (hashtable-keys (hm-tbl self)))))))
|
||||
(cons "entrySet" (lambda (self) (jolt-seq (hm->pmap self))))
|
||||
(cons "toString" (lambda (self) (jolt-pr-str (hm->pmap self))))))
|
||||
;; java.util.concurrent.ConcurrentHashMap — one shared heap, so the mutable
|
||||
;; HashMap shim serves. (get a-hashmap k) reads the map (clojure.core/get).
|
||||
(define (make-hashmap-jhost . args)
|
||||
(let ((ht (make-hashtable hm-hash jolt=2)))
|
||||
(when (and (pair? args) (or (pmap? (car args)) (hm-hashmap? (car args)))) (hm-copy-into! ht (car args)))
|
||||
(make-jhost "hashmap" (vector ht))))
|
||||
(register-class-ctor! "ConcurrentHashMap" make-hashmap-jhost)
|
||||
(register-class-ctor! "java.util.concurrent.ConcurrentHashMap" make-hashmap-jhost)
|
||||
(register-get-arm! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "hashmap")))
|
||||
(lambda (coll k d) (hashtable-ref (hm-tbl coll) k d)))
|
||||
;; count / contains? over the mutable map shim (clojure.core/count + contains?,
|
||||
;; which core.cache's SoftCache uses on its backing ConcurrentHashMap).
|
||||
(define (jhost-hashmap? x) (and (jhost? x) (string=? (jhost-tag x) "hashmap")))
|
||||
(let ((prev-count jolt-count) (prev-contains jolt-contains?))
|
||||
(set! jolt-count (lambda (c) (if (jhost-hashmap? c) (hashtable-size (hm-tbl c)) (prev-count c))))
|
||||
(set! jolt-contains? (lambda (c k) (if (jhost-hashmap? c)
|
||||
(if (hashtable-contains? (hm-tbl c) k) #t #f)
|
||||
(prev-contains c k)))))
|
||||
|
||||
;; ---- java.lang.ref.Soft/WeakReference + ReferenceQueue ----------------------
|
||||
;; Real GC reclamation via Chez's generational collector: the referent is held
|
||||
;; through a weak pair (collected once otherwise unreachable, leaving the bwp
|
||||
;; object), and a guardian registered on the referent makes the reference itself
|
||||
;; available the moment its referent is reclaimed — which the ReferenceQueue
|
||||
;; surfaces as enqueued, exactly like the JVM. (Chez has no softer-than-weak
|
||||
;; reference, so a SoftReference clears on unreachability rather than under memory
|
||||
;; pressure — its SoftCache evicts more eagerly than the JVM's, but it is genuine
|
||||
;; GC eviction, not an unbounded strong cache. Immediates like fixnums/keywords
|
||||
;; are never collected.)
|
||||
;; ref-queue state: #(guardian pending-list); reference state: #(weak-pair queue enqueued?).
|
||||
(define (rq-guardian-of q) (vector-ref (jhost-state q) 0))
|
||||
(define (rq-add! q ref)
|
||||
(let ((st (jhost-state q))) (vector-set! st 1 (append (vector-ref st 1) (list ref)))))
|
||||
(define (rq-pump! q) ; drain GC-reclaimed refs onto the list
|
||||
(let loop ()
|
||||
(let ((rep ((rq-guardian-of q)))) (when rep (rq-add! q rep) (loop)))))
|
||||
(define (rq-poll q)
|
||||
(rq-pump! q)
|
||||
(let* ((st (jhost-state q)) (l (vector-ref st 1)))
|
||||
(if (null? l) jolt-nil (begin (vector-set! st 1 (cdr l)) (car l)))))
|
||||
(define (a-ref-queue? x) (and (jhost? x) (string=? (jhost-tag x) "ref-queue")))
|
||||
(define (make-reference v rest)
|
||||
(let* ((rq (if (pair? rest) (car rest) jolt-nil))
|
||||
(ref (make-jhost "weak-ref" (vector (weak-cons v #f) rq #f))))
|
||||
(when (a-ref-queue? rq) ((rq-guardian-of rq) v ref)) ; fire on the referent's collection
|
||||
ref))
|
||||
(for-each (lambda (nm) (register-class-ctor! nm (lambda (v . rest) (make-reference v rest))))
|
||||
'("SoftReference" "java.lang.ref.SoftReference" "WeakReference" "java.lang.ref.WeakReference"))
|
||||
(register-host-methods! "weak-ref"
|
||||
(list (cons "get" (lambda (self) (let ((r (car (vector-ref (jhost-state self) 0))))
|
||||
(if (bwp-object? r) jolt-nil r))))
|
||||
(cons "clear" (lambda (self) (set-car! (vector-ref (jhost-state self) 0) jolt-nil) jolt-nil))
|
||||
(cons "isEnqueued" (lambda (self) (vector-ref (jhost-state self) 2)))
|
||||
(cons "enqueue" (lambda (self)
|
||||
(let* ((st (jhost-state self)) (rq (vector-ref st 1)))
|
||||
(if (vector-ref st 2) #f
|
||||
(begin (vector-set! st 2 #t) (when (a-ref-queue? rq) (rq-add! rq self)) #t)))))))
|
||||
(for-each (lambda (nm) (register-class-ctor! nm (lambda _ (make-jhost "ref-queue" (vector (make-guardian) '())))))
|
||||
'("ReferenceQueue" "java.lang.ref.ReferenceQueue"))
|
||||
(register-host-methods! "ref-queue"
|
||||
(list (cons "poll" (lambda (self . _) (rq-poll self)))
|
||||
(cons "remove" (lambda (self . _) (rq-poll self)))))
|
||||
|
||||
;; ---- StringReader -----------------------------------------------------------
|
||||
;; state: a vector #(string pos marked).
|
||||
(register-class-ctor! "StringReader"
|
||||
;; src is a String or a char[] ((StringReader. (char-array s)) — selmer's parser
|
||||
;; reads templates this way); a char-array becomes the string of its chars.
|
||||
(lambda (src . _)
|
||||
(make-jhost "string-reader"
|
||||
(vector (cond ((string? src) src)
|
||||
((jolt-array? src) (apply string-append (map jolt-str-render-one (seq->list (jolt-seq src)))))
|
||||
(else (jolt-str-render-one src)))
|
||||
0 0))))
|
||||
(define (sr-s self) (vector-ref (jhost-state self) 0))
|
||||
(define (sr-pos self) (vector-ref (jhost-state self) 1))
|
||||
(define (sr-pos! self p) (vector-set! (jhost-state self) 1 p))
|
||||
(register-host-methods! "string-reader"
|
||||
(list (cons "read" (lambda (self . rest)
|
||||
(let ((s (sr-s self)) (p (sr-pos self)))
|
||||
(cond
|
||||
;; .read() -> one char code, -1 at EOF
|
||||
((null? rest)
|
||||
(if (>= p (string-length s)) -1
|
||||
(begin (sr-pos! self (+ p 1)) (->num (char->integer (string-ref s p))))))
|
||||
;; .read(cbuf, off, len) -> fill cbuf, return count or -1 at EOF
|
||||
(else
|
||||
(let ((slen (string-length s)))
|
||||
(if (>= p slen) -1
|
||||
(let ((cbuf (car rest)) (off (jnum->exact (cadr rest))) (len (jnum->exact (caddr rest))))
|
||||
(let ((n (min len (- slen p))) (dv (jolt-array-vec cbuf)))
|
||||
(let loop ((i 0)) (when (< i n) (vector-set! dv (+ off i) (string-ref s (+ p i))) (loop (+ i 1))))
|
||||
(sr-pos! self (+ p n)) (->num n))))))))))
|
||||
(cons "mark" (lambda (self . _) (vector-set! (jhost-state self) 2 (sr-pos self)) jolt-nil))
|
||||
(cons "reset" (lambda (self) (sr-pos! self (vector-ref (jhost-state self) 2)) jolt-nil))
|
||||
(cons "skip" (lambda (self n) (let ((n (jnum->exact n)))
|
||||
(sr-pos! self (min (string-length (sr-s self)) (+ (sr-pos self) n))) (->num n))))
|
||||
;; readLine: the next line without its terminator (\n or \r\n), nil at EOF —
|
||||
;; what line-seq drives over a BufferedReader.
|
||||
(cons "readLine"
|
||||
(lambda (self)
|
||||
(let ((s (sr-s self)) (p (sr-pos self)) (len (string-length (sr-s self))))
|
||||
(if (>= p len) jolt-nil
|
||||
(let scan ((i p))
|
||||
(cond
|
||||
((>= i len) (sr-pos! self len) (substring s p len))
|
||||
((char=? (string-ref s i) #\newline)
|
||||
(sr-pos! self (+ i 1))
|
||||
(substring s p (if (and (> i p) (char=? (string-ref s (- i 1)) #\return)) (- i 1) i)))
|
||||
(else (scan (+ i 1)))))))))
|
||||
(cons "close" (lambda (self) jolt-nil))))
|
||||
|
||||
;; ---- PushbackReader ---------------------------------------------------------
|
||||
;; state: a vector #(wrapped-reader pushed-list)
|
||||
(register-class-ctor! "PushbackReader"
|
||||
(lambda (rdr . _) (make-jhost "pushback-reader" (vector rdr '()))))
|
||||
;; LineNumberingPushbackReader: a pushback-reader (jolt doesn't track line
|
||||
;; numbers; getLineNumber is a stub for error-reporting paths that read it).
|
||||
(register-class-ctor! "LineNumberingPushbackReader"
|
||||
(lambda (rdr . _) (make-jhost "pushback-reader" (vector rdr '()))))
|
||||
(register-class-ctor! "clojure.lang.LineNumberingPushbackReader"
|
||||
(lambda (rdr . _) (make-jhost "pushback-reader" (vector rdr '()))))
|
||||
(define (read-unit r) ; read one code unit (flonum) from any reader, -1 at EOF
|
||||
(record-method-dispatch r "read" jolt-nil))
|
||||
(register-host-methods! "pushback-reader"
|
||||
(list (cons "read"
|
||||
(lambda (self . rest)
|
||||
(define (read1)
|
||||
(let ((pushed (vector-ref (jhost-state self) 1)))
|
||||
(if (pair? pushed)
|
||||
(begin (vector-set! (jhost-state self) 1 (cdr pushed)) (car pushed))
|
||||
(read-unit (vector-ref (jhost-state self) 0)))))
|
||||
(if (null? rest)
|
||||
(read1)
|
||||
;; .read(cbuf, off, len) -> read one code unit at a time into cbuf,
|
||||
;; return count or -1 at immediate EOF.
|
||||
(let ((off (jnum->exact (cadr rest))) (len (jnum->exact (caddr rest))) (dv (jolt-array-vec (car rest))))
|
||||
(let loop ((i 0))
|
||||
(if (>= i len) (->num i)
|
||||
(let ((c (jnum->exact (read1))))
|
||||
(if (= c -1) (if (= i 0) -1 (->num i))
|
||||
(begin (vector-set! dv (+ off i) (integer->char c)) (loop (+ i 1)))))))))))
|
||||
(cons "unread"
|
||||
(lambda (self ch . rest)
|
||||
(if (null? rest)
|
||||
;; unread(int|char) — push one code unit back
|
||||
(vector-set! (jhost-state self) 1
|
||||
(cons (if (char? ch) (->num (char->integer ch)) ch) (vector-ref (jhost-state self) 1)))
|
||||
;; unread(char[] cbuf, off, len) — push cbuf[off,off+len) so cbuf[off]
|
||||
;; reads back first (the list head).
|
||||
(let ((dv (jolt-array-vec ch)) (off (jnum->exact (car rest))) (len (jnum->exact (cadr rest))))
|
||||
(let loop ((i (- (+ off len) 1)) (acc (vector-ref (jhost-state self) 1)))
|
||||
(if (< i off)
|
||||
(vector-set! (jhost-state self) 1 acc)
|
||||
(loop (- i 1) (cons (->num (char->integer (vector-ref dv i))) acc))))))
|
||||
jolt-nil))
|
||||
(cons "close" (lambda (self) jolt-nil))
|
||||
(cons "getLineNumber" (lambda (self) 0))))
|
||||
|
||||
;; ---- StringTokenizer --------------------------------------------------------
|
||||
;; state: a vector #(tokens-list pos)
|
||||
(define (tokenize s delims)
|
||||
(let ((dset (string->list delims)))
|
||||
(let loop ((chars (string->list s)) (cur '()) (toks '()))
|
||||
(cond ((null? chars) (reverse (if (null? cur) toks (cons (list->string (reverse cur)) toks))))
|
||||
((memv (car chars) dset)
|
||||
(loop (cdr chars) '() (if (null? cur) toks (cons (list->string (reverse cur)) toks))))
|
||||
(else (loop (cdr chars) (cons (car chars) cur) toks))))))
|
||||
(register-class-ctor! "StringTokenizer"
|
||||
(lambda (s . delims) (make-jhost "string-tokenizer"
|
||||
(vector (tokenize (if (string? s) s (jolt-str-render-one s))
|
||||
(if (null? delims) " \t\n\r\f" (car delims))) 0))))
|
||||
(register-host-methods! "string-tokenizer"
|
||||
(list (cons "hasMoreTokens" (lambda (self) (< (vector-ref (jhost-state self) 1) (length (vector-ref (jhost-state self) 0)))))
|
||||
(cons "countTokens" (lambda (self) (->num (- (length (vector-ref (jhost-state self) 0)) (vector-ref (jhost-state self) 1)))))
|
||||
(cons "nextToken" (lambda (self)
|
||||
(let ((toks (vector-ref (jhost-state self) 0)) (p (vector-ref (jhost-state self) 1)))
|
||||
(if (< p (length toks))
|
||||
(begin (vector-set! (jhost-state self) 1 (+ p 1)) (list-ref toks p))
|
||||
(error #f "NoSuchElementException")))))))
|
||||
|
||||
;; ---- String / BigInteger / MapEntry constructors ----------------------------
|
||||
;; (String. bytes [charset]) decodes bytes (a bytevector OR a jolt byte-array)
|
||||
;; with the named charset (UTF-8 default; ISO-8859-1/latin1/ascii = one byte per
|
||||
;; char); else stringify. clj-http-lite's body coercion is (String. ^[B body cs).
|
||||
(define (string-charset-name rest)
|
||||
(if (pair? rest)
|
||||
(let ((c (car rest)))
|
||||
(cond ((string? c) c)
|
||||
((and (jhost? c) (string=? (jhost-tag c) "charset"))
|
||||
(let ((p (assq 'name (jhost-state c)))) (if p (jolt-str-render-one (cdr p)) "UTF-8")))
|
||||
(else "UTF-8")))
|
||||
"UTF-8"))
|
||||
(define (decode-bytevector bv rest)
|
||||
(let ((cs (ascii-string-down (string-charset-name rest))))
|
||||
(cond
|
||||
((or (string=? cs "utf-8") (string=? cs "utf8")) (utf8->string bv))
|
||||
((or (string=? cs "iso-8859-1") (string=? cs "latin1") (string=? cs "iso8859-1")
|
||||
(string=? cs "us-ascii") (string=? cs "ascii"))
|
||||
(list->string (map integer->char (bytevector->u8-list bv))))
|
||||
((or (string=? cs "utf-16") (string=? cs "utf16") (string=? cs "utf-16be") (string=? cs "unicode"))
|
||||
(utf16->string bv (endianness big))) ; respects a leading BOM
|
||||
((string=? cs "utf-16le") (utf16->string bv (endianness little)))
|
||||
((or (string=? cs "utf-32") (string=? cs "utf32") (string=? cs "utf-32be"))
|
||||
(utf32->string bv (endianness big)))
|
||||
((string=? cs "utf-32le") (utf32->string bv (endianness little)))
|
||||
(else (guard (e (#t (list->string (map integer->char (bytevector->u8-list bv))))) (utf8->string bv))))))
|
||||
(register-class-ctor! "String"
|
||||
(lambda (x . rest)
|
||||
(cond ((bytevector? x) (decode-bytevector x rest))
|
||||
((and (jolt-array? x) (eq? (jolt-array-kind x) 'byte)) (decode-bytevector (na-bytearray->bv x) rest))
|
||||
;; (String. char[] [offset count]) — the whole array or a slice. Buffered
|
||||
;; readers (data.json) build a string from a fill buffer this way.
|
||||
((and (jolt-array? x) (eq? (jolt-array-kind x) 'char))
|
||||
(let ((v (jolt-array-vec x)))
|
||||
(if (pair? rest)
|
||||
(let* ((off (jnum->exact (car rest))) (cnt (jnum->exact (cadr rest))) (out (make-string cnt)))
|
||||
(let loop ((i 0)) (when (fx<? i cnt) (string-set! out i (vector-ref v (fx+ off i))) (loop (fx+ i 1))))
|
||||
out)
|
||||
(list->string (vector->list v)))))
|
||||
((string? x) x)
|
||||
(else (jolt-str-render-one x)))))
|
||||
(register-class-ctor! "BigInteger"
|
||||
(lambda (v) (parse-int-or-throw v 10 "BigInteger")))
|
||||
(register-class-ctor! "MapEntry" (lambda (k v) (make-map-entry k v)))
|
||||
;; JVM exception ctors -> a typed host throwable carrying the canonical :jolt/class
|
||||
;; (so class / instance? / getMessage / ex-message reflect the real type) and the
|
||||
;; message. Supports (E. msg), (E. msg cause), (E. cause), and (E.).
|
||||
(for-each
|
||||
(lambda (nm)
|
||||
(let ((canonical (or (resolve-class-hint nm) nm)))
|
||||
(register-class-ctor! nm
|
||||
(lambda args
|
||||
(let* ((a0 (if (pair? args) (car args) jolt-nil))
|
||||
(rest (if (pair? args) (cdr args) '()))
|
||||
(cause (if (pair? rest) (car rest) jolt-nil)))
|
||||
(cond
|
||||
((string? a0) (jolt-host-throwable canonical a0 cause))
|
||||
((jolt-nil? a0) (jolt-host-throwable canonical jolt-nil))
|
||||
;; (E. cause): a lone throwable arg is the cause, message nil.
|
||||
((and (null? rest) (ex-info-map? a0)) (jolt-host-throwable canonical jolt-nil a0))
|
||||
(else (jolt-host-throwable canonical (jolt-str-render-one a0) cause))))))))
|
||||
'("Throwable" "Exception" "RuntimeException" "IllegalArgumentException" "IllegalStateException"
|
||||
"InterruptedException" "UnsupportedOperationException" "IOException" "NumberFormatException"
|
||||
"ArithmeticException" "NullPointerException" "ClassCastException" "IndexOutOfBoundsException"
|
||||
"FileNotFoundException" "UnsupportedEncodingException" "EOFException" "java.io.EOFException"
|
||||
"Error" "AssertionError"))
|
||||
|
||||
;; ---- URLEncoder / URLDecoder (www-form-urlencoded) --------------------------
|
||||
(define (url-unreserved? b)
|
||||
(or (and (>= b 48) (<= b 57)) (and (>= b 65) (<= b 90)) (and (>= b 97) (<= b 122))
|
||||
(= b 46) (= b 42) (= b 95) (= b 45)))
|
||||
(define hex-digits "0123456789ABCDEF")
|
||||
(define (url-encode s . _)
|
||||
(let ((bs (string->utf8 (if (string? s) s (jolt-str-render-one s)))) (out '()))
|
||||
(let loop ((i 0))
|
||||
(if (= i (bytevector-length bs)) (list->string (reverse out))
|
||||
(let ((b (bytevector-u8-ref bs i)))
|
||||
(cond ((url-unreserved? b) (set! out (cons (integer->char b) out)))
|
||||
((= b 32) (set! out (cons #\+ out)))
|
||||
(else (set! out (cons (string-ref hex-digits (bitwise-and b 15))
|
||||
(cons (string-ref hex-digits (bitwise-arithmetic-shift-right b 4))
|
||||
(cons #\% out))))))
|
||||
(loop (+ i 1)))))))
|
||||
(define (hexv c)
|
||||
(cond ((and (char<=? #\0 c) (char<=? c #\9)) (- (char->integer c) 48))
|
||||
((and (char<=? #\A c) (char<=? c #\F)) (- (char->integer c) 55))
|
||||
((and (char<=? #\a c) (char<=? c #\f)) (- (char->integer c) 87))
|
||||
(else (error #f "URLDecoder: malformed escape"))))
|
||||
(define (url-decode s . _)
|
||||
(let* ((str (if (string? s) s (jolt-str-render-one s))) (n (string-length str)) (out '()))
|
||||
(let loop ((i 0))
|
||||
(if (>= i n) (utf8->string (u8-list->bytevector (reverse out)))
|
||||
(let ((c (string-ref str i)))
|
||||
(cond ((char=? c #\+) (set! out (cons 32 out)) (loop (+ i 1)))
|
||||
((char=? c #\%)
|
||||
(set! out (cons (+ (* 16 (hexv (string-ref str (+ i 1)))) (hexv (string-ref str (+ i 2)))) out))
|
||||
(loop (+ i 3)))
|
||||
(else (set! out (cons (char->integer c) out)) (loop (+ i 1)))))))))
|
||||
(define (u8-list->bytevector lst)
|
||||
(let ((bv (make-bytevector (length lst))))
|
||||
(let loop ((l lst) (i 0)) (if (null? l) bv (begin (bytevector-u8-set! bv i (car l)) (loop (cdr l) (+ i 1)))))))
|
||||
(register-class-statics! "URLEncoder" (list (cons "encode" url-encode)))
|
||||
(register-class-statics! "URLDecoder" (list (cons "decode" url-decode)))
|
||||
;; Charset/forName yields the canonical name STRING (not an opaque object) so it
|
||||
;; threads straight into (.getBytes s cs) / (String. bytes cs), which take a name.
|
||||
(register-class-statics! "Charset" (list (cons "forName" (lambda (nm) (jolt-str-render-one nm)))))
|
||||
|
||||
;; ---- Base64 (RFC 4648) ------------------------------------------------------
|
||||
(define b64-alphabet "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
|
||||
(define (->bytevector x)
|
||||
(cond ((bytevector? x) x)
|
||||
((and (jolt-array? x) (eq? (jolt-array-kind x) 'byte)) (na-bytearray->bv x))
|
||||
((string? x) (string->utf8 x))
|
||||
(else (string->utf8 (jolt-str-render-one x)))))
|
||||
(define (b64-encode x)
|
||||
(let* ((bs (->bytevector x)) (n (bytevector-length bs)) (out '()))
|
||||
(let loop ((i 0))
|
||||
(if (>= i n) (list->string (reverse out))
|
||||
(let* ((b0 (bytevector-u8-ref bs i))
|
||||
(b1 (if (< (+ i 1) n) (bytevector-u8-ref bs (+ i 1)) #f))
|
||||
(b2 (if (< (+ i 2) n) (bytevector-u8-ref bs (+ i 2)) #f)))
|
||||
(set! out (cons (string-ref b64-alphabet (bitwise-arithmetic-shift-right b0 2)) out))
|
||||
(set! out (cons (string-ref b64-alphabet (bitwise-ior (bitwise-arithmetic-shift-left (bitwise-and b0 3) 4)
|
||||
(bitwise-arithmetic-shift-right (or b1 0) 4))) out))
|
||||
(set! out (cons (if b1 (string-ref b64-alphabet (bitwise-ior (bitwise-arithmetic-shift-left (bitwise-and b1 15) 2)
|
||||
(bitwise-arithmetic-shift-right (or b2 0) 6))) #\=) out))
|
||||
(set! out (cons (if b2 (string-ref b64-alphabet (bitwise-and b2 63)) #\=) out))
|
||||
(loop (+ i 3)))))))
|
||||
(define (b64-char-val c)
|
||||
(let loop ((i 0)) (cond ((= i 64) (error #f "Base64: illegal character")) ((char=? (string-ref b64-alphabet i) c) i) (else (loop (+ i 1))))))
|
||||
(define (b64-decode x)
|
||||
(let* ((str (let ((s (if (string? x) x (utf8->string (->bytevector x)))))
|
||||
(list->string (filter (lambda (c) (not (char=? c #\=))) (string->list s)))))
|
||||
(out '()) (acc 0) (bits 0))
|
||||
(for-each (lambda (c)
|
||||
(set! acc (bitwise-ior (bitwise-arithmetic-shift-left acc 6) (b64-char-val c)))
|
||||
(set! bits (+ bits 6))
|
||||
(when (>= bits 8)
|
||||
(set! bits (- bits 8))
|
||||
(set! out (cons (bitwise-and (bitwise-arithmetic-shift-right acc bits) 255) out))))
|
||||
(string->list str))
|
||||
(u8-list->bytevector (reverse out))))
|
||||
(register-host-methods! "b64-encoder"
|
||||
(list (cons "encode" (lambda (self bs) (string->utf8 (b64-encode bs))))
|
||||
(cons "encodeToString" (lambda (self bs) (b64-encode bs)))))
|
||||
(register-host-methods! "b64-decoder"
|
||||
(list (cons "decode" (lambda (self s) (b64-decode s)))))
|
||||
(register-class-statics! "Base64"
|
||||
(list (cons "getEncoder" (lambda () (make-jhost "b64-encoder" '())))
|
||||
(cons "getDecoder" (lambda () (make-jhost "b64-decoder" '())))))
|
||||
|
||||
;; ---- java.util.regex.Pattern ------------------------------------------------
|
||||
;; Pattern/compile returns a jolt-regex value (regex-t), so str/replace, re-find,
|
||||
;; .split etc. accept it transparently.
|
||||
(define pattern-multiline 8.0)
|
||||
(define (pattern-quote s)
|
||||
(let ((meta "\\.[]{}()*+-?^$|&") (s (if (string? s) s (jolt-str-render-one s))) (out '()))
|
||||
(let loop ((i 0))
|
||||
(if (= i (string-length s)) (list->string (reverse out))
|
||||
(let ((c (string-ref s i)))
|
||||
(when (memv c (string->list meta)) (set! out (cons #\\ out)))
|
||||
(set! out (cons c out))
|
||||
(loop (+ i 1)))))))
|
||||
(register-class-statics! "Pattern"
|
||||
(list (cons "compile" (lambda (s . flags)
|
||||
(if (and (pair? flags) (= (bitwise-and (jnum->exact (car flags)) 8) 8))
|
||||
(jolt-regex (string-append "(?m)" s))
|
||||
(jolt-regex s))))
|
||||
(cons "quote" (lambda (s) (pattern-quote s)))
|
||||
(cons "MULTILINE" pattern-multiline)))
|
||||
;; record-method-dispatch already routes string? -> jolt-string-method. Add a
|
||||
;; regex-t arm (Pattern .split / .matcher-less surface used by corpus) by wrapping
|
||||
;; once more — a regex-t isn't a jhost.
|
||||
(define %hs-rmd2 record-method-dispatch)
|
||||
(set! record-method-dispatch
|
||||
(lambda (obj method-name rest-args)
|
||||
(if (regex-t? obj)
|
||||
(let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
|
||||
(cond ((string=? method-name "split")
|
||||
;; .split returns a String[] — a seq (prints
|
||||
;; (a b c), not a vector). re-split with no limit; drop trailing
|
||||
;; empties (JVM default).
|
||||
(let ((parts (re-split (regex-t-irx obj) (car rest) #f)))
|
||||
(list->cseq (str-split-drop-trailing parts))))
|
||||
((string=? method-name "pattern") (regex-t-source obj))
|
||||
(else (error #f (string-append "No method " method-name " on Pattern")))))
|
||||
(%hs-rmd2 obj method-name rest-args))))
|
||||
|
||||
;; ---- def-var! the registry entry points so emit can also reach them ---------
|
||||
(def-var! "clojure.core" "host-static-ref" host-static-ref)
|
||||
(def-var! "clojure.core" "host-static-call" (lambda (c m . a) (apply host-static-call c m a)))
|
||||
(def-var! "clojure.core" "host-new" (lambda (c . a) (apply host-new c a)))
|
||||
|
||||
;; Clojure-visible class-registration hooks. A host shim (e.g. reitit.trie-jolt,
|
||||
;; which mirrors the reitit.Trie Java class) registers a constructor proc or a
|
||||
;; map of static members against a class token so (Class. args) / (Class/member
|
||||
;; args) resolve to it. The statics argument is a jolt map {member-name -> val}.
|
||||
(define (jmap->static-alist m)
|
||||
(let loop ((s (jolt-seq m)) (acc '()))
|
||||
(if (jolt-nil? s) acc
|
||||
(let ((e (jolt-first s)))
|
||||
(loop (jolt-seq (jolt-rest s)) (cons (cons (jolt-nth e 0) (jolt-nth e 1)) acc))))))
|
||||
(def-var! "clojure.core" "__register-class-ctor!"
|
||||
(lambda (name proc) (register-class-ctor! name proc) jolt-nil))
|
||||
(def-var! "clojure.core" "__register-class-statics!"
|
||||
(lambda (name members) (register-class-statics! name (jmap->static-alist members)) jolt-nil))
|
||||
|
||||
;; ---- tagged-table method dispatch + pluggable instance? --------------------
|
||||
;; A jolt library can build stateful host objects with (jolt.host/tagged-table
|
||||
;; tag) and dispatch (.method obj ...) to handlers registered here, keyed by the
|
||||
;; table's "jolt/type" tag — the htable analogue of the jhost method registry
|
||||
;; above. jolt-lang/http-client uses this to emulate java.net URL /
|
||||
;; HttpURLConnection / java.io byte streams so clj-http-lite runs unchanged.
|
||||
(define tagged-methods-tbl (make-hashtable string-hash string=?)) ; tag-key -> (method-ht)
|
||||
(define (tag->method-key tag)
|
||||
(if (keyword-t? tag)
|
||||
(let ((ns (keyword-t-ns tag)))
|
||||
(if (and ns (not (jolt-nil? ns))) (string-append ns "/" (keyword-t-name tag)) (keyword-t-name tag)))
|
||||
(jolt-str-render-one tag)))
|
||||
(define (register-tagged-methods! tag members)
|
||||
(let* ((key (tag->method-key tag))
|
||||
(h (or (hashtable-ref tagged-methods-tbl key #f)
|
||||
(let ((nh (make-hashtable string-hash string=?)))
|
||||
(hashtable-set! tagged-methods-tbl key nh) nh))))
|
||||
(for-each (lambda (p) (hashtable-set! h (car p) (cdr p))) members)))
|
||||
|
||||
;; htable arm: dispatch (.method obj a*) through the table's tag method registry;
|
||||
;; an unregistered method falls through (sorted colls are htables too).
|
||||
(define %hs-rmd-htable record-method-dispatch)
|
||||
(set! record-method-dispatch
|
||||
(lambda (obj method-name rest-args)
|
||||
(let ((tag (and (htable? obj) (hashtable-ref (htable-h obj) "jolt/type" #f))))
|
||||
(let* ((mh (and tag (hashtable-ref tagged-methods-tbl (tag->method-key tag) #f)))
|
||||
(f (and mh (hashtable-ref mh method-name #f))))
|
||||
(if f
|
||||
(apply f obj (if (jolt-nil? rest-args) '() (seq->list rest-args)))
|
||||
(%hs-rmd-htable obj method-name rest-args))))))
|
||||
|
||||
(def-var! "clojure.core" "__register-class-methods!"
|
||||
(lambda (tag members) (register-tagged-methods! tag (jmap->static-alist members)) jolt-nil))
|
||||
|
||||
;; Pluggable instance? — a library registers (fn [class-name-string val] -> true
|
||||
;; | false | nil); nil means "not my class, fall through". First non-nil wins.
|
||||
(define user-instance-checks '())
|
||||
(register-instance-check-arm!
|
||||
(lambda (type-sym val)
|
||||
(let ((tname (symbol-t-name type-sym)))
|
||||
(let loop ((fs user-instance-checks))
|
||||
(if (null? fs)
|
||||
'pass
|
||||
(let ((r ((car fs) tname val)))
|
||||
(if (jolt-nil? r) (loop (cdr fs)) (if (jolt-truthy? r) #t #f))))))))
|
||||
(def-var! "clojure.core" "__register-instance-check!"
|
||||
(lambda (f) (set! user-instance-checks (append user-instance-checks (list f))) jolt-nil))
|
||||
|
||||
;; (instance? clojure.lang.IFoo x) for the core clojure.lang interfaces libraries
|
||||
;; branch on — jolt's value model satisfies them, so report it. Matched by the
|
||||
;; interface's last dotted segment, so "clojure.lang.IObj" and "IObj" both hit.
|
||||
(define (hsc-last-segment s)
|
||||
(let loop ((i (- (string-length s) 1)))
|
||||
(cond ((< i 0) s)
|
||||
((char=? (string-ref s i) #\.) (substring s (+ i 1) (string-length s)))
|
||||
(else (loop (- i 1))))))
|
||||
;; values that carry metadata (mirrors jolt-with-meta's set in natives-meta.ss).
|
||||
(define (hsc-imeta? x)
|
||||
(or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x)
|
||||
(jolt-lazyseq? x) (jrec? x) (jreify? x) (procedure? x) (symbol-t? x)))
|
||||
(register-instance-check-arm!
|
||||
(lambda (type-sym val)
|
||||
(let ((iface (hsc-last-segment (symbol-t-name type-sym))))
|
||||
(let ((hit (cond
|
||||
((or (string=? iface "IObj") (string=? iface "IMeta")) (hsc-imeta? val))
|
||||
((or (string=? iface "IMapEntry") (string=? iface "MapEntry")) (jolt-map-entry? val))
|
||||
((string=? iface "IRecord") (jrec? val))
|
||||
((string=? iface "IPersistentMap") (or (pmap? val) (htable-sorted-map? val)))
|
||||
((string=? iface "IPersistentVector") (and (pvec? val) (not (jolt-map-entry? val))))
|
||||
((string=? iface "IPersistentSet") (or (pset? val) (htable-sorted-set? val)))
|
||||
((string=? iface "ISeq")
|
||||
(or (cseq? val) (empty-list-t? val) (jolt-lazyseq? val)))
|
||||
;; Seqable is anything (seq x) works on — every persistent
|
||||
;; collection, not just seqs (a vector IS Seqable, not an ISeq).
|
||||
((string=? iface "Seqable")
|
||||
(or (cseq? val) (empty-list-t? val) (jolt-lazyseq? val)
|
||||
(pvec? val) (pmap? val) (pset? val)
|
||||
(htable-sorted-map? val) (htable-sorted-set? val)))
|
||||
((string=? iface "Sequential")
|
||||
(or (pvec? val) (cseq? val) (empty-list-t? val) (jolt-lazyseq? val)))
|
||||
((string=? iface "IFn")
|
||||
(or (procedure? val) (keyword? val) (symbol-t? val)
|
||||
(pmap? val) (pset? val) (pvec? val)))
|
||||
;; host-class interfaces libraries branch on (data.json, etc.).
|
||||
;; Matched by last segment, so java.util.Map and Map both hit.
|
||||
((string=? iface "Named") (or (keyword? val) (symbol-t? val)))
|
||||
((string=? iface "CharSequence") (string? val))
|
||||
((string=? iface "Number") (number? val))
|
||||
((string=? iface "Map") (or (pmap? val) (htable-sorted-map? val)))
|
||||
((string=? iface "Set") (or (pset? val) (htable-sorted-set? val)))
|
||||
;; a Java List is a vector or a seq/list — not a set or map.
|
||||
((string=? iface "List")
|
||||
(or (and (pvec? val) (not (jolt-map-entry? val)))
|
||||
(cseq? val) (empty-list-t? val) (jolt-lazyseq? val)))
|
||||
;; a Java Collection is any of those plus a set — but NOT a map.
|
||||
((string=? iface "Collection")
|
||||
(or (pvec? val) (pset? val) (cseq? val) (empty-list-t? val)
|
||||
(jolt-lazyseq? val) (htable-sorted-set? val)))
|
||||
((string=? iface "Associative")
|
||||
(or (pmap? val) (htable-sorted-map? val)
|
||||
(and (pvec? val) (not (jolt-map-entry? val)))))
|
||||
;; ILookup (valAt): maps and vectors; Indexed (nth): vectors;
|
||||
;; Counted: the counted collections. A deftype that declares one
|
||||
;; is matched by type-satisfies? in instance-check-base.
|
||||
((string=? iface "ILookup")
|
||||
(or (pmap? val) (htable-sorted-map? val)
|
||||
(and (pvec? val) (not (jolt-map-entry? val)))))
|
||||
((string=? iface "Indexed")
|
||||
(and (pvec? val) (not (jolt-map-entry? val))))
|
||||
((string=? iface "Counted")
|
||||
(or (pmap? val) (pset? val) (pvec? val)
|
||||
(htable-sorted-map? val) (htable-sorted-set? val)))
|
||||
;; reader jhosts — data.json re-wraps a reader in a new
|
||||
;; PushbackReader unless (instance? PushbackReader r), so this
|
||||
;; must hold for repeated reads from one reader to work.
|
||||
((string=? iface "PushbackReader")
|
||||
(and (jhost? val) (string=? (jhost-tag val) "pushback-reader")))
|
||||
((string=? iface "StringReader")
|
||||
(and (jhost? val) (string=? (jhost-tag val) "string-reader")))
|
||||
((or (string=? iface "Reader") (string=? iface "BufferedReader"))
|
||||
(reader-jhost? val))
|
||||
(else 'none))))
|
||||
(if (eq? hit 'none) 'pass (if hit #t #f))))))
|
||||
|
||||
;; java.lang.Class value: (class x) / (.getClass x) return one. It renders like
|
||||
;; the JVM — str/.toString -> "class <name>", pr -> "<name>", .getName -> "<name>"
|
||||
;; — but stays = and hash equal to its name STRING, so (= (class x) String),
|
||||
;; class-keyed maps/sets, multimethod dispatch on class, and instance? all keep
|
||||
;; working against the bare class-name tokens.
|
||||
(define (make-class-obj name) (make-jhost "class" (vector name)))
|
||||
(define (jclass? x) (and (jhost? x) (string=? (jhost-tag x) "class")))
|
||||
(define (jclass-name x) (vector-ref (jhost-state x) 0))
|
||||
(define (class-key x) (cond ((jclass? x) (jclass-name x)) ((string? x) x) (else #f)))
|
||||
(register-eq-arm! (lambda (a b) (or (jclass? a) (jclass? b)))
|
||||
(lambda (a b) (let ((ka (class-key a)) (kb (class-key b)))
|
||||
(and ka kb (string=? ka kb) #t))))
|
||||
(register-hash-arm! jclass? (lambda (x) (jolt-hash (jclass-name x))))
|
||||
(register-str-render! jclass? (lambda (x) (string-append "class " (jclass-name x))))
|
||||
(register-pr-arm! jclass? (lambda (x) (jclass-name x)))
|
||||
(register-host-methods! "class"
|
||||
(list (cons "getName" (lambda (self) (jclass-name self)))
|
||||
(cons "getCanonicalName" (lambda (self) (jclass-name self)))
|
||||
(cons "getSimpleName" (lambda (self) (hsc-last-segment (jclass-name self))))
|
||||
(cons "toString" (lambda (self) (string-append "class " (jclass-name self))))
|
||||
(cons "isArray" (lambda (self) (let ((n (jclass-name self)))
|
||||
(and (fx>? (string-length n) 0) (char=? (string-ref n 0) #\[)))))
|
||||
(cons "getClass" (lambda (self) (make-class-obj "java.lang.Class")))))
|
||||
|
||||
;; (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}
|
||||
;; (ancestors (class f))). jolt models a class as its name string and has no
|
||||
;; reflection, so supers/ancestors return nothing on their own. This table gives
|
||||
;; the common interfaces the direct supers the JVM reports, and the overlay's
|
||||
;; supers/ancestors fold it in. Keyed by canonical class name; value = direct
|
||||
;; supers. Extend as more interfaces are exercised.
|
||||
(define class-supers-tbl (make-hashtable string-hash string=?))
|
||||
(define (reg-class-supers! name supers) (hashtable-set! class-supers-tbl name supers))
|
||||
(reg-class-supers! "clojure.lang.IFn" '("java.lang.Runnable" "java.util.concurrent.Callable"))
|
||||
(reg-class-supers! "clojure.lang.AFn" '("clojure.lang.IFn" "java.lang.Runnable" "java.util.concurrent.Callable"))
|
||||
(reg-class-supers! "clojure.lang.AFunction" '("clojure.lang.AFn" "clojure.lang.IFn" "clojure.lang.Fn"
|
||||
"java.lang.Runnable" "java.util.concurrent.Callable"))
|
||||
|
||||
;; transitive closure of direct supers (set semantics via an accumulator list)
|
||||
(define (class-ancestors-list name)
|
||||
(let loop ((pending (hashtable-ref class-supers-tbl name '())) (seen '()))
|
||||
(cond ((null? pending) (reverse seen))
|
||||
((member (car pending) seen) (loop (cdr pending) seen))
|
||||
(else (loop (append (hashtable-ref class-supers-tbl (car pending) '()) (cdr pending))
|
||||
(cons (car pending) seen))))))
|
||||
|
||||
;; (jolt.host/class-supers name) / (jolt.host/class-ancestors name) — a jolt seq of
|
||||
;; super / ancestor class-name strings, or nil when jolt models no hierarchy for it.
|
||||
(def-var! "jolt.host" "class-supers"
|
||||
(lambda (x)
|
||||
(let ((name (class-key x)))
|
||||
(if (and name (hashtable-contains? class-supers-tbl name))
|
||||
(list->cseq (hashtable-ref class-supers-tbl name '()))
|
||||
jolt-nil))))
|
||||
(def-var! "jolt.host" "class-ancestors"
|
||||
(lambda (x)
|
||||
(let ((name (class-key x)))
|
||||
(if name
|
||||
(let ((as (class-ancestors-list name)))
|
||||
(if (null? as) jolt-nil (list->cseq as)))
|
||||
jolt-nil))))
|
||||
311
host/chez/java/host-static-methods.ss
Normal file
311
host/chez/java/host-static-methods.ss
Normal file
|
|
@ -0,0 +1,311 @@
|
|||
;; host-static-methods.ss — the `Class/member` static surface: java.lang.Math,
|
||||
;; System (properties/env), Thread, the Long/Integer/Double/Character/String static
|
||||
;; methods, java.text.NumberFormat, and the Class registry. Registers into
|
||||
;; host-static.ss's class-statics table (loaded just before this); instantiable host
|
||||
;; object classes (ArrayList, StringBuilder, …) live in host-static-classes.ss.
|
||||
|
||||
;; ---- java.lang statics ------------------------------------------------------
|
||||
;; java.lang.Math: sqrt/pow/floor/ceil/trig/log/exp always return a DOUBLE on the
|
||||
;; JVM (Chez's sqrt/expt return EXACT for exact args, e.g. (sqrt 9) -> 3), so coerce
|
||||
;; to flonum. round -> long (exact); abs/max/min preserve the argument's type.
|
||||
(define (->dbl x) (exact->inexact x))
|
||||
(register-class-statics! "Math"
|
||||
(list (cons "sqrt" (lambda (x) (->dbl (sqrt x))))
|
||||
(cons "pow" (lambda (a b) (->dbl (expt a b))))
|
||||
(cons "floor" (lambda (x) (->dbl (floor x))))
|
||||
(cons "ceil" (lambda (x) (->dbl (ceiling x))))
|
||||
(cons "round" (lambda (x) (exact (floor (+ x 1/2))))) ; JVM round-half-up -> long
|
||||
(cons "abs" (lambda (x) (abs x)))
|
||||
(cons "sin" (lambda (x) (->dbl (sin x)))) (cons "cos" (lambda (x) (->dbl (cos x))))
|
||||
(cons "tan" (lambda (x) (->dbl (tan x)))) (cons "asin" (lambda (x) (->dbl (asin x))))
|
||||
(cons "acos" (lambda (x) (->dbl (acos x)))) (cons "atan" (lambda (x) (->dbl (atan x))))
|
||||
(cons "log" (lambda (x) (->dbl (log x)))) (cons "log10" (lambda (x) (->dbl (/ (log x) (log 10)))))
|
||||
(cons "exp" (lambda (x) (->dbl (exp x))))
|
||||
(cons "max" (lambda (a b) (if (> a b) a b))) (cons "min" (lambda (a b) (if (< a b) a b)))
|
||||
(cons "signum" (lambda (x) (cond ((< x 0) -1.0) ((> x 0) 1.0) (else 0.0))))
|
||||
(cons "PI" (->dbl (* 4 (atan 1)))) (cons "E" (->dbl (exp 1)))
|
||||
(cons "random" (lambda args (random 1.0)))))
|
||||
|
||||
;; Thread: real OS threads back futures/promises.
|
||||
;; - sleep parks the calling thread for `ms` ms (a worker sleeping doesn't block
|
||||
;; the parent).
|
||||
;; - yield hands the CPU to another runnable thread (libc sched_yield).
|
||||
;; - each thread carries an interrupt flag; interrupted (static) reads AND clears
|
||||
;; the current thread's flag, matching the JVM. currentThread / .interrupt /
|
||||
;; .isInterrupted are wired in io.ss, where the thread handle is built.
|
||||
|
||||
;; Per-thread interrupt flag, lazily allocated so each OS thread gets its own box.
|
||||
;; A thread handle (from currentThread) captures this box, so .interrupt from
|
||||
;; another thread sets the target thread's flag.
|
||||
(define thread-interrupt-box (make-thread-parameter #f))
|
||||
(define (current-interrupt-box)
|
||||
(or (thread-interrupt-box)
|
||||
(let ((b (box #f))) (thread-interrupt-box b) b)))
|
||||
(define (clear-thread-interrupt!) (set-box! (current-interrupt-box) #f))
|
||||
|
||||
;; libc sched_yield, resolved once; fall back to a zero-length park if the symbol
|
||||
;; isn't available.
|
||||
(define thread-yield!
|
||||
(let ((fp #f) (tried? #f))
|
||||
(lambda ()
|
||||
(unless tried?
|
||||
(set! tried? #t)
|
||||
(set! fp (guard (e (#t #f))
|
||||
(load-shared-object #f)
|
||||
(foreign-procedure "sched_yield" () int))))
|
||||
(if fp (fp) (sleep (make-time 'time-duration 0 0)))
|
||||
jolt-nil)))
|
||||
|
||||
(define thread-statics
|
||||
(list (cons "sleep" (lambda (ms . _)
|
||||
(let* ((ms* (exact (floor ms)))
|
||||
(secs (quotient ms* 1000))
|
||||
(nanos (* (remainder ms* 1000) 1000000)))
|
||||
(sleep (make-time 'time-duration nanos secs)))
|
||||
jolt-nil))
|
||||
(cons "yield" (lambda _ (thread-yield!)))
|
||||
(cons "interrupted" (lambda _ (let* ((b (current-interrupt-box)) (v (unbox b)))
|
||||
(set-box! b #f) (and v #t))))))
|
||||
(register-class-statics! "Thread" thread-statics)
|
||||
(register-class-statics! "java.lang.Thread" thread-statics)
|
||||
|
||||
;; clojure.lang.LockingTransaction: jolt has no STM (no refs/dosync), so a
|
||||
;; transaction is never running. isRunning -> false.
|
||||
(register-class-statics! "LockingTransaction" (list (cons "isRunning" (lambda () #f))))
|
||||
(register-class-statics! "clojure.lang.LockingTransaction" (list (cons "isRunning" (lambda () #f))))
|
||||
|
||||
;; clojure.lang.LazilyPersistentVector/createOwning: build a vector from an array
|
||||
;; (malli's -vmap fills an object-array then hands it over). jolt has no array
|
||||
;; ownership transfer, so copy the array's elements into a persistent vector.
|
||||
(define (lpv-create-owning arr) (apply jolt-vector (seq->list (jolt-seq arr))))
|
||||
(register-class-statics! "LazilyPersistentVector" (list (cons "createOwning" lpv-create-owning)))
|
||||
(register-class-statics! "clojure.lang.LazilyPersistentVector" (list (cons "createOwning" lpv-create-owning)))
|
||||
|
||||
;; clojure.lang.PersistentArrayMap/createWithCheck: build a map from a [k v k v…]
|
||||
;; array, throwing on a duplicate key. malli's eager entry parser relies on the
|
||||
;; throw to report ::duplicate-keys, so a missing class would mis-fire on every
|
||||
;; map. Build the map and signal if a key collapsed (count*2 < array length).
|
||||
(define (pam-create-with-check arr)
|
||||
(let ((items (seq->list (jolt-seq arr))))
|
||||
(let loop ((xs items) (m (jolt-hash-map)))
|
||||
(if (null? xs) m
|
||||
(if (null? (cdr xs)) (error #f "PersistentArrayMap: odd key/value count")
|
||||
(let ((k (car xs)))
|
||||
(if (jolt-contains? m k) (error #f "Duplicate key")
|
||||
(loop (cddr xs) (jolt-assoc m k (cadr xs))))))))))
|
||||
(register-class-statics! "PersistentArrayMap" (list (cons "createWithCheck" pam-create-with-check)))
|
||||
(register-class-statics! "clojure.lang.PersistentArrayMap" (list (cons "createWithCheck" pam-create-with-check)))
|
||||
|
||||
(define (now-millis)
|
||||
(let ((t (current-time 'time-utc)))
|
||||
(+ (* 1000 (time-second t)) (quotient (time-nanosecond t) 1000000))))
|
||||
|
||||
;; clojure.core/current-time-ms — epoch milliseconds; backs the `time` macro.
|
||||
(def-var! "clojure.core" "current-time-ms" (lambda () (->num (now-millis))))
|
||||
(register-class-statics! "System"
|
||||
(list (cons "currentTimeMillis" (lambda () (->num (now-millis))))
|
||||
(cons "nanoTime" (lambda () (->num (* 1000000 (now-millis)))))
|
||||
(cons "exit" (lambda args (exit (if (null? args) 0 (jnum->exact (car args))))))
|
||||
;; System/gc -> a full Chez collection (so weak references clear and their
|
||||
;; guardians fire); Runtime.gc() routes here too.
|
||||
(cons "gc" (lambda _ (collect (collect-maximum-generation)) jolt-nil))
|
||||
;; wrapped in lambdas: the helpers are defined below, resolved at call time.
|
||||
(cons "getProperty" (lambda (k . d) (apply sys-get-property k d)))
|
||||
(cons "setProperty" (lambda (k v) (sys-set-property k v)))
|
||||
(cons "clearProperty" (lambda (k) (sys-clear-property k)))
|
||||
(cons "getProperties" (lambda () (sys-properties-map)))
|
||||
(cons "getenv" (lambda k (apply sys-getenv k)))))
|
||||
|
||||
(register-class-statics! "Long"
|
||||
(list (cons "MAX_VALUE" (->num 9223372036854775807))
|
||||
(cons "MIN_VALUE" (->num -9223372036854775808))
|
||||
(cons "parseLong" (lambda (s . r) (parse-int-or-throw s (if (null? r) 10 (jnum->exact (car r))) "parseLong")))
|
||||
(cons "valueOf" (lambda (s . r) (parse-int-or-throw s (if (null? r) 10 (jnum->exact (car r))) "valueOf")))))
|
||||
|
||||
;; JVM Integer.toHexString/etc. treat the int as 32-bit unsigned.
|
||||
(define (int->u32 n) (if (< n 0) (+ n 4294967296) n))
|
||||
(register-class-statics! "Integer"
|
||||
(list (cons "MAX_VALUE" (->num 2147483647)) (cons "MIN_VALUE" (->num -2147483648))
|
||||
(cons "valueOf" (lambda (x . r)
|
||||
(if (number? x) (->num x)
|
||||
(parse-int-or-throw x (if (null? r) 10 (jnum->exact (car r))) "valueOf"))))
|
||||
(cons "parseInt" (lambda (x . r) (parse-int-or-throw x (if (null? r) 10 (jnum->exact (car r))) "parseInt")))
|
||||
;; lowercase, like the JVM; a negative int is the 32-bit unsigned form.
|
||||
(cons "toHexString" (lambda (x) (string-downcase (number->string (int->u32 (jnum->exact x)) 16))))
|
||||
(cons "toOctalString" (lambda (x) (number->string (int->u32 (jnum->exact x)) 8)))
|
||||
(cons "toBinaryString" (lambda (x) (number->string (int->u32 (jnum->exact x)) 2)))
|
||||
(cons "toString" (lambda (x . r) (number->string (jnum->exact x) (if (null? r) 10 (jnum->exact (car r))))))))
|
||||
|
||||
(register-class-statics! "Boolean"
|
||||
(list (cons "parseBoolean" (lambda (s) (string=? "true" (ascii-string-down (if (string? s) s (jolt-str-render-one s))))))
|
||||
(cons "TRUE" #t) (cons "FALSE" #f)))
|
||||
|
||||
(register-class-ctor! "Double" ->double)
|
||||
(register-class-ctor! "Float" ->double)
|
||||
(register-class-statics! "Double"
|
||||
(list (cons "parseDouble" parse-double-or-throw)
|
||||
(cons "valueOf" ->double)
|
||||
(cons "toString" (lambda (x) (jolt-str-render-one (->double x))))
|
||||
(cons "isNaN" (lambda (x) (and (flonum? x) (nan? x))))
|
||||
(cons "isInfinite" (lambda (x) (and (flonum? x) (infinite? x))))
|
||||
(cons "MAX_VALUE" 1.7976931348623157e308) (cons "MIN_VALUE" 4.9e-324)
|
||||
(cons "POSITIVE_INFINITY" +inf.0) (cons "NEGATIVE_INFINITY" -inf.0) (cons "NaN" +nan.0)))
|
||||
(register-class-statics! "Float"
|
||||
(list (cons "parseFloat" parse-double-or-throw) (cons "valueOf" ->double)))
|
||||
|
||||
;; Character: ASCII predicates (the engine is byte/ASCII oriented).
|
||||
(register-class-statics! "Character"
|
||||
(list (cons "isUpperCase" (lambda (c) (let ((n (char-code c))) (and (>= n 65) (<= n 90)))))
|
||||
(cons "isLowerCase" (lambda (c) (let ((n (char-code c))) (and (>= n 97) (<= n 122)))))
|
||||
(cons "isDigit" (lambda (c) (let ((n (char-code c))) (and (>= n 48) (<= n 57)))))
|
||||
(cons "isWhitespace" (lambda (c) (char<=? (integer->char (char-code c)) #\space)))))
|
||||
|
||||
;; String/valueOf(Object): "null" for nil, else jolt's str semantics.
|
||||
;; String/format(fmt args…) / (locale fmt args…) -> the clojure.core format engine.
|
||||
(register-class-statics! "String"
|
||||
(list (cons "valueOf" (lambda (x . _) (if (jolt-nil? x) "null" (jolt-str-render-one x))))
|
||||
(cons "format" (lambda (a . rest)
|
||||
(if (and (jhost? a) (string=? (jhost-tag a) "locale"))
|
||||
(apply jolt-format (car rest) (cdr rest))
|
||||
(apply jolt-format a rest))))))
|
||||
|
||||
;; ---- java.text.NumberFormat -------------------------------------------------
|
||||
;; A grouping decimal formatter (selmer number-format / cuerdas). state:
|
||||
;; #(grouping? min-frac max-frac). .format groups the integer part with commas.
|
||||
(define (nf-make grouping? minf maxf) (make-jhost "numberformat" (vector grouping? minf maxf)))
|
||||
(define (group-int-str s) ; "1234567" -> "1,234,567"
|
||||
(let* ((neg (and (> (string-length s) 0) (char=? (string-ref s 0) #\-)))
|
||||
(digs (if neg (substring s 1 (string-length s)) s))
|
||||
(n (string-length digs)) (out '()))
|
||||
(let loop ((i 0))
|
||||
(when (< i n)
|
||||
(when (and (> i 0) (= 0 (modulo (- n i) 3))) (set! out (cons #\, out)))
|
||||
(set! out (cons (string-ref digs i) out)) (loop (+ i 1))))
|
||||
(string-append (if neg "-" "") (list->string (reverse out)))))
|
||||
(define (nf-format self x)
|
||||
(let* ((grouping? (vector-ref (jhost-state self) 0))
|
||||
(minf (vector-ref (jhost-state self) 1)) (maxf (vector-ref (jhost-state self) 2))
|
||||
(neg (< x 0)) (ax (abs (exact->inexact x)))
|
||||
(scale (expt 10 maxf))
|
||||
(scaled (exact (round (* ax scale))))
|
||||
(ipart (quotient scaled scale)) (fpart (remainder scaled scale))
|
||||
(istr (number->string ipart))
|
||||
(fstr0 (if (> maxf 0) (let ((s (number->string fpart)))
|
||||
(string-append (make-string (max 0 (- maxf (string-length s))) #\0) s)) ""))
|
||||
;; trim trailing zeros down to minf
|
||||
(fstr (let loop ((s fstr0)) (if (and (> (string-length s) minf)
|
||||
(char=? (string-ref s (- (string-length s) 1)) #\0))
|
||||
(loop (substring s 0 (- (string-length s) 1))) s))))
|
||||
(string-append (if neg "-" "") (if grouping? (group-int-str istr) istr)
|
||||
(if (> (string-length fstr) 0) (string-append "." fstr) ""))))
|
||||
(register-host-methods! "numberformat"
|
||||
(list (cons "format" (lambda (self n) (nf-format self n)))
|
||||
(cons "setMaximumFractionDigits" (lambda (self d) (vector-set! (jhost-state self) 2 (jnum->exact d)) jolt-nil))
|
||||
(cons "setMinimumFractionDigits" (lambda (self d) (vector-set! (jhost-state self) 1 (jnum->exact d)) jolt-nil))
|
||||
(cons "setGroupingUsed" (lambda (self b) (vector-set! (jhost-state self) 0 (jolt-truthy? b)) jolt-nil))))
|
||||
(let ((nf-statics (list (cons "getInstance" (lambda _ (nf-make #t 0 3)))
|
||||
(cons "getNumberInstance" (lambda _ (nf-make #t 0 3)))
|
||||
(cons "getIntegerInstance" (lambda _ (nf-make #t 0 0))))))
|
||||
(register-class-statics! "NumberFormat" nf-statics)
|
||||
(register-class-statics! "java.text.NumberFormat" nf-statics))
|
||||
|
||||
;; Class.forName: an array descriptor ("[C") is its own class token; a class Jolt
|
||||
;; can back (registered statics/ctor, or a java.*/clojure.* core class) yields a
|
||||
;; class object; anything else throws a catchable ClassNotFoundException, like the
|
||||
;; JVM — so the common `(try (Class/forName "optional.Dep") (catch …))` probe a
|
||||
;; library uses to detect an absent dependency works (e.g. ring's joda-time check).
|
||||
(define (forname-known? nm)
|
||||
(or (lookup-class class-statics-tbl nm)
|
||||
(lookup-class class-ctors-tbl nm)
|
||||
(let ((pre? (lambda (p) (and (>= (string-length nm) (string-length p))
|
||||
(string=? (substring nm 0 (string-length p)) p)))))
|
||||
(or (pre? "java.") (pre? "clojure.") (pre? "jolt.")))))
|
||||
(register-class-statics! "Class"
|
||||
(list (cons "forName"
|
||||
(lambda (nm . _)
|
||||
(cond
|
||||
((and (> (string-length nm) 0) (char=? (string-ref nm 0) #\[)) nm)
|
||||
((forname-known? nm) (make-class-obj nm))
|
||||
(else (jolt-throw (jolt-host-throwable "java.lang.ClassNotFoundException" nm))))))))
|
||||
|
||||
;; ---- System helpers (defined before use above via top-level order) ----------
|
||||
;; os.name reflects the actual platform (Chez's machine-type names it): a *osx
|
||||
;; machine is macOS, otherwise Linux. Code that branches on the OS (socket struct
|
||||
;; layout, path handling) needs the truth, not a fixed value.
|
||||
(define (substring-index needle hay)
|
||||
(let ((nl (string-length needle)) (hl (string-length hay)))
|
||||
(let loop ((i 0)) (cond ((> (+ i nl) hl) #f)
|
||||
((string=? (substring hay i (+ i nl)) needle) i)
|
||||
(else (loop (+ i 1)))))))
|
||||
(define sys-os-name
|
||||
(let ((m (symbol->string (machine-type))))
|
||||
(cond ((or (substring-index "osx" m) (substring-index "macos" m)) "Mac OS X")
|
||||
((or (substring-index "nt" m) (substring-index "windows" m)) "Windows")
|
||||
(else "Linux"))))
|
||||
;; runtime-settable system properties (System/setProperty). A set value wins over
|
||||
;; the built-in defaults below; clearProperty removes it.
|
||||
(define sys-prop-table (make-hashtable string-hash string=?))
|
||||
(define (sys-set-property k v)
|
||||
(let ((prev (hashtable-ref sys-prop-table k jolt-nil)))
|
||||
(hashtable-set! sys-prop-table k (if (string? v) v (jolt-str-render-one v)))
|
||||
prev))
|
||||
(define (sys-clear-property k)
|
||||
(let ((prev (hashtable-ref sys-prop-table k jolt-nil)))
|
||||
(hashtable-delete! sys-prop-table k) prev))
|
||||
(define (sys-get-property k . dflt)
|
||||
(let ((set-val (hashtable-ref sys-prop-table k #f)))
|
||||
(cond (set-val set-val)
|
||||
((string=? k "os.name") sys-os-name)
|
||||
((string=? k "line.separator") "\n")
|
||||
((string=? k "file.separator") "/")
|
||||
((string=? k "path.separator") ":")
|
||||
((string=? k "user.dir") (or (getenv "PWD") "."))
|
||||
((string=? k "user.home") (or (getenv "HOME") ""))
|
||||
((string=? k "java.io.tmpdir") (or (getenv "TMPDIR") "/tmp"))
|
||||
((pair? dflt) (car dflt))
|
||||
(else jolt-nil))))
|
||||
(define (sys-properties-map)
|
||||
(jolt-hash-map "os.name" sys-os-name "line.separator" "\n" "file.separator" "/"
|
||||
"user.dir" (or (getenv "PWD") ".") "user.home" (or (getenv "HOME") "")
|
||||
"java.io.tmpdir" (or (getenv "TMPDIR") "/tmp")))
|
||||
|
||||
;; full environment as an alist of (name . value), via spawning `env`.
|
||||
(define (all-env-pairs)
|
||||
(call-with-values
|
||||
(lambda () (open-process-ports "env" (buffer-mode block) (native-transcoder)))
|
||||
(lambda (stdin stdout stderr pid)
|
||||
(let loop ((acc '()))
|
||||
(let ((l (get-line stdout)))
|
||||
(if (eof-object? l) (reverse acc)
|
||||
(let ((eq (let scan ((i 0)) (cond ((= i (string-length l)) #f)
|
||||
((char=? (string-ref l i) #\=) i)
|
||||
(else (scan (+ i 1)))))))
|
||||
(loop (if eq (cons (cons (substring l 0 eq) (substring l (+ eq 1) (string-length l))) acc) acc)))))))))
|
||||
;; JOLT_BAKE_ENV_ALLOWLIST: when set, only the listed comma-separated
|
||||
;; names are served; unset (the normal case) reads are live and unfiltered.
|
||||
(define (env-allowlist)
|
||||
(let ((a (getenv "JOLT_BAKE_ENV_ALLOWLIST")))
|
||||
(and a (map str-trim (str-literal-split a ",")))))
|
||||
(define (sys-getenv . k)
|
||||
(let ((allow (env-allowlist)))
|
||||
(if (null? k)
|
||||
(apply jolt-hash-map
|
||||
(let loop ((ps (all-env-pairs)) (acc '()))
|
||||
(cond ((null? ps) (reverse acc))
|
||||
((and allow (not (member (caar ps) allow))) (loop (cdr ps) acc))
|
||||
(else (loop (cdr ps) (cons (cdar ps) (cons (caar ps) acc)))))))
|
||||
(let ((name (car k)))
|
||||
(if (and allow (not (member name allow))) jolt-nil
|
||||
(let ((v (getenv name))) (if v v jolt-nil)))))))
|
||||
|
||||
;; ---- StringBuilder ----------------------------------------------------------
|
||||
;; state: a box (1-vector) holding the accumulated string.
|
||||
(define (sb-str self) (vector-ref (jhost-state self) 0))
|
||||
(define (sb-set! self s) (vector-set! (jhost-state self) 0 s))
|
||||
(define (render-piece x)
|
||||
(cond ((jolt-nil? x) "null") ((char? x) (string x)) ((string? x) x)
|
||||
(else (jolt-str-render-one x))))
|
||||
;; (Object.) — a fresh value with distinct identity (libraries use it as a lock
|
||||
;; or a unique sentinel). Each call returns a new jhost so identical?/= separate.
|
||||
(register-class-ctor! "Object" (lambda _ (make-jhost "object" (vector))))
|
||||
|
||||
169
host/chez/java/host-static.ss
Normal file
169
host/chez/java/host-static.ss
Normal file
|
|
@ -0,0 +1,169 @@
|
|||
;; host-static.ss — the host-interop registry core: the class-statics / class-ctors
|
||||
;; / tagged-methods tables, the jhost record, and the coercion helpers. The actual
|
||||
;; entries are registered by host-static-methods.ss (Class/member statics) and
|
||||
;; host-static-classes.ss (instantiable object classes), loaded after this.
|
||||
;;
|
||||
;; The analyzer lowers `Class/member` to a :host-static node and `(Class. ...)` /
|
||||
;; `(new Class ...)` to a :host-new node (jolt-core/jolt/analyzer.clj); the Chez
|
||||
;; emit lowers a value ref to (host-static-ref "Class" "member"), a
|
||||
;; call head to (host-static-call "Class" "member" args...), and a constructor to
|
||||
;; (host-new "Class" args...). This file is the runtime registry those three
|
||||
;; resolve against — the class-statics / class-ctors /
|
||||
;; tagged-methods registries,
|
||||
;; restricted to the java.lang/util/net/io surface portable cljc code calls.
|
||||
;; (java.time formatting is a separate increment.)
|
||||
;;
|
||||
;; Constructed host objects are `jhost` records (a tag + mutable state); their
|
||||
;; (.method ...) calls reach record-method-dispatch (records.ss), extended below
|
||||
;; with a jhost arm that dispatches through host-tagged-methods.
|
||||
;;
|
||||
;; Loaded from rt.ss LAST (after natives-str.ss / records.ss): it extends
|
||||
;; record-method-dispatch and reuses jolt-str-render-one / jolt-re-pattern.
|
||||
|
||||
;; ---- registries -------------------------------------------------------------
|
||||
(define class-statics-tbl (make-hashtable string-hash string=?)) ; "Class" -> (member-ht)
|
||||
(define class-ctors-tbl (make-hashtable string-hash string=?)) ; "Class" -> ctor proc
|
||||
(define host-methods-tbl (make-hashtable string-hash string=?)) ; tag -> (method-ht)
|
||||
|
||||
;; A class token may arrive fully qualified (java.io.StringReader) or short
|
||||
;; (StringReader). Register both; resolve by exact then by last dotted segment.
|
||||
(define (short-class-name s)
|
||||
(let loop ((i (- (string-length s) 1)))
|
||||
(cond ((< i 0) s)
|
||||
((char=? (string-ref s i) #\.) (substring s (+ i 1) (string-length s)))
|
||||
(else (loop (- i 1))))))
|
||||
|
||||
(define (register-class-statics! name members) ; members: list of (str . val/proc)
|
||||
(let ((h (or (hashtable-ref class-statics-tbl name #f)
|
||||
(let ((h (make-hashtable string-hash string=?)))
|
||||
(hashtable-set! class-statics-tbl name h) h))))
|
||||
(for-each (lambda (p) (hashtable-set! h (car p) (cdr p))) members)))
|
||||
|
||||
(define (register-class-ctor! name proc) (hashtable-set! class-ctors-tbl name proc))
|
||||
|
||||
(define (register-host-methods! tag members)
|
||||
(let ((h (or (hashtable-ref host-methods-tbl tag #f)
|
||||
(let ((h (make-hashtable string-hash string=?)))
|
||||
(hashtable-set! host-methods-tbl tag h) h))))
|
||||
(for-each (lambda (p) (hashtable-set! h (car p) (cdr p))) members)))
|
||||
|
||||
(define (lookup-class h-tbl name)
|
||||
(or (hashtable-ref h-tbl name #f)
|
||||
(hashtable-ref h-tbl (short-class-name name) #f)))
|
||||
|
||||
;; ---- host object ------------------------------------------------------------
|
||||
(define-record-type jhost (fields tag (mutable state)) (nongenerative chez-jhost-v1))
|
||||
|
||||
;; record-method-dispatch (records.ss) gets a jhost arm: dispatch (.method obj a*)
|
||||
;; through the tag's method table.
|
||||
(define %hs-record-method-dispatch record-method-dispatch)
|
||||
(set! record-method-dispatch
|
||||
(lambda (obj method-name rest-args)
|
||||
(cond
|
||||
;; (.getClass x) is universal — the class token for any value (incl. numbers
|
||||
;; / jhost) — before the per-type arms that would otherwise reject it.
|
||||
((string=? method-name "getClass") (jolt-class obj))
|
||||
((jhost? obj)
|
||||
(let ((mh (hashtable-ref host-methods-tbl (jhost-tag obj) #f)))
|
||||
(let ((f (and mh (hashtable-ref mh method-name #f))))
|
||||
(if f
|
||||
(apply f obj (if (jolt-nil? rest-args) '() (seq->list rest-args)))
|
||||
(error #f (string-append "No method " method-name " on host " (jhost-tag obj)))))))
|
||||
((number? obj) (number-method method-name obj))
|
||||
(else (%hs-record-method-dispatch obj method-name rest-args)))))
|
||||
|
||||
;; java.lang.Number method surface (the boxed-number methods cljc code calls). The
|
||||
;; integer projections wrap modulo their width (ring-codec relies on byteValue
|
||||
;; overflow: (.byteValue 255) => -1); the float projections are identity flonums.
|
||||
(define (number-method method n)
|
||||
(cond
|
||||
((string=? method "byteValue") (let ((b (modulo (jnum->exact n) 256))) (->num (if (>= b 128) (- b 256) b))))
|
||||
((string=? method "shortValue") (let ((b (modulo (jnum->exact n) 65536))) (->num (if (>= b 32768) (- b 65536) b))))
|
||||
((string=? method "intValue") (->num (jnum->exact n)))
|
||||
((string=? method "longValue") (->num (jnum->exact n)))
|
||||
((string=? method "doubleValue") (->num n))
|
||||
((string=? method "floatValue") (->num n))
|
||||
((string=? method "toString") (jolt-num->string n))
|
||||
((string=? method "hashCode") (->num (jnum->exact n)))
|
||||
;; Double/Float .isNaN / .isInfinite (a non-flonum is neither).
|
||||
((string=? method "isNaN") (and (flonum? n) (not (= n n))))
|
||||
((string=? method "isInfinite") (and (flonum? n) (infinite? n)))
|
||||
(else (error #f (string-append "No method " method " for number")))))
|
||||
|
||||
;; Mutable static fields: "Class" -> (member -> 1-vector cell). A library that
|
||||
;; writes a static field — clojure.spec.alpha's (set! (. clojure.lang.RT
|
||||
;; checkSpecAsserts) flag) — lands here; the analyzer lowers the set! to a
|
||||
;; set-static-field! call and a plain Class/member read consults the cell first.
|
||||
(define mutable-statics-tbl (make-hashtable string-hash string=?))
|
||||
(define (mutable-static-cell class member create?)
|
||||
(let ((h (or (hashtable-ref mutable-statics-tbl class #f)
|
||||
(and create? (let ((nh (make-hashtable string-hash string=?)))
|
||||
(hashtable-set! mutable-statics-tbl class nh) nh)))))
|
||||
(and h (or (hashtable-ref h member #f)
|
||||
(and create? (let ((c (vector jolt-nil))) (hashtable-set! h member c) c))))))
|
||||
(def-var! "jolt.host" "set-static-field!"
|
||||
(lambda (class member val)
|
||||
(vector-set! (mutable-static-cell class member #t) 0 val)
|
||||
val))
|
||||
;; clojure.lang.RT.checkSpecAsserts — a JVM-internal flag clojure.spec.alpha reads
|
||||
;; and writes; default false. Pre-seed the cell so a read before any write works.
|
||||
(vector-set! (mutable-static-cell "clojure.lang.RT" "checkSpecAsserts" #t) 0 #f)
|
||||
|
||||
;; ---- emit entry points ------------------------------------------------------
|
||||
(define (host-static-ref class member)
|
||||
(let ((cell (mutable-static-cell class member #f)))
|
||||
(if cell
|
||||
(vector-ref cell 0)
|
||||
(let ((h (lookup-class class-statics-tbl class)))
|
||||
(if h
|
||||
(let ((v (hashtable-ref h member #f)))
|
||||
(if v v (error #f (string-append "No static " class "/" member))))
|
||||
(error #f (string-append "Unknown class " class)))))))
|
||||
|
||||
(define (host-static-call class member . args)
|
||||
(apply (host-static-ref class member) args))
|
||||
|
||||
(define (host-new class . args)
|
||||
(let ((ctor (lookup-class class-ctors-tbl class)))
|
||||
(cond
|
||||
(ctor (apply ctor args))
|
||||
;; deftype/defrecord: the type name is bound as a VAR (the
|
||||
;; make-deftype-ctor closure) in its defining ns, not a registered host class.
|
||||
;; Resolve it in the current ns / clojure.core and invoke it — so (P. args)
|
||||
;; works the same as the ->P factory.
|
||||
(else
|
||||
(let ((cell (or (var-cell-lookup (chez-current-ns) class)
|
||||
(var-cell-lookup "clojure.core" class))))
|
||||
(if (and cell (var-cell-defined? cell) (procedure? (var-cell-root cell)))
|
||||
(apply (var-cell-root cell) args)
|
||||
(error #f (string-append "No constructor for class " class))))))))
|
||||
|
||||
;; ---- coercion helpers -------------------------------------------------------
|
||||
;; numeric tower: currentTimeMillis/nanoTime are exact longs (JVM).
|
||||
(define (->num x) x)
|
||||
(define (jnum->exact n) (exact (truncate n)))
|
||||
;; parse an integer string in radix; #f on failure
|
||||
(define (parse-int-str s radix)
|
||||
(let ((n (string->number (str-trim (if (string? s) s (jolt-str-render-one s))) radix)))
|
||||
(and n (integer? n) (->num n))))
|
||||
(define (parse-int-or-throw s radix what)
|
||||
(or (parse-int-str s radix)
|
||||
(error #f (string-append "NumberFormatException: For input string: \""
|
||||
(if (string? s) s (jolt-str-render-one s)) "\""))))
|
||||
(define (char-code c) (if (char? c) (char->integer c) (jnum->exact c)))
|
||||
|
||||
;; parse a double string (Double/parseDouble, (Double. s)); JVM accepts NaN /
|
||||
;; Infinity / decimal / scientific. #f on failure.
|
||||
(define (parse-double-str s)
|
||||
(let ((t (str-trim (if (string? s) s (jolt-str-render-one s)))))
|
||||
(cond
|
||||
((or (string=? t "NaN") (string=? t "+NaN") (string=? t "-NaN")) +nan.0)
|
||||
((or (string=? t "Infinity") (string=? t "+Infinity")) +inf.0)
|
||||
((string=? t "-Infinity") -inf.0)
|
||||
(else (let ((n (string->number t))) (and n (real? n) (exact->inexact n)))))))
|
||||
(define (parse-double-or-throw s)
|
||||
(or (parse-double-str s)
|
||||
(error #f (string-append "NumberFormatException: For input string: \""
|
||||
(if (string? s) s (jolt-str-render-one s)) "\""))))
|
||||
(define (->double x) (if (number? x) (exact->inexact x) (parse-double-or-throw x)))
|
||||
|
||||
576
host/chez/java/inst-time.ss
Normal file
576
host/chez/java/inst-time.ss
Normal file
|
|
@ -0,0 +1,576 @@
|
|||
;; #inst values + a java.time formatting shim.
|
||||
;;
|
||||
;; A #inst literal lowers (analyzer :inst node -> emit) to (jolt-inst-from-string
|
||||
;; "…"); this file parses the RFC3339 string to epoch-ms and models the value as a
|
||||
;; `jinst` record (one flonum field, ms). Equality / map-key hashing are by the
|
||||
;; INSTANT (offset-normalized). The overlay inst?/inst-ms read (get x :jolt/type)/(get x :ms),
|
||||
;; so jolt-get answers those off a jinst — the overlay fns then work unchanged.
|
||||
;;
|
||||
;; The java.time surface (DateTimeFormatter/Instant/ZoneId/LocalDateTime/
|
||||
;; FormatStyle/Locale + the .format/.atZone/.toInstant/… methods) is
|
||||
;; registered through host-static.ss's class-statics / host-
|
||||
;; methods registries — so this loads LAST in rt.ss, after host-static.ss and io.ss.
|
||||
|
||||
;; --- civil <-> days since the Unix epoch (Howard Hinnant's algorithms) -------
|
||||
;; No portable UTC mktime on Chez, so compute epoch days directly from y/m/d.
|
||||
(define (days-from-civil y m d)
|
||||
(let* ((y2 (if (<= m 2) (- y 1) y))
|
||||
(era (quotient (if (>= y2 0) y2 (- y2 399)) 400))
|
||||
(yoe (- y2 (* era 400)))
|
||||
(doy (+ (quotient (+ (* 153 (+ m (if (> m 2) -3 9))) 2) 5) (- d 1)))
|
||||
(doe (+ (* yoe 365) (quotient yoe 4) (- (quotient yoe 100)) doy)))
|
||||
(+ (* era 146097) doe -719468)))
|
||||
|
||||
(define (civil-from-days z) ; -> (values year month day)
|
||||
(let* ((z2 (+ z 719468))
|
||||
(era (quotient (if (>= z2 0) z2 (- z2 146096)) 146097))
|
||||
(doe (- z2 (* era 146097)))
|
||||
(yoe (quotient (+ doe (- (quotient doe 1460)) (quotient doe 36524) (- (quotient doe 146096))) 365))
|
||||
(y (+ yoe (* era 400)))
|
||||
(doy (- doe (+ (* 365 yoe) (quotient yoe 4) (- (quotient yoe 100)))))
|
||||
(mp (quotient (+ (* 5 doy) 2) 153))
|
||||
(d (+ (- doy (quotient (+ (* 153 mp) 2) 5)) 1))
|
||||
(m (+ mp (if (< mp 10) 3 -9))))
|
||||
(values (if (<= m 2) (+ y 1) y) m d)))
|
||||
|
||||
;; --- RFC3339 parse: yyyy[-MM[-dd[Thh[:mm[:ss[.fff]]]]]][Z|±hh:mm] -> ms -------
|
||||
(define-record-type jinst (fields ms) (nongenerative chez-jinst-v1))
|
||||
|
||||
(define (digit? c) (and (char>=? c #\0) (char<=? c #\9)))
|
||||
(define (digits-at s i n) ; n digits from i -> integer, or #f
|
||||
(and (<= (+ i n) (string-length s))
|
||||
(let loop ((j i) (acc 0))
|
||||
(if (= j (+ i n))
|
||||
acc
|
||||
(and (digit? (string-ref s j))
|
||||
(loop (+ j 1) (+ (* acc 10) (- (char->integer (string-ref s j)) 48))))))))
|
||||
|
||||
(define (jolt-inst-from-string ts0)
|
||||
;; a leading '-' marks a negative (proleptic) year; the rest of the field may be
|
||||
;; more than 4 digits (java.time prints -999999999-…). Read the year up to the
|
||||
;; first '-' that separates it from the month.
|
||||
(define neg-year (and (> (string-length ts0) 0) (char=? (string-ref ts0 0) #\-)))
|
||||
(define ts (if neg-year (substring ts0 1 (string-length ts0)) ts0))
|
||||
(define len (string-length ts))
|
||||
(define (fail) (error #f (string-append "Unrecognized #inst timestamp: " ts0)))
|
||||
(define (read-year)
|
||||
;; >=4 digits up to a non-digit; java.time uses min-4 but allows more.
|
||||
(let loop ((j 0) (acc 0) (n 0))
|
||||
(if (and (< j len) (digit? (string-ref ts j)))
|
||||
(loop (+ j 1) (+ (* acc 10) (- (char->integer (string-ref ts j)) 48)) (+ n 1))
|
||||
(if (>= n 4) (cons acc j) #f))))
|
||||
(let* ((yr (or (read-year) (fail)))
|
||||
(year (if neg-year (- (car yr)) (car yr)))
|
||||
(i (cdr yr)) (month 1) (day 1) (hh 0) (mm 0) (ss 0) (frac-ms 0) (off-s 0))
|
||||
;; -MM
|
||||
(when (and (< i len) (char=? (string-ref ts i) #\-) (digits-at ts (+ i 1) 2))
|
||||
(set! month (digits-at ts (+ i 1) 2)) (set! i (+ i 3)))
|
||||
;; -dd
|
||||
(when (and (< i len) (char=? (string-ref ts i) #\-) (digits-at ts (+ i 1) 2))
|
||||
(set! day (digits-at ts (+ i 1) 2)) (set! i (+ i 3)))
|
||||
;; Thh
|
||||
(when (and (< i len) (or (char=? (string-ref ts i) #\T) (char=? (string-ref ts i) #\t))
|
||||
(digits-at ts (+ i 1) 2))
|
||||
(set! hh (digits-at ts (+ i 1) 2)) (set! i (+ i 3))
|
||||
;; :mm
|
||||
(when (and (< i len) (char=? (string-ref ts i) #\:) (digits-at ts (+ i 1) 2))
|
||||
(set! mm (digits-at ts (+ i 1) 2)) (set! i (+ i 3))
|
||||
;; :ss
|
||||
(when (and (< i len) (char=? (string-ref ts i) #\:) (digits-at ts (+ i 1) 2))
|
||||
(set! ss (digits-at ts (+ i 1) 2)) (set! i (+ i 3))
|
||||
;; .fff (truncate beyond 3)
|
||||
(when (and (< i len) (char=? (string-ref ts i) #\.))
|
||||
(let loop ((j (+ i 1)) (k 0) (acc 0))
|
||||
(if (and (< j len) (digit? (string-ref ts j)))
|
||||
(loop (+ j 1) (+ k 1) (if (< k 3) (+ (* acc 10) (- (char->integer (string-ref ts j)) 48)) acc))
|
||||
(begin
|
||||
(set! frac-ms (* acc (expt 10 (max 0 (- 3 k)))))
|
||||
(set! i j))))))))
|
||||
;; offset Z | ±hh:mm
|
||||
(when (< i len)
|
||||
(let ((c (string-ref ts i)))
|
||||
(cond
|
||||
((or (char=? c #\Z) (char=? c #\z)) (set! i (+ i 1)))
|
||||
((or (char=? c #\+) (char=? c #\-))
|
||||
(let ((oh (digits-at ts (+ i 1) 2)) (om (digits-at ts (+ i 4) 2)))
|
||||
(unless (and oh om (char=? (string-ref ts (+ i 3)) #\:)) (fail))
|
||||
(set! off-s (* (if (char=? c #\-) -1 1) (+ (* oh 3600) (* om 60))))
|
||||
(set! i (+ i 6))))
|
||||
(else (fail)))))
|
||||
(unless (= i len) (fail))
|
||||
(let ((base-s (+ (* (days-from-civil year month day) 86400) (* hh 3600) (* mm 60) ss)))
|
||||
(make-jinst (- (+ (* base-s 1000) frac-ms) (* off-s 1000))))))
|
||||
|
||||
;; --- canonical print form: yyyy-MM-ddThh:mm:ss.fff-00:00 (UTC) ---------------
|
||||
(define (pad2 n) (if (< n 10) (string-append "0" (number->string n)) (number->string n)))
|
||||
(define (pad4 n) (let ((s (number->string n))) (string-append (make-string (max 0 (- 4 (string-length s))) #\0) s)))
|
||||
(define (pad3 n) (let ((s (number->string n))) (string-append (make-string (max 0 (- 3 (string-length s))) #\0) s)))
|
||||
(define (inst-floor-div a b) (let ((q (quotient a b)) (r (remainder a b))) (if (and (not (= r 0)) (< (* a b) 0)) (- q 1) q)))
|
||||
(define (inst-floor-mod a b) (- a (* (inst-floor-div a b) b)))
|
||||
|
||||
(define (inst-fields ms) ; -> list (y mo d hh mm ss frac dow)
|
||||
(let* ((total-s (inst-floor-div (exact (truncate ms)) 1000))
|
||||
(frac (- (exact (truncate ms)) (* total-s 1000)))
|
||||
(days (inst-floor-div total-s 86400))
|
||||
(sod (inst-floor-mod total-s 86400))
|
||||
(hh (quotient sod 3600)) (mm (quotient (remainder sod 3600) 60)) (ss (remainder sod 60))
|
||||
(dow (inst-floor-mod (+ days 4) 7))) ; 1970-01-01 = Thursday; 0=Sunday
|
||||
(call-with-values (lambda () (civil-from-days days))
|
||||
(lambda (y mo d) (list y mo d hh mm ss frac dow)))))
|
||||
|
||||
(define (inst-rfc3339 inst)
|
||||
(let ((f (inst-fields (jinst-ms inst))))
|
||||
(string-append (pad4 (list-ref f 0)) "-" (pad2 (list-ref f 1)) "-" (pad2 (list-ref f 2))
|
||||
"T" (pad2 (list-ref f 3)) ":" (pad2 (list-ref f 4)) ":" (pad2 (list-ref f 5))
|
||||
"." (pad3 (list-ref f 6)) "-00:00")))
|
||||
|
||||
;; --- DateTimeFormatter pattern engine -----
|
||||
(define month-names (vector "January" "February" "March" "April" "May" "June" "July"
|
||||
"August" "September" "October" "November" "December"))
|
||||
(define day-names (vector "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
|
||||
|
||||
(define (format-ms pattern ms)
|
||||
(let ((f (inst-fields ms)) (n (string-length pattern)) (out (open-output-string)))
|
||||
(let ((y (list-ref f 0)) (mo (list-ref f 1)) (d (list-ref f 2))
|
||||
(hh (list-ref f 3)) (mi (list-ref f 4)) (se (list-ref f 5)) (dow (list-ref f 7)))
|
||||
(define (run-len i c) (let loop ((j i)) (if (and (< j n) (char=? (string-ref pattern j) c)) (loop (+ j 1)) (- j i))))
|
||||
(let loop ((i 0))
|
||||
(when (< i n)
|
||||
(let* ((c (string-ref pattern i)) (k (run-len i c)))
|
||||
(cond
|
||||
((char=? c #\')
|
||||
(if (and (< (+ i 1) n) (char=? (string-ref pattern (+ i 1)) #\'))
|
||||
(begin (write-char #\' out) (loop (+ i 2)))
|
||||
(let close ((j (+ i 1)))
|
||||
(cond ((>= j n) (loop j))
|
||||
((char=? (string-ref pattern j) #\') (loop (+ j 1)))
|
||||
(else (write-char (string-ref pattern j) out) (close (+ j 1)))))))
|
||||
((char=? c #\y) (display (if (>= k 4) (number->string y) (pad2 (modulo y 100))) out) (loop (+ i k)))
|
||||
((char=? c #\M)
|
||||
(display (cond ((= k 1) (number->string mo)) ((= k 2) (pad2 mo))
|
||||
((= k 3) (substring (vector-ref month-names (- mo 1)) 0 3))
|
||||
(else (vector-ref month-names (- mo 1)))) out)
|
||||
(loop (+ i k)))
|
||||
((char=? c #\d) (display (if (= k 1) (number->string d) (pad2 d)) out) (loop (+ i k)))
|
||||
((char=? c #\E)
|
||||
(display (if (>= k 4) (vector-ref day-names dow) (substring (vector-ref day-names dow) 0 3)) out)
|
||||
(loop (+ i k)))
|
||||
((char=? c #\H) (display (if (= k 1) (number->string hh) (pad2 hh)) out) (loop (+ i k)))
|
||||
((char=? c #\h)
|
||||
(let ((h12 (let ((h (modulo hh 12))) (if (= h 0) 12 h))))
|
||||
(display (if (= k 1) (number->string h12) (pad2 h12)) out)) (loop (+ i k)))
|
||||
((char=? c #\m) (display (if (= k 1) (number->string mi) (pad2 mi)) out) (loop (+ i k)))
|
||||
((char=? c #\s) (display (if (= k 1) (number->string se) (pad2 se)) out) (loop (+ i k)))
|
||||
((char=? c #\a) (display (if (< hh 12) "AM" "PM") out) (loop (+ i k)))
|
||||
;; timezone — format-ms renders UTC, the HTTP zone is GMT: z/zzz -> GMT,
|
||||
;; Z (RFC822) -> +0000, X (ISO) -> Z.
|
||||
((char=? c #\z) (display "GMT" out) (loop (+ i k)))
|
||||
((char=? c #\Z) (display "+0000" out) (loop (+ i k)))
|
||||
((char=? c #\X) (display "Z" out) (loop (+ i k)))
|
||||
(else (write-char c out) (loop (+ i 1)))))))
|
||||
(get-output-string out))))
|
||||
|
||||
;; --- SimpleDateFormat .parse: pattern-driven parse to epoch-ms (UTC/GMT) ------
|
||||
(define (month-from-name s)
|
||||
(let ((m3 (ascii-string-down (substring s 0 (min 3 (string-length s))))))
|
||||
(let loop ((i 0))
|
||||
(cond ((= i 12) #f)
|
||||
((string=? (ascii-string-down (substring (vector-ref month-names i) 0 3)) m3) (+ i 1))
|
||||
(else (loop (+ i 1)))))))
|
||||
(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))
|
||||
;; 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.
|
||||
(define (read-digits-w ii maxw) ; -> (val . next), pfail if none
|
||||
(let loop ((j ii) (acc 0) (n 0) (any #f))
|
||||
(if (and (< j inn) (digit? (string-ref input j)) (or (not maxw) (< n maxw)))
|
||||
(loop (+ j 1) (+ (* acc 10) (- (char->integer (string-ref input j)) 48)) (+ n 1) #t)
|
||||
(if any (cons acc j) (pfail)))))
|
||||
(define (read-digits ii) (read-digits-w ii #f))
|
||||
(define (read-alpha ii) ; -> (str . next)
|
||||
(let loop ((j ii)) (if (and (< j inn) (char-alphabetic? (string-ref input j))) (loop (+ j 1))
|
||||
(cons (substring input ii j) j))))
|
||||
(define (read-tz ii) ; consume GMT/UTC/Z or ±hhmm; -> next
|
||||
(cond ((>= ii inn) ii)
|
||||
((char-alphabetic? (string-ref input ii)) (cdr (read-alpha ii)))
|
||||
((or (char=? (string-ref input ii) #\+) (char=? (string-ref input ii) #\-))
|
||||
(let loop ((j (+ ii 1))) (if (and (< j inn) (or (digit? (string-ref input j)) (char=? (string-ref input j) #\:))) (loop (+ j 1)) j)))
|
||||
(else ii)))
|
||||
(let loop ((pi 0) (ii 0))
|
||||
(if (>= pi pn)
|
||||
(begin
|
||||
(when (eq? pm 'pm) (when (< hh 12) (set! hh (+ hh 12))))
|
||||
(when (eq? pm 'am) (when (= hh 12) (set! hh 0)))
|
||||
(make-jinst (* 1000 (+ (* (days-from-civil y mo d) 86400) (* hh 3600) (* mi 60) ss))))
|
||||
(let ((c (string-ref pattern pi)))
|
||||
(cond
|
||||
((char-alphabetic? c)
|
||||
(let ((k (run-len pi c)))
|
||||
(cond
|
||||
((char=? c #\y) (let ((r (read-digits-w ii (if (>= k 3) #f k))))
|
||||
;; 2-digit year (value < 100): JVM sliding window — 00-68 -> 20xx,
|
||||
;; 69-99 -> 19xx (rfc1036 HTTP dates). A full year stays as-is.
|
||||
(set! y (let ((v (car r))) (if (and (= k 2) (< v 100)) (if (< v 69) (+ 2000 v) (+ 1900 v)) v)))
|
||||
(loop (+ pi k) (cdr r))))
|
||||
((char=? c #\M) (if (>= k 3)
|
||||
(let ((r (read-alpha ii))) (set! mo (or (month-from-name (car r)) (pfail))) (loop (+ pi k) (cdr r)))
|
||||
(let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! mo (car r)) (loop (+ pi k) (cdr r)))))
|
||||
((char=? c #\d) (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! d (car r)) (loop (+ pi k) (cdr r))))
|
||||
((or (char=? c #\H) (char=? c #\h)) (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! hh (car r)) (loop (+ pi k) (cdr r))))
|
||||
((char=? c #\m) (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! mi (car r)) (loop (+ pi k) (cdr r))))
|
||||
((char=? c #\s) (let ((r (read-digits-w ii (if (>= k 2) k #f)))) (set! ss (car r)) (loop (+ pi k) (cdr r))))
|
||||
((char=? c #\E) (loop (+ pi k) (cdr (read-alpha ii))))
|
||||
((char=? c #\a) (let ((r (read-alpha ii)))
|
||||
(set! pm (if (string=? (ascii-string-down (car r)) "pm") 'pm 'am))
|
||||
(loop (+ pi k) (cdr r))))
|
||||
((or (char=? c #\z) (char=? c #\Z) (char=? c #\X) (char=? c #\x) (char=? c #\V) (char=? c #\v)) (loop (+ pi k) (read-tz ii)))
|
||||
(else (loop (+ pi k) ii)))))
|
||||
((char=? c #\')
|
||||
(if (and (< (+ pi 1) pn) (char=? (string-ref pattern (+ pi 1)) #\'))
|
||||
(loop (+ pi 2) (if (and (< ii inn) (char=? (string-ref input ii) #\')) (+ ii 1) ii))
|
||||
(let lit ((pj (+ pi 1)) (ij ii))
|
||||
(cond ((>= pj pn) (loop pj ij))
|
||||
((char=? (string-ref pattern pj) #\') (loop (+ pj 1) ij))
|
||||
((and (< ij inn) (char=? (string-ref input ij) (string-ref pattern pj))) (lit (+ pj 1) (+ ij 1)))
|
||||
(else (pfail))))))
|
||||
;; literal: match it; a pattern space tolerates missing/extra spaces.
|
||||
((char=? c #\space)
|
||||
(let skip ((ij ii)) (if (and (< ij inn) (char=? (string-ref input ij) #\space)) (skip (+ ij 1)) (loop (+ pi 1) ij))))
|
||||
((and (< ii inn) (char=? (string-ref input ii) c)) (loop (+ pi 1) (+ ii 1)))
|
||||
(else (pfail))))))))
|
||||
|
||||
;; --- value integration: get / = / hash / pr / type / instance? --------------
|
||||
(define kw-jolt-type (keyword "jolt" "type"))
|
||||
(define kw-ms (keyword #f "ms"))
|
||||
(define inst-type-kw (keyword "jolt" "inst"))
|
||||
|
||||
(register-get-arm! jinst?
|
||||
(lambda (coll k d)
|
||||
(cond ((jolt=2 k kw-jolt-type) inst-type-kw)
|
||||
((jolt=2 k kw-ms) (jinst-ms coll))
|
||||
(else d))))
|
||||
|
||||
(register-eq-arm! (lambda (a b) (or (jinst? a) (jinst? b)))
|
||||
(lambda (a b) (and (jinst? a) (jinst? b) (= (jinst-ms a) (jinst-ms b)))))
|
||||
|
||||
(register-hash-arm! jinst? (lambda (x) (jolt-hash (jinst-ms x))))
|
||||
|
||||
;; java.time.Instant is nano-precise: two Instants are = when their epoch-nanos
|
||||
;; match (so an Instant and one shifted by a single nanosecond differ).
|
||||
(define (jt-instant-tag? x) (and (jhost? x) (string=? (jhost-tag x) "instant")))
|
||||
(register-eq-arm! (lambda (a b) (or (jt-instant-tag? a) (jt-instant-tag? b)))
|
||||
(lambda (a b) (and (jt-instant-tag? a) (jt-instant-tag? b)
|
||||
(= (inst-nanos a) (inst-nanos b)))))
|
||||
(register-hash-arm! jt-instant-tag? (lambda (x) (jolt-hash (inst-nanos x))))
|
||||
|
||||
;; ZonedDateTime / java.sql.Date shim values (mk-zoned/mk-sql-date jhosts) are
|
||||
;; equal when same kind + same epoch-ms.
|
||||
(define (time-jhost? x) (and (jhost? x) (member (jhost-tag x) '("zoned-dt" "sql-date")) #t))
|
||||
(register-eq-arm! (lambda (a b) (or (time-jhost? a) (time-jhost? b)))
|
||||
(lambda (a b) (and (time-jhost? a) (time-jhost? b)
|
||||
(string=? (jhost-tag a) (jhost-tag b))
|
||||
(= (ms-of a) (ms-of b)))))
|
||||
(register-hash-arm! time-jhost? (lambda (x) (jolt-hash (ms-of x))))
|
||||
|
||||
(define (inst-pr i) (string-append "#inst \"" (inst-rfc3339 i) "\""))
|
||||
(register-pr-arm! jinst? inst-pr)
|
||||
(register-str-render! jinst? inst-rfc3339)
|
||||
|
||||
(define %it-type jolt-type)
|
||||
(set! jolt-type (lambda (x) (if (jinst? x) inst-type-kw (%it-type x))))
|
||||
(def-var! "clojure.core" "type" jolt-type)
|
||||
|
||||
;; instance? java.util.Date -> a jinst; java.time.Instant/LocalDateTime -> the
|
||||
;; matching jhost tag. The instance? macro passes the class-name symbol.
|
||||
(define (class-short tn) (let loop ((i (- (string-length tn) 1)))
|
||||
(cond ((< i 0) tn) ((char=? (string-ref tn i) #\.) (substring tn (+ i 1) (string-length tn))) (else (loop (- i 1))))))
|
||||
(register-instance-check-arm!
|
||||
(lambda (type-sym val)
|
||||
(let ((tn (class-short (symbol-t-name type-sym))))
|
||||
(cond
|
||||
;; a #inst / (Date.) is a java.util.Date; it is NOT a java.sql.Timestamp
|
||||
;; (on the JVM a Date is not a Timestamp), so answer Timestamp explicitly #f.
|
||||
((jinst? val) (cond ((string=? tn "Date") #t)
|
||||
((string=? tn "Timestamp") #f)
|
||||
(else 'pass)))
|
||||
((and (jhost? val) (string=? (jhost-tag val) "instant")) (if (string=? tn "Instant") #t 'pass))
|
||||
;; java.sql.Date is a java.util.Date subclass (but not a Timestamp).
|
||||
((and (jhost? val) (string=? (jhost-tag val) "sql-date"))
|
||||
(cond ((or (string=? tn "Date")) #t) ((string=? tn "Timestamp") #f) (else 'pass)))
|
||||
(else 'pass)))))
|
||||
|
||||
;; inst-ms* is a seed native (the overlay inst-ms reads (get x :ms), now answered).
|
||||
(def-var! "clojure.core" "inst-ms*" (lambda (i) (jinst-ms i)))
|
||||
|
||||
;; --- java.time shim values (jhost objects over host-static.ss registries) -----
|
||||
;; "local-date" stores an epoch-day (java-time.ss owns the type); ms-of projects it
|
||||
;; to UTC midnight so existing date math keeps working. "local-dt" stores epoch-day +
|
||||
;; nano-of-day; the others store epoch-ms.
|
||||
(define (ms-of d)
|
||||
(cond ((number? d) d)
|
||||
((jinst? d) (jinst-ms d))
|
||||
((and (jhost? d) (string=? (jhost-tag d) "local-date"))
|
||||
(* (vector-ref (jhost-state d) 0) 86400000))
|
||||
((and (jhost? d) (string=? (jhost-tag d) "local-date-time"))
|
||||
(+ (* (vector-ref (jhost-state d) 0) 86400000)
|
||||
(quotient (vector-ref (jhost-state d) 1) 1000000)))
|
||||
;; "instant" stores epoch-nanos; project to ms (floor) for ms-based callers.
|
||||
((and (jhost? d) (string=? (jhost-tag d) "instant"))
|
||||
(inst-floor-div (vector-ref (jhost-state d) 0) 1000000))
|
||||
((and (jhost? d) (member (jhost-tag d) '("zoned-dt" "calendar" "sql-date")))
|
||||
(vector-ref (jhost-state d) 0))
|
||||
(else (error #f "not a date value" d))))
|
||||
;; A java.time.Instant stores epoch-nanos (exact integer). mk-instant takes ms,
|
||||
;; for the many ms-based call sites; mk-instant-nanos is the nano-precise ctor and
|
||||
;; inst-nanos the nano accessor (java-time.ss owns the nano-aware arithmetic).
|
||||
(define (mk-instant-nanos n) (make-jhost "instant" (vector (exact (truncate n)))))
|
||||
(define (inst-nanos x) (vector-ref (jhost-state x) 0))
|
||||
(define (mk-instant ms) (mk-instant-nanos (* (ms->exact ms) 1000000)))
|
||||
(define (mk-zoned ms) (make-jhost "zoned-dt" (vector ms)))
|
||||
;; LocalDateTime from epoch-ms (UTC): the java-time.ss "local-date-time" jhost,
|
||||
;; state [epoch-day nano-of-day].
|
||||
(define (mk-local ms)
|
||||
(let* ((ems (exact (truncate ms)))
|
||||
(ed (inst-floor-div ems 86400000))
|
||||
(mod (inst-floor-mod ems 86400000)))
|
||||
(make-jhost "local-date-time" (vector ed (* mod 1000000)))))
|
||||
;; local-date from epoch-ms: the epoch-day of the UTC day containing ms.
|
||||
(define (mk-local-date ms) (make-jhost "local-date" (vector (inst-floor-div (exact (truncate ms)) 86400000))))
|
||||
;; start of the UTC day containing ms.
|
||||
(define (start-of-utc-day ms)
|
||||
(* (inst-floor-div (exact (truncate ms)) 86400000) 86400000))
|
||||
;; a formatter carries its pattern and a locale id (default "en"); the locale
|
||||
;; selects month/day names in the java-time.ss format engine.
|
||||
(define (mk-formatter pat . loc) (make-jhost "dt-formatter" (vector pat (if (null? loc) "en" (car loc)))))
|
||||
(define (fmt-pat f) (vector-ref (jhost-state f) 0))
|
||||
(define (fmt-locale f) (let ((s (jhost-state f))) (if (> (vector-length s) 1) (vector-ref s 1) "en")))
|
||||
(define (locale-id l) (if (and (jhost? l) (string=? (jhost-tag l) "locale")) (vector-ref (jhost-state l) 0) "en"))
|
||||
(define (now-ms) (now-millis)) ; exact ms (= JVM long); now-millis from host-static.ss
|
||||
;; coerce a user-supplied ms (exact or flonum) to an exact integer for storage.
|
||||
(define (ms->exact ms) (exact (round ms)))
|
||||
|
||||
(register-host-methods! "instant"
|
||||
(list (cons "atZone" (lambda (self zone) (mk-zoned (ms-of self))))
|
||||
(cons "toEpochMilli" (lambda (self) (ms-of self)))
|
||||
(cons "toString" (lambda (self) (inst-rfc3339 (make-jinst (ms-of self)))))))
|
||||
(register-host-methods! "zoned-dt"
|
||||
(list (cons "toLocalDateTime" (lambda (self) (mk-local (ms-of self))))
|
||||
(cons "toInstant" (lambda (self) (mk-instant (ms-of self))))))
|
||||
;; LocalDate.atZone(zone): the UTC layer treats it as a zoned value at midnight.
|
||||
;; (java-time.ss registers atStartOfDay and the rest of the local-date surface.)
|
||||
(register-host-methods! "local-date"
|
||||
(list (cons "atZone" (lambda (self zone) (mk-zoned (ms-of self))))))
|
||||
(register-host-methods! "dt-formatter"
|
||||
(list (cons "withLocale" (lambda (self locale) (mk-formatter (fmt-pat self) (locale-id locale))))
|
||||
(cons "withZone" (lambda (self zone) (mk-formatter (fmt-pat self) (fmt-locale self))))
|
||||
(cons "format" (lambda (self d) (format-ms (fmt-pat self) (ms-of d))))
|
||||
;; parse a string per the pattern -> an instant value; Instant/from / the
|
||||
;; LocalDateTime/parse static read its ms back out.
|
||||
(cons "parse" (lambda (self s) (mk-instant (jinst-ms (parse-ms (fmt-pat self) (jolt-str-render-one s))))))))
|
||||
|
||||
;; FormatStyle approximations (no locale DB on this host).
|
||||
(define style-patterns
|
||||
'((date . ((short . "M/d/yy") (medium . "MMM d, yyyy") (long . "MMMM d, yyyy") (full . "EEEE, MMMM d, yyyy")))
|
||||
(time . ((short . "h:mm a") (medium . "h:mm:ss a") (long . "h:mm:ss a") (full . "h:mm:ss a")))
|
||||
(datetime . ((short . "M/d/yy, h:mm a") (medium . "MMM d, yyyy, h:mm:ss a")
|
||||
(long . "MMMM d, yyyy, h:mm:ss a") (full . "EEEE, MMMM d, yyyy, h:mm:ss a")))))
|
||||
(define (style-of fs) (vector-ref (jhost-state fs) 0)) ; a symbol: short/medium/long/full
|
||||
(define (style-fmt kind fs)
|
||||
(mk-formatter (or (let ((row (assq kind style-patterns))) (and row (let ((e (assq (style-of fs) (cdr row)))) (and e (cdr e)))))
|
||||
"yyyy-MM-dd HH:mm:ss")))
|
||||
|
||||
(register-class-statics! "FormatStyle"
|
||||
(list (cons "SHORT" (make-jhost "format-style" (vector 'short)))
|
||||
(cons "MEDIUM" (make-jhost "format-style" (vector 'medium)))
|
||||
(cons "LONG" (make-jhost "format-style" (vector 'long)))
|
||||
(cons "FULL" (make-jhost "format-style" (vector 'full)))))
|
||||
(register-class-statics! "DateTimeFormatter"
|
||||
(list (cons "ofPattern" (lambda (p . _) (mk-formatter p)))
|
||||
(cons "ISO_LOCAL_DATE" (mk-formatter "yyyy-MM-dd"))
|
||||
(cons "ISO_LOCAL_DATE_TIME" (mk-formatter "yyyy-MM-dd'T'HH:mm:ss"))
|
||||
;; ISO_INSTANT always renders in UTC with a trailing Z (format-ms is UTC; X -> "Z").
|
||||
(cons "ISO_INSTANT" (mk-formatter "yyyy-MM-dd'T'HH:mm:ssX"))
|
||||
;; ISO_ZONED_DATE_TIME: the UTC layer renders/parses it like ISO_INSTANT.
|
||||
(cons "ISO_ZONED_DATE_TIME" (mk-formatter "yyyy-MM-dd'T'HH:mm:ssX"))
|
||||
(cons "ofLocalizedDate" (lambda (fs) (style-fmt 'date fs)))
|
||||
(cons "ofLocalizedTime" (lambda (fs) (style-fmt 'time fs)))
|
||||
(cons "ofLocalizedDateTime" (lambda (fs) (style-fmt 'datetime fs)))))
|
||||
(register-class-statics! "Instant"
|
||||
(list (cons "ofEpochMilli" (lambda (ms) (mk-instant (ms->exact ms))))
|
||||
(cons "now" (lambda () (mk-instant (now-ms))))
|
||||
;; Instant/parse an ISO-8601 instant ("…T…Z") -> an instant value.
|
||||
(cons "parse" (lambda (s) (mk-instant (jinst-ms (jolt-inst-from-string
|
||||
(if (string? s) s (jolt-str-render-one s)))))))
|
||||
;; Instant/from a temporal accessor -> an instant at the same epoch-ms.
|
||||
(cons "from" (lambda (t) (mk-instant (ms-of t))))))
|
||||
(register-class-statics! "ZoneId"
|
||||
(list (cons "systemDefault" (lambda () (make-jhost "zone-id" (vector "system"))))
|
||||
(cons "of" (lambda (id) (make-jhost "zone-id" (vector id))))))
|
||||
(register-class-statics! "LocalDateTime"
|
||||
(list (cons "ofInstant" (lambda (inst zone) (mk-local (ms-of inst))))
|
||||
(cons "now" (lambda () (mk-local (now-ms))))
|
||||
;; LocalDateTime/parse text, or text + a formatter (the UTC layer ignores
|
||||
;; the parsed offset) -> a local-dt at the parsed instant.
|
||||
(cons "parse" (lambda (s . fmt)
|
||||
(let ((str (if (string? s) s (jolt-str-render-one s))))
|
||||
(mk-local (jinst-ms (if (null? fmt)
|
||||
(jolt-inst-from-string str)
|
||||
(parse-ms (fmt-pat (car fmt)) str)))))))))
|
||||
(let ((locale-ctor (lambda (id . _) (make-jhost "locale" (vector (if (string? id) id (jolt-str-render-one id)))))))
|
||||
(register-class-ctor! "Locale" locale-ctor)
|
||||
(register-class-ctor! "java.util.Locale" locale-ctor))
|
||||
(register-class-statics! "Locale"
|
||||
(list (cons "getDefault" (lambda () (make-jhost "locale" (vector "default"))))
|
||||
(cons "ENGLISH" (make-jhost "locale" (vector "en")))
|
||||
(cons "US" (make-jhost "locale" (vector "en-US")))
|
||||
(cons "FRENCH" (make-jhost "locale" (vector "fr")))
|
||||
(cons "FRANCE" (make-jhost "locale" (vector "fr-FR")))
|
||||
(cons "GERMAN" (make-jhost "locale" (vector "de")))
|
||||
(cons "ROOT" (make-jhost "locale" (vector "root")))))
|
||||
|
||||
;; java.util.Date / java.sql.Timestamp: #inst's classes. (Date.) = now, (Date. ms)
|
||||
;; or (Date. another-date) -> a jinst (ms-of accepts a number / jinst / instant), so
|
||||
;; .getTime / inst? / instance? Date|Timestamp work.
|
||||
(define (date-ctor . args)
|
||||
(cond
|
||||
((null? args) (make-jinst (now-ms)))
|
||||
((null? (cdr args)) (make-jinst (ms->exact (ms-of (car args)))))
|
||||
;; deprecated (Date. year-1900 month0 date [hrs min sec]) — civil fields in UTC.
|
||||
(else
|
||||
(let* ((y (+ 1900 (jnum->exact (list-ref args 0))))
|
||||
(mo (+ 1 (jnum->exact (list-ref args 1))))
|
||||
(d (jnum->exact (list-ref args 2)))
|
||||
(hh (if (> (length args) 3) (jnum->exact (list-ref args 3)) 0))
|
||||
(mm (if (> (length args) 4) (jnum->exact (list-ref args 4)) 0))
|
||||
(ss (if (> (length args) 5) (jnum->exact (list-ref args 5)) 0)))
|
||||
(make-jinst (* 1000 (+ (* (days-from-civil y mo d) 86400) (* hh 3600) (* mm 60) ss)))))))
|
||||
(register-class-ctor! "Date" date-ctor)
|
||||
(register-class-ctor! "java.util.Date" date-ctor)
|
||||
(register-class-ctor! "Timestamp" date-ctor)
|
||||
(register-class-ctor! "java.sql.Timestamp" date-ctor)
|
||||
;; Date/from(Instant) -> a java.util.Date at the instant's epoch-ms.
|
||||
(let ((date-statics (list (cons "from" (lambda (inst) (make-jinst (ms->exact (ms-of inst))))))))
|
||||
(register-class-statics! "Date" date-statics)
|
||||
(register-class-statics! "java.util.Date" date-statics))
|
||||
;; java.sql.Date: a distinct class from java.util.Date (a "sql-date" jhost over
|
||||
;; epoch-ms) so a protocol extended to both routes a sql.Date to its own impl.
|
||||
;; (Date. year-1900 month0 day) builds UTC midnight of that civil date; valueOf
|
||||
;; parses "yyyy-MM-dd" to the same instant (so the two agree).
|
||||
(define (mk-sql-date ms) (make-jhost "sql-date" (vector (ms->exact ms))))
|
||||
(define (sql-date-midnight y mo d) (mk-sql-date (* 1000 (* (days-from-civil y mo d) 86400))))
|
||||
(register-class-ctor! "java.sql.Date"
|
||||
(case-lambda
|
||||
((ms) (mk-sql-date (ms-of ms))) ; (Date. epoch-ms)
|
||||
((y m d) (sql-date-midnight (+ 1900 (jnum->exact y)) (+ 1 (jnum->exact m)) (jnum->exact d)))))
|
||||
(register-class-statics! "java.sql.Date"
|
||||
(list (cons "valueOf" (lambda (s) (mk-sql-date (jinst-ms (parse-ms "yyyy-MM-dd" (if (string? s) s (jolt-str-render-one s)))))))))
|
||||
(register-host-methods! "sql-date"
|
||||
(list (cons "getTime" (lambda (self) (ms-of self)))
|
||||
(cons "toInstant" (lambda (self) (mk-instant (ms-of self))))
|
||||
(cons "toLocalDate" (lambda (self) (mk-local-date (ms-of self))))
|
||||
(cons "toString" (lambda (self) (inst-rfc3339 (make-jinst (ms-of self)))))))
|
||||
|
||||
;; java.util.Calendar: a mutable broken-down UTC time over an epoch-ms. setTime/
|
||||
;; getTime read/write it; set(field,value) recomputes ms from the field projection.
|
||||
;; Field constants are Java's int values so .set/.get dispatch on the right field.
|
||||
(define cal-YEAR 1) (define cal-MONTH 2) (define cal-DAY_OF_MONTH 5)
|
||||
(define cal-HOUR_OF_DAY 11) (define cal-MINUTE 12) (define cal-SECOND 13)
|
||||
(define cal-MILLISECOND 14)
|
||||
(define (cal-ms->fields ms) ; -> vector [y mo0 d hh mi ss frac] (MONTH 0-based, JVM)
|
||||
(let ((f (inst-fields ms)))
|
||||
(vector (list-ref f 0) (- (list-ref f 1) 1) (list-ref f 2)
|
||||
(list-ref f 3) (list-ref f 4) (list-ref f 5) (list-ref f 6))))
|
||||
(define (cal-fields->ms v)
|
||||
(+ (* 1000 (+ (* (days-from-civil (vector-ref v 0) (+ 1 (vector-ref v 1)) (vector-ref v 2)) 86400)
|
||||
(* (vector-ref v 3) 3600) (* (vector-ref v 4) 60) (vector-ref v 5)))
|
||||
(vector-ref v 6)))
|
||||
(define (cal-field-index fld)
|
||||
(cond ((= fld cal-YEAR) 0) ((= fld cal-MONTH) 1) ((= fld cal-DAY_OF_MONTH) 2)
|
||||
((= fld cal-HOUR_OF_DAY) 3) ((= fld cal-MINUTE) 4) ((= fld cal-SECOND) 5)
|
||||
((= fld cal-MILLISECOND) 6) (else #f)))
|
||||
(register-host-methods! "calendar"
|
||||
(list (cons "setTime" (lambda (self d) (vector-set! (jhost-state self) 0 (ms->exact (ms-of d))) jolt-nil))
|
||||
(cons "getTime" (lambda (self) (make-jinst (vector-ref (jhost-state self) 0))))
|
||||
(cons "getTimeInMillis" (lambda (self) (vector-ref (jhost-state self) 0)))
|
||||
(cons "setTimeInMillis" (lambda (self ms) (vector-set! (jhost-state self) 0 (ms->exact ms)) jolt-nil))
|
||||
(cons "set" (lambda (self field val)
|
||||
(let ((v (cal-ms->fields (vector-ref (jhost-state self) 0)))
|
||||
(idx (cal-field-index (jnum->exact field))))
|
||||
(when idx (vector-set! v idx (jnum->exact val))
|
||||
(vector-set! (jhost-state self) 0 (cal-fields->ms v)))
|
||||
jolt-nil)))
|
||||
(cons "get" (lambda (self field)
|
||||
(let ((v (cal-ms->fields (vector-ref (jhost-state self) 0)))
|
||||
(idx (cal-field-index (jnum->exact field))))
|
||||
(if idx (vector-ref v idx) 0))))))
|
||||
(define calendar-statics
|
||||
(list (cons "getInstance" (lambda _ (make-jhost "calendar" (vector (now-ms)))))
|
||||
(cons "YEAR" cal-YEAR) (cons "MONTH" cal-MONTH) (cons "DAY_OF_MONTH" cal-DAY_OF_MONTH)
|
||||
(cons "HOUR_OF_DAY" cal-HOUR_OF_DAY) (cons "MINUTE" cal-MINUTE)
|
||||
(cons "SECOND" cal-SECOND) (cons "MILLISECOND" cal-MILLISECOND)))
|
||||
(register-class-statics! "Calendar" calendar-statics)
|
||||
(register-class-statics! "java.util.Calendar" calendar-statics)
|
||||
|
||||
;; java.util.TimeZone: an opaque id holder (format-ms is UTC, so a non-UTC zone is
|
||||
;; not honored — only the UTC case the corpus uses is exercised).
|
||||
(define (timezone-of id) (make-jhost "timezone" (vector (if (string? id) id (jolt-str-render-one id)))))
|
||||
(define timezone-statics
|
||||
(list (cons "getTimeZone" timezone-of)
|
||||
(cons "getDefault" (lambda () (timezone-of "default")))))
|
||||
(register-class-statics! "TimeZone" timezone-statics)
|
||||
(register-class-statics! "java.util.TimeZone" timezone-statics)
|
||||
|
||||
;; java.text.SimpleDateFormat: holds a pattern; .setTimeZone is accepted (format-ms
|
||||
;; is UTC); .format(date) renders the date per the pattern via the format-ms engine.
|
||||
(define (sdf-ctor pat . _) (make-jhost "sdf" (vector (if (string? pat) pat (jolt-str-render-one pat)))))
|
||||
(register-class-ctor! "SimpleDateFormat" sdf-ctor)
|
||||
(register-class-ctor! "java.text.SimpleDateFormat" sdf-ctor)
|
||||
(register-host-methods! "sdf"
|
||||
(list (cons "setTimeZone" (lambda (self tz) jolt-nil))
|
||||
(cons "setLenient" (lambda (self b) jolt-nil))
|
||||
(cons "applyPattern" (lambda (self p) (vector-set! (jhost-state self) 0 (jolt-str-render-one p)) jolt-nil))
|
||||
(cons "toPattern" (lambda (self) (vector-ref (jhost-state self) 0)))
|
||||
(cons "parse" (lambda (self s) (parse-ms (vector-ref (jhost-state self) 0) (jolt-str-render-one s))))
|
||||
(cons "format" (lambda (self d) (format-ms (vector-ref (jhost-state self) 0) (ms-of d))))))
|
||||
|
||||
;; a jinst's java.util.Date method surface (record-method-dispatch arm).
|
||||
(define %it-rmd record-method-dispatch)
|
||||
(set! record-method-dispatch
|
||||
(lambda (obj method-name rest-args)
|
||||
(cond
|
||||
((jinst? obj)
|
||||
(cond ((string=? method-name "getTime") (jinst-ms obj))
|
||||
;; deprecated java.util.Date accessors (UTC civil fields).
|
||||
((string=? method-name "getYear") (- (list-ref (inst-fields (jinst-ms obj)) 0) 1900))
|
||||
((string=? method-name "getMonth") (- (list-ref (inst-fields (jinst-ms obj)) 1) 1))
|
||||
((string=? method-name "getDate") (list-ref (inst-fields (jinst-ms obj)) 2))
|
||||
((string=? method-name "getHours") (list-ref (inst-fields (jinst-ms obj)) 3))
|
||||
((string=? method-name "getMinutes") (list-ref (inst-fields (jinst-ms obj)) 4))
|
||||
((string=? method-name "getSeconds") (list-ref (inst-fields (jinst-ms obj)) 5))
|
||||
((string=? method-name "getDay") (list-ref (inst-fields (jinst-ms obj)) 7))
|
||||
((string=? method-name "toInstant") (mk-instant (jinst-ms obj)))
|
||||
((string=? method-name "toLocalDate") (mk-local-date (jinst-ms obj)))
|
||||
((string=? method-name "toLocalDateTime") (mk-local (jinst-ms obj)))
|
||||
((string=? method-name "toString") (inst-rfc3339 obj))
|
||||
((string=? method-name "equals") (and (pair? (if (jolt-nil? rest-args) '() (seq->list rest-args)))
|
||||
(jinst? (car (seq->list rest-args)))
|
||||
(= (jinst-ms obj) (jinst-ms (car (seq->list rest-args))))))
|
||||
((string=? method-name "before") (< (jinst-ms obj) (ms-of (car (seq->list rest-args)))))
|
||||
((string=? method-name "after") (> (jinst-ms obj) (ms-of (car (seq->list rest-args)))))
|
||||
(else (error #f (string-append "No method " method-name " on Date")))))
|
||||
(else (%it-rmd obj method-name rest-args)))))
|
||||
|
||||
;; Clojure's built-in data readers, so a library that merges default-data-readers
|
||||
;; or binds *data-readers* (e.g. aero's reader opts) resolves #inst / #uuid.
|
||||
;; Keyed by symbol, like Clojure. *data-readers* is the bindable user table.
|
||||
(def-var! "clojure.core" "default-data-readers"
|
||||
(jolt-hash-map (jolt-symbol #f "inst") jolt-inst-from-string
|
||||
(jolt-symbol #f "uuid") jolt-uuid-from-string))
|
||||
(def-var! "clojure.core" "*data-readers*" empty-pmap)
|
||||
333
host/chez/java/io-streams.ss
Normal file
333
host/chez/java/io-streams.ss
Normal file
|
|
@ -0,0 +1,333 @@
|
|||
;; java.io byte/char streams over Chez ports. Each stream is a jhost wrapping a
|
||||
;; Chez port, so buffering, EOF and binary<->char transcoding come from Chez
|
||||
;; rather than a hand-rolled buffer.
|
||||
;;
|
||||
;; in-stream #(binary-input-port) FileInputStream / ByteArrayInputStream
|
||||
;; out-stream #(binary-output-port extract acc) FileOutputStream / ByteArrayOutputStream
|
||||
;; char-reader #(textual-input-port) FileReader / InputStreamReader
|
||||
;; char-writer #(textual-output-port) FileWriter / OutputStreamWriter
|
||||
;;
|
||||
;; Buffered{Reader,Writer,Input,Output}Stream are buffering wrappers; Chez ports
|
||||
;; are already buffered, so their constructors return the wrapped stream.
|
||||
;;
|
||||
;; Loaded after io.ss + natives-array.ss (uses make-jfile/slurp helpers + the
|
||||
;; byte-array <-> bytevector bridge), and extends io.ss's reader-jhost? / slurp /
|
||||
;; __close so the new readers/streams flow through slurp / line-seq / with-open.
|
||||
|
||||
;; --- byte input stream ------------------------------------------------------
|
||||
(define (in-stream-port self) (vector-ref (jhost-state self) 0))
|
||||
(define (make-in-stream port) (make-jhost "in-stream" (vector port)))
|
||||
(define (in-stream? x) (and (jhost? x) (string=? (jhost-tag x) "in-stream")))
|
||||
(register-host-methods! "in-stream"
|
||||
(list
|
||||
(cons "read"
|
||||
(lambda (self . rest)
|
||||
(let ((port (in-stream-port self)))
|
||||
(if (null? rest)
|
||||
(let ((b (get-u8 port))) (if (eof-object? b) -1 (->num b)))
|
||||
(let* ((buf (car rest))
|
||||
(vec (jolt-array-vec buf))
|
||||
(off (if (>= (length rest) 3) (jnum->exact (cadr rest)) 0))
|
||||
(len (if (>= (length rest) 3) (jnum->exact (caddr rest)) (vector-length vec))))
|
||||
(let loop ((i 0))
|
||||
(if (>= i len) (->num i)
|
||||
(let ((b (get-u8 port)))
|
||||
(if (eof-object? b)
|
||||
(if (= i 0) -1 (->num i))
|
||||
(begin (vector-set! vec (+ off i) b) (loop (+ i 1))))))))))))
|
||||
(cons "readAllBytes" (lambda (self) (let ((bv (get-bytevector-all (in-stream-port self))))
|
||||
(na-byte-array (if (eof-object? bv) (make-bytevector 0) bv)))))
|
||||
(cons "skip" (lambda (self n) (let ((bv (get-bytevector-n (in-stream-port self) (jnum->exact n))))
|
||||
(->num (if (eof-object? bv) 0 (bytevector-length bv))))))
|
||||
(cons "available" (lambda (self) (->num 0)))
|
||||
(cons "close" (lambda (self) (close-port (in-stream-port self)) jolt-nil))
|
||||
(cons "mark" (lambda (self . _) jolt-nil))
|
||||
(cons "reset" (lambda (self) (guard (e (#t jolt-nil)) (set-port-position! (in-stream-port self) 0) jolt-nil)))
|
||||
(cons "markSupported" (lambda (self) #f))
|
||||
(cons "toString" (lambda (self) "#<InputStream>"))))
|
||||
|
||||
;; --- byte output stream -----------------------------------------------------
|
||||
;; state #(port extract acc): extract/acc are #f for a file/passthrough stream;
|
||||
;; a ByteArrayOutputStream carries the R6RS extraction proc + an accumulator
|
||||
;; bytevector (Chez's extract resets the port, so snapshot on demand, not per write).
|
||||
(define (out-stream-port self) (vector-ref (jhost-state self) 0))
|
||||
(define (out-stream? x) (and (jhost? x) (string=? (jhost-tag x) "out-stream")))
|
||||
(define (make-out-stream port) (make-jhost "out-stream" (vector port #f #f)))
|
||||
(define (bv-concat a b)
|
||||
(if (= 0 (bytevector-length b)) a
|
||||
(let ((m (make-bytevector (+ (bytevector-length a) (bytevector-length b)))))
|
||||
(bytevector-copy! a 0 m 0 (bytevector-length a))
|
||||
(bytevector-copy! b 0 m (bytevector-length a) (bytevector-length b))
|
||||
m)))
|
||||
;; all bytes written to a ByteArrayOutputStream so far (folds the latest extract
|
||||
;; into the accumulator).
|
||||
(define (baos-bytes self)
|
||||
(let* ((st (jhost-state self)) (port (vector-ref st 0)) (extract (vector-ref st 1)) (acc (vector-ref st 2)))
|
||||
(flush-output-port port)
|
||||
(let ((merged (bv-concat acc (extract))))
|
||||
(vector-set! st 2 merged) merged)))
|
||||
(register-host-methods! "out-stream"
|
||||
(list
|
||||
(cons "write"
|
||||
(lambda (self x . rest)
|
||||
(let ((port (out-stream-port self)))
|
||||
(cond
|
||||
((number? x) (put-u8 port (bitwise-and (jnum->exact x) #xff)))
|
||||
((and (jolt-array? x) (eq? (jolt-array-kind x) 'byte))
|
||||
(let ((bv (na-bytearray->bv x)))
|
||||
(if (pair? rest)
|
||||
(put-bytevector port bv (jnum->exact (car rest)) (jnum->exact (cadr rest)))
|
||||
(put-bytevector port bv))))
|
||||
((bytevector? x) (put-bytevector port x))
|
||||
(else (error #f "OutputStream/write: unsupported" x)))
|
||||
jolt-nil)))
|
||||
(cons "flush" (lambda (self) (flush-output-port (out-stream-port self)) jolt-nil))
|
||||
(cons "close" (lambda (self) (flush-output-port (out-stream-port self))
|
||||
;; a ByteArrayOutputStream's close is a no-op (toByteArray stays valid);
|
||||
;; a file stream's port is closed.
|
||||
(unless (vector-ref (jhost-state self) 1) (close-port (out-stream-port self))) jolt-nil))
|
||||
(cons "toByteArray" (lambda (self) (na-byte-array (bytevector-copy (baos-bytes self)))))
|
||||
(cons "size" (lambda (self) (->num (bytevector-length (baos-bytes self)))))
|
||||
(cons "reset" (lambda (self) (baos-bytes self) (vector-set! (jhost-state self) 2 (make-bytevector 0)) jolt-nil))
|
||||
(cons "toString" (lambda (self . cs) (decode-bytevector (baos-bytes self)
|
||||
(if (pair? cs) (list (jolt-str-render-one (car cs))) '()))))))
|
||||
|
||||
;; --- char input (Reader) ----------------------------------------------------
|
||||
(define (char-reader-port self) (vector-ref (jhost-state self) 0))
|
||||
(define (char-reader? x) (and (jhost? x) (string=? (jhost-tag x) "char-reader")))
|
||||
(define (make-char-reader port) (make-jhost "char-reader" (vector port)))
|
||||
(register-host-methods! "char-reader"
|
||||
(list
|
||||
(cons "read"
|
||||
(lambda (self . rest)
|
||||
(let ((port (char-reader-port self)))
|
||||
(if (null? rest)
|
||||
(let ((c (get-char port))) (if (eof-object? c) -1 (->num (char->integer c))))
|
||||
(let* ((buf (car rest))
|
||||
(vec (jolt-array-vec buf))
|
||||
(off (if (>= (length rest) 3) (jnum->exact (cadr rest)) 0))
|
||||
(len (if (>= (length rest) 3) (jnum->exact (caddr rest)) (vector-length vec))))
|
||||
(let loop ((i 0))
|
||||
(if (>= i len) (->num i)
|
||||
(let ((c (get-char port)))
|
||||
(if (eof-object? c)
|
||||
(if (= i 0) -1 (->num i))
|
||||
(begin (vector-set! vec (+ off i) c) (loop (+ i 1))))))))))))
|
||||
(cons "readLine" (lambda (self) (let ((l (get-line (char-reader-port self)))) (if (eof-object? l) jolt-nil l))))
|
||||
(cons "lines" (lambda (self)
|
||||
(let loop ((acc '()))
|
||||
(let ((l (get-line (char-reader-port self))))
|
||||
(if (eof-object? l) (list->cseq (reverse acc)) (loop (cons l acc)))))))
|
||||
(cons "ready" (lambda (self) #t))
|
||||
(cons "skip" (lambda (self n) (let loop ((i 0) (k (jnum->exact n)))
|
||||
(if (or (>= i k) (eof-object? (get-char (char-reader-port self)))) (->num i)
|
||||
(loop (+ i 1) k)))))
|
||||
(cons "close" (lambda (self) (close-port (char-reader-port self)) jolt-nil))
|
||||
(cons "mark" (lambda (self . _) jolt-nil))
|
||||
(cons "reset" (lambda (self) (guard (e (#t jolt-nil)) (set-port-position! (char-reader-port self) 0) jolt-nil)))
|
||||
(cons "toString" (lambda (self) "#<Reader>"))))
|
||||
|
||||
;; --- char output (Writer) ---------------------------------------------------
|
||||
(define (char-writer-port self) (vector-ref (jhost-state self) 0))
|
||||
(define (char-writer? x) (and (jhost? x) (string=? (jhost-tag x) "char-writer")))
|
||||
(define (make-char-writer port) (make-jhost "char-writer" (vector port)))
|
||||
(define (cw-text x) (if (number? x) (string (integer->char (jnum->exact x))) (jolt-str-render-one x)))
|
||||
(register-host-methods! "char-writer"
|
||||
(list
|
||||
(cons "write" (lambda (self x . rest)
|
||||
;; (write str) | (write int) | (write str off len)
|
||||
(let ((s (cw-text x)))
|
||||
(put-string (char-writer-port self)
|
||||
(if (>= (length rest) 2) (substring s (jnum->exact (car rest))
|
||||
(+ (jnum->exact (car rest)) (jnum->exact (cadr rest)))) s)))
|
||||
jolt-nil))
|
||||
(cons "append" (lambda (self x . rest) (put-string (char-writer-port self) (cw-text x)) self))
|
||||
(cons "newLine" (lambda (self) (put-char (char-writer-port self) #\newline) jolt-nil))
|
||||
(cons "flush" (lambda (self) (flush-output-port (char-writer-port self)) jolt-nil))
|
||||
(cons "close" (lambda (self) (close-port (char-writer-port self)) jolt-nil))
|
||||
(cons "toString" (lambda (self) "#<Writer>"))))
|
||||
|
||||
;; --- constructors -----------------------------------------------------------
|
||||
(define utf8-tx (make-transcoder (utf-8-codec)))
|
||||
(define (path-of x) (project-relative (file-path-of x)))
|
||||
(define (src-bytevector x) ; a byte[] or Chez bytevector -> bytevector
|
||||
(cond ((bytevector? x) x)
|
||||
((and (jolt-array? x) (eq? (jolt-array-kind x) 'byte)) (na-bytearray->bv x))
|
||||
(else (error #f "expected a byte array" x))))
|
||||
|
||||
(define (reg-ctor! names ctor) (for-each (lambda (n) (register-class-ctor! n ctor)) names))
|
||||
|
||||
(reg-ctor! '("FileInputStream" "java.io.FileInputStream")
|
||||
(lambda (src . _) (make-in-stream (open-file-input-port (path-of src) (file-options) (buffer-mode block)))))
|
||||
(reg-ctor! '("FileOutputStream" "java.io.FileOutputStream")
|
||||
(lambda (src . rest)
|
||||
(let ((append? (and (pair? rest) (jolt-truthy? (car rest)))))
|
||||
(make-out-stream (open-file-output-port (path-of src)
|
||||
(if append? (file-options no-fail no-truncate append) (file-options no-fail))
|
||||
(buffer-mode block))))))
|
||||
(reg-ctor! '("ByteArrayInputStream" "java.io.ByteArrayInputStream")
|
||||
(lambda (bytes . rest)
|
||||
(let ((bv (src-bytevector bytes)))
|
||||
(make-in-stream (open-bytevector-input-port
|
||||
(if (>= (length rest) 2)
|
||||
(let ((off (jnum->exact (car rest))) (len (jnum->exact (cadr rest))))
|
||||
(let ((sub (make-bytevector len))) (bytevector-copy! bv off sub 0 len) sub))
|
||||
bv))))))
|
||||
(reg-ctor! '("ByteArrayOutputStream" "java.io.ByteArrayOutputStream")
|
||||
(lambda _
|
||||
(call-with-values open-bytevector-output-port
|
||||
(lambda (port extract) (make-jhost "out-stream" (vector port extract (make-bytevector 0)))))))
|
||||
(reg-ctor! '("FileReader" "java.io.FileReader")
|
||||
(lambda (src . _) (make-char-reader (transcoded-port (open-file-input-port (path-of src) (file-options) (buffer-mode block)) utf8-tx))))
|
||||
(reg-ctor! '("FileWriter" "java.io.FileWriter")
|
||||
(lambda (src . rest)
|
||||
(let ((append? (and (pair? rest) (jolt-truthy? (car rest)))))
|
||||
(make-char-writer (transcoded-port (open-file-output-port (path-of src)
|
||||
(if append? (file-options no-fail no-truncate append) (file-options no-fail))
|
||||
(buffer-mode block)) utf8-tx)))))
|
||||
;; InputStreamReader / OutputStreamWriter take ownership of the wrapped byte
|
||||
;; stream's port and transcode it (UTF-8 default; an explicit charset is honored
|
||||
;; only as UTF-8 here).
|
||||
(reg-ctor! '("InputStreamReader" "java.io.InputStreamReader")
|
||||
(lambda (in . _) (make-char-reader (transcoded-port (in-stream-port in) utf8-tx))))
|
||||
(reg-ctor! '("OutputStreamWriter" "java.io.OutputStreamWriter")
|
||||
(lambda (out . _) (make-char-writer (transcoded-port (out-stream-port out) utf8-tx))))
|
||||
;; Buffered* — Chez ports are buffered already; the wrapper is the wrapped stream.
|
||||
(for-each (lambda (n) (register-class-ctor! n (lambda (inner . _) inner)))
|
||||
'("BufferedReader" "java.io.BufferedReader"
|
||||
"BufferedWriter" "java.io.BufferedWriter"
|
||||
"BufferedInputStream" "java.io.BufferedInputStream"
|
||||
"BufferedOutputStream" "java.io.BufferedOutputStream"))
|
||||
|
||||
;; --- integration: slurp / line-seq / with-open ------------------------------
|
||||
;; a char-reader joins the reader-jhost set (drain-reader / line-seq read it via
|
||||
;; its .read method).
|
||||
(let ((prev reader-jhost?))
|
||||
(set! reader-jhost? (lambda (x) (or (char-reader? x) (prev x)))))
|
||||
|
||||
;; slurp a char-reader (drain chars) or a byte in-stream (drain bytes -> decode).
|
||||
(let ((prev jolt-slurp))
|
||||
(set! jolt-slurp
|
||||
(lambda (src . opts)
|
||||
(cond
|
||||
((char-reader? src) (drain-reader src))
|
||||
((in-stream? src) (decode-bytevector (let ((bv (get-bytevector-all (in-stream-port src))))
|
||||
(if (eof-object? bv) (make-bytevector 0) bv))
|
||||
(slurp-encoding opts)))
|
||||
(else (apply prev src opts)))))
|
||||
(def-var! "clojure.core" "slurp" jolt-slurp))
|
||||
|
||||
;; with-open closes the new stream jhosts via their .close method.
|
||||
(let ((prev jolt-close))
|
||||
(set! jolt-close
|
||||
(lambda (x)
|
||||
(if (and (jhost? x) (member (jhost-tag x) '("in-stream" "out-stream" "char-reader" "char-writer")))
|
||||
(begin (record-method-dispatch x "close" jolt-nil) jolt-nil)
|
||||
(prev x))))
|
||||
(def-var! "clojure.core" "__close" jolt-close))
|
||||
|
||||
;; --- clojure.java.io: byte streams + copy / make-parents / delete-file -------
|
||||
;; input-stream/output-stream now yield real byte streams (were char reader/writer).
|
||||
(define (jio-input-stream x)
|
||||
(cond ((in-stream? x) x)
|
||||
((jfile? x) (make-in-stream (open-file-input-port (jfile-fs x) (file-options) (buffer-mode block))))
|
||||
((and (jolt-array? x) (eq? (jolt-array-kind x) 'byte)) (make-in-stream (open-bytevector-input-port (na-bytearray->bv x))))
|
||||
((bytevector? x) (make-in-stream (open-bytevector-input-port x)))
|
||||
((and (jhost? x) (string=? (jhost-tag x) "url")) (make-in-stream (open-file-input-port (url-strip-scheme (url-spec x)) (file-options) (buffer-mode block))))
|
||||
((string? x) (make-in-stream (open-file-input-port (project-relative x) (file-options) (buffer-mode block))))
|
||||
(else (error #f "io/input-stream: don't know how to open" x))))
|
||||
(define (jio-output-stream x . rest)
|
||||
(cond ((out-stream? x) x)
|
||||
((or (jfile? x) (string? x))
|
||||
(let ((append? (let loop ((o rest)) (cond ((or (null? o) (null? (cdr o))) #f)
|
||||
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "append") (jolt-truthy? (cadr o))) #t)
|
||||
(else (loop (cddr o)))))))
|
||||
(make-out-stream (open-file-output-port (path-of x)
|
||||
(if append? (file-options no-fail no-truncate append) (file-options no-fail))
|
||||
(buffer-mode block)))))
|
||||
(else (error #f "io/output-stream: don't know how to open" x))))
|
||||
(def-var! "clojure.java.io" "input-stream" jio-input-stream)
|
||||
(def-var! "clojure.java.io" "output-stream" jio-output-stream)
|
||||
|
||||
;; io/make-parents: create the parent directories of the last path segment.
|
||||
(define (jio-make-parents . args)
|
||||
(let ((p (apply-make-file-path args)))
|
||||
(let loop ((i (- (string-length p) 1)))
|
||||
(cond ((<= i 0) #f)
|
||||
((char=? (string-ref p i) #\/) (mkdirs! (substring p 0 i)))
|
||||
(else (loop (- i 1)))))))
|
||||
(define (apply-make-file-path args)
|
||||
(jfile-path (apply jolt-make-file args)))
|
||||
(def-var! "clojure.java.io" "make-parents" jio-make-parents)
|
||||
|
||||
;; io/delete-file: delete the file; raise unless :silently truthy.
|
||||
(define (jio-delete-file f . opts)
|
||||
(let ((p (file-path-of f)))
|
||||
(if (delete-path! p) jolt-nil
|
||||
(if (and (pair? opts) (jolt-truthy? (car opts))) jolt-nil
|
||||
(error #f (string-append "Couldn't delete " p))))))
|
||||
(def-var! "clojure.java.io" "delete-file" jio-delete-file)
|
||||
|
||||
;; io/copy: file/path/reader/stream/string/byte[] -> writer/stream/file/path.
|
||||
;; A byte source copies byte-exact to a byte/file destination (no lossy text
|
||||
;; round-trip); otherwise the content is read as text. UTF-8 bridges byte<->char.
|
||||
(define (input-bytes input) ; bytevector for a byte source, else #f
|
||||
(cond ((in-stream? input) (let ((bv (get-bytevector-all (in-stream-port input)))) (if (eof-object? bv) (make-bytevector 0) bv)))
|
||||
((bytevector? input) input)
|
||||
((and (jolt-array? input) (eq? (jolt-array-kind input) 'byte)) (na-bytearray->bv input))
|
||||
;; a byte-input-stream shim (host tagged-table, :jolt/input-stream — e.g.
|
||||
;; http-client's ByteArrayInputStream): drain it byte-exact, like slurp.
|
||||
((and (htable? input) (jolt-truthy? (jolt-ref-get input (keyword "jolt" "input-stream"))))
|
||||
(drain-byte-stream input))
|
||||
(else #f)))
|
||||
(define (input-text input)
|
||||
(cond ((string? input) input)
|
||||
((or (char-reader? input) (reader-jhost? input)) (drain-reader input))
|
||||
((jfile? input) (jolt-slurp input))
|
||||
((input-bytes input) => (lambda (bv) (decode-bytevector bv '())))
|
||||
(else (jolt-str-render-one input))))
|
||||
(define (jio-copy input output . opts)
|
||||
(cond
|
||||
((out-stream? output)
|
||||
(put-bytevector (out-stream-port output)
|
||||
(or (input-bytes input) (string->utf8 (input-text input)))))
|
||||
((char-writer? output) (put-string (char-writer-port output) (input-text input)))
|
||||
((and (jhost? output) (member (jhost-tag output) '("writer" "file-writer" "port-writer" "print-writer")))
|
||||
(record-method-dispatch output "write" (list->cseq (list (input-text input)))))
|
||||
((or (jfile? output) (string? output))
|
||||
(let ((bv (and (not (string? input)) (not (jfile? input)) (input-bytes input))))
|
||||
(if bv
|
||||
(let ((port (open-file-output-port (path-of output) (file-options no-fail) (buffer-mode block))))
|
||||
(put-bytevector port bv) (close-port port))
|
||||
(jolt-spit output (input-text input)))))
|
||||
;; a byte-output-stream shim (a host tagged-table with :jolt/output-stream,
|
||||
;; e.g. http-client's ByteArrayOutputStream): write through its .write method,
|
||||
;; byte-exact for a byte source.
|
||||
((and (htable? output) (jolt-truthy? (jolt-ref-get output (keyword "jolt" "output-stream"))))
|
||||
(let ((bv (input-bytes input)))
|
||||
(record-method-dispatch output "write"
|
||||
(list->cseq (list (if bv (make-jolt-array (list->vector (bytevector->u8-list bv)) 'byte)
|
||||
(input-text input)))))))
|
||||
(else (error #f "io/copy: don't know how to write to" output)))
|
||||
jolt-nil)
|
||||
(def-var! "clojure.java.io" "copy" jio-copy)
|
||||
|
||||
;; --- instance? for the java.io stream taxonomy ------------------------------
|
||||
(register-class-arm! in-stream? (lambda (x) "java.io.InputStream"))
|
||||
(register-class-arm! out-stream? (lambda (x) "java.io.OutputStream"))
|
||||
(register-class-arm! char-reader? (lambda (x) "java.io.Reader"))
|
||||
(register-class-arm! char-writer? (lambda (x) "java.io.Writer"))
|
||||
(register-instance-check-arm!
|
||||
(lambda (type-sym val)
|
||||
(if (not (symbol-t? type-sym)) 'pass
|
||||
(let ((short (last-dot (symbol-t-name type-sym))))
|
||||
(cond
|
||||
((and (in-stream? val) (member short '("InputStream" "FileInputStream" "ByteArrayInputStream"
|
||||
"BufferedInputStream" "FilterInputStream" "Closeable" "AutoCloseable"))) #t)
|
||||
((and (out-stream? val) (member short '("OutputStream" "FileOutputStream" "ByteArrayOutputStream"
|
||||
"BufferedOutputStream" "FilterOutputStream" "Closeable" "AutoCloseable" "Flushable"))) #t)
|
||||
((and (char-reader? val) (member short '("Reader" "BufferedReader" "FileReader" "InputStreamReader"
|
||||
"Closeable" "AutoCloseable" "Readable"))) #t)
|
||||
((and (char-writer? val) (member short '("Writer" "BufferedWriter" "FileWriter" "OutputStreamWriter"
|
||||
"Closeable" "AutoCloseable" "Flushable" "Appendable"))) #t)
|
||||
(else 'pass))))))
|
||||
617
host/chez/java/io.ss
Normal file
617
host/chez/java/io.ss
Normal file
|
|
@ -0,0 +1,617 @@
|
|||
;; java.io.File + host file I/O, implemented over Chez's filesystem
|
||||
;; primitives. A File is a
|
||||
;; path-backed jfile record: (instance? java.io.File f) is true, str/slurp coerce
|
||||
;; it to its path, and the File method surface (getName/getPath/exists/
|
||||
;; isDirectory/isFile/listFiles) dispatches through record-method-dispatch.
|
||||
;;
|
||||
;; Provides make-file/file?/slurp/spit/flush/dir?/
|
||||
;; list-dir for the overlay file-seq (20-coll.clj), which calls __file?/__dir?/
|
||||
;; __list-dir + the .isDirectory/.listFiles/.isFile method surface.
|
||||
;;
|
||||
;; Loaded LAST in rt.ss, after
|
||||
;; dot-forms.ss (so the jfile method arm wraps the fully-built dispatch) and
|
||||
;; natives-meta.ss / records.ss / printing.ss (jolt-type / instance-check /
|
||||
;; jolt-str-render-one, which it extends).
|
||||
|
||||
(define-record-type jfile (fields path) (nongenerative jolt-jfile-v1))
|
||||
(define (jolt-file? x) (jfile? x))
|
||||
|
||||
;; path string of any value: a jfile -> its path, else its str rendering.
|
||||
(define (file-path-of x) (if (jfile? x) (jfile-path x) (jolt-str-render-one x)))
|
||||
|
||||
;; Resources baked into a standalone binary by `jolt build` (deps.edn
|
||||
;; :jolt/build :embed). The build emits a register-embedded-resource! per file at
|
||||
;; heap-build time, so the contents live in the boot image — io/resource serves
|
||||
;; them with no file on disk. An embedded hit reads through slurp/reader exactly
|
||||
;; like a jfile would.
|
||||
(define embedded-resources (make-hashtable equal-hash equal?))
|
||||
(define (register-embedded-resource! name content)
|
||||
(hashtable-set! embedded-resources name content))
|
||||
(define-record-type embedded-res (fields name content) (nongenerative jolt-embres-v1))
|
||||
|
||||
;; A user-facing relative path resolves against JOLT_PWD — the user's cwd before
|
||||
;; the launcher cd'd to the jolt repo root — matching the JVM, where io/file is
|
||||
;; cwd-relative. (io/resource builds jfiles from the source roots directly, so it
|
||||
;; isn't routed through here.)
|
||||
(define (project-relative p)
|
||||
(if (or (= (string-length p) 0) (char=? (string-ref p 0) #\/))
|
||||
p
|
||||
(let ((pwd (getenv "JOLT_PWD")))
|
||||
(if (and pwd (> (string-length pwd) 0)) (string-append pwd "/" p) p))))
|
||||
|
||||
;; (io/file path) / (io/file parent child) — join children with "/". The File
|
||||
;; keeps the path AS GIVEN (like the JVM: new File("rel").getPath() is "rel");
|
||||
;; a relative path resolves against JOLT_PWD only when the filesystem is touched
|
||||
;; (jfile-fs / slurp / spit / the stream constructors).
|
||||
(define (jolt-make-file path . rest)
|
||||
(let loop ((p (file-path-of path)) (cs rest))
|
||||
(if (null? cs) (make-jfile p)
|
||||
(loop (string-append p "/" (file-path-of (car cs))) (cdr cs)))))
|
||||
;; the on-disk path of a value: a relative path resolves against JOLT_PWD.
|
||||
(define (jfile-fs f) (project-relative (file-path-of f)))
|
||||
|
||||
(define (path-last-segment p)
|
||||
(let loop ((i (- (string-length p) 1)))
|
||||
(cond ((< i 0) p)
|
||||
((char=? (string-ref p i) #\/) (substring p (+ i 1) (string-length p)))
|
||||
(else (loop (- i 1))))))
|
||||
|
||||
;; directory children as full paths, sorted (the __list-dir seed primitive).
|
||||
(define (jolt-list-dir path)
|
||||
(let ((p (project-relative (file-path-of path))))
|
||||
(map (lambda (e) (string-append p "/" e))
|
||||
(sort string<? (directory-list p)))))
|
||||
(define (jolt-dir? path) (if (file-directory? (project-relative (file-path-of path))) #t #f))
|
||||
|
||||
;; absolute path string (cwd-relative paths resolved against current-directory).
|
||||
(define (jfile-abs p)
|
||||
(if (and (> (string-length p) 0) (char=? (string-ref p 0) #\/)) p
|
||||
(string-append (current-directory) "/" p)))
|
||||
|
||||
;; --- file metadata over Chez filesystem ops ---------------------------------
|
||||
;; byte size of a regular file (0 for a directory or a missing file).
|
||||
(define (file-byte-size p)
|
||||
(if (or (not (file-exists? p)) (file-directory? p)) 0
|
||||
(let ((port (open-file-input-port p))) (let ((n (file-length port))) (close-port port) n))))
|
||||
;; last-modified as epoch milliseconds (0 if the file is absent).
|
||||
(define (file-mtime-millis p)
|
||||
(if (file-exists? p)
|
||||
(let ((t (file-modification-time p)))
|
||||
(+ (* (time-second t) 1000) (div (time-nanosecond t) 1000000)))
|
||||
0))
|
||||
;; mkdir -p: create p and any missing parents. Returns #t if p ends up a dir.
|
||||
(define (mkdirs! p)
|
||||
(unless (or (= 0 (string-length p)) (file-exists? p))
|
||||
(let loop ((i (- (string-length p) 1)))
|
||||
(cond ((<= i 0) #f)
|
||||
((char=? (string-ref p i) #\/)
|
||||
(let ((parent (substring p 0 i))) (unless (file-exists? parent) (mkdirs! parent))))
|
||||
(else (loop (- i 1)))))
|
||||
(guard (e (#t #f)) (mkdir p)))
|
||||
(and (file-exists? p) (file-directory? p)))
|
||||
;; delete a file or an (empty) directory; #t on success.
|
||||
(define (delete-path! p)
|
||||
(guard (e (#t #f))
|
||||
(cond ((not (file-exists? p)) #f)
|
||||
((file-directory? p) (delete-directory p) #t)
|
||||
(else (delete-file p) #t))))
|
||||
|
||||
;; --- java.net.URL (a jhost "url", state #(spec)) ----------------------------
|
||||
;; A File.toURL value: .toString / .toExternalForm give the spec, .getPath /
|
||||
;; .getFile strip the "file:" scheme.
|
||||
(define (make-url spec) (make-jhost "url" (vector spec)))
|
||||
(define (url-spec u) (vector-ref (jhost-state u) 0))
|
||||
(define (url-strip-scheme spec)
|
||||
(if (and (>= (string-length spec) 5) (string=? (substring spec 0 5) "file:"))
|
||||
(substring spec 5 (string-length spec)) spec))
|
||||
(define (url-protocol spec)
|
||||
(let ((i (let loop ((j 0)) (cond ((>= j (string-length spec)) #f)
|
||||
((char=? (string-ref spec j) #\:) j) (else (loop (+ j 1)))))))
|
||||
(if i (substring spec 0 i) "")))
|
||||
;; (java.net.URL. spec) — a basic file/http URL value (a library may register a
|
||||
;; richer URL shim, which overrides this).
|
||||
(register-class-ctor! "URL" (lambda (spec . _) (make-url (jolt-str-render-one spec))))
|
||||
(register-class-ctor! "java.net.URL" (lambda (spec . _) (make-url (jolt-str-render-one spec))))
|
||||
(register-host-methods! "url"
|
||||
(list (cons "toString" (lambda (self) (url-spec self)))
|
||||
(cons "toExternalForm" (lambda (self) (url-spec self)))
|
||||
(cons "getProtocol" (lambda (self) (url-protocol (url-spec self))))
|
||||
(cons "getPath" (lambda (self) (url-strip-scheme (url-spec self))))
|
||||
(cons "getFile" (lambda (self) (url-strip-scheme (url-spec self))))))
|
||||
|
||||
;; --- File method surface (record-method-dispatch arm) -----------------------
|
||||
(define (jfile-method f name args) ; -> boxed result, or #f to fall through
|
||||
(let ((p (jfile-path f)) ; the path as given (display methods)
|
||||
(fp (jfile-fs f))) ; JOLT_PWD-resolved on-disk path (FS methods)
|
||||
(cond
|
||||
((string=? name "getPath") (list p))
|
||||
((string=? name "getName") (list (path-last-segment p)))
|
||||
((string=? name "toString") (list p))
|
||||
((string=? name "getAbsolutePath")(list (jfile-abs fp)))
|
||||
((string=? name "getCanonicalPath")(list (jfile-abs fp)))
|
||||
((string=? name "toURI") (list (string-append "file:" (jfile-abs fp))))
|
||||
((string=? name "toURL") (list (make-url (string-append "file:" (jfile-abs fp)))))
|
||||
;; io/resource returns a File where the JVM returns a file: URL; answer the
|
||||
;; two URL methods resource-serving middleware (ring) calls on the result, so
|
||||
;; it sees a "file" protocol and a path without changing the return type.
|
||||
((string=? name "getProtocol") (list "file"))
|
||||
((string=? name "getFile") (list (jfile-abs fp)))
|
||||
((string=? name "exists") (list (if (file-exists? fp) #t #f)))
|
||||
((string=? name "isDirectory") (list (if (file-directory? fp) #t #f)))
|
||||
((string=? name "isFile") (list (if (and (file-exists? fp) (not (file-directory? fp))) #t #f)))
|
||||
((string=? name "isAbsolute") (list (if (and (> (string-length p) 0) (char=? (string-ref p 0) #\/)) #t #f)))
|
||||
((string=? name "listFiles") (list (list->cseq (map make-jfile (jolt-list-dir fp)))))
|
||||
;; .list -> the child NAMES (a String[]), nil if not a directory.
|
||||
((string=? name "list")
|
||||
(list (if (file-directory? fp)
|
||||
(apply jolt-vector (sort string<? (directory-list fp)))
|
||||
jolt-nil)))
|
||||
((string=? name "length") (list (->num (file-byte-size fp))))
|
||||
((string=? name "lastModified") (list (->num (file-mtime-millis fp))))
|
||||
((string=? name "canRead") (list (if (file-exists? fp) #t #f)))
|
||||
((string=? name "canWrite") (list (if (file-exists? fp) #t #f)))
|
||||
((string=? name "canExecute") (list (if (file-exists? fp) #t #f)))
|
||||
((string=? name "isHidden") (list (let ((nm (path-last-segment p)))
|
||||
(if (and (> (string-length nm) 0) (char=? (string-ref nm 0) #\.)) #t #f))))
|
||||
((string=? name "mkdir") (list (guard (e (#t #f)) (and (not (file-exists? fp)) (begin (mkdir fp) #t)))))
|
||||
((string=? name "mkdirs") (list (if (mkdirs! fp) #t #f)))
|
||||
((string=? name "delete") (list (if (delete-path! fp) #t #f)))
|
||||
((string=? name "deleteOnExit") (list jolt-nil))
|
||||
((string=? name "setLastModified")(list #t))
|
||||
((string=? name "createNewFile")
|
||||
(list (if (file-exists? fp) #f
|
||||
(guard (e (#t #f)) (close-port (open-output-file fp 'truncate)) #t))))
|
||||
((string=? name "renameTo")
|
||||
(list (let ((dst (jfile-fs (car args)))) (guard (e (#t #f)) (rename-file fp dst) #t))))
|
||||
((string=? name "getParentFile")
|
||||
(let loop ((i (- (string-length p) 1)))
|
||||
(cond ((< i 0) (list jolt-nil))
|
||||
((char=? (string-ref p i) #\/) (list (make-jfile (if (= i 0) "/" (substring p 0 i)))))
|
||||
(else (loop (- i 1))))))
|
||||
((string=? name "getAbsoluteFile") (list (make-jfile (jfile-abs p))))
|
||||
((string=? name "getCanonicalFile") (list (make-jfile (jfile-abs p))))
|
||||
((string=? name "compareTo") (list (->num (let ((o (file-path-of (car args))))
|
||||
(cond ((string<? p o) -1) ((string>? p o) 1) (else 0))))))
|
||||
((string=? name "equals") (list (and (jfile? (car args)) (string=? p (jfile-path (car args))))))
|
||||
((string=? name "hashCode") (list (->num (string-hash p))))
|
||||
((string=? name "getParent")
|
||||
(let loop ((i (- (string-length p) 1)))
|
||||
(cond ((< i 0) (list jolt-nil))
|
||||
((char=? (string-ref p i) #\/) (list (if (= i 0) "/" (substring p 0 i))))
|
||||
(else (loop (- i 1))))))
|
||||
(else #f))))
|
||||
|
||||
(define %io-rmd record-method-dispatch)
|
||||
(set! record-method-dispatch
|
||||
(lambda (obj method-name rest-args)
|
||||
(if (jfile? obj)
|
||||
(let* ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args)))
|
||||
(r (jfile-method obj method-name rest)))
|
||||
(if r (car r) (error #f "no File method" method-name)))
|
||||
(%io-rmd obj method-name rest-args))))
|
||||
|
||||
;; .isDirectory / .listFiles emit to jolt-host-call (rt.ss), not record-method-
|
||||
;; dispatch — the shims there assume a path STRING target. Make them jfile-aware
|
||||
;; so file-seq's File branch works.
|
||||
(define %io-host-call jolt-host-call)
|
||||
(set! jolt-host-call
|
||||
(lambda (method target . args)
|
||||
(cond
|
||||
((and (jfile? target) (string=? method "isDirectory"))
|
||||
(if (file-directory? (jfile-fs target)) #t #f))
|
||||
((and (jfile? target) (string=? method "listFiles"))
|
||||
(list->cseq (map make-jfile (jolt-list-dir target))))
|
||||
(else (apply %io-host-call method target args)))))
|
||||
|
||||
;; --- slurp / spit / flush ---------------------------------------------------
|
||||
(define (read-file-string path)
|
||||
(let ((p (open-input-file path)))
|
||||
(let ((s (get-string-all p))) (close-port p) (if (eof-object? s) "" s))))
|
||||
|
||||
;; Drain a jhost reader (StringReader / PushbackReader): read code units from the
|
||||
;; current position to EOF (-1) and assemble the string. Used by slurp; advances
|
||||
;; the reader, as on the JVM.
|
||||
(define (drain-reader r)
|
||||
(let loop ((acc '()))
|
||||
(let ((u (record-method-dispatch r "read" jolt-nil)))
|
||||
(if (or (jolt-nil? u) (and (number? u) (< u 0)))
|
||||
(list->string (reverse acc))
|
||||
(loop (cons (integer->char (exact (truncate u))) acc))))))
|
||||
|
||||
(define (reader-jhost? x)
|
||||
(and (jhost? x) (member (jhost-tag x) '("string-reader" "pushback-reader"))))
|
||||
|
||||
;; Refill a host reader so subsequent read/slurp see `s` (the unconsumed tail).
|
||||
(define (reader-refill! r s)
|
||||
(cond
|
||||
((string=? (jhost-tag r) "string-reader")
|
||||
(vector-set! (jhost-state r) 0 s) (vector-set! (jhost-state r) 1 0))
|
||||
((string=? (jhost-tag r) "pushback-reader")
|
||||
(vector-set! (jhost-state r) 0 (host-new "StringReader" s))
|
||||
(vector-set! (jhost-state r) 1 '()))))
|
||||
;; Read ONE form from a host reader (StringReader/PushbackReader): drain the
|
||||
;; remaining chars, parse one form, push the tail back. -> (values form found?).
|
||||
;; (read r) over a java.io reader — cuerdas' interpolation reads this way.
|
||||
(define (host-reader-read-form r)
|
||||
(let* ((s (drain-reader r)) (pr (jolt-parse-next s)))
|
||||
(if (jolt-nil? pr)
|
||||
(begin (reader-refill! r "") (values jolt-nil #f))
|
||||
(begin (reader-refill! r (jolt-nth pr 1)) (values (jolt-nth pr 0) #t)))))
|
||||
|
||||
;; clojure.edn/read over a reader: drain the jhost reader to a string and read the
|
||||
;; first EDN form (read-string). Re-asserted over the prelude in post-prelude.ss.
|
||||
(define (chez-edn-read reader)
|
||||
(jolt-invoke (var-deref "clojure.core" "read-string")
|
||||
(if (reader-jhost? reader) (drain-reader reader) (jolt-str-render-one reader))))
|
||||
|
||||
;; line-seq: an io/reader is a jhost StringReader. Drain it (or take a string)
|
||||
;; and split on newline; a trailing newline does NOT yield a final empty line
|
||||
;; (like readLine -> nil at EOF). Re-asserted in post-prelude.ss.
|
||||
(define (chez-lines s)
|
||||
(let loop ((cs (string->list s)) (cur '()) (acc '()))
|
||||
(cond ((null? cs) (reverse (if (null? cur) acc (cons (list->string (reverse cur)) acc))))
|
||||
((char=? (car cs) #\newline) (loop (cdr cs) '() (cons (list->string (reverse cur)) acc)))
|
||||
(else (loop (cdr cs) (cons (car cs) cur) acc)))))
|
||||
(define (chez-line-seq rdr)
|
||||
(list->cseq (chez-lines (cond ((string? rdr) rdr)
|
||||
((reader-jhost? rdr) (drain-reader rdr))
|
||||
(else (jolt-str-render-one rdr))))))
|
||||
|
||||
;; (slurp src :encoding "...") — pull the charset from the trailing kwargs.
|
||||
(define (slurp-encoding opts)
|
||||
(let loop ((o opts))
|
||||
(cond ((or (null? o) (null? (cdr o))) '())
|
||||
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "encoding"))
|
||||
(list (jolt-str-render-one (cadr o))))
|
||||
(else (loop (cddr o))))))
|
||||
;; drain a byte input-stream shim (tagged-table) one byte at a time to a bytevector.
|
||||
(define (drain-byte-stream src)
|
||||
(let loop ((acc '()))
|
||||
(let ((b (record-method-dispatch src "read" jolt-nil)))
|
||||
(if (or (jolt-nil? b) (and (number? b) (< b 0)))
|
||||
(u8-list->bytevector (reverse acc))
|
||||
(loop (cons (bitwise-and (jnum->exact b) #xff) acc))))))
|
||||
(define (jolt-slurp src . opts)
|
||||
(cond
|
||||
((jfile? src) (read-file-string (jfile-fs src)))
|
||||
((embedded-res? src) (embedded-res-content src))
|
||||
((reader-jhost? src) (drain-reader src))
|
||||
;; bytes (a bytevector or a jolt byte-array): decode with :encoding (UTF-8
|
||||
;; default). clj-http-lite slurps response-body byte arrays.
|
||||
((bytevector? src) (decode-bytevector src (slurp-encoding opts)))
|
||||
((and (jolt-array? src) (eq? (jolt-array-kind src) 'byte))
|
||||
(decode-bytevector (na-bytearray->bv src) (slurp-encoding opts)))
|
||||
;; a byte input-stream shim (e.g. clj-http-lite's :as :stream body): drain it.
|
||||
((and (htable? src) (jolt-truthy? (jolt-ref-get src (keyword "jolt" "input-stream"))))
|
||||
(decode-bytevector (drain-byte-stream src) (slurp-encoding opts)))
|
||||
((string? src) (read-file-string (project-relative src)))
|
||||
(else (error #f "slurp: unsupported source" src))))
|
||||
|
||||
(define (spit-append? opts)
|
||||
(let loop ((o opts))
|
||||
(cond ((or (null? o) (null? (cdr o))) #f)
|
||||
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "append")
|
||||
(jolt-truthy? (cadr o))) #t)
|
||||
(else (loop (cddr o))))))
|
||||
|
||||
(define (jolt-spit path content . opts)
|
||||
(let* ((p (project-relative (file-path-of path)))
|
||||
(port (open-output-file p (if (spit-append? opts) 'append 'truncate))))
|
||||
(put-string port (jolt-str-render-one content))
|
||||
(close-port port)
|
||||
jolt-nil))
|
||||
|
||||
(define (jolt-flush) (flush-output-port (current-output-port)) jolt-nil)
|
||||
|
||||
;; --- str / type / instance? integration ------------------------------------
|
||||
;; str of a jfile is its path (Clojure's File.toString).
|
||||
(register-str-render! jfile? jfile-path)
|
||||
|
||||
;; stdin line seam: the clojure.core *in* reader (50-io.clj) drives read-line /
|
||||
;; read / read+string through __stdin-read-line. Return the next line (newline
|
||||
;; stripped) or nil at EOF. Without this, (read-line) and the REPL call nil.
|
||||
(def-var! "clojure.core" "__stdin-read-line"
|
||||
(lambda () (let ((l (get-line (current-input-port)))) (if (eof-object? l) jolt-nil l))))
|
||||
|
||||
;; (type f) -> :jolt/file (the tagged-file :jolt/type). Re-def-var!
|
||||
;; "type": natives-meta.ss already bound the var to the old jolt-type value, so the
|
||||
;; set! alone (which updates the symbol for internal callers) wouldn't reach it.
|
||||
(define io-kw-file (keyword "jolt" "file"))
|
||||
(define %io-type jolt-type)
|
||||
(set! jolt-type (lambda (x) (if (jfile? x) io-kw-file (%io-type x))))
|
||||
(def-var! "clojure.core" "type" jolt-type)
|
||||
|
||||
;; (instance? java.io.File f): the instance? macro passes the class-name symbol;
|
||||
;; match "File" / "java.io.File" (and any *.File) against a jfile.
|
||||
(register-instance-check-arm!
|
||||
(lambda (type-sym val)
|
||||
(let ((tname (symbol-t-name type-sym)))
|
||||
(if (and (jfile? val)
|
||||
(or (string=? tname "File") (string=? tname "java.io.File")
|
||||
(string=? (path-last-segment tname) "File")))
|
||||
#t
|
||||
'pass))))
|
||||
|
||||
;; --- def-var! the native names the overlay file-seq + str/slurp use ----
|
||||
(def-var! "clojure.core" "__make-file" jolt-make-file)
|
||||
(def-var! "clojure.core" "__file?" jolt-file?)
|
||||
(def-var! "clojure.core" "__dir?" jolt-dir?)
|
||||
(def-var! "clojure.core" "__list-dir" (lambda (p) (list->cseq (jolt-list-dir p))))
|
||||
(def-var! "clojure.core" "slurp" jolt-slurp)
|
||||
(def-var! "clojure.core" "spit" jolt-spit)
|
||||
(def-var! "clojure.core" "flush" jolt-flush)
|
||||
|
||||
;; --- with-open's close seam (__close): a map-like value closes via its :close
|
||||
;; fn; a jhost reader/writer/file via its .close method (a no-op here); anything
|
||||
;; else is an error.
|
||||
(define (jolt-close x)
|
||||
(cond
|
||||
((jolt-nil? x) jolt-nil)
|
||||
((and (jhost? x) (member (jhost-tag x) '("string-reader" "pushback-reader" "writer"
|
||||
"file-writer" "port-writer" "print-writer")))
|
||||
(record-method-dispatch x "close" jolt-nil) jolt-nil)
|
||||
;; a library's stream shim (tagged-table) closes via its registered .close
|
||||
;; method (a no-op for in-memory streams); absent method -> no-op.
|
||||
((htable? x) (guard (e (#t jolt-nil)) (record-method-dispatch x "close" jolt-nil)) jolt-nil)
|
||||
((jfile? x) jolt-nil)
|
||||
(else
|
||||
(let ((closef (jolt-get x (keyword #f "close") jolt-nil)))
|
||||
(if (and (not (jolt-nil? closef)) (procedure? closef))
|
||||
(begin (jolt-invoke closef) jolt-nil)
|
||||
(error #f "with-open: don't know how to close" x))))))
|
||||
(def-var! "clojure.core" "__close" jolt-close)
|
||||
|
||||
;; --- clojure.java.io/reader: an in-memory java.io.Reader over the source. An
|
||||
;; existing reader passes through; a File / path / URL is slurped; a char[] (or
|
||||
;; any seq) becomes a reader over (apply str …). Mirrors io.clj's reader. Returns
|
||||
;; a StringReader (host-static.ss jhost) so .read/.mark/.reset and slurp work.
|
||||
(define (seq-source->string x)
|
||||
(apply string-append (map jolt-str-render-one (seq->list x))))
|
||||
;; io/reader returns an in-memory StringReader (the full Reader contract incl.
|
||||
;; (read), mark/reset and pushback). The streaming java.io.FileReader /
|
||||
;; BufferedReader classes (io-streams.ss) read a Chez port directly when a caller
|
||||
;; wants to avoid loading the whole source.
|
||||
(define (jolt-io-reader x)
|
||||
(cond
|
||||
((reader-jhost? x) x)
|
||||
((jfile? x) (host-new "StringReader" (read-file-string (jfile-fs x))))
|
||||
((embedded-res? x) (host-new "StringReader" (embedded-res-content x)))
|
||||
((and (jhost? x) (string=? (jhost-tag x) "url"))
|
||||
(host-new "StringReader" (read-file-string (url-strip-scheme (url-spec x)))))
|
||||
((string? x) (host-new "StringReader" (read-file-string (project-relative x))))
|
||||
((or (cseq? x) (empty-list-t? x) (pvec? x))
|
||||
(host-new "StringReader" (seq-source->string x)))
|
||||
(else (host-new "StringReader" (jolt-str-render-one x)))))
|
||||
|
||||
;; --- clojure.java.io/writer: an existing writer passes through; a File / path
|
||||
;; gets a file-backed writer (host-static.ss "file-writer") that persists on
|
||||
;; flush/close. Mirrors io.clj's writer over the host's StringWriter/file ports.
|
||||
(define (jolt-io-writer x)
|
||||
(cond
|
||||
((and (jhost? x) (string=? (jhost-tag x) "writer")) x)
|
||||
((and (jhost? x) (string=? (jhost-tag x) "file-writer")) x)
|
||||
((jfile? x) (make-jhost "file-writer" (vector (jfile-path x) "")))
|
||||
((string? x) (make-jhost "file-writer" (vector x "")))
|
||||
(else (error #f "io/writer: don't know how to create a writer from" x))))
|
||||
|
||||
;; --- clojure.java.io ns -----------------------------------------------------
|
||||
(def-var! "clojure.java.io" "file" jolt-make-file)
|
||||
(def-var! "clojure.java.io" "as-file" (lambda (x) (if (jfile? x) x (make-jfile (file-path-of x)))))
|
||||
;; "reader" is bound by natives-array.ss (loaded later) so a char[] argument is
|
||||
;; handled; that binding delegates here via jolt-io-reader for everything else.
|
||||
(def-var! "clojure.java.io" "writer" jolt-io-writer)
|
||||
(def-var! "clojure.java.io" "input-stream" jolt-io-reader)
|
||||
(def-var! "clojure.java.io" "output-stream" jolt-io-writer)
|
||||
;; resource: jolt has no classpath, so a named resource is resolved against the
|
||||
;; loader's source roots (a project's :paths, e.g. "resources"). Returns a File
|
||||
;; (slurp/reader-able) for the first match, else nil. get-source-roots is the
|
||||
;; loader's accessor (loader.ss), resolved at call time — the runtime CLI loads it.
|
||||
(define (jolt-io-resource name)
|
||||
(let* ((nm (jolt-str-render-one name))
|
||||
(emb (hashtable-ref embedded-resources nm #f)))
|
||||
(if emb (make-embedded-res nm emb)
|
||||
(let loop ((roots (get-source-roots)))
|
||||
(cond ((null? roots) jolt-nil)
|
||||
((file-exists? (string-append (car roots) "/" nm)) (make-jfile (string-append (car roots) "/" nm)))
|
||||
(else (loop (cdr roots))))))))
|
||||
(def-var! "clojure.java.io" "resource" jolt-io-resource)
|
||||
;; as-url honors a library-registered URL class (e.g. jolt-lang/http-client's full
|
||||
;; java.net.URL shim) so io/as-url and (URL. spec) agree; else the file-only jhost.
|
||||
(def-var! "clojure.java.io" "as-url"
|
||||
(lambda (x)
|
||||
(cond ((and (jhost? x) (string=? (jhost-tag x) "url")) x)
|
||||
((htable? x) x)
|
||||
(else (let ((ctor (lookup-class class-ctors-tbl "URL")))
|
||||
(if ctor (ctor (jolt-str-render-one x)) (make-url (jolt-str-render-one x))))))))
|
||||
|
||||
;; --- java.lang.ClassLoader --------------------------------------------------
|
||||
;; jolt has no classpath; a "classloader" resolves a named resource against the
|
||||
;; loader's source roots (the same model as clojure.java.io/resource), returning a
|
||||
;; file: URL or nil. getSystemClassLoader / a thread's contextClassLoader both hand
|
||||
;; back this loader. Libraries that probe the classpath (e.g. migratus's migration-
|
||||
;; dir discovery) then fall back to the filesystem when a resource isn't a root.
|
||||
(define the-classloader (make-jhost "classloader" (vector)))
|
||||
(define (cl-get-resource self name)
|
||||
(let ((nm (jolt-str-render-one name)))
|
||||
(let loop ((roots (get-source-roots)))
|
||||
(cond ((null? roots) jolt-nil)
|
||||
((file-exists? (string-append (car roots) "/" nm))
|
||||
(make-url (string-append "file:" (car roots) "/" nm)))
|
||||
(else (loop (cdr roots)))))))
|
||||
;; getResources: every source root that holds the named resource, as file: URLs
|
||||
;; (enumeration-seq just calls seq, so a list serves). ring's static-resource
|
||||
;; symlink check enumerates these to confirm a served file sits under a root.
|
||||
(define (cl-get-resources self name)
|
||||
(let ((nm (jolt-str-render-one name)))
|
||||
(let loop ((roots (get-source-roots)) (acc '()))
|
||||
(cond ((null? roots) (list->cseq (reverse acc)))
|
||||
((file-exists? (string-append (car roots) "/" nm))
|
||||
(loop (cdr roots) (cons (make-url (string-append "file:" (car roots) "/" nm)) acc)))
|
||||
(else (loop (cdr roots) acc))))))
|
||||
(register-host-methods! "classloader"
|
||||
(list (cons "getResource" cl-get-resource)
|
||||
(cons "getResources" cl-get-resources)
|
||||
(cons "getResourceAsStream"
|
||||
(lambda (self name)
|
||||
(let ((u (cl-get-resource self name)))
|
||||
(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
|
||||
;; clearing (instance semantics; the static Thread/interrupted reads-and-clears).
|
||||
;; getContextClassLoader hands back the loader.
|
||||
(register-host-methods! "thread"
|
||||
(list (cons "getContextClassLoader" (lambda (self) the-classloader))
|
||||
(cons "getName" (lambda (self) "main"))
|
||||
(cons "interrupt" (lambda (self)
|
||||
(when (box? (jhost-state self)) (set-box! (jhost-state self) #t))
|
||||
jolt-nil))
|
||||
(cons "isInterrupted" (lambda (self)
|
||||
(and (box? (jhost-state self)) (unbox (jhost-state self)) #t)))))
|
||||
(define (current-thread-handle) (make-jhost "thread" (current-interrupt-box)))
|
||||
(register-class-statics! "Thread" (list (cons "currentThread" current-thread-handle)))
|
||||
(register-class-statics! "java.lang.Thread" (list (cons "currentThread" current-thread-handle)))
|
||||
|
||||
;; --- java.io.File / java.util.UUID constructors -----------------------------
|
||||
;; (java.io.File. parent child) joins with "/"; (File. path) wraps the path.
|
||||
(register-class-ctor! "File"
|
||||
(lambda (a . rest)
|
||||
(if (pair? rest)
|
||||
(jolt-make-file (string-append (file-path-of a) "/" (file-path-of (car rest))))
|
||||
(jolt-make-file a))))
|
||||
;; File statics: the platform separators plus createTempFile / listRoots.
|
||||
(define temp-file-counter 0)
|
||||
(define (file-create-temp prefix suffix . dir)
|
||||
(let* ((d (cond ((pair? dir) (file-path-of (car dir)))
|
||||
((getenv "TMPDIR") => (lambda (t) t))
|
||||
(else "/tmp")))
|
||||
(sfx (if (or (null? (list suffix)) (jolt-nil? suffix)) ".tmp" (jolt-str-render-one suffix))))
|
||||
(set! temp-file-counter (+ temp-file-counter 1))
|
||||
(let loop ((n temp-file-counter))
|
||||
(let ((p (string-append d "/" (jolt-str-render-one prefix)
|
||||
(number->string (now-millis)) "-" (number->string n) sfx)))
|
||||
(if (file-exists? p) (loop (+ n 1))
|
||||
(begin (close-port (open-output-file p 'truncate)) (make-jfile p)))))))
|
||||
(let ((statics (list (cons "separator" "/")
|
||||
(cons "separatorChar" #\/)
|
||||
(cons "pathSeparator" ":")
|
||||
(cons "pathSeparatorChar" #\:)
|
||||
(cons "createTempFile" file-create-temp)
|
||||
(cons "listRoots" (lambda () (jolt-vector (make-jfile "/")))))))
|
||||
(register-class-statics! "File" statics)
|
||||
(register-class-statics! "java.io.File" statics))
|
||||
(register-class-ctor! "java.io.File"
|
||||
(lambda (a . rest)
|
||||
(if (pair? rest)
|
||||
(jolt-make-file (string-append (file-path-of a) "/" (file-path-of (car rest))))
|
||||
(jolt-make-file a))))
|
||||
;; UUID: randomUUID / fromString statics + a (UUID. s) string ctor.
|
||||
(register-class-statics! "UUID"
|
||||
(list (cons "randomUUID" (lambda () (jolt-random-uuid)))
|
||||
(cons "fromString" (lambda (s) (jolt-parse-uuid (jolt-str-render-one s))))))
|
||||
(register-class-statics! "java.util.UUID"
|
||||
(list (cons "randomUUID" (lambda () (jolt-random-uuid)))
|
||||
(cons "fromString" (lambda (s) (jolt-parse-uuid (jolt-str-render-one s))))))
|
||||
(register-class-ctor! "UUID" (lambda (s) (jolt-parse-uuid (jolt-str-render-one s))))
|
||||
|
||||
;; --- java.net.URI -----------------------------------------------------------
|
||||
;; A minimal RFC-3986 split into scheme/authority/host/port/path/query/fragment,
|
||||
;; kept in a jhost "uri" carrying the original string. (str u)/(.toString u) give
|
||||
;; the original; getHost is nil for a relative URI (hiccup.util/to-str branches on
|
||||
;; it). instance? java.net.URI + extend-protocol dispatch work via value-host-tags.
|
||||
(define (uri-index-of s ch from)
|
||||
(let ((n (string-length s)))
|
||||
(let loop ((i from)) (cond ((>= i n) #f) ((char=? (string-ref s i) ch) i) (else (loop (+ i 1)))))))
|
||||
(define (uri-scheme-end s)
|
||||
;; index of ':' that ends a scheme (letter then alnum/+-. before any /?#), or #f.
|
||||
(let ((n (string-length s)))
|
||||
(and (> n 0) (char-alphabetic? (string-ref s 0))
|
||||
(let loop ((i 1))
|
||||
(cond ((>= i n) #f)
|
||||
((char=? (string-ref s i) #\:) i)
|
||||
((let ((c (string-ref s i)))
|
||||
(or (char-alphabetic? c) (char-numeric? c) (char=? c #\+) (char=? c #\-) (char=? c #\.)))
|
||||
(loop (+ i 1)))
|
||||
(else #f))))))
|
||||
(define (uri-parse s)
|
||||
(let* ((n (string-length s))
|
||||
(se (uri-scheme-end s))
|
||||
(scheme (and se (substring s 0 se)))
|
||||
(rest-start (if se (+ se 1) 0))
|
||||
;; fragment
|
||||
(hash (uri-index-of s #\# rest-start))
|
||||
(frag (and hash (substring s (+ hash 1) n)))
|
||||
(pre-frag-end (or hash n))
|
||||
;; query
|
||||
(qm (uri-index-of s #\? rest-start))
|
||||
(query (and qm (< qm pre-frag-end) (substring s (+ qm 1) pre-frag-end)))
|
||||
(hp-end (cond ((and qm (< qm pre-frag-end)) qm) (else pre-frag-end)))
|
||||
;; authority (after "//")
|
||||
(has-auth (and (<= (+ rest-start 2) n)
|
||||
(char=? (string-ref s rest-start) #\/)
|
||||
(char=? (string-ref s (+ rest-start 1)) #\/)))
|
||||
(auth-start (and has-auth (+ rest-start 2)))
|
||||
(auth-end (and has-auth
|
||||
(let loop ((i auth-start))
|
||||
(cond ((>= i hp-end) hp-end)
|
||||
((char=? (string-ref s i) #\/) i)
|
||||
(else (loop (+ i 1)))))))
|
||||
(authority (and has-auth (substring s auth-start auth-end)))
|
||||
(path-start (if has-auth auth-end rest-start))
|
||||
(path (substring s path-start hp-end)))
|
||||
;; host:port from authority (strip userinfo@)
|
||||
(let* ((at (and authority (uri-index-of authority #\@ 0)))
|
||||
(hostport (if at (substring authority (+ at 1) (string-length authority)) authority))
|
||||
(colon (and hostport (uri-index-of hostport #\: 0)))
|
||||
(host (cond ((not hostport) jolt-nil)
|
||||
(colon (substring hostport 0 colon))
|
||||
(else hostport)))
|
||||
(port (if (and colon (< (+ colon 1) (string-length hostport)))
|
||||
(or (string->number (substring hostport (+ colon 1) (string-length hostport))) -1)
|
||||
-1)))
|
||||
(make-jhost "uri"
|
||||
(list (cons 'string s)
|
||||
(cons 'scheme (or scheme jolt-nil))
|
||||
(cons 'authority (or authority jolt-nil))
|
||||
(cons 'host (if (and host (string? host) (= 0 (string-length host))) jolt-nil host))
|
||||
(cons 'port (->num port))
|
||||
(cons 'path (if (= 0 (string-length path)) (if has-auth "" jolt-nil) path))
|
||||
(cons 'query (or query jolt-nil))
|
||||
(cons 'fragment (or frag 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! "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)))
|
||||
(cons "getScheme" (lambda (u) (uri-field u 'scheme)))
|
||||
(cons "getAuthority" (lambda (u) (uri-field u 'authority)))
|
||||
(cons "getHost" (lambda (u) (uri-field u 'host)))
|
||||
(cons "getPort" (lambda (u) (uri-field u 'port)))
|
||||
(cons "getPath" (lambda (u) (uri-field u 'path)))
|
||||
(cons "getRawPath" (lambda (u) (uri-field u 'path)))
|
||||
(cons "getQuery" (lambda (u) (uri-field u 'query)))
|
||||
(cons "getRawQuery" (lambda (u) (uri-field u 'query)))
|
||||
(cons "getFragment" (lambda (u) (uri-field u 'fragment)))
|
||||
(cons "isAbsolute" (lambda (u) (not (jolt-nil? (uri-field u 'scheme)))))
|
||||
(cons "hashCode" (lambda (u) (string-hash (uri-field u 'string))))
|
||||
(cons "equals" (lambda (u o) (and (jhost? o) (string=? (jhost-tag o) "uri")
|
||||
(string=? (uri-field u 'string) (uri-field o 'string)))))))
|
||||
;; str / pr-str of a uri -> its string form.
|
||||
(register-str-render! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "uri")))
|
||||
(lambda (x) (uri-field x 'string)))
|
||||
(register-pr-readable-arm! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "uri")))
|
||||
(lambda (x) (string-append "#object[java.net.URI \"" (uri-field x 'string) "\"]")))
|
||||
;; class of the host value types defined by now (uri/uuid/file).
|
||||
(register-class-arm! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "uri"))) (lambda (x) "java.net.URI"))
|
||||
(register-class-arm! juuid? (lambda (x) "java.util.UUID"))
|
||||
(register-class-arm! jfile? (lambda (x) "java.io.File"))
|
||||
2262
host/chez/java/java-time.ss
Normal file
2262
host/chez/java/java-time.ss
Normal file
File diff suppressed because it is too large
Load diff
67
host/chez/java/math.ss
Normal file
67
host/chez/java/math.ss
Normal file
|
|
@ -0,0 +1,67 @@
|
|||
;; clojure.math — host shim over native flonum math.
|
||||
;;
|
||||
;; clojure.math is registered as native bindings, NOT a .clj file — so there's no
|
||||
;; source tier to emit. The def-var! shims here back each clojure.math fn over
|
||||
;; Chez's native procedures. The analyzer knows the clojure.math ns exists, so a
|
||||
;; ref like clojure.math/sqrt lowers to a var-deref; these cells back it at
|
||||
;; runtime.
|
||||
;;
|
||||
;; jolt is all-flonum, so every result is a flonum (inputs arrive as flonums; Chez
|
||||
;; sqrt/sin/expt/... return flonums for flonum args). Semantics match
|
||||
;; Clojure 1.11 clojure.math: round = floor(x+0.5), rint = round-half-even,
|
||||
;; floor/ceil/floor-div return doubles, to-degrees/to-radians via PI.
|
||||
|
||||
(define jolt-math-pi (acos -1.0))
|
||||
(define jolt-math-e (exp 1.0))
|
||||
|
||||
(define (jolt-math-cbrt x)
|
||||
;; sign-aware so negative inputs stay real (expt of a negative flonum to a
|
||||
;; fractional power goes complex).
|
||||
(if (< x 0.0)
|
||||
(- (expt (- x) (/ 1.0 3.0)))
|
||||
(expt x (/ 1.0 3.0))))
|
||||
|
||||
;; clojure.math/round returns a long (exact); floor/ceil/signum/rint return doubles.
|
||||
(define (jolt-math-round x) (exact (floor (+ x 0.5))))
|
||||
(define (jolt-math-signum x) (cond ((< x 0.0) -1.0) ((> x 0.0) 1.0) (else 0.0)))
|
||||
(define (jolt-math-to-degrees r) (/ (* r 180.0) jolt-math-pi))
|
||||
(define (jolt-math-to-radians d) (/ (* d jolt-math-pi) 180.0))
|
||||
(define (jolt-math-hypot a b) (sqrt (+ (* a a) (* b b))))
|
||||
(define (jolt-math-floor-div a b) (floor (/ a b)))
|
||||
(define (jolt-math-floor-mod a b) (- a (* b (floor (/ a b)))))
|
||||
|
||||
;; clojure.math fns always return a DOUBLE; Chez's sqrt/expt/sin/floor/... return
|
||||
;; EXACT for exact args ((sqrt 9) -> 3, (sin 0) -> 0), so coerce.
|
||||
(define (m1 f) (lambda (x) (exact->inexact (f x))))
|
||||
(define (m2 f) (lambda (a b) (exact->inexact (f a b))))
|
||||
(def-var! "clojure.math" "sqrt" (m1 sqrt))
|
||||
(def-var! "clojure.math" "cbrt" jolt-math-cbrt)
|
||||
(def-var! "clojure.math" "pow" (m2 expt))
|
||||
(def-var! "clojure.math" "exp" (m1 exp))
|
||||
(def-var! "clojure.math" "expm1" (lambda (x) (- (exp x) 1.0)))
|
||||
(def-var! "clojure.math" "log" (m1 log))
|
||||
(def-var! "clojure.math" "log10" (lambda (x) (exact->inexact (log x 10.0))))
|
||||
(def-var! "clojure.math" "log1p" (lambda (x) (log (+ 1.0 x))))
|
||||
(def-var! "clojure.math" "sin" (m1 sin))
|
||||
(def-var! "clojure.math" "cos" (m1 cos))
|
||||
(def-var! "clojure.math" "tan" (m1 tan))
|
||||
(def-var! "clojure.math" "asin" (m1 asin))
|
||||
(def-var! "clojure.math" "acos" (m1 acos))
|
||||
(def-var! "clojure.math" "atan" (m1 atan))
|
||||
;; clojure.math/atan2 is atan2(y, x); Chez's 2-arg atan is (atan y x).
|
||||
(def-var! "clojure.math" "atan2" (lambda (y x) (exact->inexact (atan y x))))
|
||||
(def-var! "clojure.math" "sinh" (m1 sinh))
|
||||
(def-var! "clojure.math" "cosh" (m1 cosh))
|
||||
(def-var! "clojure.math" "tanh" (m1 tanh))
|
||||
(def-var! "clojure.math" "floor" (m1 floor))
|
||||
(def-var! "clojure.math" "ceil" (m1 ceiling))
|
||||
(def-var! "clojure.math" "rint" (m1 round))
|
||||
(def-var! "clojure.math" "round" jolt-math-round)
|
||||
(def-var! "clojure.math" "signum" jolt-math-signum)
|
||||
(def-var! "clojure.math" "to-degrees" jolt-math-to-degrees)
|
||||
(def-var! "clojure.math" "to-radians" jolt-math-to-radians)
|
||||
(def-var! "clojure.math" "hypot" jolt-math-hypot)
|
||||
(def-var! "clojure.math" "floor-div" jolt-math-floor-div)
|
||||
(def-var! "clojure.math" "floor-mod" jolt-math-floor-mod)
|
||||
(def-var! "clojure.math" "E" jolt-math-e)
|
||||
(def-var! "clojure.math" "PI" jolt-math-pi)
|
||||
230
host/chez/java/natives-array.ss
Normal file
230
host/chez/java/natives-array.ss
Normal file
|
|
@ -0,0 +1,230 @@
|
|||
;; natives-array.ss — Java-style mutable arrays for the Chez host.
|
||||
;;
|
||||
;; A jolt-array wraps a Chez mutable vector + a `kind` tag (for bytes?). The array
|
||||
;; CONSTRUCTORS are native (they build the backing); the overlay's aget/aset/alength
|
||||
;; are pure over count / nth / jolt.host/ref-put!, so we extend those dispatchers
|
||||
;; to see a jolt-array (backed by a Chez vector). Loaded after host-table.ss (ref-put!),
|
||||
;; transients.ss, seq.ss (the dispatchers it chains).
|
||||
|
||||
(define-record-type jolt-array (fields (mutable vec) kind) (nongenerative jolt-array-v1))
|
||||
|
||||
;; JVM array class name per element kind ((class (int-array 3)) -> "[I", like the
|
||||
;; JVM's Class.getName for arrays). Object arrays use the descriptor form.
|
||||
(define (na-array-class-name arr)
|
||||
(case (jolt-array-kind arr)
|
||||
((int) "[I") ((long) "[J") ((short) "[S") ((double) "[D")
|
||||
((float) "[F") ((boolean) "[Z") ((byte) "[B") ((char) "[C")
|
||||
(else "[Ljava.lang.Object;")))
|
||||
|
||||
(define (na-idx i) (if (and (number? i) (not (exact? i))) (exact (floor i)) i))
|
||||
(define (na-from-seq x kind) (make-jolt-array (list->vector (seq->list (jolt-seq x))) kind))
|
||||
;; (T-array size) | (T-array size init) | (T-array seq)
|
||||
(define (na-num-array a rest init kind)
|
||||
(if (number? a)
|
||||
(make-jolt-array (make-vector (exact (na-idx a)) (if (pair? rest) (car rest) init)) kind)
|
||||
(na-from-seq a kind)))
|
||||
|
||||
;; numeric tower: array element defaults / masked bytes / count are
|
||||
;; EXACT integers (= JVM byte/short/int), matching exact integer literals.
|
||||
(define (na-byte-of v) (bitwise-and (exact (floor v)) #xff))
|
||||
|
||||
;; --- constructors -----------------------------------------------------------
|
||||
(define (na-object-array a . rest) (na-num-array a rest jolt-nil 'object))
|
||||
;; integer kinds default to exact 0 (JVM int/long/short 0 -> "0", not "0.0").
|
||||
(define (na-int-array a . rest) (na-num-array a rest 0 'int))
|
||||
(define (na-long-array a . rest) (na-num-array a rest 0 'long))
|
||||
(define (na-short-array a . rest) (na-num-array a rest 0 'short))
|
||||
(define (na-double-array a . rest) (na-num-array a rest 0.0 'double))
|
||||
(define (na-float-array a . rest) (na-num-array a rest 0.0 'float))
|
||||
(define (na-boolean-array a . rest) (na-num-array a rest #f 'boolean))
|
||||
;; char-array is a real 'char array (instance? "[C"), seqing as chars via the
|
||||
;; dispatchers below — io/reader (extended here) and str/slurp consume the seq.
|
||||
(define (na-char-array a . rest)
|
||||
(cond
|
||||
((string? a) (make-jolt-array (list->vector (string->list a)) 'char))
|
||||
((number? a) (make-jolt-array (make-vector (exact (na-idx a)) #\nul) 'char))
|
||||
(else (make-jolt-array
|
||||
(list->vector (map (lambda (c) (if (char? c) c (integer->char (exact (truncate c)))))
|
||||
(seq->list (jolt-seq a)))) 'char))))
|
||||
;; (byte-array n [init]) | (byte-array coll). Also coerces the host's OTHER byte
|
||||
;; carrier — a Chez bytevector (what String/.getBytes produce) — and a string's
|
||||
;; UTF-8 bytes, so bytevector and byte-array interconvert across interop seams.
|
||||
(define (na-byte-array a . rest)
|
||||
(cond
|
||||
((number? a) (make-jolt-array (make-vector (exact (na-idx a)) (na-byte-of (if (pair? rest) (car rest) 0))) 'byte))
|
||||
((bytevector? a) (make-jolt-array (list->vector (bytevector->u8-list a)) 'byte))
|
||||
((string? a) (make-jolt-array (list->vector (bytevector->u8-list (string->utf8 a))) 'byte))
|
||||
(else (make-jolt-array (list->vector (map na-byte-of (seq->list (jolt-seq a)))) 'byte))))
|
||||
;; jolt byte-array -> Chez bytevector (for String decode / utf8->string).
|
||||
(define (na-bytearray->bv arr)
|
||||
(let* ((v (jolt-array-vec arr)) (n (vector-length v)) (bv (make-bytevector n)))
|
||||
(do ((i 0 (+ i 1))) ((= i n)) (bytevector-u8-set! bv i (bitwise-and (exact (vector-ref v i)) #xff)))
|
||||
bv))
|
||||
(define (na-make-array a . rest) ; (make-array len) | (make-array type len ...)
|
||||
(make-jolt-array (make-vector (exact (na-idx (if (number? a) a (car rest)))) jolt-nil) 'object))
|
||||
(define (na-into-array a . rest) (na-from-seq (if (pair? rest) (car rest) a) 'object))
|
||||
(define (na-to-array coll) (na-from-seq coll 'object))
|
||||
(define (na-aclone arr)
|
||||
(if (jolt-array? arr)
|
||||
(make-jolt-array (vector-copy (jolt-array-vec arr)) (jolt-array-kind arr))
|
||||
(na-from-seq arr 'object)))
|
||||
|
||||
;; --- typed aset (return the stored value) -----------------------------------
|
||||
(define (na-aset! arr i v) (vector-set! (jolt-array-vec arr) (exact (na-idx i)) v) v)
|
||||
(define (na-aset-int arr i v) (na-aset! arr i v))
|
||||
(define (na-aset-long arr i v) (na-aset! arr i v))
|
||||
(define (na-aset-short arr i v) (na-aset! arr i v))
|
||||
(define (na-aset-double arr i v) (na-aset! arr i v))
|
||||
(define (na-aset-float arr i v) (na-aset! arr i v))
|
||||
(define (na-aset-char arr i v) (na-aset! arr i v))
|
||||
(define (na-aset-boolean arr i v) (na-aset! arr i v))
|
||||
(define (na-aset-byte arr i v)
|
||||
(vector-set! (jolt-array-vec arr) (exact (na-idx i)) (na-byte-of v)) v)
|
||||
|
||||
;; --- coercions (identity on arrays; byte/short are masked scalar casts) ------
|
||||
(define (na-bytes x) (if (and (jolt-array? x) (eq? (jolt-array-kind x) 'byte)) x (na-byte-array x)))
|
||||
(define (na-bytes? x) (and (jolt-array? x) (eq? (jolt-array-kind x) 'byte)))
|
||||
(define (na-identity x) x)
|
||||
(define (na-byte x)
|
||||
(let ((b (bitwise-and (exact (floor x)) #xff))) (if (>= b 128) (- b 256) b)))
|
||||
(define (na-short x)
|
||||
(let ((s (bitwise-and (exact (floor x)) #xffff))) (if (>= s #x8000) (- s #x10000) s)))
|
||||
|
||||
;; --- chunked seqs -----------------------------------------------------------
|
||||
;; A vector's seq is a REAL chunked-seq: (seq v) carries its backing vector +
|
||||
;; element index (seq.ss cseq-vec), so chunked-seq? is true and chunk-first hands
|
||||
;; out a 32-element block (a pvec slice) while chunk-rest is the seq at the next
|
||||
;; block boundary — the Clojure/CLJS ChunkedSeq contract (chunk-first ++
|
||||
;; chunk-rest == the seq). The eager buffer model (chunk-buffer/chunk-append/
|
||||
;; chunk) builds a plain cseq; chunk-cons/first/rest fall back to seq ops over it.
|
||||
(define na-chunk-size 32)
|
||||
(define-record-type jolt-chunkbuf (fields (mutable items)) (nongenerative jolt-chunkbuf-v1))
|
||||
(define (na-chunk-buffer cap) (make-jolt-chunkbuf '()))
|
||||
(define (na-chunk-append b x) (jolt-chunkbuf-items-set! b (append (jolt-chunkbuf-items b) (list x))) b)
|
||||
(define (na-chunk b) (list->cseq (jolt-chunkbuf-items b)))
|
||||
(define (na-chunk-cons chunk rest) (jolt-concat chunk rest))
|
||||
;; backing (vector . end-of-block index) for a vector-seq cell, or #f.
|
||||
(define (na-vblock s)
|
||||
(and (cseq? s) (cseq-cvec s)
|
||||
(let* ((v (cseq-cvec s)) (i (cseq-ci s)))
|
||||
(cons v (fxmin (fx+ i na-chunk-size) (pvec-count v))))))
|
||||
(define (na-chunked-seq? x) (and (na-vblock x) #t))
|
||||
(define (na-chunk-first s)
|
||||
(let ((vb (na-vblock s)))
|
||||
(if vb (make-pvec (vec-copy-range (pvec-v (car vb)) (cseq-ci s) (cdr vb)))
|
||||
(jolt-first s)))) ; eager-buffer fallback
|
||||
(define (na-chunk-rest s)
|
||||
(let ((vb (na-vblock s)))
|
||||
(if vb (if (fx>=? (cdr vb) (pvec-count (car vb))) jolt-empty-list (vec->seq (car vb) (cdr vb)))
|
||||
(jolt-rest s))))
|
||||
(define (na-chunk-next s)
|
||||
(let ((vb (na-vblock s)))
|
||||
(if vb (if (fx>=? (cdr vb) (pvec-count (car vb))) jolt-nil (vec->seq (car vb) (cdr vb)))
|
||||
(jolt-next s))))
|
||||
|
||||
;; --- extend the collection dispatchers to see a jolt-array ------------------
|
||||
(define %na-count jolt-count)
|
||||
(set! jolt-count (lambda (c) (if (jolt-array? c) (vector-length (jolt-array-vec c)) (%na-count c))))
|
||||
(define %na-seq jolt-seq)
|
||||
(set! jolt-seq (lambda (c) (if (jolt-array? c) (list->cseq (vector->list (jolt-array-vec c))) (%na-seq c))))
|
||||
(define %na-nth jolt-nth)
|
||||
(set! jolt-nth
|
||||
(case-lambda
|
||||
((c i) (if (jolt-array? c) (vector-ref (jolt-array-vec c) (exact (na-idx i))) (%na-nth c i)))
|
||||
((c i d) (if (jolt-array? c)
|
||||
(let ((v (jolt-array-vec c)) (j (exact (na-idx i))))
|
||||
(if (and (>= j 0) (< j (vector-length v))) (vector-ref v j) d))
|
||||
(%na-nth c i d)))))
|
||||
(define %na-get jolt-get)
|
||||
(set! jolt-get
|
||||
(case-lambda
|
||||
((c k) (if (jolt-array? c) (jolt-nth c k) (%na-get c k)))
|
||||
((c k d) (if (jolt-array? c) (jolt-nth c k d) (%na-get c k d)))))
|
||||
;; aset (overlay) writes through jolt.host/ref-put! — mutate the slot, return arr.
|
||||
;; count/nth/seq/get above are NATIVE-OPS (inlined at call sites), so aget/alength/
|
||||
;; array-seq/vec already use the set!-extended globals; ref-put! is a host var
|
||||
;; (var-deref'd), so re-assert its cell to the array-aware closure.
|
||||
(define %na-ref-put! jolt-ref-put!)
|
||||
(set! jolt-ref-put!
|
||||
(lambda (t k v)
|
||||
(if (jolt-array? t) (begin (vector-set! (jolt-array-vec t) (exact (na-idx k)) v) t)
|
||||
(%na-ref-put! t k v))))
|
||||
(def-var! "jolt.host" "ref-put!" jolt-ref-put!)
|
||||
|
||||
;; --- array identity: type / class / instance? recognize arrays ---------------
|
||||
;; (type arr) / (class arr) -> the JVM array class name; (class …) delegates to
|
||||
;; (jolt-type …) for arrays, so extending jolt-type covers both.
|
||||
(define %na-type jolt-type)
|
||||
(set! jolt-type (lambda (x) (if (jolt-array? x) (na-array-class-name x) (%na-type x))))
|
||||
(def-var! "clojure.core" "type" jolt-type)
|
||||
|
||||
;; instance? over an array class token ([I, [C, …). An array token reaches us as
|
||||
;; a string ("[C", from (Class/forName "[C")) — the dispatcher leaves it a string
|
||||
;; (non-array string tokens are already normalized to symbols there); decide it
|
||||
;; here, deferring everything else.
|
||||
(register-instance-check-arm!
|
||||
(lambda (type-sym val)
|
||||
(let ((tname (cond ((string? type-sym) type-sym)
|
||||
((symbol-t? type-sym) (symbol-t-name type-sym))
|
||||
(else #f))))
|
||||
(if (and tname (> (string-length tname) 0) (char=? (string-ref tname 0) #\[))
|
||||
(and (jolt-array? val) (string=? (na-array-class-name val) tname))
|
||||
'pass))))
|
||||
|
||||
;; clojure.java.io/reader over a char-array reads its chars (the JVM char[] branch).
|
||||
(def-var! "clojure.java.io" "reader"
|
||||
(lambda (x)
|
||||
(if (jolt-array? x)
|
||||
(host-new "StringReader"
|
||||
(apply string-append (map jolt-str-render-one (seq->list (jolt-seq x)))))
|
||||
(jolt-io-reader x))))
|
||||
|
||||
;; --- bind into clojure.core -------------------------------------------------
|
||||
(for-each (lambda (p) (def-var! "clojure.core" (car p) (cdr p)))
|
||||
(list
|
||||
(cons "object-array" na-object-array) (cons "int-array" na-int-array)
|
||||
(cons "long-array" na-long-array) (cons "short-array" na-short-array)
|
||||
(cons "double-array" na-double-array) (cons "float-array" na-float-array)
|
||||
(cons "boolean-array" na-boolean-array)
|
||||
(cons "byte-array" na-byte-array) (cons "char-array" na-char-array)
|
||||
(cons "array?" (lambda (x) (jolt-array? x)))
|
||||
(cons "make-array" na-make-array)
|
||||
(cons "into-array" na-into-array) (cons "to-array" na-to-array) (cons "aclone" na-aclone)
|
||||
(cons "aset-int" na-aset-int) (cons "aset-long" na-aset-long)
|
||||
(cons "aset-short" na-aset-short) (cons "aset-double" na-aset-double)
|
||||
(cons "aset-float" na-aset-float) (cons "aset-char" na-aset-char)
|
||||
(cons "aset-boolean" na-aset-boolean) (cons "aset-byte" na-aset-byte)
|
||||
(cons "bytes" na-bytes) (cons "bytes?" na-bytes?)
|
||||
(cons "booleans" na-identity) (cons "ints" na-identity) (cons "longs" na-identity)
|
||||
(cons "shorts" na-identity) (cons "doubles" na-identity) (cons "floats" na-identity)
|
||||
(cons "chars" na-identity) (cons "byte" na-byte) (cons "short" na-short)
|
||||
(cons "chunk-buffer" na-chunk-buffer) (cons "chunk-append" na-chunk-append)
|
||||
(cons "chunk" na-chunk) (cons "chunk-cons" na-chunk-cons)
|
||||
(cons "chunk-first" na-chunk-first) (cons "chunk-rest" na-chunk-rest)
|
||||
(cons "chunk-next" na-chunk-next) (cons "chunked-seq?" na-chunked-seq?)))
|
||||
|
||||
;; --- clojure.java.io/copy ---------------------------------------------------
|
||||
;; Copy src -> dst, JVM-style. Raw bytes (byte-array / bytevector / string) and a
|
||||
;; jhost reader write in one shot; any other source (a stream shim with a .read
|
||||
;; method, e.g. jolt-lang/http-client's ByteArrayInputStream) drains via .read
|
||||
;; into a byte-array buffer and .write to dst — both reached through method
|
||||
;; dispatch, so a library's tagged-table streams work without the host knowing
|
||||
;; their layout. Lives here (not io.ss) because io.ss loads before byte-array.
|
||||
(define (jolt-io-copy src dst . _opts)
|
||||
(define (write-all! bytes)
|
||||
(record-method-dispatch dst "write" (list->cseq (list bytes 0 (vector-length (jolt-array-vec bytes))))))
|
||||
(cond
|
||||
((or (bytevector? src) (string? src)
|
||||
(and (jolt-array? src) (eq? (jolt-array-kind src) 'byte)))
|
||||
(write-all! (na-byte-array src)))
|
||||
((and (jhost? src) (member (jhost-tag src) '("string-reader" "pushback-reader")))
|
||||
(write-all! (na-byte-array (drain-reader src))))
|
||||
(else
|
||||
(let ((buf (na-byte-array 8192)))
|
||||
(let loop ()
|
||||
(let ((n (record-method-dispatch src "read" (list->cseq (list buf 0 8192)))))
|
||||
(when (and (number? n) (> (jnum->exact n) 0))
|
||||
(record-method-dispatch dst "write" (list->cseq (list buf 0 n)))
|
||||
(loop)))))))
|
||||
jolt-nil)
|
||||
(def-var! "clojure.java.io" "copy" jolt-io-copy)
|
||||
69
host/chez/java/natives-queue.ss
Normal file
69
host/chez/java/natives-queue.ss
Normal file
|
|
@ -0,0 +1,69 @@
|
|||
;; natives-queue.ss — clojure.lang.PersistentQueue for the Chez host.
|
||||
;;
|
||||
;; A functional queue: a `front` Scheme list (the dequeue end, head = front of the
|
||||
;; queue) + a reversed `rear` Scheme list (the enqueue end, head = most recent).
|
||||
;; conj adds to rear; peek/first read front; pop drops the front, rebalancing
|
||||
;; rear->front when front empties — amortized O(1). A queue is jolt-sequential?, so
|
||||
;; seq=?/seq-hash give cross-type equality (= [1 2 3] (queue 1 2 3)) for free, like
|
||||
;; the JVM. Loaded after seq/collections/lazy-bridge/records/host-table so every
|
||||
;; dispatcher it chains is at its latest binding.
|
||||
|
||||
(define-record-type jolt-queue (fields front rear cnt) (nongenerative jolt-queue-v1))
|
||||
(define jolt-queue-empty (make-jolt-queue '() '() 0))
|
||||
|
||||
(define (queue-conj q x)
|
||||
(if (null? (jolt-queue-front q))
|
||||
(make-jolt-queue (list x) '() (fx+ (jolt-queue-cnt q) 1))
|
||||
(make-jolt-queue (jolt-queue-front q) (cons x (jolt-queue-rear q)) (fx+ (jolt-queue-cnt q) 1))))
|
||||
(define (queue->list q) (append (jolt-queue-front q) (reverse (jolt-queue-rear q))))
|
||||
(define (queue-peek q) (if (null? (jolt-queue-front q)) jolt-nil (car (jolt-queue-front q))))
|
||||
(define (queue-pop q)
|
||||
(let ((f (jolt-queue-front q)))
|
||||
;; popping an empty PersistentQueue returns it (Clojure's pop: if f==null
|
||||
;; return this) — unlike a vector, which throws.
|
||||
(cond ((null? f) q)
|
||||
((null? (cdr f)) (make-jolt-queue (reverse (jolt-queue-rear q)) '() (fx- (jolt-queue-cnt q) 1)))
|
||||
(else (make-jolt-queue (cdr f) (jolt-queue-rear q) (fx- (jolt-queue-cnt q) 1))))))
|
||||
|
||||
;; --- extend the collection dispatchers to see a jolt-queue ------------------
|
||||
(define %q-seq jolt-seq)
|
||||
(set! jolt-seq (lambda (x) (if (jolt-queue? x)
|
||||
(let ((l (queue->list x))) (if (null? l) jolt-nil (list->cseq l)))
|
||||
(%q-seq x))))
|
||||
(define %q-count jolt-count)
|
||||
(set! jolt-count (lambda (x) (if (jolt-queue? x) (jolt-queue-cnt x) (%q-count x))))
|
||||
(define %q-empty? jolt-empty?)
|
||||
(set! jolt-empty? (lambda (x) (if (jolt-queue? x) (fx=? 0 (jolt-queue-cnt x)) (%q-empty? x))))
|
||||
(define %q-peek jolt-peek)
|
||||
(set! jolt-peek (lambda (x) (if (jolt-queue? x) (queue-peek x) (%q-peek x))))
|
||||
(define %q-pop jolt-pop)
|
||||
(set! jolt-pop (lambda (x) (if (jolt-queue? x) (queue-pop x) (%q-pop x))))
|
||||
(define %q-conj1 jolt-conj1)
|
||||
(set! jolt-conj1 (lambda (coll x) (if (jolt-queue? coll) (queue-conj coll x) (%q-conj1 coll x))))
|
||||
;; sequential => seq=?/seq-hash handle queue equality + hashing.
|
||||
(define %q-sequential? jolt-sequential?)
|
||||
(set! jolt-sequential? (lambda (x) (or (jolt-queue? x) (%q-sequential? x))))
|
||||
|
||||
;; printing: render the elements as a parenthesized list (delegate to the seq path).
|
||||
(define (jolt-seq-or-empty x) (let ((s (jolt-seq x))) (if (jolt-nil? s) jolt-empty-list s)))
|
||||
(register-pr-readable-arm! jolt-queue? (lambda (x) (jolt-pr-readable (jolt-seq-or-empty x))))
|
||||
(register-str-render! jolt-queue? (lambda (x) (jolt-str-render-one (jolt-seq-or-empty x))))
|
||||
|
||||
;; class / type / instance? recognize a queue.
|
||||
(register-class-arm! jolt-queue? (lambda (x) "clojure.lang.PersistentQueue"))
|
||||
(register-instance-check-arm!
|
||||
(lambda (type-sym val)
|
||||
(if (jolt-queue? val)
|
||||
(let ((tn (cond ((string? type-sym) type-sym)
|
||||
((symbol-t? type-sym) (symbol-t-name type-sym)) (else ""))))
|
||||
(and (member (last-dot tn)
|
||||
'("PersistentQueue" "IPersistentCollection" "Sequential" "Collection" "Object"))
|
||||
#t))
|
||||
'pass)))
|
||||
|
||||
;; clojure.lang.PersistentQueue/EMPTY + a queue? predicate.
|
||||
(register-class-statics! "PersistentQueue" (list (cons "EMPTY" jolt-queue-empty)))
|
||||
(register-class-statics! "clojure.lang.PersistentQueue" (list (cons "EMPTY" jolt-queue-empty)))
|
||||
(def-var! "clojure.core" "queue?" (lambda (x) (jolt-queue? x)))
|
||||
;; the FQ class token self-evaluates (for (instance? clojure.lang.PersistentQueue …)).
|
||||
(def-var! "clojure.core" "clojure.lang.PersistentQueue" "clojure.lang.PersistentQueue")
|
||||
380
host/chez/java/natives-str.ss
Normal file
380
host/chez/java/natives-str.ss
Normal file
|
|
@ -0,0 +1,380 @@
|
|||
;; natives-str.ss — java.lang.String method interop on Chez.
|
||||
;;
|
||||
;; (.method s arg*) on a string target lowers to record-method-dispatch (emit.ss),
|
||||
;; which falls through to jolt-string-method here when the target is a string.
|
||||
;; Covers the
|
||||
;; portable java.lang.String/CharSequence methods cljc libraries actually call.
|
||||
;; Case mapping is ASCII (the whole engine is byte-oriented), indexOf returns -1
|
||||
;; on miss as on the JVM, indices come in as flonums, char results are Scheme
|
||||
;; chars, and numeric results are flonums to match jolt's number model.
|
||||
;;
|
||||
;; Loaded from rt.ss AFTER regex.ss (the regex methods reuse jolt-re-pattern /
|
||||
;; regex-t-irx) and records.ss (which calls jolt-string-method).
|
||||
|
||||
;; --- ASCII case mapping (byte-oriented) -------
|
||||
(define (ascii-up-char c)
|
||||
(if (and (char<=? #\a c) (char<=? c #\z))
|
||||
(integer->char (fx- (char->integer c) 32)) c))
|
||||
(define (ascii-down-char c)
|
||||
(if (and (char<=? #\A c) (char<=? c #\Z))
|
||||
(integer->char (fx+ (char->integer c) 32)) c))
|
||||
(define (ascii-string-up s) (list->string (map ascii-up-char (string->list s))))
|
||||
(define (ascii-string-down s) (list->string (map ascii-down-char (string->list s))))
|
||||
|
||||
;; --- ASCII trim: drop leading/trailing chars with code <= space (JVM .trim) ---
|
||||
(define (str-trim s)
|
||||
(let ((len (string-length s)))
|
||||
(let scan-l ((i 0))
|
||||
(cond ((fx=? i len) "")
|
||||
((char<=? (string-ref s i) #\space) (scan-l (fx+ i 1)))
|
||||
(else (let scan-r ((j (fx- len 1)))
|
||||
(if (char<=? (string-ref s j) #\space)
|
||||
(scan-r (fx- j 1))
|
||||
(substring s i (fx+ j 1)))))))))
|
||||
(define (str-triml s)
|
||||
(let ((len (string-length s)))
|
||||
(let loop ((i 0))
|
||||
(cond ((fx=? i len) "")
|
||||
((char<=? (string-ref s i) #\space) (loop (fx+ i 1)))
|
||||
(else (substring s i len))))))
|
||||
(define (str-trimr s)
|
||||
(let loop ((j (fx- (string-length s) 1)))
|
||||
(cond ((fx<? j 0) "")
|
||||
((char<=? (string-ref s j) #\space) (loop (fx- j 1)))
|
||||
(else (substring s 0 (fx+ j 1))))))
|
||||
|
||||
;; --- substring search: first index of `needle` in `s` at/after `from`, or -1 --
|
||||
(define (str-index-of s needle from)
|
||||
(let ((nlen (string-length needle)) (slen (string-length s)))
|
||||
(let loop ((i (max 0 from)))
|
||||
(cond ((fx>? (fx+ i nlen) slen) -1)
|
||||
((string=? (substring s i (fx+ i nlen)) needle) i)
|
||||
(else (loop (fx+ i 1)))))))
|
||||
(define (str-last-index-of s needle)
|
||||
(let ((nlen (string-length needle)) (slen (string-length s)))
|
||||
(let loop ((i (fx- slen nlen)) (found -1))
|
||||
(cond ((fx<? i 0) found)
|
||||
((string=? (substring s i (fx+ i nlen)) needle) i)
|
||||
(else (loop (fx- i 1) found))))))
|
||||
|
||||
;; A needle arg: a char value -> its 1-char string; a number -> the char at that
|
||||
;; code point (JVM treats an int arg to indexOf as a char code); else a string.
|
||||
(define (str-needle x)
|
||||
(cond ((char? x) (string x))
|
||||
((number? x) (string (integer->char (exact (truncate x)))))
|
||||
((string? x) x)
|
||||
(else (jolt-str x))))
|
||||
|
||||
;; literal replace-all (JVM String.replace(CharSequence,CharSequence)).
|
||||
(define (str-replace-literal s a b)
|
||||
(let ((alen (string-length a)) (slen (string-length s)))
|
||||
(if (fx=? alen 0) s
|
||||
(let loop ((i 0) (acc '()))
|
||||
(cond ((fx>? (fx+ i alen) slen)
|
||||
(apply string-append (reverse (cons (substring s i slen) acc))))
|
||||
((string=? (substring s i (fx+ i alen)) a)
|
||||
(loop (fx+ i alen) (cons b acc)))
|
||||
(else (loop (fx+ i 1) (cons (substring s i (fx+ i 1)) acc))))))))
|
||||
|
||||
;; A compiled irregex for a plain-string Java-regex pattern (or a jolt-regex).
|
||||
(define (str-irx pat) (regex-t-irx (jolt-re-pattern pat)))
|
||||
|
||||
;; JVM String.split: split fully, then drop trailing empty strings.
|
||||
(define (str-split-drop-trailing parts)
|
||||
(let loop ((p (reverse parts)))
|
||||
(if (and (pair? p) (string=? (car p) "")) (loop (cdr p)) (reverse p))))
|
||||
|
||||
;; Encode a string to bytes (a bytevector) under a named charset. UTF-8 default;
|
||||
;; ISO-8859-1/latin1/ascii are one byte per char; UTF-16/UTF-32 via Chez's codecs
|
||||
;; (plain "UTF-16" emits a big-endian BOM then BE, matching the JVM). Shared by
|
||||
;; .getBytes and decode-bytevector (String.).
|
||||
(define (charset-encode-bv s csname)
|
||||
(let ((cs (ascii-string-down (if (string? csname) csname (jolt-str-render-one csname)))))
|
||||
(cond
|
||||
((or (string=? cs "utf-8") (string=? cs "utf8")) (string->utf8 s))
|
||||
((member cs '("iso-8859-1" "latin1" "iso8859-1" "us-ascii" "ascii"))
|
||||
(let* ((n (string-length s)) (bv (make-bytevector n)))
|
||||
(do ((i 0 (+ i 1))) ((= i n) bv)
|
||||
(bytevector-u8-set! bv i (bitwise-and (char->integer (string-ref s i)) #xff)))))
|
||||
((string=? cs "utf-16be") (string->utf16 s (endianness big)))
|
||||
((string=? cs "utf-16le") (string->utf16 s (endianness little)))
|
||||
((or (string=? cs "utf-16") (string=? cs "utf16") (string=? cs "unicode"))
|
||||
(let ((be (string->utf16 s (endianness big))))
|
||||
(let* ((n (bytevector-length be)) (bv (make-bytevector (+ n 2))))
|
||||
(bytevector-u8-set! bv 0 #xfe) (bytevector-u8-set! bv 1 #xff)
|
||||
(bytevector-copy! be 0 bv 2 n) bv)))
|
||||
((or (string=? cs "utf-32be") (string=? cs "utf-32") (string=? cs "utf32"))
|
||||
(string->utf32 s (endianness big)))
|
||||
((string=? cs "utf-32le") (string->utf32 s (endianness little)))
|
||||
(else (string->utf8 s)))))
|
||||
|
||||
(define (jolt-string-method method s rest)
|
||||
(define (arg n) (list-ref rest n))
|
||||
(cond
|
||||
((string=? method "toString") s)
|
||||
((string=? method "toLowerCase") (ascii-string-down s))
|
||||
((string=? method "toUpperCase") (ascii-string-up s))
|
||||
((string=? method "trim") (str-trim s))
|
||||
((string=? method "length") (string-length s)) ; exact int (= JVM)
|
||||
((string=? method "isEmpty") (fx=? (string-length s) 0))
|
||||
((string=? method "charAt") (string-ref s (jolt->idx (arg 0))))
|
||||
((string=? method "substring")
|
||||
(substring s (jolt->idx (arg 0))
|
||||
(if (fx>? (length rest) 1) (jolt->idx (arg 1)) (string-length s))))
|
||||
((string=? method "indexOf")
|
||||
(str-index-of s (str-needle (arg 0))
|
||||
(if (fx>? (length rest) 1) (jolt->idx (arg 1)) 0)))
|
||||
((string=? method "lastIndexOf")
|
||||
(str-last-index-of s (str-needle (arg 0))))
|
||||
((string=? method "startsWith")
|
||||
(let ((p (arg 0))) (and (fx>=? (string-length s) (string-length p))
|
||||
(string=? (substring s 0 (string-length p)) p))))
|
||||
((string=? method "endsWith")
|
||||
(let ((p (arg 0)) (slen (string-length s)))
|
||||
(and (fx>=? slen (string-length p))
|
||||
(string=? (substring s (fx- slen (string-length p)) slen) p))))
|
||||
((string=? method "contains")
|
||||
(fx>=? (str-index-of s (str-needle (arg 0)) 0) 0))
|
||||
((string=? method "concat") (string-append s (arg 0)))
|
||||
((string=? method "replace") (str-replace-literal s (str-needle (arg 0)) (str-needle (arg 1))))
|
||||
((string=? method "equalsIgnoreCase")
|
||||
(string=? (ascii-string-down s) (ascii-string-down (arg 0))))
|
||||
((string=? method "compareTo")
|
||||
(let ((o (arg 0))) (cond ((string<? s o) -1.0) ((string>? s o) 1.0) (else 0.0))))
|
||||
((string=? method "getBytes")
|
||||
;; (.getBytes s) / (.getBytes s charset) -> a jolt byte-array (seqable /
|
||||
;; countable / alength-able, like (byte-array …)); the JVM returns byte[].
|
||||
(na-byte-array
|
||||
(charset-encode-bv s (if (null? rest)
|
||||
"utf-8"
|
||||
(if (string? (arg 0)) (arg 0) (jolt-str-render-one (arg 0)))))))
|
||||
((string=? method "matches") (if (irregex-match (str-irx (arg 0)) s) #t #f))
|
||||
((string=? method "replaceAll") (irregex-replace/all (str-irx (arg 0)) s (arg 1)))
|
||||
((string=? method "replaceFirst") (irregex-replace (str-irx (arg 0)) s (arg 1)))
|
||||
((string=? method "split")
|
||||
(apply jolt-vector (str-split-drop-trailing (irregex-split (str-irx (arg 0)) s))))
|
||||
;; universal object-methods that reach a string target (seed object-methods):
|
||||
;; a thrown string / Exception. ctor (which keeps the message string) answers
|
||||
;; getMessage with itself; equals is value equality.
|
||||
((or (string=? method "getMessage") (string=? method "getLocalizedMessage")) s)
|
||||
((string=? method "equals") (and (string? (arg 0)) (string=? s (arg 0))))
|
||||
;; String.intern: jolt strings aren't pooled, but value equality holds, so the
|
||||
;; canonical representation is the string itself.
|
||||
((string=? method "intern") s)
|
||||
;; A class token is its canonical-name string, so Class methods land here:
|
||||
;; (.getName (.getClass x)) / (.getSimpleName …) over the name string.
|
||||
((or (string=? method "getName") (string=? method "getCanonicalName")) s)
|
||||
((string=? method "getSimpleName")
|
||||
(let ((i (str-last-index-of s "."))) (if (>= i 0) (substring s (+ i 1) (string-length s)) s)))
|
||||
;; .getChars srcBegin srcEnd dst dstBegin — copy s[srcBegin,srcEnd) into the
|
||||
;; char-array dst at dstBegin (used by buffered readers, e.g. data.json).
|
||||
((string=? method "getChars")
|
||||
(let ((src-begin (jolt->idx (arg 0))) (src-end (jolt->idx (arg 1)))
|
||||
(dv (jolt-array-vec (arg 2))) (dst-begin (jolt->idx (arg 3))))
|
||||
(let loop ((i src-begin) (j dst-begin))
|
||||
(when (fx<? i src-end)
|
||||
(vector-set! dv j (string-ref s i))
|
||||
(loop (fx+ i 1) (fx+ j 1)))))
|
||||
jolt-nil)
|
||||
((string=? method "subSequence")
|
||||
(substring s (jolt->idx (arg 0)) (jolt->idx (arg 1))))
|
||||
;; Class.isArray over a class-name string: array classes are "[…" (e.g. "[C").
|
||||
((string=? method "isArray") (and (fx>? (string-length s) 0) (char=? (string-ref s 0) #\[)))
|
||||
(else (error #f (string-append "No method " method " for value")))))
|
||||
|
||||
;; --- clojure.core str-* primitives (the substrate clojure.string.clj calls) ---
|
||||
;; clojure.string.clj is pure Clojure over these
|
||||
;; natives; def-var!'d here so the emitted
|
||||
;; clojure.string prelude tier's var-derefs resolve:
|
||||
;; string/ascii-* (ASCII), string/find (index or nil), core-str-* (regex|literal).
|
||||
|
||||
;; (string/split sep s) -> parts, splitting on each non-overlapping sep.
|
||||
(define (str-literal-split s sep)
|
||||
(let ((slen (string-length s)) (plen (string-length sep)))
|
||||
(if (fx=? plen 0)
|
||||
(map string (string->list s))
|
||||
(let loop ((i 0) (start 0) (acc '()))
|
||||
(cond ((fx>? (fx+ i plen) slen)
|
||||
(reverse (cons (substring s start slen) acc)))
|
||||
((string=? (substring s i (fx+ i plen)) sep)
|
||||
(loop (fx+ i plen) (fx+ i plen) (cons (substring s start i) acc)))
|
||||
(else (loop (fx+ i 1) start acc)))))))
|
||||
|
||||
(define (str-upper s) (ascii-string-up s))
|
||||
(define (str-lower s) (ascii-string-down s))
|
||||
(define (str-reverse-b s) (list->string (reverse (string->list s))))
|
||||
|
||||
;; (str-find needle haystack) -> exact int index of first occurrence, or nil.
|
||||
(define (str-find needle s)
|
||||
(let ((i (str-index-of s needle 0)))
|
||||
(if (fx<? i 0) jolt-nil i)))
|
||||
|
||||
;; (str-join coll [sep]) -> stringify each element (Clojure str), join by sep.
|
||||
;; str-join-strs (defined below) does the join; here we just render each element.
|
||||
(define (str-join coll . opt)
|
||||
(let ((sep (if (pair? opt) (jolt-str-render-one (car opt)) "")))
|
||||
(str-join-strs (map jolt-str-render-one (seq->list coll)) sep)))
|
||||
|
||||
;; (re-split irx s limit) -> parts, splitting at each match. Keeps interior AND
|
||||
;; trailing empty strings (the clojure.string wrapper drops trailing for limit 0);
|
||||
;; a positive limit yields at most `limit` parts (the rest kept unsplit).
|
||||
;; The clojure.string.clj split wrapper
|
||||
;; layers the trailing-empty trim on top.
|
||||
(define (re-split irx s limit)
|
||||
(let ((len (string-length s)))
|
||||
(let loop ((start 0) (last 0) (out '()))
|
||||
(if (and limit (fx>=? (length out) (fx- limit 1)))
|
||||
(reverse (cons (substring s last len) out))
|
||||
(let ((m (and (fx<=? start len) (irregex-search irx s start))))
|
||||
(if (not m)
|
||||
(reverse (cons (substring s last len) out))
|
||||
(let ((ms (irregex-match-start-index m 0))
|
||||
(me (irregex-match-end-index m 0)))
|
||||
(if (fx=? me ms) ; zero-width: step past to avoid a stall
|
||||
(if (fx>=? start len)
|
||||
(reverse (cons (substring s last len) out))
|
||||
(loop (fx+ start 1) last out))
|
||||
(loop me me (cons (substring s last ms) out))))))))))
|
||||
|
||||
;; (str-split pat s [limit]) -> parts. Regex or literal separator; a positive
|
||||
;; limit caps the part count (the unsplit tail kept), matching core-str-split.
|
||||
(define (str-split pat s . opt)
|
||||
(let ((limit (if (and (pair? opt) (not (jolt-nil? (car opt)))) (jolt->idx (car opt)) #f)))
|
||||
(if (jolt-regex? pat)
|
||||
(apply jolt-vector (re-split (regex-t-irx pat) s limit))
|
||||
(let ((parts (str-literal-split s pat)))
|
||||
(apply jolt-vector
|
||||
(if (and limit (fx>? limit 0) (fx>? (length parts) limit))
|
||||
(append (list-head parts (fx- limit 1))
|
||||
(list (str-join-strs (list-tail parts (fx- limit 1)) pat)))
|
||||
parts))))))
|
||||
(define (str-join-strs strs sep)
|
||||
(let loop ((xs strs) (first #t) (acc '()))
|
||||
(cond ((null? xs) (apply string-append (reverse acc)))
|
||||
(first (loop (cdr xs) #f (cons (car xs) acc)))
|
||||
(else (loop (cdr xs) #f (cons (car xs) (cons sep acc)))))))
|
||||
|
||||
;; $0/$1... expansion in a string replacement against an irregex match (the
|
||||
;; JVM/seed replacement syntax). $N -> group N's text (dropped if non-matching).
|
||||
(define (expand-dollar repl m)
|
||||
(let ((len (string-length repl)))
|
||||
(let loop ((i 0) (acc '()))
|
||||
(if (fx>=? i len)
|
||||
(apply string-append (reverse acc))
|
||||
(let ((c (string-ref repl i)))
|
||||
(if (and (char=? c #\$) (fx<? (fx+ i 1) len)
|
||||
(char<=? #\0 (string-ref repl (fx+ i 1)))
|
||||
(char<=? (string-ref repl (fx+ i 1)) #\9))
|
||||
(let* ((n (fx- (char->integer (string-ref repl (fx+ i 1))) 48))
|
||||
(g (and (fx<=? n (irregex-match-num-submatches m))
|
||||
(irregex-match-substring m n))))
|
||||
(loop (fx+ i 2) (if g (cons g acc) acc)))
|
||||
(loop (fx+ i 1) (cons (string c) acc))))))))
|
||||
|
||||
;; One match's replacement text. A string gets $N expansion; a fn (jolt closure)
|
||||
;; is called with the match result (whole string, or [whole g1 ...] when grouped)
|
||||
;; and its result stringified.
|
||||
(define (replacement-text replacement m)
|
||||
(cond
|
||||
((string? replacement) (expand-dollar replacement m))
|
||||
((procedure? replacement) (jolt-str-render-one (jolt-invoke replacement (irx-result m))))
|
||||
(else (jolt-str-render-one replacement))))
|
||||
|
||||
;; regex replace, first or all matches.
|
||||
(define (re-replace irx s replacement all?)
|
||||
(let ((len (string-length s)))
|
||||
(let loop ((start 0) (last 0) (acc '()))
|
||||
(let ((m (and (fx<=? start len) (irregex-search irx s start))))
|
||||
(if (not m)
|
||||
(apply string-append (reverse (cons (substring s last len) acc)))
|
||||
(let ((ms (irregex-match-start-index m 0))
|
||||
(me (irregex-match-end-index m 0)))
|
||||
(if (fx=? me ms) ; zero-width: step past
|
||||
(if (fx>=? start len)
|
||||
(apply string-append (reverse (cons (substring s last len) acc)))
|
||||
(loop (fx+ start 1) last acc))
|
||||
(let ((acc2 (cons (replacement-text replacement m)
|
||||
(cons (substring s last ms) acc))))
|
||||
(if all?
|
||||
(loop me me acc2)
|
||||
(apply string-append (reverse (cons (substring s me len) acc2))))))))))))
|
||||
|
||||
;; (str-replace-all pat repl s) / (str-replace pat repl s) — regex or literal.
|
||||
(define (str-replace-all pat repl s)
|
||||
(if (jolt-regex? pat)
|
||||
(re-replace (regex-t-irx pat) s repl #t)
|
||||
;; literal match: a char/number match or replacement (str/replace s \a \b)
|
||||
;; coerces to a string, as on the JVM.
|
||||
(str-replace-literal s (str-needle pat) (str-needle repl))))
|
||||
(define (str-replace-literal-first s a b)
|
||||
(let ((alen (string-length a)) (i (str-index-of s a 0)))
|
||||
(if (fx<? i 0) s
|
||||
(string-append (substring s 0 i) b (substring s (fx+ i alen) (string-length s))))))
|
||||
(define (str-replace pat repl s)
|
||||
(if (jolt-regex? pat)
|
||||
(re-replace (regex-t-irx pat) s repl #f)
|
||||
(str-replace-literal-first s (str-needle pat) (str-needle repl))))
|
||||
|
||||
(def-var! "clojure.core" "str-upper" str-upper)
|
||||
(def-var! "clojure.core" "str-lower" str-lower)
|
||||
(def-var! "clojure.core" "str-trim" str-trim)
|
||||
(def-var! "clojure.core" "str-triml" str-triml)
|
||||
(def-var! "clojure.core" "str-trimr" str-trimr)
|
||||
(def-var! "clojure.core" "str-find" str-find)
|
||||
(def-var! "clojure.core" "str-reverse-b" str-reverse-b)
|
||||
(def-var! "clojure.core" "str-join" str-join)
|
||||
(def-var! "clojure.core" "str-split" str-split)
|
||||
(def-var! "clojure.core" "str-replace" str-replace)
|
||||
(def-var! "clojure.core" "str-replace-all" str-replace-all)
|
||||
|
||||
;; (require ...) / (use ...) at runtime: register each spec's :as alias + :refer
|
||||
;; names into the runtime ns tables (chez-register-spec!, ns.ss), keyed by the
|
||||
;; current ns. The spine also pre-registers these at analyze time (idempotent),
|
||||
;; so ns-aliases/ns-resolve over an :as alias resolve. Specs arrive evaluated
|
||||
;; (quoted).
|
||||
(define (chez-runtime-require . specs)
|
||||
(for-each (lambda (s) (chez-register-spec! (chez-current-ns) s)) specs)
|
||||
jolt-nil)
|
||||
(def-var! "clojure.core" "require" chez-runtime-require)
|
||||
;; use = require + refer ALL of the target's public vars (unless an explicit
|
||||
;; :only/:refer filter is given, which chez-register-spec! handles per-name).
|
||||
(define (chez-runtime-use . specs)
|
||||
(for-each
|
||||
(lambda (spec)
|
||||
(chez-register-spec! (chez-current-ns) spec)
|
||||
(let* ((items (cond ((pvec? spec) (seq->list spec))
|
||||
((or (cseq? spec) (empty-list-t? spec)) (seq->list spec))
|
||||
((symbol-t? spec) (list spec))
|
||||
(else '())))
|
||||
(target (and (pair? items) (symbol-t? (car items)) (symbol-t-name (car items))))
|
||||
(filtered (let scan ((xs (if (pair? items) (cdr items) '())))
|
||||
(cond ((null? xs) #f)
|
||||
((and (keyword? (car xs))
|
||||
(member (keyword-t-name (car xs)) '("only" "refer"))) #t)
|
||||
(else (scan (cdr xs)))))))
|
||||
(when (and target (not filtered))
|
||||
(chez-register-refer-all! (chez-current-ns) target))))
|
||||
specs)
|
||||
jolt-nil)
|
||||
(def-var! "clojure.core" "use" chez-runtime-use)
|
||||
;; import: bring a deftype/defrecord from another ns into the current one. A spec
|
||||
;; [from-ns Type ...] binds each Type's ctor closure under the current ns, so its
|
||||
;; (Type. ...) constructor (host-new resolves it as a var) works after :import.
|
||||
(define (chez-runtime-import . specs)
|
||||
(for-each
|
||||
(lambda (spec)
|
||||
(let ((items (cond ((pvec? spec) (seq->list spec))
|
||||
((or (cseq? spec) (empty-list-t? spec)) (seq->list spec))
|
||||
(else '()))))
|
||||
(when (and (pair? items) (symbol-t? (car items)))
|
||||
(let ((from (symbol-t-name (car items))))
|
||||
(for-each
|
||||
(lambda (tn)
|
||||
(when (symbol-t? tn)
|
||||
(let ((c (var-cell-lookup from (symbol-t-name tn))))
|
||||
(when (and c (var-cell-defined? c))
|
||||
(def-var! (chez-current-ns) (symbol-t-name tn) (var-cell-root c))))))
|
||||
(cdr items))))))
|
||||
specs)
|
||||
jolt-nil)
|
||||
(def-var! "clojure.core" "import" chez-runtime-import)
|
||||
146
host/chez/java/records-interop.ss
Normal file
146
host/chez/java/records-interop.ss
Normal file
|
|
@ -0,0 +1,146 @@
|
|||
;; records-interop.ss — JVM-emulation taxonomy split out of records.ss: the
|
||||
;; ex-info class accessors, the exception supertype hierarchy, and instance-check
|
||||
;; / case-string (the (instance? Class x) decision table). Loaded right after
|
||||
;; records.ss; instance-check forward-refs nothing in records.ss at load time.
|
||||
|
||||
;; pmap? guard: ex-info maps are plain hash-maps, never sorted-map htables — and a
|
||||
;; bare jolt-get on a sorted-map would invoke its comparator on :jolt/type and throw.
|
||||
(define (ex-info-map? v)
|
||||
(and (pmap? v) (jolt=2 (jolt-get v jolt-kw-ex-type jolt-nil) jolt-kw-ex-info)))
|
||||
(define (ex-info-class v)
|
||||
(let ((c (jolt-get v jolt-kw-class jolt-nil)))
|
||||
(if (string? c) c "clojure.lang.ExceptionInfo")))
|
||||
;; immediate-parent chain of the JVM exception hierarchy (simple names). Drives
|
||||
;; instance? across exception supertypes — (instance? Throwable (ex-info …)) etc.
|
||||
(define exception-parent
|
||||
'(("ExceptionInfo" . "RuntimeException")
|
||||
("RuntimeException" . "Exception")
|
||||
("IllegalArgumentException" . "RuntimeException")
|
||||
("NumberFormatException" . "IllegalArgumentException")
|
||||
("IllegalStateException" . "RuntimeException")
|
||||
("UnsupportedOperationException" . "RuntimeException")
|
||||
("ArithmeticException" . "RuntimeException")
|
||||
("NullPointerException" . "RuntimeException")
|
||||
("ClassCastException" . "RuntimeException")
|
||||
("IndexOutOfBoundsException" . "RuntimeException")
|
||||
("ConcurrentModificationException" . "RuntimeException")
|
||||
("NoSuchElementException" . "RuntimeException")
|
||||
("UncheckedIOException" . "RuntimeException")
|
||||
("DateTimeException" . "RuntimeException")
|
||||
("DateTimeParseException" . "DateTimeException")
|
||||
("InterruptedException" . "Exception")
|
||||
("IOException" . "Exception")
|
||||
("FileNotFoundException" . "IOException")
|
||||
("UnsupportedEncodingException" . "IOException")
|
||||
("UnknownHostException" . "IOException")
|
||||
("SocketException" . "IOException")
|
||||
("ConnectException" . "IOException")
|
||||
("SocketTimeoutException" . "IOException")
|
||||
("MalformedURLException" . "IOException")
|
||||
("SSLException" . "IOException")
|
||||
("Exception" . "Throwable")
|
||||
("Error" . "Throwable")
|
||||
("AssertionError" . "Error")
|
||||
("Throwable" . "Object")))
|
||||
;; Is `wanted` (simple name) `cls` or a supertype of it? ExceptionInfo also
|
||||
;; implements the IExceptionInfo interface.
|
||||
(define (exception-isa? cls wanted)
|
||||
(let loop ((c cls))
|
||||
(cond ((not c) #f)
|
||||
((string=? c wanted) #t)
|
||||
((and (string=? c "ExceptionInfo") (string=? wanted "IExceptionInfo")) #t)
|
||||
(else (let ((p (assoc c exception-parent))) (loop (and p (cdr p))))))))
|
||||
|
||||
;; instance-check: (type-sym val) — type/protocol membership. Host shims loaded
|
||||
;; later (io, inst-time, natives-array, natives-queue, host-static-classes)
|
||||
;; register an arm with register-instance-check-arm! instead of set!-wrapping
|
||||
;; instance-check; an arm returns #t/#f to decide or 'pass to defer to the next.
|
||||
;; Newest arm is checked first (matches the old outermost-wins set! order).
|
||||
;; instance-check-base is the JVM taxonomy fallback when no arm decides.
|
||||
(define instance-check-registry '())
|
||||
(define (register-instance-check-arm! f) ; f: (type-sym val) -> #t | #f | 'pass
|
||||
(set! instance-check-registry (cons f instance-check-registry)))
|
||||
|
||||
(define (instance-check-base type-sym val)
|
||||
(let ((tname (symbol-t-name type-sym)))
|
||||
(cond
|
||||
((jrec? val)
|
||||
(let ((tag (jrec-tag val)))
|
||||
(or (string=? tag tname)
|
||||
(and (> (string-length tag) (string-length tname))
|
||||
(string=? (substring tag (- (string-length tag) (string-length tname)) (string-length tag)) tname))
|
||||
;; a protocol/interface the type implements (defprotocol generates an
|
||||
;; interface; (instance? SomeProtocol record) is true when the record
|
||||
;; implements it — core.match dispatches on instance? IPatternCompile).
|
||||
(type-satisfies? tag tname)
|
||||
(type-satisfies? tag (last-dot tname)))))
|
||||
((jreify? val) (let ((short (last-dot tname)))
|
||||
;; every Clojure reify implements IObj/IMeta (carries metadata).
|
||||
(or (member short '("IObj" "IMeta"))
|
||||
(and (memp (lambda (p) (string=? (last-dot p) short)) (jreify-protos val)) #t))))
|
||||
((ex-info-map? val) (exception-isa? (last-dot (ex-info-class val)) (last-dot tname)))
|
||||
(else (case-string tname val)))))
|
||||
|
||||
(define (instance-check type-sym0 val)
|
||||
;; a Class value as the type arg (instance? (class x) y) -> use its name string.
|
||||
(let* ((type-sym (if (jclass? type-sym0) (jclass-name type-sym0) type-sym0))
|
||||
(ts (if (and (string? type-sym)
|
||||
(or (= 0 (string-length type-sym))
|
||||
(not (char=? (string-ref type-sym 0) #\[))))
|
||||
(jolt-symbol #f type-sym)
|
||||
type-sym)))
|
||||
(let loop ((rs instance-check-registry))
|
||||
(if (null? rs)
|
||||
(instance-check-base ts val)
|
||||
(let ((r ((car rs) ts val)))
|
||||
(if (eq? r 'pass) (loop (cdr rs)) r))))))
|
||||
(define (case-string tname val)
|
||||
(cond
|
||||
((member tname '("Number" "java.lang.Number")) (number? val))
|
||||
((member tname '("Long" "java.lang.Long" "Integer" "java.lang.Integer"))
|
||||
(and (number? val) (exact? val) (integer? val)))
|
||||
((member tname '("Double" "java.lang.Double" "Float" "java.lang.Float")) (and (number? val) (flonum? val)))
|
||||
((member tname '("Ratio" "clojure.lang.Ratio")) (and (number? val) (exact? val) (rational? val) (not (integer? val))))
|
||||
((member tname '("String" "java.lang.String" "CharSequence" "java.lang.CharSequence")) (string? val))
|
||||
((member tname '("Boolean" "java.lang.Boolean")) (boolean? val))
|
||||
((member tname '("Character" "java.lang.Character")) (char? val))
|
||||
((member tname '("Keyword" "clojure.lang.Keyword")) (keyword? val))
|
||||
((member tname '("Symbol" "clojure.lang.Symbol")) (jolt-symbol? val))
|
||||
((member tname '("Atom" "clojure.lang.Atom")) (jolt-atom? val))
|
||||
((member tname '("IFn" "clojure.lang.IFn" "Fn" "clojure.lang.Fn")) (procedure? val))
|
||||
((member tname '("Pattern" "java.util.regex.Pattern")) (regex-t? val))
|
||||
((member tname '("URI" "java.net.URI"))
|
||||
(and (jhost? val) (string=? (jhost-tag val) "uri")))
|
||||
((member tname '("File" "java.io.File")) (jfile? val))
|
||||
((member tname '("UUID" "java.util.UUID")) (juuid? val))
|
||||
(else #f)))
|
||||
|
||||
;; str of a record uses a custom (Object toString) impl if the type defines one
|
||||
;; (deftype with no default toString relies on this); otherwise the map form
|
||||
;; without the leading # (Clojure's record .toString). converters.ss loads before
|
||||
;; records.ss, so this set! sees the registry — forward refs resolve at call time.
|
||||
|
||||
(def-var! "clojure.core" "instance-check" instance-check)
|
||||
|
||||
;; Broad-catch fallback for catch-clause dispatch (analyze-try desugars
|
||||
;; (catch C e …) to (or (instance? C e) (__catch-broad? "C" e))). A jolt host
|
||||
;; condition or a raw raised value carries no jolt exception class, so instance?
|
||||
;; can't place it; a Clojure (catch C e) over such a value matches when C is
|
||||
;; RuntimeException (or a subclass) / Exception / Throwable — most host runtime
|
||||
;; errors are RuntimeExceptions. Typed throwables (ex-info, (SomeException. …)) are
|
||||
;; recognized by instance? as Throwable, so untyped? is false and they dispatch
|
||||
;; precisely through the instance? arm instead.
|
||||
(define throwable-type-sym (jolt-symbol #f "Throwable"))
|
||||
(define (simple-class-name nm)
|
||||
(let loop ((i (- (string-length nm) 1)))
|
||||
(cond ((< i 0) nm)
|
||||
((char=? (string-ref nm i) #\.) (substring nm (+ i 1) (string-length nm)))
|
||||
(else (loop (- i 1))))))
|
||||
(define (jolt-catch-broad? nm v)
|
||||
(and (not (instance-check throwable-type-sym v))
|
||||
(let ((s (simple-class-name nm)))
|
||||
(or (exception-isa? s "RuntimeException")
|
||||
(string=? s "Exception")
|
||||
(string=? s "Throwable")))))
|
||||
(def-var! "clojure.core" "__catch-broad?"
|
||||
(lambda (nm v) (if (jolt-catch-broad? nm v) #t #f)))
|
||||
Loading…
Add table
Add a link
Reference in a new issue