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

Fix conformance gaps: exception types, byte/getBytes, host classes

Browse source 
Shake-out from the conformance-library sweep. Host-side fixes (runtime .ss,
no re-mint) plus one analyzer change (re-minted):

- Exception fidelity: ex-info and host-constructed throwables (RuntimeException.
  etc.) now carry their JVM class, so (class e), instance? across the exception
  hierarchy, .getMessage, and clojure.test thrown?/thrown-with-msg? all work.
- .getBytes returns a seqable/countable byte-array and honors UTF-16/UTF-32;
  String. decodes them. ->bytevector accepts byte-arrays (Base64).
- Universal .getClass / .toString / .indexOf / .lastIndexOf on any value/seq.
- record? uses the host jrec? predicate (the old (get x :jolt/deftype) crashed
  on a sorted-map by invoking its comparator).
- extend-protocol to abstract host types (clojure.lang.Fn/IFn/APersistentVector,
  java.net.URI) dispatches.
- New host classes: clojure.lang.PersistentQueue, java.util.ArrayList,
  java.net.URI, java.io.File / java.util.UUID ctors, Double/Float ctors+statics,
  regex instance? Pattern, System/setProperty.
- *assert* / *print-readably* are real settable/bindable vars.
- (symbol "ns/name") splits the namespace at the last slash.
- letfn fn params desugar destructuring (analyzer; re-minted).

unit.edn gains exinfo/hostobj/queue/hostctor/destructure regression rows.
This commit is contained in:
Yogthos 2026-06-22 17:52:38 -04:00
parent 185b4fd3ca
commit d83175b8c2
14 changed files with 570 additions and 39 deletions
Download patch file Download diff file Expand all files Collapse all files

18
host/chez/converters.ss
View file

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

3
host/chez/dot-forms.ss
View file

@ -71,6 +71,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)))

7
host/chez/dynamic-vars.ss
View file

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

25
host/chez/host-class.ss
View file

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

146
host/chez/host-static.ss
View file

@ -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)))))
@ -251,16 +284,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 +351,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 +623,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 +639,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 +703,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))

118
host/chez/io.ss
View file

@ -323,3 +323,121 @@
((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.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)

73
host/chez/natives-queue.ss Normal file
View 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")

45
host/chez/natives-str.ss
View file

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

4
host/chez/post-prelude.ss
View file

@ -97,3 +97,7 @@
;; 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)))

94
host/chez/records.ss
View file

@ -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)))
@ -264,6 +271,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)
@ -321,6 +333,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 +396,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 +456,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 +472,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

16
host/chez/rt.ss
View file

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

2
host/chez/seed/image.ss
View file

File diff suppressed because one or more lines are too long