e17bcfd0af
The clojure.string case fns and searches now take any Object s through its toString like the reference's ^CharSequence signatures ((upper-case :kw) is ":KW", (capitalize 1) is "1"); nil throws, and a nil substr in starts-with?/ends-with? throws. some-fn re-ported with the reference arities: (some-fn) is an arity error and a no-match result is the last predicate's own falsy value (false, not nil). ifn? covers multimethods, promises (which are now invocable — calling one delivers, via a cold-path invoke-arm registry that costs the hot dispatch nothing), and deftypes implementing IFn's invoke. One structural find on the way: defmulti/defmethod deferred inside a fn body (the deftest pattern) interned/resolved in whatever namespace was current when they RAN, not the one they were written in — the macros now bake their expansion ns and the setups honor it. Also: Boolean/Integer/Double wrapper ctors, primitive TYPE statics (Integer/TYPE etc.), .reduce on collections (IReduce), and Long/TYPE. cts baseline 5857 -> 5904 pass, 58 -> 28 errors, 57 baselined namespaces — the string cluster, some-fn, ifn-qmark, boolean-qmark, and reduce namespaces are all fully clean. 7 JVM-certified corpus rows; spec entry.
445 lines
26 KiB
Scheme
445 lines
26 KiB
Scheme
;; 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))))
|
|
;; getExponent: the unbiased binary exponent of a double (floor(log2|x|));
|
|
;; scalb: x * 2^n. test.check's double generator uses both.
|
|
(cons "getExponent" (lambda (x) (if (= x 0.0) -1023
|
|
(exact (floor (/ (log (abs (exact->inexact x))) (log 2.0)))))))
|
|
(cons "scalb" (lambda (x n) (->dbl (* (exact->inexact x) (expt 2.0 (jnum->exact n))))))
|
|
(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)))
|
|
|
|
;; clojure.lang.RT/map: build a map from a [k v k v…] array/seq (RT.map). Small
|
|
;; maps keep insertion order (PersistentArrayMap). tools.reader builds map and
|
|
;; namespaced-map literals this way.
|
|
(define (rt-map arr)
|
|
(let loop ((xs (if (jolt-nil? arr) '() (seq->list (jolt-seq arr)))) (m (jolt-hash-map)))
|
|
(cond ((null? xs) m)
|
|
((null? (cdr xs)) (error #f "RT/map: odd key/value count"))
|
|
(else (loop (cddr xs) (jolt-assoc m (car xs) (cadr xs)))))))
|
|
(register-class-statics! "RT" (list (cons "map" rt-map)))
|
|
(register-class-statics! "clojure.lang.RT" (list (cons "map" rt-map)))
|
|
|
|
;; clojure.lang.PersistentList/create: a list (in order) from a seq; empty -> ().
|
|
(define (plist-create x)
|
|
(let ((items (seq->list (jolt-seq x))))
|
|
(if (null? items) jolt-empty-list (list->cseq items))))
|
|
(register-class-statics! "PersistentList" (list (cons "create" plist-create)))
|
|
(register-class-statics! "clojure.lang.PersistentList" (list (cons "create" plist-create)))
|
|
|
|
;; clojure.lang.PersistentHashSet/createWithCheck: a set from a seq, throwing on a
|
|
;; duplicate element (tools.reader's #{…} reader reports the dup).
|
|
(define (phs-create-with-check x)
|
|
(let loop ((xs (seq->list (jolt-seq x))) (s (jolt-hash-set)))
|
|
(if (null? xs) s
|
|
(let ((e (car xs)))
|
|
(if (jolt-truthy? (jolt-contains? s e))
|
|
(jolt-throw (jolt-ex-info (string-append "Duplicate key: " (jolt-str-render-one e)) (jolt-hash-map)))
|
|
(loop (cdr xs) (jolt-conj1 s e)))))))
|
|
(register-class-statics! "PersistentHashSet" (list (cons "createWithCheck" phs-create-with-check)))
|
|
(register-class-statics! "clojure.lang.PersistentHashSet" (list (cons "createWithCheck" phs-create-with-check)))
|
|
|
|
;; java.lang.Character statics. digit(ch, radix) -> the digit value or -1; ch may
|
|
;; be a char or an int codepoint (tools.reader passes (int c)). isDigit/
|
|
;; isWhitespace take a char; valueOf boxes a char (identity on jolt).
|
|
(define (char->cp x) (if (char? x) (char->integer x) (jnum->exact x)))
|
|
(define (char-digit-value cp radix)
|
|
(let ((d (cond ((and (fx>=? cp 48) (fx<=? cp 57)) (fx- cp 48)) ; 0-9
|
|
((and (fx>=? cp 97) (fx<=? cp 122)) (fx+ 10 (fx- cp 97))) ; a-z
|
|
((and (fx>=? cp 65) (fx<=? cp 90)) (fx+ 10 (fx- cp 65))) ; A-Z
|
|
(else 99))))
|
|
(if (fx<? d radix) d -1)))
|
|
(define character-statics
|
|
(list (cons "digit" (lambda (ch radix) (->num (char-digit-value (char->cp ch) (jnum->exact radix)))))
|
|
(cons "isDigit" (lambda (ch) (let ((cp (char->cp ch))) (and (fx>=? cp 48) (fx<=? cp 57)))))
|
|
(cons "isWhitespace" (lambda (ch) (char-whitespace? (integer->char (char->cp ch)))))
|
|
(cons "valueOf" (lambda (ch) (if (char? ch) ch (integer->char (char->cp ch)))))))
|
|
(register-class-statics! "Character" character-statics)
|
|
(register-class-statics! "java.lang.Character" character-statics)
|
|
|
|
;; java.util.regex.Pattern/compile: a regex value from a string pattern.
|
|
(define pattern-statics (list (cons "compile" (lambda (s) (jolt-regex (jolt-str-render-one s))))))
|
|
(register-class-statics! "Pattern" pattern-statics)
|
|
(register-class-statics! "java.util.regex.Pattern" pattern-statics)
|
|
|
|
;; clojure.lang.BigInt / clojure.lang.Numbers: jolt has one exact-integer type
|
|
;; (Chez bignums auto-reduce), so BigInt.fromBigInteger and Numbers.reduceBigInt
|
|
;; are identity. tools.reader's number parser threads integers through these.
|
|
(define identity-num-statics (list (cons "fromBigInteger" (lambda (x) x))))
|
|
(register-class-statics! "BigInt" identity-num-statics)
|
|
(register-class-statics! "clojure.lang.BigInt" identity-num-statics)
|
|
(register-class-statics! "Numbers"
|
|
(list (cons "reduceBigInt" (lambda (x) x)) (cons "toRatio" (lambda (x) x))))
|
|
(register-class-statics! "clojure.lang.Numbers"
|
|
(list (cons "reduceBigInt" (lambda (x) x)) (cons "toRatio" (lambda (x) x))))
|
|
|
|
(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)))))
|
|
|
|
;; java.lang.Long.bitCount: the population count of the value's 64-bit two's-
|
|
;; complement (mask to 64 bits so a negative long counts like the JVM, e.g.
|
|
;; bitCount(-1) = 64). test.check's splittable PRNG uses it.
|
|
(define long-mask64 #xFFFFFFFFFFFFFFFF)
|
|
(define long-2^63 (expt 2 63))
|
|
(define long-2^64 (expt 2 64))
|
|
;; interpret a 64-bit value as a signed long (top bit = sign), like the JVM.
|
|
(define (as-signed64 v) (if (>= v long-2^63) (- v long-2^64) v))
|
|
(define (long-nlz n) (- 64 (integer-length (bitwise-and (jnum->exact n) long-mask64))))
|
|
(define (long-reverse n)
|
|
(let ((v (bitwise-and (jnum->exact n) long-mask64)))
|
|
(let loop ((i 0) (r 0))
|
|
(if (fx=? i 64) (as-signed64 r)
|
|
(loop (fx+ i 1)
|
|
(bitwise-ior (bitwise-arithmetic-shift-left r 1)
|
|
(bitwise-and (bitwise-arithmetic-shift-right v i) 1)))))))
|
|
(register-class-statics! "Long"
|
|
(list (cons "TYPE" "long")
|
|
(cons "MAX_VALUE" (->num 9223372036854775807))
|
|
(cons "MIN_VALUE" (->num -9223372036854775808))
|
|
(cons "bitCount" (lambda (n) (->num (bitwise-bit-count (bitwise-and (jnum->exact n) long-mask64)))))
|
|
(cons "numberOfLeadingZeros" (lambda (n) (->num (long-nlz n))))
|
|
(cons "reverse" (lambda (n) (->num (long-reverse n))))
|
|
(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))
|
|
;; the primitive class token (int.class); jolt models a class as its name
|
|
(cons "TYPE" "int")
|
|
(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))))))))
|
|
|
|
;; Byte / Short bounds (their values are plain integers on jolt; the statics let
|
|
;; libraries reference the JVM ranges — clojure.test.check generates over them).
|
|
(register-class-statics! "Byte"
|
|
(list (cons "TYPE" "byte")
|
|
(cons "MAX_VALUE" (->num 127)) (cons "MIN_VALUE" (->num -128))
|
|
(cons "valueOf" (lambda (x . r) (->num (if (number? x) x (parse-int-or-throw x 10 "valueOf")))))
|
|
(cons "parseByte" (lambda (x . r) (parse-int-or-throw x (if (null? r) 10 (jnum->exact (car r))) "parseByte")))
|
|
(cons "toString" (lambda (x . r) (number->string (jnum->exact x))))))
|
|
(register-class-statics! "Short"
|
|
(list (cons "TYPE" "short")
|
|
(cons "MAX_VALUE" (->num 32767)) (cons "MIN_VALUE" (->num -32768))
|
|
(cons "valueOf" (lambda (x . r) (->num (if (number? x) x (parse-int-or-throw x 10 "valueOf")))))
|
|
(cons "parseShort" (lambda (x . r) (parse-int-or-throw x (if (null? r) 10 (jnum->exact (car r))) "parseShort")))
|
|
(cons "toString" (lambda (x . r) (number->string (jnum->exact x))))))
|
|
|
|
;; java.util.Locale — jolt's case ops are codepoint-based (locale-independent), so
|
|
;; the default locale is a no-op token. Libraries set/restore it around formatting
|
|
;; to prove output is locale-stable (honeysql's Turkish-İ regression guard).
|
|
(register-class-statics! "Locale"
|
|
(list (cons "getDefault" (lambda () "und"))
|
|
(cons "setDefault" (lambda (x) jolt-nil))
|
|
(cons "forLanguageTag" (lambda (tag) (if (string? tag) tag (jolt-str-render-one tag))))
|
|
(cons "ROOT" "und") (cons "US" "en-US") (cons "ENGLISH" "en")))
|
|
|
|
(register-class-statics! "Boolean"
|
|
(list (cons "TYPE" "boolean")
|
|
(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 "TYPE" "double")
|
|
(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 "TYPE" "float")
|
|
(cons "parseFloat" parse-double-or-throw) (cons "valueOf" ->double)))
|
|
|
|
;; Character: ASCII predicates (the engine is byte/ASCII oriented).
|
|
(register-class-statics! "Character"
|
|
(list (cons "TYPE" "char")
|
|
(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)))))
|
|
;; JVM Character.isWhitespace: Unicode whitespace (so U+2028 line separator
|
|
;; counts, like the JVM) MINUS the no-break spaces the JVM excludes
|
|
;; (U+00A0/U+2007/U+202F). char<=?space missed everything above ASCII.
|
|
(cons "isWhitespace" (lambda (c) (let ((cp (char-code c)))
|
|
(and (char-whitespace? (integer->char cp))
|
|
(not (fx=? cp #xA0)) (not (fx=? cp #x2007)) (not (fx=? cp #x202F))))))))
|
|
|
|
;; 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).
|
|
;; java.* / clojure.* packages jolt does NOT back, even though the broad prefix
|
|
;; below would otherwise claim them — optional backends a library feature-probes
|
|
;; with (Class/forName …) (e.g. tools.logging's java.util.logging / log4j). Listing
|
|
;; them here keeps class-found? honest so the probe sees them absent and skips the
|
|
;; backend (jolt has its own logging) instead of trying to use it and crashing.
|
|
(define forname-absent-prefixes
|
|
'("java.util.logging." "javax.management." "java.lang.management."))
|
|
(define (forname-known? nm)
|
|
;; exact lookups only — lookup-class would fall back to the short class name, so
|
|
;; any "x.y.Class" would spuriously match the registered java.lang.Class.
|
|
(or (hashtable-ref class-statics-tbl nm #f)
|
|
(hashtable-ref class-ctors-tbl nm #f)
|
|
(let ((pre? (lambda (p) (and (>= (string-length nm) (string-length p))
|
|
(string=? (substring nm 0 (string-length p)) p)))))
|
|
(and (or (pre? "java.") (pre? "clojure.") (pre? "jolt."))
|
|
(not (exists pre? forname-absent-prefixes))))))
|
|
(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))))
|
|
|