Group the JVM interop shims under host/chez/java/
The host/chez directory mixed jolt's own runtime (value model, seq, reader, vars, ns, multimethods) with the shims that emulate the JVM: java.* / javax.* classes, clojure.lang interfaces, and the host-class registry they hang off. Move that JVM-emulation layer into host/chez/java/ so it reads as a distinct unit instead of being interleaved with the platform runtime. Moved (content unchanged): host-static, host-static-methods, host-static-classes, host-class, dot-forms, records-interop, byte-buffer, io, io-streams, inst-time, java-time, bigdec, natives-queue, natives-str, natives-array, math, concurrency, async, ffi. The load paths in rt.ss/cli.ss and the build.ss runtime manifest are updated to point at java/; the build inliner follows the (load ...) strings, so the AOT path needs no other change. All runtime shims, no seed source touched (the three .clj edits are doc comments), so no re-mint. Gate green: make test (selfhost fixpoint, certify 0-new, sci 211, infer), shakesmoke (4 apps byte-identical).
This commit is contained in:
Yogthos
parent
5b77efa499
commit
ec9fde9e7e
26 changed files with 24 additions and 24 deletions
169
host/chez/java/host-static.ss
Normal file
169
host/chez/java/host-static.ss
Normal file
|
|
@ -0,0 +1,169 @@
|
|||
;; host-static.ss — the host-interop registry core: the class-statics / class-ctors
|
||||
;; / tagged-methods tables, the jhost record, and the coercion helpers. The actual
|
||||
;; entries are registered by host-static-methods.ss (Class/member statics) and
|
||||
;; host-static-classes.ss (instantiable object classes), loaded after this.
|
||||
;;
|
||||
;; The analyzer lowers `Class/member` to a :host-static node and `(Class. ...)` /
|
||||
;; `(new Class ...)` to a :host-new node (jolt-core/jolt/analyzer.clj); the Chez
|
||||
;; emit lowers a value ref to (host-static-ref "Class" "member"), a
|
||||
;; call head to (host-static-call "Class" "member" args...), and a constructor to
|
||||
;; (host-new "Class" args...). This file is the runtime registry those three
|
||||
;; resolve against — the class-statics / class-ctors /
|
||||
;; tagged-methods registries,
|
||||
;; restricted to the java.lang/util/net/io surface portable cljc code calls.
|
||||
;; (java.time formatting is a separate increment.)
|
||||
;;
|
||||
;; Constructed host objects are `jhost` records (a tag + mutable state); their
|
||||
;; (.method ...) calls reach record-method-dispatch (records.ss), extended below
|
||||
;; with a jhost arm that dispatches through host-tagged-methods.
|
||||
;;
|
||||
;; Loaded from rt.ss LAST (after natives-str.ss / records.ss): it extends
|
||||
;; record-method-dispatch and reuses jolt-str-render-one / jolt-re-pattern.
|
||||
|
||||
;; ---- registries -------------------------------------------------------------
|
||||
(define class-statics-tbl (make-hashtable string-hash string=?)) ; "Class" -> (member-ht)
|
||||
(define class-ctors-tbl (make-hashtable string-hash string=?)) ; "Class" -> ctor proc
|
||||
(define host-methods-tbl (make-hashtable string-hash string=?)) ; tag -> (method-ht)
|
||||
|
||||
;; A class token may arrive fully qualified (java.io.StringReader) or short
|
||||
;; (StringReader). Register both; resolve by exact then by last dotted segment.
|
||||
(define (short-class-name s)
|
||||
(let loop ((i (- (string-length s) 1)))
|
||||
(cond ((< i 0) s)
|
||||
((char=? (string-ref s i) #\.) (substring s (+ i 1) (string-length s)))
|
||||
(else (loop (- i 1))))))
|
||||
|
||||
(define (register-class-statics! name members) ; members: list of (str . val/proc)
|
||||
(let ((h (or (hashtable-ref class-statics-tbl name #f)
|
||||
(let ((h (make-hashtable string-hash string=?)))
|
||||
(hashtable-set! class-statics-tbl name h) h))))
|
||||
(for-each (lambda (p) (hashtable-set! h (car p) (cdr p))) members)))
|
||||
|
||||
(define (register-class-ctor! name proc) (hashtable-set! class-ctors-tbl name proc))
|
||||
|
||||
(define (register-host-methods! tag members)
|
||||
(let ((h (or (hashtable-ref host-methods-tbl tag #f)
|
||||
(let ((h (make-hashtable string-hash string=?)))
|
||||
(hashtable-set! host-methods-tbl tag h) h))))
|
||||
(for-each (lambda (p) (hashtable-set! h (car p) (cdr p))) members)))
|
||||
|
||||
(define (lookup-class h-tbl name)
|
||||
(or (hashtable-ref h-tbl name #f)
|
||||
(hashtable-ref h-tbl (short-class-name name) #f)))
|
||||
|
||||
;; ---- host object ------------------------------------------------------------
|
||||
(define-record-type jhost (fields tag (mutable state)) (nongenerative chez-jhost-v1))
|
||||
|
||||
;; record-method-dispatch (records.ss) gets a jhost arm: dispatch (.method obj a*)
|
||||
;; through the tag's method table.
|
||||
(define %hs-record-method-dispatch record-method-dispatch)
|
||||
(set! record-method-dispatch
|
||||
(lambda (obj method-name rest-args)
|
||||
(cond
|
||||
;; (.getClass x) is universal — the class token for any value (incl. numbers
|
||||
;; / jhost) — before the per-type arms that would otherwise reject it.
|
||||
((string=? method-name "getClass") (jolt-class obj))
|
||||
((jhost? obj)
|
||||
(let ((mh (hashtable-ref host-methods-tbl (jhost-tag obj) #f)))
|
||||
(let ((f (and mh (hashtable-ref mh method-name #f))))
|
||||
(if f
|
||||
(apply f obj (if (jolt-nil? rest-args) '() (seq->list rest-args)))
|
||||
(error #f (string-append "No method " method-name " on host " (jhost-tag obj)))))))
|
||||
((number? obj) (number-method method-name obj))
|
||||
(else (%hs-record-method-dispatch obj method-name rest-args)))))
|
||||
|
||||
;; java.lang.Number method surface (the boxed-number methods cljc code calls). The
|
||||
;; integer projections wrap modulo their width (ring-codec relies on byteValue
|
||||
;; overflow: (.byteValue 255) => -1); the float projections are identity flonums.
|
||||
(define (number-method method n)
|
||||
(cond
|
||||
((string=? method "byteValue") (let ((b (modulo (jnum->exact n) 256))) (->num (if (>= b 128) (- b 256) b))))
|
||||
((string=? method "shortValue") (let ((b (modulo (jnum->exact n) 65536))) (->num (if (>= b 32768) (- b 65536) b))))
|
||||
((string=? method "intValue") (->num (jnum->exact n)))
|
||||
((string=? method "longValue") (->num (jnum->exact n)))
|
||||
((string=? method "doubleValue") (->num n))
|
||||
((string=? method "floatValue") (->num n))
|
||||
((string=? method "toString") (jolt-num->string n))
|
||||
((string=? method "hashCode") (->num (jnum->exact n)))
|
||||
;; Double/Float .isNaN / .isInfinite (a non-flonum is neither).
|
||||
((string=? method "isNaN") (and (flonum? n) (not (= n n))))
|
||||
((string=? method "isInfinite") (and (flonum? n) (infinite? n)))
|
||||
(else (error #f (string-append "No method " method " for number")))))
|
||||
|
||||
;; Mutable static fields: "Class" -> (member -> 1-vector cell). A library that
|
||||
;; writes a static field — clojure.spec.alpha's (set! (. clojure.lang.RT
|
||||
;; checkSpecAsserts) flag) — lands here; the analyzer lowers the set! to a
|
||||
;; set-static-field! call and a plain Class/member read consults the cell first.
|
||||
(define mutable-statics-tbl (make-hashtable string-hash string=?))
|
||||
(define (mutable-static-cell class member create?)
|
||||
(let ((h (or (hashtable-ref mutable-statics-tbl class #f)
|
||||
(and create? (let ((nh (make-hashtable string-hash string=?)))
|
||||
(hashtable-set! mutable-statics-tbl class nh) nh)))))
|
||||
(and h (or (hashtable-ref h member #f)
|
||||
(and create? (let ((c (vector jolt-nil))) (hashtable-set! h member c) c))))))
|
||||
(def-var! "jolt.host" "set-static-field!"
|
||||
(lambda (class member val)
|
||||
(vector-set! (mutable-static-cell class member #t) 0 val)
|
||||
val))
|
||||
;; clojure.lang.RT.checkSpecAsserts — a JVM-internal flag clojure.spec.alpha reads
|
||||
;; and writes; default false. Pre-seed the cell so a read before any write works.
|
||||
(vector-set! (mutable-static-cell "clojure.lang.RT" "checkSpecAsserts" #t) 0 #f)
|
||||
|
||||
;; ---- emit entry points ------------------------------------------------------
|
||||
(define (host-static-ref class member)
|
||||
(let ((cell (mutable-static-cell class member #f)))
|
||||
(if cell
|
||||
(vector-ref cell 0)
|
||||
(let ((h (lookup-class class-statics-tbl class)))
|
||||
(if h
|
||||
(let ((v (hashtable-ref h member #f)))
|
||||
(if v v (error #f (string-append "No static " class "/" member))))
|
||||
(error #f (string-append "Unknown class " class)))))))
|
||||
|
||||
(define (host-static-call class member . args)
|
||||
(apply (host-static-ref class member) args))
|
||||
|
||||
(define (host-new class . args)
|
||||
(let ((ctor (lookup-class class-ctors-tbl class)))
|
||||
(cond
|
||||
(ctor (apply ctor args))
|
||||
;; deftype/defrecord: the type name is bound as a VAR (the
|
||||
;; make-deftype-ctor closure) in its defining ns, not a registered host class.
|
||||
;; Resolve it in the current ns / clojure.core and invoke it — so (P. args)
|
||||
;; works the same as the ->P factory.
|
||||
(else
|
||||
(let ((cell (or (var-cell-lookup (chez-current-ns) class)
|
||||
(var-cell-lookup "clojure.core" class))))
|
||||
(if (and cell (var-cell-defined? cell) (procedure? (var-cell-root cell)))
|
||||
(apply (var-cell-root cell) args)
|
||||
(error #f (string-append "No constructor for class " class))))))))
|
||||
|
||||
;; ---- coercion helpers -------------------------------------------------------
|
||||
;; numeric tower: currentTimeMillis/nanoTime are exact longs (JVM).
|
||||
(define (->num x) x)
|
||||
(define (jnum->exact n) (exact (truncate n)))
|
||||
;; parse an integer string in radix; #f on failure
|
||||
(define (parse-int-str s radix)
|
||||
(let ((n (string->number (str-trim (if (string? s) s (jolt-str-render-one s))) radix)))
|
||||
(and n (integer? n) (->num n))))
|
||||
(define (parse-int-or-throw s radix what)
|
||||
(or (parse-int-str s radix)
|
||||
(error #f (string-append "NumberFormatException: For input string: \""
|
||||
(if (string? s) s (jolt-str-render-one s)) "\""))))
|
||||
(define (char-code c) (if (char? c) (char->integer c) (jnum->exact c)))
|
||||
|
||||
;; parse a double string (Double/parseDouble, (Double. s)); JVM accepts NaN /
|
||||
;; Infinity / decimal / scientific. #f on failure.
|
||||
(define (parse-double-str s)
|
||||
(let ((t (str-trim (if (string? s) s (jolt-str-render-one s)))))
|
||||
(cond
|
||||
((or (string=? t "NaN") (string=? t "+NaN") (string=? t "-NaN")) +nan.0)
|
||||
((or (string=? t "Infinity") (string=? t "+Infinity")) +inf.0)
|
||||
((string=? t "-Infinity") -inf.0)
|
||||
(else (let ((n (string->number t))) (and n (real? n) (exact->inexact n)))))))
|
||||
(define (parse-double-or-throw s)
|
||||
(or (parse-double-str s)
|
||||
(error #f (string-append "NumberFormatException: For input string: \""
|
||||
(if (string? s) s (jolt-str-render-one s)) "\""))))
|
||||
(define (->double x) (if (number? x) (exact->inexact x) (parse-double-or-throw x)))
|
||||
|
||||
Loading…
Add table
Add a link
Reference in a new issue