Merge pull request #172 from jolt-lang/spike/chez-bootstrap
Conformance + nREPL fixes from the library sweep
This commit is contained in:
Dmitri Sotnikov
GitHub
commit
2a07792757
20 changed files with 907 additions and 49 deletions
|
|
@ -272,3 +272,43 @@
|
|||
(def-var! "clojure.core" "make-delay" jolt-make-delay)
|
||||
(def-var! "clojure.core" "delay?" jolt-delay?)
|
||||
(def-var! "clojure.core" "deref" jolt-deref)
|
||||
|
||||
;; --- cooperative thread interrupt (jolt-amzy) -------------------------------
|
||||
;; 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)
|
||||
|
|
|
|||
|
|
@ -70,10 +70,20 @@
|
|||
(let ((a (car args)))
|
||||
(cond
|
||||
((jolt-symbol? a) a)
|
||||
;; no-ns sentinel is #f — matches emit's quoted-symbol lowering
|
||||
;; (jolt-symbol #f "x"), so (= 'x (symbol "x")) holds (jolt= compares ns
|
||||
;; with strict equal?; jolt-nil vs #f would otherwise differ).
|
||||
((string? a) (jolt-symbol #f a))
|
||||
;; (symbol "ns/name") splits the namespace at the LAST "/" (JVM
|
||||
;; Symbol.intern), so (namespace (symbol "foo/bar")) => "foo". A lone "/"
|
||||
;; or a leading slash has no namespace. The no-ns sentinel is #f — matches
|
||||
;; emit's quoted-symbol lowering (jolt-symbol #f "x"), so (= 'x (symbol
|
||||
;; "x")) holds (jolt= compares ns with strict equal?).
|
||||
((string? a)
|
||||
(let ((slen (string-length a)))
|
||||
(if (string=? a "/")
|
||||
(jolt-symbol #f "/")
|
||||
(let loop ((i (- slen 1)))
|
||||
(cond ((<= i 0) (jolt-symbol #f a))
|
||||
((char=? (string-ref a i) #\/)
|
||||
(jolt-symbol (substring a 0 i) (substring a (+ i 1) slen)))
|
||||
(else (loop (- i 1))))))))
|
||||
((keyword? a) (jolt-symbol (keyword-t-ns a) (keyword-t-name a)))
|
||||
(else (error #f "symbol: requires string/symbol" a)))))
|
||||
((= (length args) 2) (jolt-symbol (car args) (cadr args)))
|
||||
|
|
|
|||
|
|
@ -57,6 +57,9 @@
|
|||
(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)))
|
||||
|
|
@ -71,6 +74,9 @@
|
|||
(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)))
|
||||
|
|
|
|||
|
|
@ -102,12 +102,20 @@
|
|||
;; var-deref (rt.ss): the compiled-code read path for every clojure.core var
|
||||
;; reference. Consult the stack first; fall straight back to the root (NOT through
|
||||
;; jolt-var-get's unbound-error path) so undefined-var reads keep prior behaviour.
|
||||
;; The *ns* var cell — its reads are thread-local: with no thread-binding they
|
||||
;; derive from chez-current-ns (a thread-parameter), so *ns* tracks in-ns per
|
||||
;; thread and a (binding [*ns* ..]) drives resolution (jolt-6rld). Captured now
|
||||
;; that *ns* is defined (ns.ss loaded earlier); chez-current-ns consults it too.
|
||||
(set! star-ns-cell (jolt-var "clojure.core" "*ns*"))
|
||||
|
||||
(define %dyn-rt-var-deref var-deref)
|
||||
(set! var-deref
|
||||
(lambda (ns name)
|
||||
(let ((cell (jolt-var ns name)))
|
||||
(let ((bv (dyn-binding-value cell)))
|
||||
(if (eq? bv dyn-no-binding) (var-cell-root cell) bv)))))
|
||||
(cond ((not (eq? bv dyn-no-binding)) bv)
|
||||
((eq? cell star-ns-cell) (intern-ns! (chez-current-ns)))
|
||||
(else (var-cell-root cell)))))))
|
||||
|
||||
;; jolt-var-get (vars.ss): the var-get fn + deref/@ on a cell. Stack first, then
|
||||
;; the original (which errors on an unbound root, matching Clojure).
|
||||
|
|
@ -116,7 +124,9 @@
|
|||
(lambda (v)
|
||||
(if (var-cell? v)
|
||||
(let ((bv (dyn-binding-value v)))
|
||||
(if (eq? bv dyn-no-binding) (%dyn-var-get v) bv))
|
||||
(cond ((not (eq? bv dyn-no-binding)) bv)
|
||||
((eq? v star-ns-cell) (intern-ns! (chez-current-ns)))
|
||||
(else (%dyn-var-get v))))
|
||||
(%dyn-var-get v))))
|
||||
|
||||
;; var-cell keys hash/compare by ns/name (jolt=2 in vars.ss already compares
|
||||
|
|
|
|||
|
|
@ -16,3 +16,10 @@
|
|||
;; *warn-on-reflection* — jolt has no reflection, so the var reads false; (set!
|
||||
;; *warn-on-reflection* …) resolves and updates it (a no-op effect).
|
||||
(def-var! "clojure.core" "*warn-on-reflection*" #f)
|
||||
|
||||
;; *assert* — gates `assert`; settable/bindable (malli.assert toggles it). Default
|
||||
;; true, like the JVM.
|
||||
(def-var! "clojure.core" "*assert*" #t)
|
||||
|
||||
;; *print-readably* — bound by pr-family / with-out-str-style code; default true.
|
||||
(def-var! "clojure.core" "*print-readably*" #t)
|
||||
|
|
|
|||
|
|
@ -28,7 +28,12 @@
|
|||
((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)))))
|
||||
|
||||
(def-var! "clojure.core" "class" jolt-class)
|
||||
|
|
@ -59,6 +64,18 @@
|
|||
("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)))
|
||||
|
|
@ -90,4 +107,12 @@
|
|||
"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"))
|
||||
|
|
|
|||
|
|
@ -57,6 +57,9 @@
|
|||
(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))))
|
||||
|
|
@ -121,6 +124,21 @@
|
|||
(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)))
|
||||
|
||||
;; ---- 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
|
||||
|
|
@ -198,6 +216,8 @@
|
|||
(cons "exit" (lambda args (exit (if (null? args) 0 (jnum->exact (car args))))))
|
||||
;; 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)))))
|
||||
|
||||
|
|
@ -218,6 +238,19 @@
|
|||
(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)))))
|
||||
|
|
@ -226,8 +259,56 @@
|
|||
(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))))))
|
||||
(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 (jolt-1nnn) -------------------------------------
|
||||
;; 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))))
|
||||
(register-class-statics! "NumberFormat"
|
||||
(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! "java.text.NumberFormat"
|
||||
(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! "Class"
|
||||
;; an array descriptor ("[C", "[I", …) is its own class token (so instance? and
|
||||
|
|
@ -251,16 +332,28 @@
|
|||
(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)
|
||||
(cond ((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)))
|
||||
(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") "")
|
||||
|
|
@ -306,6 +399,52 @@
|
|||
;; or a unique sentinel). Each call returns a new jhost so identical?/= separate.
|
||||
(register-class-ctor! "Object" (lambda _ (make-jhost "object" (vector))))
|
||||
|
||||
;; ---- java.util.ArrayList (jolt-1nnn) ----------------------------------------
|
||||
;; A mutable list backed by a Scheme list in a box. medley's stateful transducers
|
||||
;; (window / partition-between) build one with .add / .size / .toArray / .clear /
|
||||
;; .remove. (ArrayList.) | (ArrayList. n) | (ArrayList. coll).
|
||||
(define (al-list self) (vector-ref (jhost-state self) 0))
|
||||
(define (al-set! self xs) (vector-set! (jhost-state self) 0 xs))
|
||||
(define (make-arraylist xs) (make-jhost "arraylist" (vector xs)))
|
||||
(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))))))))
|
||||
(define (al-remove-at xs i)
|
||||
(let loop ((xs xs) (i i) (acc '()))
|
||||
(cond ((null? xs) (reverse acc))
|
||||
((= i 0) (append (reverse acc) (cdr xs)))
|
||||
(else (loop (cdr xs) (- i 1) (cons (car xs) acc))))))
|
||||
(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-set! self (append (al-list self) (list (car a)))) #t)
|
||||
(let ((i (jnum->exact (car a))) (x (cadr a)) (xs (al-list self)))
|
||||
(al-set! self (append (list-head xs i) (list x) (list-tail xs i))) jolt-nil))))
|
||||
(cons "add!" (lambda (self x) (al-set! self (append (al-list self) (list x))) #t))
|
||||
(cons "get" (lambda (self i) (list-ref (al-list self) (jnum->exact i))))
|
||||
(cons "set" (lambda (self i x)
|
||||
(let* ((xs (al-list self)) (idx (jnum->exact i)) (old (list-ref xs idx)))
|
||||
(al-set! self (append (list-head xs idx) (list x) (list-tail xs (+ idx 1)))) old)))
|
||||
(cons "size" (lambda (self) (->num (length (al-list self)))))
|
||||
(cons "isEmpty" (lambda (self) (null? (al-list self))))
|
||||
(cons "remove" (lambda (self i)
|
||||
(let* ((xs (al-list self)) (idx (jnum->exact i)) (old (list-ref xs idx)))
|
||||
(al-set! self (al-remove-at xs idx)) old)))
|
||||
(cons "clear" (lambda (self) (al-set! self '()) 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)))))))
|
||||
|
||||
(register-class-ctor! "StringBuilder"
|
||||
(lambda args (make-jhost "string-builder"
|
||||
;; a numeric first arg is a CAPACITY hint, not content.
|
||||
|
|
@ -532,6 +671,12 @@
|
|||
((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)
|
||||
|
|
@ -542,10 +687,27 @@
|
|||
(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: keep the message string (so getMessage / ex-message work).
|
||||
(for-each (lambda (nm) (register-class-ctor! nm (lambda (msg . _) (if (string? msg) msg (jolt-str-render-one msg)))))
|
||||
'("Exception" "RuntimeException" "IllegalArgumentException" "IllegalStateException"
|
||||
"InterruptedException" "UnsupportedOperationException" "IOException"))
|
||||
;; 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"))
|
||||
|
||||
;; ---- URLEncoder / URLDecoder (www-form-urlencoded) --------------------------
|
||||
(define (url-unreserved? b)
|
||||
|
|
@ -589,7 +751,11 @@
|
|||
|
||||
;; ---- Base64 (RFC 4648) ------------------------------------------------------
|
||||
(define b64-alphabet "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
|
||||
(define (->bytevector x) (cond ((bytevector? x) x) ((string? x) (string->utf8 x)) (else (string->utf8 (jolt-str-render-one x)))))
|
||||
(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))
|
||||
|
|
|
|||
|
|
@ -150,9 +150,83 @@
|
|||
((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))
|
||||
(define (pfail) (error #f (string-append "ParseException: unparseable date \"" input "\"")))
|
||||
(define (run-len i c) (let loop ((j i)) (if (and (< j pn) (char=? (string-ref pattern j) c)) (loop (+ j 1)) (- j i))))
|
||||
(define (read-digits ii) ; -> (val . next), pfail if none
|
||||
(let loop ((j ii) (acc 0) (any #f))
|
||||
(if (and (< j inn) (digit? (string-ref input j)))
|
||||
(loop (+ j 1) (+ (* acc 10) (- (char->integer (string-ref input j)) 48)) #t)
|
||||
(if any (cons acc j) (pfail)))))
|
||||
(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 ii)))
|
||||
;; 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 (< 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 ii))) (set! mo (car r)) (loop (+ pi k) (cdr r)))))
|
||||
((char=? c #\d) (let ((r (read-digits ii))) (set! d (car r)) (loop (+ pi k) (cdr r))))
|
||||
((or (char=? c #\H) (char=? c #\h)) (let ((r (read-digits ii))) (set! hh (car r)) (loop (+ pi k) (cdr r))))
|
||||
((char=? c #\m) (let ((r (read-digits ii))) (set! mi (car r)) (loop (+ pi k) (cdr r))))
|
||||
((char=? c #\s) (let ((r (read-digits ii))) (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)) (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"))
|
||||
|
|
@ -303,6 +377,10 @@
|
|||
(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).
|
||||
|
|
@ -313,6 +391,13 @@
|
|||
((jinst? obj)
|
||||
(cond ((string=? method-name "getTime") (jinst-ms obj))
|
||||
((string=? method-name "toInstant") (mk-instant (jinst-ms obj)))
|
||||
((string=? method-name "toLocalDate") (mk-local (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)))))
|
||||
|
|
|
|||
174
host/chez/io.ss
174
host/chez/io.ss
|
|
@ -62,9 +62,18 @@
|
|||
(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))))))
|
||||
|
||||
|
|
@ -130,6 +139,23 @@
|
|||
(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 (jolt-uicd): the overlay edn.clj's drain-reader is
|
||||
;; janet/type-coupled, so on Chez we drain the jhost reader to a string and read the
|
||||
;; first EDN form (read-string). Re-asserted over the prelude in post-prelude.ss.
|
||||
|
|
@ -323,3 +349,151 @@
|
|||
((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-1nnn) --------------------------------------
|
||||
;; 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)))))))
|
||||
(register-host-methods! "classloader"
|
||||
(list (cons "getResource" cl-get-resource)
|
||||
(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))))
|
||||
;; Thread/currentThread -> a thread jhost whose getContextClassLoader is the loader.
|
||||
(define the-thread (make-jhost "thread" (vector)))
|
||||
(register-host-methods! "thread"
|
||||
(list (cons "getContextClassLoader" (lambda (self) the-classloader))
|
||||
(cons "getName" (lambda (self) "main"))))
|
||||
(register-class-statics! "Thread" (list (cons "currentThread" (lambda () the-thread))))
|
||||
(register-class-statics! "java.lang.Thread" (list (cons "currentThread" (lambda () the-thread))))
|
||||
|
||||
;; --- java.io.File / java.util.UUID constructors (jolt-1nnn) ------------------
|
||||
;; (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))))
|
||||
;; 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 (jolt-1nnn) -----------------------------------------------
|
||||
;; 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))))
|
||||
(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.
|
||||
(define %uri-str-render-one jolt-str-render-one)
|
||||
(set! jolt-str-render-one
|
||||
(lambda (x) (if (and (jhost? x) (string=? (jhost-tag x) "uri")) (uri-field x 'string) (%uri-str-render-one x))))
|
||||
(define %uri-pr-readable jolt-pr-readable)
|
||||
(set! jolt-pr-readable
|
||||
(lambda (x) (if (and (jhost? x) (string=? (jhost-tag x) "uri"))
|
||||
(string-append "#object[java.net.URI \"" (uri-field x 'string) "\"]")
|
||||
(%uri-pr-readable x))))
|
||||
;; class of the host value types defined by now (uri/uuid/file).
|
||||
(define %uri-class jolt-class)
|
||||
(set! jolt-class
|
||||
(lambda (x)
|
||||
(cond ((and (jhost? x) (string=? (jhost-tag x) "uri")) "java.net.URI")
|
||||
((juuid? x) "java.util.UUID")
|
||||
((jfile? x) "java.io.File")
|
||||
(else (%uri-class x)))))
|
||||
(def-var! "clojure.core" "class" jolt-class)
|
||||
|
|
|
|||
|
|
@ -90,8 +90,8 @@
|
|||
".clj (or .cljc) on the source roots") name))
|
||||
(let ((saved (chez-current-ns)))
|
||||
(load-jolt-file file)
|
||||
(set-chez-ns! saved)
|
||||
(def-var! "clojure.core" "*ns*" (intern-ns! saved)))))))
|
||||
;; restore the current ns (thread-local); *ns* reads derive from it.
|
||||
(set-chez-ns! saved))))))
|
||||
|
||||
;; load-file: load an explicit path (a `run FILE`), in the current ns.
|
||||
(define (jolt-load-file path)
|
||||
|
|
|
|||
|
|
@ -21,9 +21,23 @@
|
|||
;; so they agree with defmulti. Loaded from rt.ss after seq.ss (jolt-invoke),
|
||||
;; collections.ss (jolt=/key-hash/jolt-hash-map) and the var-cell machinery.
|
||||
|
||||
(define chez-current-ns-box (vector "user"))
|
||||
(define (chez-current-ns) (vector-ref chez-current-ns-box 0))
|
||||
(define (set-chez-ns! ns) (vector-set! chez-current-ns-box 0 ns))
|
||||
;; THREAD-LOCAL (jolt-6rld): a Chez thread-parameter, so each OS thread (an nREPL
|
||||
;; session worker / future) has its own current ns — vars stay global, only the
|
||||
;; "current ns" pointer is per-thread, matching Clojure's thread-local *ns*. A new
|
||||
;; thread inherits the forking thread's value. `star-ns-cell` (the *ns* var cell,
|
||||
;; captured by dyn-binding.ss once *ns* exists) lets chez-current-ns DERIVE from a
|
||||
;; thread-local (binding [*ns* ..]) so a bound *ns* drives load-string/analyzer
|
||||
;; resolution; bootstrap-safe (it's #f until then, so we just read the parameter).
|
||||
(define chez-current-ns-param (make-thread-parameter "user"))
|
||||
(define star-ns-cell #f)
|
||||
(define (chez-current-ns)
|
||||
(if star-ns-cell
|
||||
(let ((bv (dyn-binding-value star-ns-cell)))
|
||||
(if (and (not (eq? bv dyn-no-binding)) (jns? bv))
|
||||
(jns-name bv)
|
||||
(chez-current-ns-param)))
|
||||
(chez-current-ns-param)))
|
||||
(define (set-chez-ns! ns) (chez-current-ns-param ns))
|
||||
|
||||
(define-record-type jolt-multifn
|
||||
(fields name dispatch-fn methods default hierarchy prefers)
|
||||
|
|
|
|||
73
host/chez/natives-queue.ss
Normal file
73
host/chez/natives-queue.ss
Normal file
|
|
@ -0,0 +1,73 @@
|
|||
;; natives-queue.ss (jolt-b8he) — 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)))
|
||||
(cond ((null? f) (error 'pop "can't pop empty queue"))
|
||||
((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)))
|
||||
(define %q-pr-readable jolt-pr-readable)
|
||||
(set! jolt-pr-readable (lambda (x) (if (jolt-queue? x) (%q-pr-readable (jolt-seq-or-empty x)) (%q-pr-readable x))))
|
||||
(define %q-str-render-one jolt-str-render-one)
|
||||
(set! jolt-str-render-one (lambda (x) (if (jolt-queue? x) (%q-str-render-one (jolt-seq-or-empty x)) (%q-str-render-one x))))
|
||||
|
||||
;; class / type / instance? recognize a queue.
|
||||
(define %q-class jolt-class)
|
||||
(set! jolt-class (lambda (x) (if (jolt-queue? x) "clojure.lang.PersistentQueue" (%q-class x))))
|
||||
(def-var! "clojure.core" "class" jolt-class)
|
||||
(define %q-instance-check instance-check)
|
||||
(set! instance-check
|
||||
(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))
|
||||
(%q-instance-check type-sym val))))
|
||||
(def-var! "clojure.core" "instance-check" instance-check)
|
||||
|
||||
;; 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")
|
||||
|
|
@ -84,6 +84,30 @@
|
|||
(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
|
||||
|
|
@ -118,16 +142,12 @@
|
|||
((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). UTF-8 default; ISO-8859-1/latin1/
|
||||
;; ascii encode one byte per char (clj-http-lite's body-encoding path).
|
||||
(if (null? rest)
|
||||
(string->utf8 s)
|
||||
(let ((cn (ascii-string-down (if (string? (arg 0)) (arg 0) (jolt-str-render-one (arg 0))))))
|
||||
(if (member cn '("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->utf8 s)))))
|
||||
;; (.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)))
|
||||
|
|
@ -141,6 +161,11 @@
|
|||
;; 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)))
|
||||
(else (error #f (string-append "No method " method " for value")))))
|
||||
|
||||
;; --- clojure.core str-* primitives (the substrate clojure.string.clj calls) ---
|
||||
|
|
|
|||
|
|
@ -111,8 +111,9 @@
|
|||
;; redirect them. It is enough for *ns* / str-of-ns to track the switch.
|
||||
(define (jolt-in-ns desig)
|
||||
(let* ((nm (ns-desig->name desig)) (n (intern-ns! nm)))
|
||||
;; set the THREAD-LOCAL current ns; *ns* reads derive from it (dyn-binding.ss),
|
||||
;; so this is per-thread — concurrent nREPL sessions don't clobber each other.
|
||||
(set-chez-ns! nm)
|
||||
(def-var! "clojure.core" "*ns*" n)
|
||||
n))
|
||||
|
||||
;; ns-name: a namespace's name as a (no-ns) symbol. Overrides the overlay (which
|
||||
|
|
|
|||
|
|
@ -97,3 +97,44 @@
|
|||
;; chunked-seq? is true for a vector's seq (a real chunked-seq); the overlay's
|
||||
;; always-false stub loaded over the host fn, so re-assert it (jolt-hs5q).
|
||||
(def-var! "clojure.core" "chunked-seq?" na-chunked-seq?)
|
||||
;; record? is a host type check (jrec?), not the overlay's (some? (get x
|
||||
;; :jolt/deftype)) — the get-trick invokes a sorted-map's comparator on
|
||||
;; :jolt/deftype and throws (jolt-3bbj). Matches the JVM (instance? IRecord).
|
||||
(def-var! "clojure.core" "record?" (lambda (x) (jrec? x)))
|
||||
|
||||
;; read / read+string over a HOST reader jhost (java.io StringReader/PushbackReader):
|
||||
;; the overlay's IReader protocol only covers the reify map-reader, so a (read
|
||||
;; pushback-reader) — cuerdas' string interpolation — would miss. Intercept a host
|
||||
;; reader; everything else (the *in* reify) delegates to the overlay.
|
||||
(let ((ov-read (var-deref "clojure.core" "read")))
|
||||
(def-var! "clojure.core" "read"
|
||||
(case-lambda
|
||||
(() (jolt-invoke ov-read))
|
||||
((stream)
|
||||
(if (reader-jhost? stream)
|
||||
(let-values (((form found?) (host-reader-read-form stream)))
|
||||
(if found? form (jolt-throw (jolt-ex-info "EOF while reading" (empty-pmap)))))
|
||||
(jolt-invoke ov-read stream)))
|
||||
((stream e? ev)
|
||||
(if (reader-jhost? stream)
|
||||
(let-values (((form found?) (host-reader-read-form stream)))
|
||||
(cond (found? form)
|
||||
((jolt-truthy? e?) (jolt-throw (jolt-ex-info "EOF while reading" (empty-pmap))))
|
||||
(else ev)))
|
||||
(jolt-invoke ov-read stream e? ev))))))
|
||||
(let ((ov-rps (var-deref "clojure.core" "read+string")))
|
||||
(def-var! "clojure.core" "read+string"
|
||||
(case-lambda
|
||||
(() (jolt-invoke ov-rps))
|
||||
((stream) (jolt-invoke (var-deref "clojure.core" "read+string") stream #t jolt-nil))
|
||||
((stream e? ev)
|
||||
(if (reader-jhost? stream)
|
||||
(let* ((s (drain-reader stream)) (pr (jolt-parse-next s)))
|
||||
(if (jolt-nil? pr)
|
||||
(begin (reader-refill! stream "")
|
||||
(if (jolt-truthy? e?) (jolt-throw (jolt-ex-info "EOF while reading" (empty-pmap)))
|
||||
(jolt-vector ev "")))
|
||||
(let ((rest (jolt-nth pr 1)))
|
||||
(reader-refill! stream rest)
|
||||
(jolt-vector (jolt-nth pr 0) (substring s 0 (- (string-length s) (string-length rest)))))))
|
||||
(jolt-invoke ov-rps stream e? ev))))))
|
||||
|
|
|
|||
|
|
@ -139,12 +139,16 @@
|
|||
((boolean? obj) '("Boolean" "Object"))
|
||||
((keyword? obj) '("Keyword" "Named" "Object"))
|
||||
((jolt-symbol? obj) '("Symbol" "Named" "Object"))
|
||||
((pvec? obj) '("PersistentVector" "IPersistentVector" "IPersistentCollection"
|
||||
((pvec? obj) '("PersistentVector" "APersistentVector" "IPersistentVector" "IPersistentCollection"
|
||||
"List" "java.util.List" "Sequential" "Collection" "Object"))
|
||||
((pmap? obj) '("PersistentArrayMap" "IPersistentMap" "Associative"
|
||||
((pmap? obj) '("PersistentArrayMap" "APersistentMap" "IPersistentMap" "Associative"
|
||||
"Map" "java.util.Map" "Object"))
|
||||
((pset? obj) '("PersistentHashSet" "IPersistentSet" "Set" "java.util.Set" "Collection" "Object"))
|
||||
((or (cseq? obj) (empty-list-t? obj)) '("ISeq" "IPersistentCollection" "Sequential" "Collection" "Object"))
|
||||
((pset? obj) '("PersistentHashSet" "APersistentSet" "IPersistentSet" "Set" "java.util.Set" "Collection" "Object"))
|
||||
((or (cseq? obj) (empty-list-t? obj)) '("ASeq" "ISeq" "IPersistentCollection" "Sequential" "Collection" "Object"))
|
||||
;; java.net.URI jhost — extend-protocol java.net.URI (hiccup ToURI/ToStr).
|
||||
((and (jhost? obj) (string=? (jhost-tag obj) "uri")) '("URI" "java.net.URI" "Object"))
|
||||
;; a bare procedure (fn) — extend-protocol to clojure.lang.{Fn,IFn,AFn}.
|
||||
((procedure? obj) '("Fn" "IFn" "AFn" "Object"))
|
||||
((jolt-nil? obj) '("nil"))
|
||||
(else '("Object"))))
|
||||
|
||||
|
|
@ -185,9 +189,11 @@
|
|||
'("Long" "Integer" "Number" "Double" "Ratio" "BigInt" "BigInteger"
|
||||
"String" "CharSequence" "Boolean" "Character"
|
||||
"Keyword" "Symbol" "Named" "Object" "nil"
|
||||
"PersistentVector" "IPersistentVector"
|
||||
"PersistentArrayMap" "IPersistentMap" "PersistentHashSet" "IPersistentSet"
|
||||
"ISeq" "IPersistentCollection" "Associative" "Sequential"
|
||||
"Fn" "IFn" "AFn" "URI"
|
||||
"PersistentVector" "APersistentVector" "IPersistentVector"
|
||||
"PersistentArrayMap" "APersistentMap" "IPersistentMap"
|
||||
"PersistentHashSet" "APersistentSet" "IPersistentSet"
|
||||
"ASeq" "ISeq" "IPersistentCollection" "Associative" "Sequential"
|
||||
"Map" "java.util.Map" "List" "java.util.List" "Set" "java.util.Set"
|
||||
"Collection" "java.util.Collection"))
|
||||
h))
|
||||
|
|
@ -197,6 +203,7 @@
|
|||
(define (canonical-host-tag type-name)
|
||||
(let ((base (or (strip-prefix type-name "java.lang.")
|
||||
(strip-prefix type-name "java.util.")
|
||||
(strip-prefix type-name "java.net.")
|
||||
(strip-prefix type-name "clojure.lang.")
|
||||
type-name)))
|
||||
(and (hashtable-ref host-type-set base #f) base)))
|
||||
|
|
@ -233,7 +240,16 @@
|
|||
((reified-methods obj)
|
||||
=> (lambda (rm) (let ((f (hashtable-ref rm method-name #f)))
|
||||
(if f (apply jolt-invoke f obj rest)
|
||||
(error #f (string-append "No reified method " method-name))))))
|
||||
;; not implemented on the reify — fall back to the
|
||||
;; protocol's extended impls over the reify's host tags
|
||||
;; (e.g. an Object/default extension). malli reifies some
|
||||
;; protocols and relies on a protocol's default for the
|
||||
;; rest (jolt-az9a).
|
||||
(let loop ((tags (value-host-tags obj)))
|
||||
(cond ((null? tags) (error #f (string-append "No reified method " method-name)))
|
||||
((find-protocol-method (car tags) proto-name method-name)
|
||||
=> (lambda (g) (apply jolt-invoke g obj rest)))
|
||||
(else (loop (cdr tags)))))))))
|
||||
(else
|
||||
(let loop ((tags (value-host-tags obj)))
|
||||
(cond ((null? tags) (error #f (string-append "No method " method-name " in " proto-name)))
|
||||
|
|
@ -264,6 +280,11 @@
|
|||
(define (record-method-dispatch obj method-name rest-args)
|
||||
(let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
|
||||
(cond
|
||||
;; (.getClass x): universal Object method — the class token for any value
|
||||
;; (jolt has no Class objects; the token is the canonical name string, on
|
||||
;; which .getName/.getSimpleName work via the String method shim).
|
||||
((and (string=? method-name "getClass") (not (jrec? obj)) (not (jreify? obj)))
|
||||
(jolt-class obj))
|
||||
((and (jrec? obj) (find-method-any-protocol (jrec-tag obj) method-name))
|
||||
=> (lambda (f) (apply jolt-invoke f obj rest)))
|
||||
((reified-methods obj)
|
||||
|
|
@ -311,6 +332,10 @@
|
|||
(condition->message-string obj))
|
||||
((string=? method-name "toString") (condition->message-string obj))
|
||||
((string=? method-name "getCause") jolt-nil)
|
||||
;; java.sql.SQLException chaining — jolt errors don't chain (nil).
|
||||
((or (string=? method-name "getNextException") (string=? method-name "getCause")) jolt-nil)
|
||||
((string=? method-name "getStackTrace") (jolt-vector))
|
||||
((string=? method-name "printStackTrace") jolt-nil)
|
||||
(else (error #f (string-append "No method " method-name " on Throwable")))))
|
||||
;; java.lang.Character interop: (.toString \+) -> "+", etc.
|
||||
((char? obj)
|
||||
|
|
@ -321,6 +346,19 @@
|
|||
((string=? method-name "compareTo")
|
||||
(let ((o (car rest))) (cond ((char<? obj o) -1) ((char>? obj o) 1) (else 0))))
|
||||
(else (error #f (string-append "No method " method-name " on char")))))
|
||||
;; java.util.List .indexOf / .lastIndexOf over any seqable (vector / list /
|
||||
;; seq) — -1 when absent, like the JVM (medley/index-of reads this).
|
||||
((or (string=? method-name "indexOf") (string=? method-name "lastIndexOf"))
|
||||
(let ((target (car rest)) (last? (string=? method-name "lastIndexOf")))
|
||||
(let loop ((s (jolt-seq obj)) (i 0) (found -1))
|
||||
(cond ((jolt-nil? s) found)
|
||||
((jolt=2 (seq-first s) target)
|
||||
(if last? (loop (jolt-seq (seq-more s)) (fx+ i 1) i) i))
|
||||
(else (loop (jolt-seq (seq-more s)) (fx+ i 1) found))))))
|
||||
;; universal Object methods on any remaining value (boolean, etc.).
|
||||
((string=? method-name "toString") (jolt-str-render-one obj))
|
||||
((string=? method-name "hashCode") (jolt-hash obj))
|
||||
((string=? method-name "equals") (and (pair? rest) (if (jolt= obj (car rest)) #t #f)))
|
||||
(else (error #f (string-append "No method " method-name " for value: "
|
||||
(jolt-pr-str obj)))))))
|
||||
|
||||
|
|
@ -371,6 +409,55 @@
|
|||
(hashtable-keys type-registry))
|
||||
(if (null? out) jolt-nil (list->cseq out))))
|
||||
|
||||
;; jolt exception values (ex-info + host-constructed throwables) are ex-info-shaped
|
||||
;; maps tagged :jolt/type :jolt/ex-info; (class …)/instance? read the JVM class off
|
||||
;; the optional :jolt/class key, defaulting to clojure.lang.ExceptionInfo.
|
||||
;; 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")
|
||||
("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.
|
||||
(define (instance-check type-sym val)
|
||||
(let ((tname (symbol-t-name type-sym)))
|
||||
|
|
@ -382,6 +469,7 @@
|
|||
(string=? (substring tag (- (string-length tag) (string-length tname)) (string-length tag)) tname)))))
|
||||
((jreify? val) (let ((short (last-dot tname)))
|
||||
(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 (case-string tname val)
|
||||
(cond
|
||||
|
|
@ -397,6 +485,11 @@
|
|||
((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
|
||||
|
|
|
|||
|
|
@ -38,6 +38,17 @@
|
|||
jolt-kw-message msg
|
||||
jolt-kw-data data
|
||||
jolt-kw-cause (if (null? more) jolt-nil (car more))))
|
||||
;; A host-constructed throwable (RuntimeException. etc.): an ex-info-shaped map
|
||||
;; carrying its canonical JVM :jolt/class, so (class …) / instance? / .getMessage /
|
||||
;; ex-message all reflect the real type. Plain ex-info has no :jolt/class (its class
|
||||
;; defaults to clojure.lang.ExceptionInfo), so those maps stay byte-identical.
|
||||
(define jolt-kw-class (keyword "jolt" "class"))
|
||||
(define (jolt-host-throwable class-name msg . more)
|
||||
(jolt-hash-map jolt-kw-ex-type jolt-kw-ex-info
|
||||
jolt-kw-class class-name
|
||||
jolt-kw-message msg
|
||||
jolt-kw-data jolt-nil
|
||||
jolt-kw-cause (if (null? more) jolt-nil (car more))))
|
||||
|
||||
;; --- host interop (jolt-0kf5) ------------------------------------------------
|
||||
;; (.method target arg*) lowers to (jolt-host-call "method" target arg*). JVM
|
||||
|
|
@ -331,6 +342,11 @@
|
|||
;; it. After the dispatchers it chains.
|
||||
(load "host/chez/natives-array.ss")
|
||||
|
||||
;; clojure.lang.PersistentQueue (jolt-b8he): a functional queue + EMPTY static.
|
||||
;; Chains seq/count/empty?/peek/pop/conj/sequential?/class/instance?/printer, so
|
||||
;; load after natives-array (the dispatchers it extends).
|
||||
(load "host/chez/natives-queue.ss")
|
||||
|
||||
;; syntax-quote form builders (jolt-r9lm, inc6b): __sqcat/__sqvec/__sqmap/__sqset/
|
||||
;; __sq1, def-var!'d into clojure.core. A cross-compiled macro expander (analyzer
|
||||
;; on Chez, inc6b) calls these to build its expansion as reader forms. Needs the
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
|
|
@ -241,10 +241,12 @@
|
|||
env* (add-locals env names)
|
||||
binds (mapv (fn [spec]
|
||||
(let [cl (vec (form-elements spec))]
|
||||
;; analyze as a named fn (items[1] = the name): self- and
|
||||
;; sibling-calls resolve, the fn carries its own name.
|
||||
;; Build (fn name [params] body*) and analyze through the fn
|
||||
;; MACRO so destructuring params desugar (the fn* primitive
|
||||
;; would not — same trick defmacro uses). The named fn means
|
||||
;; self- and sibling-calls resolve and it carries its own name.
|
||||
[(form-sym-name (first cl))
|
||||
(analyze-fn ctx (vec (cons (first cl) cl)) env*)]))
|
||||
(analyze ctx (cons (symbol "fn") cl) env*)]))
|
||||
specs)]
|
||||
{:op :let :letrec true :bindings binds
|
||||
:body (analyze-seq ctx (drop 2 items) env*)}))
|
||||
|
|
|
|||
|
|
@ -51,6 +51,76 @@
|
|||
{:suite "dotform" :expr "(try (throw \"boom\") (catch Throwable e (.getMessage e)))" :expected "boom"}
|
||||
{:suite "dotform" :expr "(try (throw (Exception. \"boom\")) (catch Throwable e (.getMessage e)))" :expected "boom"}
|
||||
{:suite "dotform" :expr "(try (throw (IllegalArgumentException. \"bad\")) (catch Exception e (.getMessage e)))" :expected "bad"}
|
||||
{:suite "exinfo" :expr "(instance? clojure.lang.ExceptionInfo (ex-info \"x\" {}))" :expected "true"}
|
||||
{:suite "exinfo" :expr "(instance? clojure.lang.IExceptionInfo (ex-info \"x\" {}))" :expected "true"}
|
||||
{:suite "exinfo" :expr "(instance? RuntimeException (ex-info \"x\" {}))" :expected "true"}
|
||||
{:suite "exinfo" :expr "(instance? Throwable (ex-info \"x\" {}))" :expected "true"}
|
||||
{:suite "exinfo" :expr "(class (ex-info \"x\" {}))" :expected "clojure.lang.ExceptionInfo"}
|
||||
{:suite "exinfo" :expr "(= clojure.lang.ExceptionInfo (class (ex-info \"x\" {})))" :expected "true"}
|
||||
{:suite "exinfo" :expr "(class (RuntimeException. \"x\"))" :expected "java.lang.RuntimeException"}
|
||||
{:suite "exinfo" :expr "(instance? RuntimeException (RuntimeException. \"x\"))" :expected "true"}
|
||||
{:suite "exinfo" :expr "(instance? Exception (IllegalArgumentException. \"x\"))" :expected "true"}
|
||||
{:suite "exinfo" :expr "(instance? Throwable (IllegalArgumentException. \"x\"))" :expected "true"}
|
||||
{:suite "exinfo" :expr "(instance? IllegalArgumentException (RuntimeException. \"x\"))" :expected "false"}
|
||||
{:suite "exinfo" :expr "(instance? RuntimeException (InterruptedException. \"x\"))" :expected "false"}
|
||||
{:suite "exinfo" :expr "(.getMessage (RuntimeException. \"boom\"))" :expected "boom"}
|
||||
{:suite "exinfo" :expr "(ex-message (RuntimeException. \"boom\"))" :expected "boom"}
|
||||
{:suite "exinfo" :expr "(type (ex-info \"x\" {}))" :expected ":jolt/ex-info"}
|
||||
{:suite "hostobj" :expr "(.getName (.getClass \"x\"))" :expected "java.lang.String"}
|
||||
{:suite "hostobj" :expr "(.getClass 5)" :expected "java.lang.Long"}
|
||||
{:suite "hostobj" :expr "(.getSimpleName (.getClass :k))" :expected "Keyword"}
|
||||
{:suite "hostobj" :expr "(.toString true)" :expected "true"}
|
||||
{:suite "hostobj" :expr "(class (ex-info \"x\" {}))" :expected "clojure.lang.ExceptionInfo"}
|
||||
{:suite "hostobj" :expr "[(instance? Double 1.5) (Double. \"3.5\") (Double/parseDouble \"2.5\")]" :expected "[true 3.5 2.5]"}
|
||||
{:suite "hostobj" :expr "(instance? java.util.regex.Pattern #\"x\")" :expected "true"}
|
||||
{:suite "hostobj" :expr "(class #\"x\")" :expected "java.util.regex.Pattern"}
|
||||
{:suite "hostobj" :expr "[(namespace (symbol \"foo/bar\")) (name (symbol \"foo/bar\"))]" :expected "[foo bar]"}
|
||||
{:suite "hostobj" :expr "(str (symbol \"a/b/c\"))" :expected "a/b/c"}
|
||||
{:suite "hostobj" :expr "(do (System/setProperty \"jolt.test.x\" \"z\") (System/getProperty \"jolt.test.x\"))" :expected "z"}
|
||||
{:suite "hostobj" :expr "(set! *assert* false)" :expected "false"}
|
||||
{:suite "hostobj" :expr "(binding [*print-readably* false] *print-readably*)" :expected "false"}
|
||||
{:suite "hostobj" :expr "(do (defprotocol P (m [_])) (extend-protocol P clojure.lang.Fn (m [_] :fn)) (m (fn [x] x)))" :expected ":fn"}
|
||||
{:suite "hostobj" :expr "(do (defprotocol P (m [_])) (extend-protocol P clojure.lang.APersistentVector (m [_] :vec)) (m [1 2 3]))" :expected ":vec"}
|
||||
{:suite "hostobj" :expr "(record? (sorted-map 1 2 3 4))" :expected "false"}
|
||||
{:suite "queue" :expr "(seq (conj clojure.lang.PersistentQueue/EMPTY 1 2 3))" :expected "(1 2 3)"}
|
||||
{:suite "queue" :expr "(peek (conj clojure.lang.PersistentQueue/EMPTY 1 2 3))" :expected "1"}
|
||||
{:suite "queue" :expr "(seq (pop (conj clojure.lang.PersistentQueue/EMPTY 1 2 3)))" :expected "(2 3)"}
|
||||
{:suite "queue" :expr "(count (conj clojure.lang.PersistentQueue/EMPTY 1 2 3))" :expected "3"}
|
||||
{:suite "queue" :expr "(empty? clojure.lang.PersistentQueue/EMPTY)" :expected "true"}
|
||||
{:suite "queue" :expr "(instance? clojure.lang.PersistentQueue (conj clojure.lang.PersistentQueue/EMPTY 1))" :expected "true"}
|
||||
{:suite "queue" :expr "(= [1 2 3] (into clojure.lang.PersistentQueue/EMPTY [1 2 3]))" :expected "true"}
|
||||
{:suite "queue" :expr "(first (into clojure.lang.PersistentQueue/EMPTY [1 2 3]))" :expected "1"}
|
||||
{:suite "destructure" :expr "(letfn [(up [s [k & ks]] (cons s ks))] (up 1 [2 3 4]))" :expected "(1 3 4)"}
|
||||
{:suite "hostctor" :expr "(.getName (java.io.File. \"/tmp/abc.txt\"))" :expected "abc.txt"}
|
||||
{:suite "hostctor" :expr "(instance? java.io.File (java.io.File. \"/x\"))" :expected "true"}
|
||||
{:suite "hostctor" :expr "(uuid? (java.util.UUID/randomUUID))" :expected "true"}
|
||||
{:suite "hostctor" :expr "(instance? java.util.UUID (java.util.UUID/fromString \"12345678-1234-1234-1234-123456789abc\"))" :expected "true"}
|
||||
{:suite "hostctor" :expr "(let [u (java.net.URI. \"http://h.com:81/p?q=1#f\")] [(.getScheme u) (.getHost u) (.getPort u) (.getPath u) (.getQuery u) (.getFragment u)])" :expected "[http h.com 81 /p q=1 f]"}
|
||||
{:suite "hostctor" :expr "(nil? (.getHost (java.net.URI. \"/rel/path\")))" :expected "true"}
|
||||
{:suite "hostctor" :expr "(str (java.net.URI. \"http://x/y\"))" :expected "http://x/y"}
|
||||
{:suite "hostctor" :expr "(instance? java.net.URI (java.net.URI. \"/x\"))" :expected "true"}
|
||||
{:suite "hostctor" :expr "(let [a (java.util.ArrayList.)] (.add a 1) (.add a 2) (.add a 3) (.remove a 0) [(.size a) (vec (.toArray a))])" :expected "[2 [2 3]]"}
|
||||
{:suite "hostctor" :expr "[(.indexOf [:a :b :c] :b) (.indexOf (list :a :b) :b) (.indexOf [:a] :z) (.indexOf (range 0 10) 1)]" :expected "[1 1 -1 1]"}
|
||||
{:suite "sdf" :expr "(.format (java.text.SimpleDateFormat. \"EEE, dd MMM yyyy HH:mm:ss zzz\") (java.util.Date. 1348401170000))" :expected "Sun, 23 Sep 2012 11:52:50 GMT"}
|
||||
{:suite "sdf" :expr "(.getTime (.parse (java.text.SimpleDateFormat. \"EEE, dd MMM yyyy HH:mm:ss zzz\") \"Sun, 23 Sep 2012 11:52:50 GMT\"))" :expected "1348401170000"}
|
||||
{:suite "sdf" :expr "(.getTime (.parse (java.text.SimpleDateFormat. \"EEEE, dd-MMM-yy HH:mm:ss zzz\") \"Sunday, 23-Sep-12 11:52:50 GMT\"))" :expected "1348401170000"}
|
||||
{:suite "sdf" :expr "(.getTime (.parse (java.text.SimpleDateFormat. \"EEE MMM d HH:mm:ss yyyy\") \"Sun Sep 23 11:52:50 2012\"))" :expected "1348401170000"}
|
||||
{:suite "sdf" :expr "(let [f (java.text.SimpleDateFormat. \"yyyy-MM-dd\")] (.format f (.parse f \"2023-07-15\")))" :expected "2023-07-15"}
|
||||
{:suite "reader" :expr "(let [r (-> \"foo bar baz\" java.io.StringReader. java.io.PushbackReader.)] [(read r) (slurp r)])" :expected "[foo bar baz]"}
|
||||
{:suite "reader" :expr "(let [r (-> \"(+ 1 2) 99\" java.io.StringReader. java.io.PushbackReader.)] [(read r) (read r)])" :expected "[(+ 1 2) 99]"}
|
||||
{:suite "hostctor" :expr "(String/format \"%d-%s\" 5 \"x\")" :expected "5-x"}
|
||||
{:suite "hostctor" :expr "[(.format (java.text.NumberFormat/getInstance) 1234567.5) (.format (java.text.NumberFormat/getIntegerInstance) 1234567)]" :expected "[1,234,567.5 1,234,567]"}
|
||||
{:suite "hostctor" :expr "[(.getProtocol (java.net.URL. \"file:/tmp/x\")) (.getFile (java.net.URL. \"http://h/p\")) (.getProtocol (java.net.URL. \"http://h/p\"))]" :expected "[file http://h/p http]"}
|
||||
{:suite "hostobj" :expr "(try (throw (ex-info \"x\" {})) (catch Throwable e [(.getNextException e) (vec (.getStackTrace e))]))" :expected "[nil []]"}
|
||||
{:suite "hostobj" :expr "[(some? (ClassLoader/getSystemClassLoader)) (some? (.getContextClassLoader (Thread/currentThread)))]" :expected "[true true]"}
|
||||
{:suite "reify" :expr "(do (defprotocol P (pm [_])) (defprotocol Q (qm [_])) (extend-protocol Q java.lang.Object (qm [_] :q-default)) (qm (reify P (pm [_] :p))))" :expected ":q-default"}
|
||||
{:suite "reify" :expr "(do (defprotocol Q (qa [_]) (qb [_])) (extend-protocol Q java.lang.Object (qa [_] :da) (qb [_] :db)) (def r (reify Q (qa [_] :ra))) [(qa r) (qb r)])" :expected "[:ra :db]"}
|
||||
{:suite "interrupt" :expr "(jolt.host/run-interruptible (jolt.host/make-interrupt) (fn [] (+ 1 2)))" :expected "3"}
|
||||
{:suite "interrupt" :expr "(let [t (jolt.host/make-interrupt)] (jolt.host/interrupt! t) (try (jolt.host/run-interruptible t (fn [] (loop [i 0] (recur (inc i))))) :not-interrupted (catch :default e (:jolt/interrupted (ex-data e)))))" :expected "true"}
|
||||
{:suite "ns-tl" :expr "(do (in-ns (quote foo.bar)) (str *ns*))" :expected "foo.bar"}
|
||||
{:suite "ns-tl" :expr "(do (create-ns (quote my.ns)) (binding [*ns* (find-ns (quote my.ns))] (str *ns*)))" :expected "my.ns"}
|
||||
{:suite "ns-tl" :expr "(do (in-ns (quote app.core)) (def sekret 42) (in-ns (quote user)) (binding [*ns* (find-ns (quote app.core))] (load-string \"sekret\")))" :expected "42"}
|
||||
{:suite "ns-tl" :expr "(do (create-ns (quote a.x)) (create-ns (quote b.y)) (let [fa (future (in-ns (quote a.x)) (Thread/sleep 80) (str *ns*)) fb (future (in-ns (quote b.y)) (Thread/sleep 80) (str *ns*))] [(deref fa) (deref fb) (str *ns*)]))" :expected "[a.x b.y user]"}
|
||||
{:suite "dotform" :expr "(.equals \"a\" \"a\")" :expected "true"}
|
||||
{:suite "dotform" :expr "(.equals \"a\" \"b\")" :expected "false"}
|
||||
{:suite "dotform" :expr "(. {:value 41 :describe (fn [self] (str \"v=\" (:value self)))} describe)" :expected "v=41"}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue