Chez Phase 2 (inc Q): Java class statics + constructors (jolt-avt6)
Lower host class interop on the Chez back end. The analyzer now turns a non-var qualified ref `Class/member` into a :host-static node and a `(Class. ...)` / `(new Class ...)` form into a :host-new node (ir.clj gains both, with walker support). The Janet back end punts both to the interpreter, so its behavior is unchanged (verified: dot-form, `..` threading, shadowed `new`, and all interop still resolve via fallback). The Chez emit lowers a value ref to host-static-ref, a call head to host-static-call, and a constructor to host-new. host/chez/host-static.ss is the runtime registry these resolve against — the Chez port of the seed's class-statics / class-ctors / tagged-methods (java_base.janet + host_io.janet), restricted to the java.lang/util/net/io surface portable cljc code calls: Math, System (getenv/getProperty/exit/currentTimeMillis), Long, Integer, Boolean, Character, String, Thread, Class, Pattern (compile/quote/MULTILINE), URLEncoder/Decoder, Base64, the Number method surface (byteValue/intValue/...), plus the StringBuilder, StringWriter, StringReader, PushbackReader, HashMap, StringTokenizer, BigInteger, String, MapEntry, and exception constructors. Constructed objects are jhost records dispatched through record-method-dispatch. Also: emit now evaluates collection-literal elements left-to-right (emit-ordered) — Chez evaluates call args right-to-left, which had been swapping side-effecting elements in [(read r) (read r)] and map literals. This un-allowlisted the 6 eval-order corpus cases (the read-line trio + the three map-construction cases). Removed `.write` from the jolt-host-call fast-path so a StringWriter routes through dispatch. java.time formatting, edn/read-over-readers, and slurp/with-open over readers are deferred to a follow-up. Corpus parity 2078 -> 2134 (floor raised), 0 new divergences; the print-method builtin-override case is allowlisted (same multimethod gap, newly reachable now that StringWriter constructs). emit-test 326/326, _javastatic 51/51, conformance 355x3, full jpm test green.
This commit is contained in:
Yogthos
parent
a706a79b90
commit
c90c4cb610
10 changed files with 711 additions and 26 deletions
|
|
@ -107,6 +107,20 @@
|
|||
(var- gensym-n 0)
|
||||
(defn- fresh-label [prefix] (string prefix (++ gensym-n)))
|
||||
|
||||
# Emit a call `(ctor a0 a1 ...)` with the args evaluated LEFT-TO-RIGHT. Chez's
|
||||
# procedure-argument evaluation order is unspecified (and in practice right-to-
|
||||
# left), but Clojure/JVM evaluates collection-literal elements left-to-right, so a
|
||||
# literal like [(read r) (read r)] over side-effecting reads must bind in source
|
||||
# order. Bind each arg to a fresh temp in a let* (sequential) then construct. Only
|
||||
# wraps when there are >= 2 args (0/1 have no ordering to preserve), keeping the
|
||||
# common small-literal output compact (jolt-avt6).
|
||||
(defn- emit-ordered [ctor arg-strs]
|
||||
(if (< (length arg-strs) 2)
|
||||
(string "(" ctor (if (empty? arg-strs) "" (string " " (string/join arg-strs " "))) ")")
|
||||
(let [tmps (map (fn [_] (fresh-label "_o$")) arg-strs)
|
||||
binds (string/join (map (fn [t a] (string "(" t " " a ")")) tmps arg-strs) " ")]
|
||||
(string "(let* (" binds ") (" ctor " " (string/join tmps " ") "))"))))
|
||||
|
||||
# Most jolt names are already valid Scheme identifiers (inc, even?, +, ->str all
|
||||
# are — Scheme allows ! $ % & * + - . / : < = > ? @ ^ _ ~). The one that isn't is
|
||||
# `#`, which jolt auto-gensyms use as a suffix (e.g. p1__0000X4# from #(...)
|
||||
|
|
@ -345,7 +359,10 @@
|
|||
|
||||
# Host interop methods with a Chez RT shim (rt.ss jolt-host-call). A `.method`
|
||||
# call on any other method is out of subset until shimmed — keep this in sync.
|
||||
(def- supported-host-methods {"write" true "isDirectory" true "listFiles" true})
|
||||
# `.write` is NOT here: StringWriter (a jhost, host-static.ss) handles .write via
|
||||
# record-method-dispatch; the old jolt-host-call "write" fast-path (display to a
|
||||
# port) would mis-route a writer to `(display x jhost)`. Keep the File-op methods.
|
||||
(def- supported-host-methods {"isDirectory" true "listFiles" true})
|
||||
|
||||
# jolt's comparison ops are vacuously true at arity 1 and DON'T inspect the arg
|
||||
# (so (< :kw) is true), but Scheme's < demands a number even there — special-case.
|
||||
|
|
@ -381,6 +398,13 @@
|
|||
(= kind :coll) (string "(jolt-get " (emit fnode) " " (first args) default ")")
|
||||
(and (stdlib-var? fnode) (not prelude-mode?))
|
||||
(errorf "emit: unsupported stdlib fn `%s/%s` (no core on Chez yet)" (get fnode :ns) (get fnode :name))
|
||||
# static method call (Class/method arg*) -> (host-static-call "Class"
|
||||
# "method" arg*). host-static.ss resolves the method from the class-statics
|
||||
# registry and applies it (jolt-avt6).
|
||||
(= :host-static (get fnode :op))
|
||||
(string "(host-static-call " (chez-str-lit (get fnode :class)) " "
|
||||
(chez-str-lit (get fnode :member))
|
||||
(if (empty? args) "" (string " " (string/join args " "))) ")")
|
||||
(= :host (get fnode :op))
|
||||
(errorf "emit: unsupported host call `%s` (no host interop on Chez yet)" (get fnode :name))
|
||||
# a :local callee that isn't a known procedure (a let/param binding holding a
|
||||
|
|
@ -438,6 +462,14 @@
|
|||
(string "(var-deref " (chez-str-lit (get node :ns)) " "
|
||||
(chez-str-lit (get node :name)) ")")))
|
||||
:host (errorf "emit: unsupported host ref `%s` (no host interop on Chez yet)" (get node :name))
|
||||
# value-position static ref (Class/member, e.g. Long/MAX_VALUE, System/exit
|
||||
# passed as a value) -> the registered static value/procedure (host-static.ss).
|
||||
:host-static (string "(host-static-ref " (chez-str-lit (get node :class)) " "
|
||||
(chez-str-lit (get node :member)) ")")
|
||||
# constructor (Class. args*) / (new Class args*) -> (host-new "Class" args*).
|
||||
:host-new (string "(host-new " (chez-str-lit (get node :class))
|
||||
(let [args (map emit (vv (get node :args)))]
|
||||
(if (empty? args) "" (string " " (string/join args " ")))) ")")
|
||||
# (var x) / #'x -> the var cell itself (the rt.ss var-cell, a first-class var
|
||||
# object). var?/var-get/deref/invoke/= operate on it (vars.ss).
|
||||
:the-var (string "(jolt-var " (chez-str-lit (get node :ns)) " " (chez-str-lit (get node :name)) ")")
|
||||
|
|
@ -450,15 +482,16 @@
|
|||
(if (empty? (vv (get node :statements))) "" " ")
|
||||
(emit (get node :ret)) ")")
|
||||
:invoke (emit-invoke node)
|
||||
# collection literals -> rt constructors (collections.ss)
|
||||
:vector (string "(jolt-vector " (string/join (map emit (vv (get node :items))) " ") ")")
|
||||
:set (string "(jolt-hash-set " (string/join (map emit (vv (get node :items))) " ") ")")
|
||||
# collection literals -> rt constructors (collections.ss). Elements evaluate
|
||||
# LEFT-TO-RIGHT (emit-ordered) to match Clojure for side-effecting elements.
|
||||
:vector (emit-ordered "jolt-vector" (map emit (vv (get node :items))))
|
||||
:set (emit-ordered "jolt-hash-set" (map emit (vv (get node :items))))
|
||||
:map (let [flat @[]]
|
||||
(each p (vv (get node :pairs))
|
||||
(def p (vv p))
|
||||
(array/push flat (emit (get p 0)))
|
||||
(array/push flat (emit (get p 1))))
|
||||
(string "(jolt-hash-map " (string/join flat " ") ")"))
|
||||
(emit-ordered "jolt-hash-map" flat))
|
||||
:let (emit-let node)
|
||||
:loop (emit-loop node)
|
||||
:recur (emit-recur node)
|
||||
|
|
|
|||
476
host/chez/host-static.ss
Normal file
476
host/chez/host-static.ss
Normal file
|
|
@ -0,0 +1,476 @@
|
|||
;; host-static.ss (jolt-avt6) — host class statics + constructors on Chez.
|
||||
;;
|
||||
;; 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 (emit.janet) 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 Chez port of the seed's class-statics / class-ctors /
|
||||
;; tagged-methods registries (src/jolt/interop/java_base.janet + host_io.janet),
|
||||
;; 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
|
||||
((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)))
|
||||
(else (error #f (string-append "No method " method " for number")))))
|
||||
|
||||
;; ---- emit entry points ------------------------------------------------------
|
||||
(define (host-static-ref class member)
|
||||
(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)))
|
||||
(if ctor (apply ctor args)
|
||||
(error #f (string-append "No constructor for class " class)))))
|
||||
|
||||
;; ---- coercion helpers -------------------------------------------------------
|
||||
(define (->num x) (exact->inexact x))
|
||||
(define (jnum->exact n) (exact (truncate n)))
|
||||
;; parse an integer string in radix; #f on failure (matches the seed's scan-number)
|
||||
(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)))
|
||||
|
||||
;; ---- java.lang statics ------------------------------------------------------
|
||||
(register-class-statics! "Math"
|
||||
(list (cons "sqrt" (lambda (x) (->num (sqrt x))))
|
||||
(cons "pow" (lambda (a b) (->num (expt a b))))
|
||||
(cons "floor" (lambda (x) (->num (floor x))))
|
||||
(cons "ceil" (lambda (x) (->num (ceiling x))))
|
||||
(cons "round" (lambda (x) (->num (round x))))
|
||||
(cons "abs" (lambda (x) (->num (abs x))))
|
||||
(cons "sin" (lambda (x) (->num (sin x)))) (cons "cos" (lambda (x) (->num (cos x))))
|
||||
(cons "tan" (lambda (x) (->num (tan x)))) (cons "asin" (lambda (x) (->num (asin x))))
|
||||
(cons "acos" (lambda (x) (->num (acos x)))) (cons "atan" (lambda (x) (->num (atan x))))
|
||||
(cons "log" (lambda (x) (->num (log x)))) (cons "log10" (lambda (x) (->num (/ (log x) (log 10)))))
|
||||
(cons "exp" (lambda (x) (->num (exp x))))
|
||||
(cons "max" (lambda (a b) (->num (if (> a b) a b)))) (cons "min" (lambda (a b) (->num (if (< a b) a b))))
|
||||
(cons "signum" (lambda (x) (cond ((< x 0) -1.0) ((> x 0) 1.0) (else 0.0))))
|
||||
(cons "PI" (->num (* 4 (atan 1)))) (cons "E" (->num (exp 1)))
|
||||
(cons "random" (lambda args (->num (random 1.0))))))
|
||||
|
||||
;; Thread: no real threading here (futures/timing are jolt-byjr). sleep is a no-op.
|
||||
(register-class-statics! "Thread"
|
||||
(list (cons "sleep" (lambda (ms . _) jolt-nil))
|
||||
(cons "yield" (lambda () jolt-nil))
|
||||
(cons "interrupted" (lambda () #f))
|
||||
(cons "currentThread" (lambda () (make-jhost "thread" '())))))
|
||||
(register-host-methods! "thread"
|
||||
(list (cons "getContextClassLoader" (lambda (self) (make-jhost "classloader" '())))))
|
||||
|
||||
(define (now-millis)
|
||||
(let ((t (current-time 'time-utc)))
|
||||
(+ (* 1000 (time-second t)) (quotient (time-nanosecond t) 1000000))))
|
||||
(register-class-statics! "System"
|
||||
(list (cons "currentTimeMillis" (lambda () (->num (now-millis))))
|
||||
(cons "nanoTime" (lambda () (->num (* 1000000 (now-millis)))))
|
||||
(cons "exit" (lambda args (exit (if (null? args) 0 (jnum->exact (car args))))))
|
||||
;; wrapped in lambdas: the helpers are defined below, resolved at call time.
|
||||
(cons "getProperty" (lambda (k . d) (apply sys-get-property k d)))
|
||||
(cons "getProperties" (lambda () (sys-properties-map)))
|
||||
(cons "getenv" (lambda k (apply sys-getenv k)))))
|
||||
|
||||
(register-class-statics! "Long"
|
||||
(list (cons "MAX_VALUE" (->num 9223372036854775807))
|
||||
(cons "MIN_VALUE" (->num -9223372036854775808))
|
||||
(cons "parseLong" (lambda (s . r) (parse-int-or-throw s (if (null? r) 10 (jnum->exact (car r))) "parseLong")))
|
||||
(cons "valueOf" (lambda (s . r) (parse-int-or-throw s (if (null? r) 10 (jnum->exact (car r))) "valueOf")))))
|
||||
|
||||
(register-class-statics! "Integer"
|
||||
(list (cons "MAX_VALUE" (->num 2147483647)) (cons "MIN_VALUE" (->num -2147483648))
|
||||
(cons "valueOf" (lambda (x . r)
|
||||
(if (number? x) (->num x)
|
||||
(parse-int-or-throw x (if (null? r) 10 (jnum->exact (car r))) "valueOf"))))
|
||||
(cons "parseInt" (lambda (x . r) (parse-int-or-throw x (if (null? r) 10 (jnum->exact (car r))) "parseInt")))))
|
||||
|
||||
(register-class-statics! "Boolean"
|
||||
(list (cons "parseBoolean" (lambda (s) (string=? "true" (ascii-string-down (if (string? s) s (jolt-str-render-one s))))))
|
||||
(cons "TRUE" #t) (cons "FALSE" #f)))
|
||||
|
||||
;; Character: ASCII predicates (the engine is byte/ASCII oriented).
|
||||
(register-class-statics! "Character"
|
||||
(list (cons "isUpperCase" (lambda (c) (let ((n (char-code c))) (and (>= n 65) (<= n 90)))))
|
||||
(cons "isLowerCase" (lambda (c) (let ((n (char-code c))) (and (>= n 97) (<= n 122)))))
|
||||
(cons "isDigit" (lambda (c) (let ((n (char-code c))) (and (>= n 48) (<= n 57)))))
|
||||
(cons "isWhitespace" (lambda (c) (char<=? (integer->char (char-code c)) #\space)))))
|
||||
|
||||
;; String/valueOf(Object): "null" for nil, else jolt's str semantics.
|
||||
(register-class-statics! "String"
|
||||
(list (cons "valueOf" (lambda (x . _) (if (jolt-nil? x) "null" (jolt-str-render-one x))))))
|
||||
|
||||
(register-class-statics! "Class"
|
||||
(list (cons "forName" (lambda (nm) (make-jhost "class" (list (cons 'name nm)))))))
|
||||
|
||||
;; ---- System helpers (defined before use above via top-level order) ----------
|
||||
(define (sys-get-property k . dflt)
|
||||
(cond ((string=? k "os.name") "Mac OS X")
|
||||
((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" "Mac OS X" "line.separator" "\n" "file.separator" "/"
|
||||
"user.dir" (or (getenv "PWD") ".") "user.home" (or (getenv "HOME") "")
|
||||
"java.io.tmpdir" (or (getenv "TMPDIR") "/tmp")))
|
||||
|
||||
;; full environment as an alist of (name . value), via spawning `env`.
|
||||
(define (all-env-pairs)
|
||||
(call-with-values
|
||||
(lambda () (open-process-ports "env" (buffer-mode block) (native-transcoder)))
|
||||
(lambda (stdin stdout stderr pid)
|
||||
(let loop ((acc '()))
|
||||
(let ((l (get-line stdout)))
|
||||
(if (eof-object? l) (reverse acc)
|
||||
(let ((eq (let scan ((i 0)) (cond ((= i (string-length l)) #f)
|
||||
((char=? (string-ref l i) #\=) i)
|
||||
(else (scan (+ i 1)))))))
|
||||
(loop (if eq (cons (cons (substring l 0 eq) (substring l (+ eq 1) (string-length l))) acc) acc)))))))))
|
||||
;; JOLT_BAKE_ENV_ALLOWLIST (jolt-s3j): when set, only the listed comma-separated
|
||||
;; names are served; unset (the normal case) reads are live and unfiltered.
|
||||
(define (env-allowlist)
|
||||
(let ((a (getenv "JOLT_BAKE_ENV_ALLOWLIST")))
|
||||
(and a (map str-trim (str-literal-split a ",")))))
|
||||
(define (sys-getenv . k)
|
||||
(let ((allow (env-allowlist)))
|
||||
(if (null? k)
|
||||
(apply jolt-hash-map
|
||||
(let loop ((ps (all-env-pairs)) (acc '()))
|
||||
(cond ((null? ps) (reverse acc))
|
||||
((and allow (not (member (caar ps) allow))) (loop (cdr ps) acc))
|
||||
(else (loop (cdr ps) (cons (cdar ps) (cons (caar ps) acc)))))))
|
||||
(let ((name (car k)))
|
||||
(if (and allow (not (member name allow))) jolt-nil
|
||||
(let ((v (getenv name))) (if v v jolt-nil)))))))
|
||||
|
||||
;; ---- StringBuilder ----------------------------------------------------------
|
||||
;; state: a box (1-vector) holding the accumulated string.
|
||||
(define (sb-str self) (vector-ref (jhost-state self) 0))
|
||||
(define (sb-set! self s) (vector-set! (jhost-state self) 0 s))
|
||||
(define (render-piece x)
|
||||
(cond ((jolt-nil? x) "null") ((char? x) (string x)) ((string? x) x)
|
||||
(else (jolt-str-render-one x))))
|
||||
(register-class-ctor! "StringBuilder"
|
||||
(lambda args (make-jhost "string-builder"
|
||||
;; a numeric first arg is a CAPACITY hint, not content.
|
||||
(vector (if (and (pair? args) (not (number? (car args)))) (render-piece (car args)) "")))))
|
||||
(register-host-methods! "string-builder"
|
||||
(list (cons "append" (lambda (self x) (sb-set! self (string-append (sb-str self) (render-piece x))) self))
|
||||
(cons "toString" (lambda (self) (sb-str self)))
|
||||
(cons "length" (lambda (self) (->num (string-length (sb-str self)))))
|
||||
(cons "charAt" (lambda (self i) (string-ref (sb-str self) (jnum->exact i))))
|
||||
(cons "setLength" (lambda (self n)
|
||||
(let ((cur (sb-str self)) (n (jnum->exact n)))
|
||||
(sb-set! self (if (< n (string-length cur))
|
||||
(substring cur 0 n)
|
||||
(string-append cur (make-string (- n (string-length cur)) #\nul)))))
|
||||
jolt-nil))))
|
||||
|
||||
;; ---- StringWriter -----------------------------------------------------------
|
||||
;; Writer.write(int) writes the CHAR for that code; append(char) appends the char.
|
||||
(define (writer-piece x) (if (number? x) (string (integer->char (jnum->exact x))) (render-piece x)))
|
||||
(register-class-ctor! "StringWriter" (lambda args (make-jhost "writer" (vector ""))))
|
||||
(register-host-methods! "writer"
|
||||
(list (cons "write" (lambda (self x) (sb-set! self (string-append (sb-str self) (writer-piece x))) jolt-nil))
|
||||
(cons "append" (lambda (self x) (sb-set! self (string-append (sb-str self) (render-piece x))) self))
|
||||
(cons "flush" (lambda (self) jolt-nil))
|
||||
(cons "close" (lambda (self) jolt-nil))
|
||||
(cons "toString" (lambda (self) (sb-str self)))))
|
||||
|
||||
;; ---- StringReader -----------------------------------------------------------
|
||||
;; state: a vector #(string pos marked).
|
||||
(register-class-ctor! "StringReader"
|
||||
(lambda (src . _) (make-jhost "string-reader" (vector (if (string? src) src (jolt-str-render-one src)) 0 0))))
|
||||
(define (sr-s self) (vector-ref (jhost-state self) 0))
|
||||
(define (sr-pos self) (vector-ref (jhost-state self) 1))
|
||||
(define (sr-pos! self p) (vector-set! (jhost-state self) 1 p))
|
||||
(register-host-methods! "string-reader"
|
||||
(list (cons "read" (lambda (self)
|
||||
(let ((s (sr-s self)) (p (sr-pos self)))
|
||||
(if (>= p (string-length s)) -1.0
|
||||
(begin (sr-pos! self (+ p 1)) (->num (char->integer (string-ref s p))))))))
|
||||
(cons "mark" (lambda (self . _) (vector-set! (jhost-state self) 2 (sr-pos self)) jolt-nil))
|
||||
(cons "reset" (lambda (self) (sr-pos! self (vector-ref (jhost-state self) 2)) jolt-nil))
|
||||
(cons "skip" (lambda (self n) (let ((n (jnum->exact n)))
|
||||
(sr-pos! self (min (string-length (sr-s self)) (+ (sr-pos self) n))) (->num n))))
|
||||
(cons "close" (lambda (self) jolt-nil))))
|
||||
|
||||
;; ---- PushbackReader ---------------------------------------------------------
|
||||
;; state: a vector #(wrapped-reader pushed-list)
|
||||
(register-class-ctor! "PushbackReader"
|
||||
(lambda (rdr . _) (make-jhost "pushback-reader" (vector rdr '()))))
|
||||
(define (read-unit r) ; read one code unit (flonum) from any reader, -1 at EOF
|
||||
(record-method-dispatch r "read" jolt-nil))
|
||||
(register-host-methods! "pushback-reader"
|
||||
(list (cons "read" (lambda (self)
|
||||
(let ((pushed (vector-ref (jhost-state self) 1)))
|
||||
(if (pair? pushed)
|
||||
(begin (vector-set! (jhost-state self) 1 (cdr pushed)) (car pushed))
|
||||
(read-unit (vector-ref (jhost-state self) 0))))))
|
||||
(cons "unread" (lambda (self ch)
|
||||
(vector-set! (jhost-state self) 1
|
||||
(cons (if (char? ch) (->num (char->integer ch)) ch) (vector-ref (jhost-state self) 1)))
|
||||
jolt-nil))
|
||||
(cons "close" (lambda (self) jolt-nil))))
|
||||
|
||||
;; ---- HashMap ----------------------------------------------------------------
|
||||
;; state: a box holding an alist of (k . v), jolt= keyed.
|
||||
(define (hm-alist self) (vector-ref (jhost-state self) 0))
|
||||
(define (hm-set! self al) (vector-set! (jhost-state self) 0 al))
|
||||
(define (hm-assoc al k v)
|
||||
(let loop ((ps al) (acc '()) (hit #f))
|
||||
(cond ((null? ps) (reverse (if hit acc (cons (cons k v) acc))))
|
||||
((jolt=2 (caar ps) k) (loop (cdr ps) (cons (cons k v) acc) #t))
|
||||
(else (loop (cdr ps) (cons (car ps) acc) hit)))))
|
||||
(define (hm-get al k) (let loop ((ps al)) (cond ((null? ps) jolt-nil) ((jolt=2 (caar ps) k) (cdar ps)) (else (loop (cdr ps))))))
|
||||
(define (coll->pairs m)
|
||||
(if (jolt-nil? m) '()
|
||||
(let loop ((s (jolt-seq m)) (acc '()))
|
||||
(if (jolt-nil? s) (reverse acc)
|
||||
(let ((e (seq-first s))) (loop (jolt-seq (seq-more s)) (cons (cons (jolt-nth e 0) (jolt-nth e 1)) acc)))))))
|
||||
(register-class-ctor! "HashMap"
|
||||
(lambda args
|
||||
(let ((init (and (pair? args) (car args))))
|
||||
(make-jhost "hashmap" (vector (if (and init (not (number? init))) (coll->pairs init) '()))))))
|
||||
(register-host-methods! "hashmap"
|
||||
(list (cons "get" (lambda (self k) (hm-get (hm-alist self) k)))
|
||||
(cons "put" (lambda (self k v) (hm-set! self (hm-assoc (hm-alist self) k v)) v))
|
||||
(cons "putAll" (lambda (self m) (for-each (lambda (p) (hm-set! self (hm-assoc (hm-alist self) (car p) (cdr p)))) (coll->pairs m)) jolt-nil))
|
||||
(cons "containsKey" (lambda (self k) (not (jolt-nil? (hm-get (hm-alist self) k)))))
|
||||
(cons "size" (lambda (self) (->num (length (hm-alist self)))))))
|
||||
|
||||
;; ---- StringTokenizer --------------------------------------------------------
|
||||
;; state: a vector #(tokens-list pos)
|
||||
(define (tokenize s delims)
|
||||
(let ((dset (string->list delims)))
|
||||
(let loop ((chars (string->list s)) (cur '()) (toks '()))
|
||||
(cond ((null? chars) (reverse (if (null? cur) toks (cons (list->string (reverse cur)) toks))))
|
||||
((memv (car chars) dset)
|
||||
(loop (cdr chars) '() (if (null? cur) toks (cons (list->string (reverse cur)) toks))))
|
||||
(else (loop (cdr chars) (cons (car chars) cur) toks))))))
|
||||
(register-class-ctor! "StringTokenizer"
|
||||
(lambda (s . delims) (make-jhost "string-tokenizer"
|
||||
(vector (tokenize (if (string? s) s (jolt-str-render-one s))
|
||||
(if (null? delims) " \t\n\r\f" (car delims))) 0))))
|
||||
(register-host-methods! "string-tokenizer"
|
||||
(list (cons "hasMoreTokens" (lambda (self) (< (vector-ref (jhost-state self) 1) (length (vector-ref (jhost-state self) 0)))))
|
||||
(cons "countTokens" (lambda (self) (->num (- (length (vector-ref (jhost-state self) 0)) (vector-ref (jhost-state self) 1)))))
|
||||
(cons "nextToken" (lambda (self)
|
||||
(let ((toks (vector-ref (jhost-state self) 0)) (p (vector-ref (jhost-state self) 1)))
|
||||
(if (< p (length toks))
|
||||
(begin (vector-set! (jhost-state self) 1 (+ p 1)) (list-ref toks p))
|
||||
(error #f "NoSuchElementException")))))))
|
||||
|
||||
;; ---- String / BigInteger / MapEntry constructors ----------------------------
|
||||
;; (String. x) / (String. bytes): a bytevector decodes UTF-8; else stringify.
|
||||
(register-class-ctor! "String"
|
||||
(lambda (x . _) (cond ((bytevector? x) (utf8->string x)) ((string? x) x) (else (jolt-str-render-one x)))))
|
||||
(register-class-ctor! "BigInteger"
|
||||
(lambda (v) (parse-int-or-throw v 10 "BigInteger")))
|
||||
(register-class-ctor! "MapEntry" (lambda (k v) (make-map-entry k v)))
|
||||
;; JVM exception ctors: 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"))
|
||||
|
||||
;; ---- URLEncoder / URLDecoder (www-form-urlencoded) --------------------------
|
||||
(define (url-unreserved? b)
|
||||
(or (and (>= b 48) (<= b 57)) (and (>= b 65) (<= b 90)) (and (>= b 97) (<= b 122))
|
||||
(= b 46) (= b 42) (= b 95) (= b 45)))
|
||||
(define hex-digits "0123456789ABCDEF")
|
||||
(define (url-encode s . _)
|
||||
(let ((bs (string->utf8 (if (string? s) s (jolt-str-render-one s)))) (out '()))
|
||||
(let loop ((i 0))
|
||||
(if (= i (bytevector-length bs)) (list->string (reverse out))
|
||||
(let ((b (bytevector-u8-ref bs i)))
|
||||
(cond ((url-unreserved? b) (set! out (cons (integer->char b) out)))
|
||||
((= b 32) (set! out (cons #\+ out)))
|
||||
(else (set! out (cons (string-ref hex-digits (bitwise-and b 15))
|
||||
(cons (string-ref hex-digits (bitwise-arithmetic-shift-right b 4))
|
||||
(cons #\% out))))))
|
||||
(loop (+ i 1)))))))
|
||||
(define (hexv c)
|
||||
(cond ((and (char<=? #\0 c) (char<=? c #\9)) (- (char->integer c) 48))
|
||||
((and (char<=? #\A c) (char<=? c #\F)) (- (char->integer c) 55))
|
||||
((and (char<=? #\a c) (char<=? c #\f)) (- (char->integer c) 87))
|
||||
(else (error #f "URLDecoder: malformed escape"))))
|
||||
(define (url-decode s . _)
|
||||
(let* ((str (if (string? s) s (jolt-str-render-one s))) (n (string-length str)) (out '()))
|
||||
(let loop ((i 0))
|
||||
(if (>= i n) (utf8->string (u8-list->bytevector (reverse out)))
|
||||
(let ((c (string-ref str i)))
|
||||
(cond ((char=? c #\+) (set! out (cons 32 out)) (loop (+ i 1)))
|
||||
((char=? c #\%)
|
||||
(set! out (cons (+ (* 16 (hexv (string-ref str (+ i 1)))) (hexv (string-ref str (+ i 2)))) out))
|
||||
(loop (+ i 3)))
|
||||
(else (set! out (cons (char->integer c) out)) (loop (+ i 1)))))))))
|
||||
(define (u8-list->bytevector lst)
|
||||
(let ((bv (make-bytevector (length lst))))
|
||||
(let loop ((l lst) (i 0)) (if (null? l) bv (begin (bytevector-u8-set! bv i (car l)) (loop (cdr l) (+ i 1)))))))
|
||||
(register-class-statics! "URLEncoder" (list (cons "encode" url-encode)))
|
||||
(register-class-statics! "URLDecoder" (list (cons "decode" url-decode)))
|
||||
(register-class-statics! "Charset" (list (cons "forName" (lambda (nm) (make-jhost "charset" (list (cons 'name nm)))))))
|
||||
|
||||
;; ---- 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 (b64-encode x)
|
||||
(let* ((bs (->bytevector x)) (n (bytevector-length bs)) (out '()))
|
||||
(let loop ((i 0))
|
||||
(if (>= i n) (list->string (reverse out))
|
||||
(let* ((b0 (bytevector-u8-ref bs i))
|
||||
(b1 (if (< (+ i 1) n) (bytevector-u8-ref bs (+ i 1)) #f))
|
||||
(b2 (if (< (+ i 2) n) (bytevector-u8-ref bs (+ i 2)) #f)))
|
||||
(set! out (cons (string-ref b64-alphabet (bitwise-arithmetic-shift-right b0 2)) out))
|
||||
(set! out (cons (string-ref b64-alphabet (bitwise-ior (bitwise-arithmetic-shift-left (bitwise-and b0 3) 4)
|
||||
(bitwise-arithmetic-shift-right (or b1 0) 4))) out))
|
||||
(set! out (cons (if b1 (string-ref b64-alphabet (bitwise-ior (bitwise-arithmetic-shift-left (bitwise-and b1 15) 2)
|
||||
(bitwise-arithmetic-shift-right (or b2 0) 6))) #\=) out))
|
||||
(set! out (cons (if b2 (string-ref b64-alphabet (bitwise-and b2 63)) #\=) out))
|
||||
(loop (+ i 3)))))))
|
||||
(define (b64-char-val c)
|
||||
(let loop ((i 0)) (cond ((= i 64) (error #f "Base64: illegal character")) ((char=? (string-ref b64-alphabet i) c) i) (else (loop (+ i 1))))))
|
||||
(define (b64-decode x)
|
||||
(let* ((str (let ((s (if (string? x) x (utf8->string (->bytevector x)))))
|
||||
(list->string (filter (lambda (c) (not (char=? c #\=))) (string->list s)))))
|
||||
(out '()) (acc 0) (bits 0))
|
||||
(for-each (lambda (c)
|
||||
(set! acc (bitwise-ior (bitwise-arithmetic-shift-left acc 6) (b64-char-val c)))
|
||||
(set! bits (+ bits 6))
|
||||
(when (>= bits 8)
|
||||
(set! bits (- bits 8))
|
||||
(set! out (cons (bitwise-and (bitwise-arithmetic-shift-right acc bits) 255) out))))
|
||||
(string->list str))
|
||||
(u8-list->bytevector (reverse out))))
|
||||
(register-host-methods! "b64-encoder"
|
||||
(list (cons "encode" (lambda (self bs) (string->utf8 (b64-encode bs))))
|
||||
(cons "encodeToString" (lambda (self bs) (b64-encode bs)))))
|
||||
(register-host-methods! "b64-decoder"
|
||||
(list (cons "decode" (lambda (self s) (b64-decode s)))))
|
||||
(register-class-statics! "Base64"
|
||||
(list (cons "getEncoder" (lambda () (make-jhost "b64-encoder" '())))
|
||||
(cons "getDecoder" (lambda () (make-jhost "b64-decoder" '())))))
|
||||
|
||||
;; ---- java.util.regex.Pattern ------------------------------------------------
|
||||
;; Pattern/compile returns a jolt-regex value (regex-t), so str/replace, re-find,
|
||||
;; .split etc. accept it transparently.
|
||||
(define pattern-multiline 8.0)
|
||||
(define (pattern-quote s)
|
||||
(let ((meta "\\.[]{}()*+-?^$|&") (s (if (string? s) s (jolt-str-render-one s))) (out '()))
|
||||
(let loop ((i 0))
|
||||
(if (= i (string-length s)) (list->string (reverse out))
|
||||
(let ((c (string-ref s i)))
|
||||
(when (memv c (string->list meta)) (set! out (cons #\\ out)))
|
||||
(set! out (cons c out))
|
||||
(loop (+ i 1)))))))
|
||||
(register-class-statics! "Pattern"
|
||||
(list (cons "compile" (lambda (s . flags)
|
||||
(if (and (pair? flags) (= (bitwise-and (jnum->exact (car flags)) 8) 8))
|
||||
(jolt-regex (string-append "(?m)" s))
|
||||
(jolt-regex s))))
|
||||
(cons "quote" (lambda (s) (pattern-quote s)))
|
||||
(cons "MULTILINE" pattern-multiline)))
|
||||
;; record-method-dispatch already routes string? -> jolt-string-method. Add a
|
||||
;; regex-t arm (Pattern .split / .matcher-less surface used by corpus) by wrapping
|
||||
;; once more — a regex-t isn't a jhost.
|
||||
(define %hs-rmd2 record-method-dispatch)
|
||||
(set! record-method-dispatch
|
||||
(lambda (obj method-name rest-args)
|
||||
(if (regex-t? obj)
|
||||
(let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
|
||||
(cond ((string=? method-name "split")
|
||||
;; .split returns a String[] — a seq, like the seed's array (prints
|
||||
;; (a b c), not a vector). re-split with no limit; drop trailing
|
||||
;; empties (JVM default).
|
||||
(let ((parts (re-split (regex-t-irx obj) (car rest) #f)))
|
||||
(list->cseq (str-split-drop-trailing parts))))
|
||||
((string=? method-name "pattern") (regex-t-source obj))
|
||||
(else (error #f (string-append "No method " method-name " on Pattern")))))
|
||||
(%hs-rmd2 obj method-name rest-args))))
|
||||
|
||||
;; ---- def-var! the registry entry points so emit can also reach them ---------
|
||||
(def-var! "clojure.core" "host-static-ref" host-static-ref)
|
||||
(def-var! "clojure.core" "host-static-call" (lambda (c m . a) (apply host-static-call c m a)))
|
||||
(def-var! "clojure.core" "host-new" (lambda (c . a) (apply host-new c a)))
|
||||
|
|
@ -22,6 +22,7 @@
|
|||
"host/chez/atoms.ss" "host/chez/predicates.ss" "host/chez/regex.ss"
|
||||
"host/chez/ns.ss" "host/chez/post-prelude.ss" "host/chez/natives-meta.ss"
|
||||
"host/chez/natives-str.ss" "host/chez/records.ss"
|
||||
"host/chez/host-static.ss"
|
||||
"src/jolt/clojure/string.clj"]
|
||||
(array/push parts (slurp f)))
|
||||
(string/slice (string (hash (string/join parts))) 0))
|
||||
|
|
|
|||
|
|
@ -271,3 +271,9 @@
|
|||
;; a string target. After regex.ss (jolt-re-pattern/regex-t-irx) + records.ss
|
||||
;; (which references jolt-string-method).
|
||||
(load "host/chez/natives-str.ss")
|
||||
|
||||
;; host class statics + constructors (jolt-avt6, Phase 2): host-static-ref/
|
||||
;; host-static-call/host-new + the jhost method registry. Loads LAST — it extends
|
||||
;; record-method-dispatch (records.ss) and reuses natives-str helpers (str-trim,
|
||||
;; ascii-string-down, re-split, str-split-drop-trailing) + the regex-t accessors.
|
||||
(load "host/chez/host-static.ss")
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@
|
|||
them to one keeps the compiled namespace simple."
|
||||
(:require [jolt.ir :refer [const local var-ref the-var host-ref if-node do-node invoke
|
||||
def-node let-node fn-node vector-node map-node set-node
|
||||
quote-node throw-node]]
|
||||
quote-node throw-node host-static host-new]]
|
||||
[jolt.host :refer [form-sym? form-sym-name form-sym-ns form-list?
|
||||
form-vec? form-map? form-set? form-char?
|
||||
form-literal? form-elements form-vec-items
|
||||
|
|
@ -294,6 +294,20 @@
|
|||
:target (analyze ctx (nth items 1) env)
|
||||
:args (mapv #(analyze ctx % env) (drop 2 items))})
|
||||
|
||||
;; A constructor head: `Class.` — a symbol ending in "." (but not the member
|
||||
;; access `.method` / `..` forms). `(Class. args*)` builds an instance.
|
||||
(defn- ctor-head? [nm]
|
||||
(and (> (count nm) 1)
|
||||
(= "." (subs nm (dec (count nm)) (count nm)))
|
||||
(not (= "." (subs nm 0 1)))))
|
||||
|
||||
;; `(Class. args*)` and `(new Class args*)` -> a :host-new node carrying the class
|
||||
;; token and the analyzed args. The Janet back end punts it (the interpreter runs
|
||||
;; the constructor from its class-ctors registry); the Chez back end lowers it to
|
||||
;; a runtime constructor dispatch (jolt-avt6).
|
||||
(defn- analyze-ctor [ctx class args env]
|
||||
(host-new class (mapv #(analyze ctx % env) args)))
|
||||
|
||||
(defn- analyze-symbol [ctx form env]
|
||||
(let [nm (form-sym-name form) ns (form-sym-ns form)]
|
||||
(cond
|
||||
|
|
@ -302,7 +316,13 @@
|
|||
ns (let [r (resolve-global ctx form)]
|
||||
(if (= :var (:kind r))
|
||||
(var-ref (:ns r) (:name r))
|
||||
(uncompilable (str "qualified ref " ns "/" nm))))
|
||||
;; A non-var qualified ref `Class/member` is a host class static
|
||||
;; (Math/sqrt, Long/MAX_VALUE, System/getenv). The Janet back end
|
||||
;; punts the :host-static node (the interpreter resolves it from its
|
||||
;; class-statics registry, exactly as it did when this was an
|
||||
;; uncompilable); the Chez back end lowers it to a runtime static
|
||||
;; dispatch (jolt-avt6).
|
||||
(host-static ns nm)))
|
||||
:else (let [r (resolve-global ctx form)]
|
||||
(case (:kind r)
|
||||
:var (var-ref (:ns r) (:name r))
|
||||
|
|
@ -337,6 +357,13 @@
|
|||
(analyze-special ctx hname items env)
|
||||
(and hname (not shadowed) (method-head? hname))
|
||||
(analyze-host-call ctx hname items env)
|
||||
;; (Class. args*) — trailing-dot constructor sugar.
|
||||
(and hname (not shadowed) (ctor-head? hname))
|
||||
(analyze-ctor ctx (subs hname 0 (dec (count hname))) (rest items) env)
|
||||
;; (new Class args*) — explicit constructor.
|
||||
(and (= hname "new") (not shadowed) (>= (count items) 2)
|
||||
(form-sym? (nth items 1)))
|
||||
(analyze-ctor ctx (form-sym-name (nth items 1)) (drop 2 items) env)
|
||||
(and hname (not shadowed) (form-special? hname))
|
||||
(uncompilable (str "special form " hname))
|
||||
(and (form-sym? head) (not shadowed) (form-macro? ctx head))
|
||||
|
|
|
|||
|
|
@ -27,6 +27,18 @@
|
|||
;; Janet) — the back end emits a host-appropriate reference.
|
||||
(defn host-ref [name] {:op :host :name name})
|
||||
|
||||
;; A qualified static reference to a host class member, `Class/member` (e.g.
|
||||
;; Math/sqrt, Long/MAX_VALUE, System/getenv). A leaf node carrying the class and
|
||||
;; member names. The Janet back end punts it (the interpreter resolves the static
|
||||
;; from its class-statics registry); the Chez back end lowers a value ref to
|
||||
;; host-static-ref and a call head to host-static-call (host-static.ss).
|
||||
(defn host-static [class member] {:op :host-static :class class :member member})
|
||||
|
||||
;; A host constructor, `(Class. args*)` / `(new Class args*)`. Carries the class
|
||||
;; name and the analyzed argument nodes. Janet punts (interpreter runs the
|
||||
;; constructor); Chez lowers to host-new (host-static.ss class-ctor registry).
|
||||
(defn host-new [class args] {:op :host-new :class class :args args})
|
||||
|
||||
(defn if-node [test then else] {:op :if :test test :then then :else else})
|
||||
|
||||
(defn do-node [statements ret] {:op :do :statements statements :ret ret})
|
||||
|
|
@ -103,6 +115,7 @@
|
|||
(= op :def) (assoc node :init (f (get node :init)))
|
||||
(= op :host-call) (assoc node :target (f (get node :target))
|
||||
:args (mapv f (get node :args)))
|
||||
(= op :host-new) (assoc node :args (mapv f (get node :args)))
|
||||
;; :catch-body / :finally are optional; recurse them only when PRESENT.
|
||||
;; Assoc'ing them nil-when-absent would turn the node into a phm (jolt's
|
||||
;; nil-valued-key representation) and force backend densification — so we
|
||||
|
|
@ -112,5 +125,5 @@
|
|||
n (if (get node :catch-body) (assoc n :catch-body (f (get node :catch-body))) n)
|
||||
n (if (get node :finally) (assoc n :finally (f (get node :finally))) n)]
|
||||
n)
|
||||
;; :const :local :var :host :the-var :rt :quote — no child nodes
|
||||
;; :const :local :var :host :host-static :the-var :rt :quote — no child nodes
|
||||
:else node)))
|
||||
|
|
|
|||
|
|
@ -781,6 +781,13 @@
|
|||
# punt to the interpreter, exactly as the analyzer used to before producing
|
||||
# a :host-call node (the Chez back end lowers it instead).
|
||||
:host-call (error "jolt/uncompilable: host method call")
|
||||
# host class statics (Class/member) and constructors ((Class. ...)/(new
|
||||
# Class ...)): the back end doesn't model class interop — punt to the
|
||||
# interpreter (its class-statics / class-ctors registries), exactly as the
|
||||
# analyzer used to before producing these nodes. The Chez back end lowers
|
||||
# them to a runtime static/ctor dispatch (jolt-avt6).
|
||||
:host-static (error "jolt/uncompilable: host static ref")
|
||||
:host-new (error "jolt/uncompilable: host constructor")
|
||||
# regex literal: the back end doesn't compile patterns — punt to the
|
||||
# interpreter (the seed compiles #"…" to a Janet PEG). Chez emits jolt-regex.
|
||||
:regex (error "jolt/uncompilable: regex literal")
|
||||
|
|
|
|||
91
test/chez/_javastatic.janet
Normal file
91
test/chez/_javastatic.janet
Normal file
|
|
@ -0,0 +1,91 @@
|
|||
# jolt-avt6 — host class statics + constructors on Chez. The analyzer lowers
|
||||
# Class/member to :host-static and (Class. ...) to :host-new; the Chez emit lowers
|
||||
# them to host-static-ref/host-static-call/host-new (host-static.ss registry).
|
||||
# Expectations are the build/jolt (seed) oracle, captured per case.
|
||||
#
|
||||
# janet test/chez/_javastatic.janet
|
||||
(def jolt-bin (or (os/getenv "JOLT_BIN") "bin/jolt-chez"))
|
||||
|
||||
# [label expr] — expected is whatever build/jolt prints (captured at runtime).
|
||||
(def exprs
|
||||
["(Math/sqrt 16)"
|
||||
"(Math/abs -3)"
|
||||
"(Math/max 2 7)"
|
||||
"(pos? Long/MAX_VALUE)"
|
||||
"(String/valueOf 42)"
|
||||
"(String/valueOf \"hi\")"
|
||||
"(String/valueOf :k)"
|
||||
"(String/valueOf nil)"
|
||||
"(Long/parseLong \"42\")"
|
||||
"(Long/valueOf \"42\")"
|
||||
"(Integer/parseInt \"ff\" 16)"
|
||||
"(.byteValue (Integer/valueOf \"ff\" 16))"
|
||||
"(Boolean/parseBoolean \"true\")"
|
||||
"(Boolean/parseBoolean \"yes\")"
|
||||
"(Character/isUpperCase \\A)"
|
||||
"(Character/isLowerCase \\a)"
|
||||
"(Character/isUpperCase \\a)"
|
||||
"(Thread/interrupted)"
|
||||
"(System/getProperty \"os.name\")"
|
||||
"(string? (get (System/getenv) \"HOME\"))"
|
||||
"(string? (System/getenv \"HOME\"))"
|
||||
"(fn? System/exit)"
|
||||
"(string? (get (System/getProperties) \"os.name\"))"
|
||||
"(pos? (count (seq (System/getenv))))"
|
||||
"(let [es (map (fn [[k v]] [k v]) (System/getenv))] (and (pos? (count es)) (every? vector? es)))"
|
||||
# constructors + their methods
|
||||
"(.toString (StringBuilder. \"x\"))"
|
||||
"(.toString (-> (StringBuilder.) (.append \"a\") (.append \\b) (.append 1)))"
|
||||
"(.toString (.append (StringBuilder. 16) \"x\"))"
|
||||
"(let [sb (StringBuilder.)] (.append sb \"abcd\") (.setLength sb 2) (.toString sb))"
|
||||
"(let [w (StringWriter.)] (.write w \"a\") (.append w \\b) (.toString w))"
|
||||
"(let [r (StringReader. \"ab\")] [(.read r) (.read r) (.read r)])"
|
||||
"(let [r (StringReader. \"ab\")] (.mark r 1) [(.read r) (do (.reset r) (.read r))])"
|
||||
"(let [r (java.io.PushbackReader. (java.io.StringReader. \"ab\"))] [(.read r) (.read r)])"
|
||||
"(let [r (PushbackReader. (StringReader. \"ab\")) a (.read r)] (.unread r a) [a (.read r) (.read r)])"
|
||||
"(let [r (PushbackReader. (StringReader. \"a\"))] (.unread r \\x) [(.read r) (.read r)])"
|
||||
"(BigInteger. \"123\")"
|
||||
"(let [m (HashMap. {:a 1 :b 2})] (.get m :b))"
|
||||
"(let [m (HashMap. {})] (.put m :x 1) (.put m :y 2) (.size m))"
|
||||
"(let [t (StringTokenizer. \"a=1&b=2\" \"&\")] [(.nextToken t) (.nextToken t)])"
|
||||
"(.toString (StringBuilder. \"x\"))"
|
||||
# ring-codec surface
|
||||
"(URLEncoder/encode \"a b=c\")"
|
||||
"(URLDecoder/decode (URLEncoder/encode \"x &=%?\"))"
|
||||
"(String. (.encode (Base64/getEncoder) (.getBytes \"hello\")))"
|
||||
"(String. (.decode (Base64/getDecoder) (String. (.encode (Base64/getEncoder) (.getBytes \"hello\")))))"
|
||||
"(Integer/parseInt \"ff\" 16)"
|
||||
# Pattern statics
|
||||
"(regex? (Pattern/compile \"a.c\"))"
|
||||
"(.split (Pattern/compile \",\") \"a,b,c\")"
|
||||
"(do (require '[clojure.string :as s]) (s/replace \"a1b2\" (Pattern/compile \"[0-9]\") \"\"))"
|
||||
"(boolean (re-find (Pattern/compile \"^x\" Pattern/MULTILINE) \"y\\nx\"))"
|
||||
"(boolean (re-find (re-pattern (Pattern/quote \"a.c\")) \"za.cy\"))"
|
||||
"(boolean (re-find (re-pattern (Pattern/quote \"a.c\")) \"zabcy\"))"])
|
||||
|
||||
(defn run-capture [bin expr]
|
||||
(def proc (os/spawn [bin "-e" expr] :p {:out :pipe :err :pipe}))
|
||||
(def out (ev/read (proc :out) 0x100000))
|
||||
(def err (ev/read (proc :err) 0x100000))
|
||||
(def code (os/proc-wait proc))
|
||||
(def lines (filter (fn [l] (not (empty? l)))
|
||||
(string/split "\n" (string/trim (if out (string out) "")))))
|
||||
[code (if (empty? lines) "" (last lines)) (string/trim (if err (string err) ""))])
|
||||
|
||||
(var pass 0)
|
||||
(def fails @[])
|
||||
(each expr exprs
|
||||
(def [ocode oracle _] (run-capture "build/jolt" expr))
|
||||
(def [code got err] (run-capture jolt-bin expr))
|
||||
(cond
|
||||
(not= ocode 0) (array/push fails [expr (string "ORACLE FAILED exit " ocode)])
|
||||
(not= code 0) (array/push fails [expr (string "exit " code "; err: " err)])
|
||||
(= got oracle) (++ pass)
|
||||
(array/push fails [expr (string "want `" oracle "`, got `" got "`")])))
|
||||
|
||||
(printf "\n_javastatic parity [%s]: %d/%d passed" jolt-bin pass (length exprs))
|
||||
(when (> (length fails) 0)
|
||||
(printf "%d FAIL(s):" (length fails))
|
||||
(each [e m] fails (printf " FAIL %s\n %s" e m)))
|
||||
(flush)
|
||||
(os/exit (if (empty? fails) 0 1))
|
||||
|
|
@ -300,14 +300,17 @@
|
|||
(string "chez=" out " janet=" want " | " err))))
|
||||
|
||||
# 3l) host interop method calls (inc 3h). (.method target arg*) analyzes to a
|
||||
# :host-call IR node and lowers to a jolt-host-call dispatch. The Janet back end
|
||||
# PUNTS these (no interop model -> interpreter); the Chez RT shims the methods
|
||||
# jolt-core's io tier uses: .write -> display to a port, .isDirectory ->
|
||||
# file-directory?, .listFiles -> directory-list. Interop has no portable oracle
|
||||
# (the Janet host models it differently), so these are emit-shape checks plus one
|
||||
# deterministic runtime probe (the root "/" is always a directory).
|
||||
# :host-call IR node and lowers to a dispatch. The Janet back end PUNTS these
|
||||
# (no interop model -> interpreter); the Chez RT shims the File methods
|
||||
# jolt-core's io tier uses via jolt-host-call (.isDirectory -> file-directory?,
|
||||
# .listFiles -> directory-list). All OTHER methods (.write/.append/.read/... on
|
||||
# a StringWriter/StringReader/record) route through record-method-dispatch
|
||||
# (jolt-avt6 removed .write from the jolt-host-call fast-path so a StringWriter
|
||||
# jhost handles it). Interop has no portable oracle (the Janet host models it
|
||||
# differently), so these are emit-shape checks plus one deterministic runtime
|
||||
# probe (the root "/" is always a directory).
|
||||
(each [label src needle]
|
||||
[["emit .write -> jolt-host-call" "(fn [w x] (.write w x))" "jolt-host-call"]
|
||||
[["emit .write -> record-method-dispatch" "(fn [w x] (.write w x))" "record-method-dispatch"]
|
||||
["emit .write keeps method name" "(fn [w x] (.write w x))" "\"write\""]
|
||||
["emit .isDirectory -> jolt-host-call" "(fn [f] (.isDirectory f))" "isDirectory"]
|
||||
["emit .listFiles -> jolt-host-call" "(fn [f] (.listFiles f))" "listFiles"]]
|
||||
|
|
@ -318,6 +321,21 @@
|
|||
(ok "runtime .isDirectory \"/\" = true" (and (= code 0) (= out "true"))
|
||||
(string "chez=" out " | " err)))
|
||||
|
||||
# 3l') host class statics + constructors (jolt-avt6). Class/member lowers to a
|
||||
# :host-static node (host-static-ref in value position, host-static-call as a
|
||||
# call head); (Class. ...) / (new Class ...) lower to :host-new. The Janet back
|
||||
# end punts all three; the Chez RT resolves them from the class-statics /
|
||||
# class-ctors / jhost-method registries (host/chez/host-static.ss). Emit-shape
|
||||
# checks; the registry behaviour is covered by test/chez/_javastatic.janet.
|
||||
(each [label src needle]
|
||||
[["emit Class/field -> host-static-ref" "(fn [] Long/MAX_VALUE)" "(host-static-ref \"Long\" \"MAX_VALUE\")"]
|
||||
["emit Class/method call -> host-static-call" "(fn [] (System/getenv))" "(host-static-call \"System\" \"getenv\")"]
|
||||
["emit static call passes args" "(fn [x] (Long/parseLong x))" "(host-static-call \"Long\" \"parseLong\""]
|
||||
["emit (Class.) -> host-new" "(fn [] (StringBuilder.))" "(host-new \"StringBuilder\")"]
|
||||
["emit (new Class ...) -> host-new" "(fn [s] (new java.io.StringReader s))" "(host-new \"java.io.StringReader\""]]
|
||||
(let [scm (protect (emit/emit (backend/analyze-form ctx (in (r/parse-next src) 0))))]
|
||||
(ok label (and (scm 0) (string/find needle (scm 1))) (string/format "%p" scm))))
|
||||
|
||||
# 3m) regex (jolt-i0s3): the #"…" literal lowers to a jolt-regex value over the
|
||||
# vendored irregex; re-pattern/re-matches/re-find/re-seq/regex? are def-var!'d
|
||||
# into clojure.core (not subset native-ops — irregex's Unicode/property
|
||||
|
|
|
|||
|
|
@ -45,9 +45,10 @@
|
|||
{"class name evaluates to canonical string" true
|
||||
"dispatch-only class name" true
|
||||
"inside class" true
|
||||
"values evaluate in source order" true
|
||||
"keys evaluate before their values, pairwise" true
|
||||
"source order with a nil value (phm form)" true
|
||||
# (the collection-literal eval-order entries here — "values evaluate in source
|
||||
# order" / "keys evaluate before their values" / "source order with a nil value"
|
||||
# — were REMOVED in jolt-avt6: emit now evaluates vector/set/map literal
|
||||
# elements left-to-right via emit-ordered, so they pass.)
|
||||
"close on throw" true
|
||||
# *ns* now a namespace value (jolt-yxqm): str/ns-name of *ns* + the var str
|
||||
# case ("ns-name of *ns*" / "str of *ns*" / "*ns* user" / "str of a var") pass.
|
||||
|
|
@ -69,19 +70,21 @@
|
|||
"defmethod overrides a record, top level" true
|
||||
"defmethod fires nested in a map" true
|
||||
"defmethod fires through prn" true
|
||||
# Same print-method gap, newly REACHABLE in jolt-avt6: StringWriter now
|
||||
# constructs, so (defmethod print-method :number ...) + (print-method 42 w)
|
||||
# runs — but print-method's multimethod override on a builtin isn't consulted,
|
||||
# so the StringWriter holds "42" not "#42#". (The :default print-method path —
|
||||
# "StringWriter accumulates" / "direct call uses :default" — does pass now.)
|
||||
"direct builtin override" true
|
||||
# var def-time metadata (^:private / ^Type tag / docstring) is now captured on
|
||||
# the Chez var-cell (jolt-zikh), so those three cases pass.
|
||||
"methods table inspectable" true
|
||||
# jolt-nfca made (require ...) a runtime no-op (the driver pre-evals requires
|
||||
# for aliases), and the clojure.string prelude tier now loads — which makes
|
||||
# these previously-CRASHING cases emit + run, surfacing pre-existing gaps:
|
||||
# - the read-line trio reads two lines into a [(read-line) (read-line)] vector;
|
||||
# the emitted Scheme evaluates the two elements in non-source order (the same
|
||||
# eval-order gap already allowlisted above as "values evaluate in source
|
||||
# order"), so the lines come back swapped. Reachable now that with-in-str runs.
|
||||
"read-line sequential" true
|
||||
"read-line after last" true
|
||||
"empty line" true
|
||||
# - the read-line trio ([(read-line) (read-line)]) now PASSES: jolt-avt6's
|
||||
# emit-ordered evaluates the two vector elements left-to-right, so the lines
|
||||
# no longer come back swapped (the entries were removed here).
|
||||
# - (instance? clojure.lang.Atom (atom 0)): the fully-qualified host class name
|
||||
# clojure.lang.Atom isn't mapped to the atom predicate on Chez (host-class
|
||||
# interop, jolt-mn9o/avt6). Reachable now that the leading require is a no-op.
|
||||
|
|
@ -220,8 +223,18 @@
|
|||
# join/split/replace/replace-all/reverse-b) def-var!'d on the RT; regex split
|
||||
# keeps interior empties + honors limit, regex replace does $N + fn replacement;
|
||||
# require/use are runtime no-ops) 2078.
|
||||
# jolt-avt6 (host class statics + constructors — the analyzer lowers Class/member
|
||||
# to :host-static and (Class. ...)/(new Class ...) to :host-new; the Chez RT
|
||||
# resolves them from class-statics/class-ctors/jhost-method registries
|
||||
# (host-static.ss): Math/System/Long/Integer/Boolean/Character/String/Thread/Class
|
||||
# statics, Pattern compile/quote/MULTILINE, URLEncoder/Decoder, Base64, the Number
|
||||
# method surface (byteValue/intValue/...), and the StringBuilder/StringWriter/
|
||||
# StringReader/PushbackReader/HashMap/StringTokenizer/BigInteger/String/MapEntry/
|
||||
# exception constructors. Also emit now evaluates collection-literal elements
|
||||
# left-to-right (emit-ordered), which un-allowlisted the 6 eval-order cases.
|
||||
# java.time formatting / edn-read-over-readers / slurp-over-readers deferred) 2134.
|
||||
# Strided runs scale down.
|
||||
(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_PRELUDE_FLOOR") "2078")))
|
||||
(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_PRELUDE_FLOOR") "2134")))
|
||||
(def floor (if (os/getenv "JOLT_CORPUS_LIMIT") 0 base-floor))
|
||||
(when (or (> (length diverged) 0) (< pass floor))
|
||||
(printf "REGRESSION: pass %d < floor %d or %d new divergence(s)" pass floor (length diverged)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue