Chez Phase 2 (inc I+J): first-class vars + scalar natives

inc I (jolt-n7rz) — vars as first-class objects. (var x)/#'x lowered a
:the-var IR op the Chez emitter didn't handle (57 emit-fails, the biggest
bucket); emit it to the rt.ss var-cell and shim the static var ops in
vars.ss: var?/var-get/deref/var-as-IFn/var =/pr-str (#'ns/name) + a native
bound? (the overlay reads (get v :root), nil on a var-cell record). def now
RETURNS the var (#'ns/name) like Clojure — def-var!/declare-var! yield the
cell, not the value — so (var? (def x 1)) is true and pr-str-of-var/defn
pass (un-allowlisted). Dynamic binding (binding/with-bindings*/var-set/
thread-bound?) stays a follow-up; those crash on nil host prims (safe).
Var def-time metadata (^:private/^Type/doc) isn't captured yet — allowlisted.

inc J (jolt-snry) — scalar natives. natives-misc.ss: a juuid record
(random-uuid v4 / parse-uuid / uuid? / #uuid pr-str / str), a %-format
engine (%d/%s/%.Nf/%x/%c/%%; printf rides on it), a jtagged record
(tagged-literal + :tag/:form + #tag pr-str), bigint/biginteger as
near-identity over the all-flonum model. Overlay names (uuid?/random-uuid/
parse-uuid/tagged-literal?) re-asserted in post-prelude.ss.

Prelude parity 1898 -> 1951, 0 new divergences. Floor raised to 1951.
This commit is contained in:
Yogthos 2026-06-18 15:44:10 -04:00
parent 6581df2d17
commit eb26ad0401
6 changed files with 249 additions and 10 deletions

View file

@ -429,6 +429,9 @@
(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))
# (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)) ")")
:if (let [test (get node :test)
t (if (returns-scheme-bool? test) (emit test)
(string "(jolt-truthy? " (emit test) ")"))]

144
host/chez/natives-misc.ss Normal file
View file

@ -0,0 +1,144 @@
;; misc scalar natives (jolt-cf1q.3) — UUID, format/printf, tagged-literal,
;; bigint. Seed natives that were jolt-nil on the prelude.
;;
;; Loaded after the printers (pr-str of a uuid is #uuid "…") and converters
;; (jolt-str-render-one for %s / str of a uuid).
;; --- UUID --------------------------------------------------------------------
;; A uuid is a record wrapping its canonical 36-char lowercase string. str -> the
;; bare string; pr-str -> #uuid "…"; not map?/coll?.
(define-record-type juuid (fields s) (nongenerative chez-juuid-v1))
(define (jolt-uuid-pred? x) (juuid? x))
(define hexd "0123456789abcdef")
(define (rand-hex) (string-ref hexd (random 16)))
;; v4: 8-4-4-4-12, version nibble (index 14) = 4, variant nibble (index 19) in 8-b.
(define (random-uuid-str)
(let ((cs (make-string 36)))
(let loop ((i 0))
(if (fx=? i 36) cs
(begin
(string-set! cs i
(cond ((or (fx=? i 8) (fx=? i 13) (fx=? i 18) (fx=? i 23)) #\-)
((fx=? i 14) #\4)
((fx=? i 19) (string-ref "89ab" (random 4)))
(else (rand-hex))))
(loop (fx+ i 1)))))))
(define (jolt-random-uuid) (make-juuid (random-uuid-str)))
;; parse-uuid: validate the canonical shape (8-4-4-4-12 hex), lowercase, -> uuid;
;; nil if the string doesn't conform (Clojure parse-uuid), error on a non-string.
(define (hex-char? c) (or (and (char>=? c #\0) (char<=? c #\9))
(and (char>=? c #\a) (char<=? c #\f))
(and (char>=? c #\A) (char<=? c #\F))))
(define (uuid-shape? s)
(and (string? s) (fx=? (string-length s) 36)
(let loop ((i 0))
(if (fx=? i 36) #t
(let ((c (string-ref s i)))
(cond ((or (fx=? i 8) (fx=? i 13) (fx=? i 18) (fx=? i 23)) (and (char=? c #\-) (loop (fx+ i 1))))
((hex-char? c) (loop (fx+ i 1)))
(else #f)))))))
(define (jolt-parse-uuid s)
(cond ((not (string? s)) (error #f "parse-uuid: not a string" s))
((uuid-shape? s) (make-juuid (string-downcase s)))
(else jolt-nil)))
;; uuid? / random-uuid / parse-uuid are OVERLAY fns (they read :jolt/type), so
;; the prelude would clobber a def-var! here — they're asserted in post-prelude.ss.
;; str of a uuid -> the bare 36-char string; pr-str -> #uuid "…".
(define %m-str-render-one jolt-str-render-one)
(set! jolt-str-render-one (lambda (x) (if (juuid? x) (juuid-s x) (%m-str-render-one x))))
(define (juuid-pr u) (string-append "#uuid \"" (juuid-s u) "\""))
(define %m-pr-str jolt-pr-str)
(set! jolt-pr-str (lambda (x) (if (juuid? x) (juuid-pr x) (%m-pr-str x))))
(define %m-pr-readable jolt-pr-readable)
(set! jolt-pr-readable (lambda (x) (if (juuid? x) (juuid-pr x) (%m-pr-readable x))))
;; two uuids are = iff same string.
(define %m-=2 jolt=2)
(set! jolt=2 (lambda (a b)
(cond ((juuid? a) (and (juuid? b) (string=? (juuid-s a) (juuid-s b))))
((juuid? b) #f)
(else (%m-=2 a b)))))
;; --- bigint / biginteger -----------------------------------------------------
;; jolt models every number as a double; an integer-valued double prints without
;; a ".0" (jolt-num->string), so bigint is just the number for the corpus range.
;; (Arbitrary-precision beyond 2^53 is a separate concern.)
(define (jolt-bigint x) x)
(def-var! "clojure.core" "bigint" jolt-bigint)
(def-var! "clojure.core" "biginteger" jolt-bigint)
;; --- tagged-literal ----------------------------------------------------------
;; (tagged-literal tag form): a tagged value with :tag / :form. tagged-literal? is
;; overlay (reads :jolt/type) so it's overridden in post-prelude.ss.
(define-record-type jtagged (fields tag form) (nongenerative chez-jtagged-v1))
(define (jolt-tagged-literal tag form) (make-jtagged tag form))
(define (jolt-tagged-literal-pred? x) (jtagged? x))
(define kw-tl-tag (keyword #f "tag"))
(define kw-tl-form (keyword #f "form"))
(define %m-get jolt-get)
(set! jolt-get (case-lambda
((coll k) (if (jtagged? coll) (jolt-get coll k jolt-nil) (%m-get coll k)))
((coll k d) (if (jtagged? coll)
(cond ((jolt=2 k kw-tl-tag) (jtagged-tag coll))
((jolt=2 k kw-tl-form) (jtagged-form coll))
(else d))
(%m-get coll k d)))))
(define (jtagged-pr t) (string-append "#" (jolt-pr-str (jtagged-tag t)) " " (jolt-pr-readable (jtagged-form t))))
(define %m2-pr-str jolt-pr-str)
(set! jolt-pr-str (lambda (x) (if (jtagged? x) (jtagged-pr x) (%m2-pr-str x))))
(define %m2-pr-readable jolt-pr-readable)
(set! jolt-pr-readable (lambda (x) (if (jtagged? x) (jtagged-pr x) (%m2-pr-readable x))))
(def-var! "clojure.core" "tagged-literal" jolt-tagged-literal)
;; tagged-literal? is OVERLAY (reads :jolt/type) — asserted in post-prelude.ss.
;; --- format / printf ---------------------------------------------------------
;; A small %-format engine over the all-flonum number model: %d (integer), %s
;; (str), %f / %.Nf (fixed-point), %x/%X (hex int), %o (octal), %c (char int),
;; %b (boolean), %% (literal). Enough for the corpus; not the full Java spec.
(define (->long x) (exact (truncate x)))
(define (pad-left s n c) (if (fx>=? (string-length s) n) s (string-append (make-string (fx- n (string-length s)) c) s)))
(define (fmt-float x prec)
(let* ((neg (< x 0)) (ax (abs x))
(scale (expt 10 prec))
(scaled (round (* (inexact ax) scale)))
(i (exact (truncate (/ scaled scale))))
(frac (exact (truncate (- scaled (* i scale))))))
(string-append (if neg "-" "")
(number->string i)
(if (fx>? prec 0) (string-append "." (pad-left (number->string frac) prec #\0)) ""))))
(define (jolt-format fmt . args)
(let ((out (open-output-string)))
(let loop ((i 0) (as args))
(if (fx>=? i (string-length fmt))
(get-output-string out)
(let ((c (string-ref fmt i)))
(if (char=? c #\%)
;; parse a directive: %[.prec]conv
(let scan ((j (fx+ i 1)) (prec #f) (seen-dot #f))
(let ((d (string-ref fmt j)))
(cond
((char=? d #\%) (write-char #\% out) (loop (fx+ j 1) as))
((char=? d #\.) (scan (fx+ j 1) 0 #t))
((and (char>=? d #\0) (char<=? d #\9))
(scan (fx+ j 1) (fx+ (fx* (or prec 0) 10) (fx- (char->integer d) 48)) seen-dot))
(else
(let ((a (if (null? as) jolt-nil (car as)))
(rest (if (null? as) '() (cdr as))))
(display
(case d
((#\d) (number->string (->long a)))
((#\s) (jolt-str-render-one a))
((#\f) (fmt-float a (or prec 6)))
((#\x) (number->string (->long a) 16))
((#\X) (string-upcase (number->string (->long a) 16)))
((#\o) (number->string (->long a) 8))
((#\b) (if (jolt-truthy? a) "true" "false"))
((#\c) (string (integer->char (->long a))))
(else (string #\% d)))
out)
(loop (fx+ j 1) rest))))))
(begin (write-char c out) (loop (fx+ i 1) as))))))))
(def-var! "clojure.core" "format" jolt-format)

View file

@ -19,3 +19,12 @@
(def-var! "clojure.core" "vreset!" jolt-vreset!)
(def-var! "clojure.core" "vswap!" jolt-vswap!)
(def-var! "clojure.core" "volatile?" jolt-volatile-pred?)
;; bound?: the overlay reads (get v :root) — nil on a Chez var-cell record, so it
;; would wrongly report every var unbound. Native version (defined in vars.ss).
(def-var! "clojure.core" "bound?" jolt-bound?)
;; uuid?/random-uuid/parse-uuid/tagged-literal? are overlay (read :jolt/type or
;; build tagged tables) — re-assert the native versions (defined in natives-misc.ss).
(def-var! "clojure.core" "uuid?" jolt-uuid-pred?)
(def-var! "clojure.core" "random-uuid" jolt-random-uuid)
(def-var! "clojure.core" "parse-uuid" jolt-parse-uuid)
(def-var! "clojure.core" "tagged-literal?" jolt-tagged-literal-pred?)

View file

@ -70,14 +70,20 @@
(hashtable-set! var-table k c)
c))))
(define (var-deref ns name) (var-cell-root (jolt-var ns name)))
(define (def-var! ns name v) (var-cell-root-set! (jolt-var ns name) v) v)
;; def-var! / declare-var! return the VAR CELL, not the value — Clojure's `def`
;; evaluates to #'ns/name (a first-class var), so (var? (def x 1)) is true and
;; (pr-str (def x 1)) is "#'ns/x". The prelude's def-var! forms discard the
;; return, so this is transparent there.
(define (def-var! ns name v) (let ((c (jolt-var ns name))) (var-cell-root-set! c v) c))
;; declare / (def name) with no init: reserve the cell ONLY if absent. An
;; existing root is left intact — Clojure's (def x) with no init does not clobber
;; a prior binding (do (def x 7) (def x) x) => 7.
;; a prior binding (do (def x 7) (def x) x) => 7. Returns the cell either way.
(define (declare-var! ns name)
(let ((k (string-append ns "/" name)))
(unless (hashtable-ref var-table k #f)
(hashtable-set! var-table k (make-var-cell ns name jolt-unbound)))))
(or (hashtable-ref var-table k #f)
(let ((c (make-var-cell ns name jolt-unbound)))
(hashtable-set! var-table k c)
c))))
;; regex (jolt-i0s3): defines regex-t + the re-* fns (def-var!'d into
;; clojure.core), so it loads after def-var! and before the printer below (which
@ -217,3 +223,14 @@
;; the transduce/sequence entry points over into-xform/reduce-seq. After
;; natives-seq.ss (into-xform), seq.ss (reduce-seq) + atoms.ss (deref).
(load "host/chez/natives-xform.ss")
;; vars as first-class objects (jolt-n7rz, Phase 2): var?/var-get/deref/invoke/=/
;; pr-str over the rt.ss var-cell. After natives-xform.ss (chains deref) + the
;; printers. emit lowers :the-var to (jolt-var ns name).
(load "host/chez/vars.ss")
;; misc scalar natives (jolt-cf1q.3): UUID (random-uuid/parse-uuid/uuid?), format/
;; printf, tagged-literal, bigint. After the printers + converters (str/pr-str of
;; a uuid). Overlay names (uuid?/random-uuid/parse-uuid/tagged-literal?) re-asserted
;; in post-prelude.ss.
(load "host/chez/natives-misc.ss")

57
host/chez/vars.ss Normal file
View file

@ -0,0 +1,57 @@
;; vars as first-class objects (jolt-cf1q.3, jolt-n7rz) — (var x) / #'x.
;;
;; The emitter lowers :the-var to (jolt-var ns name) — the rt.ss var-cell, which
;; is now also a Clojure VAR value. var? / var-get / deref-of-var / var-as-IFn /
;; var equality / pr-str(#'ns/name) operate on it. bound? is overridden natively
;; in post-prelude.ss (the overlay reads (get v :root), nil on a record).
;;
;; Dynamic binding (binding / with-bindings* / var-set / thread-bound? /
;; with-redefs) is a separate follow-up — those crash on nil host primitives,
;; which is safe (a crash stays a crash, not a divergence).
;;
;; Loaded LAST (after natives-xform.ss): chains jolt-deref (atom/volatile arms)
;; and the printers.
(define (jolt-var-pred? x) (var-cell? x))
;; the var's current root; unbound is an error (Clojure throws on an unbound var).
(define (jolt-var-get v)
(if (var-cell? v)
(let ((r (var-cell-root v)))
(if (eq? r jolt-unbound) (error #f "Unbound var" v) r))
(error #f "var-get: not a var" v)))
;; deref of a var -> its root.
(define %v-deref jolt-deref)
(set! jolt-deref (lambda (x) (if (var-cell? x) (jolt-var-get x) (%v-deref x))))
;; a var is an IFn — invoking it invokes its root value ((var f) args -> (f args)).
(define %v-invoke jolt-invoke)
(set! jolt-invoke (lambda (f . args)
(if (var-cell? f) (apply jolt-invoke (var-cell-root f) args) (apply %v-invoke f args))))
;; two var cells are = iff same ns/name (Clojure var identity).
(define %v-=2 jolt=2)
(set! jolt=2 (lambda (a b)
(cond ((var-cell? a) (and (var-cell? b)
(string=? (var-cell-ns a) (var-cell-ns b))
(string=? (var-cell-name a) (var-cell-name b))))
((var-cell? b) #f)
(else (%v-=2 a b)))))
;; pr-str / str of a var -> #'ns/name.
(define (var->str v) (string-append "#'" (var-cell-ns v) "/" (var-cell-name v)))
(define %v-pr-str jolt-pr-str)
(set! jolt-pr-str (lambda (x) (if (var-cell? x) (var->str x) (%v-pr-str x))))
(define %v-pr-readable jolt-pr-readable)
(set! jolt-pr-readable (lambda (x) (if (var-cell? x) (var->str x) (%v-pr-readable x))))
(define %v-str-render-one jolt-str-render-one)
(set! jolt-str-render-one (lambda (x) (if (var-cell? x) (var->str x) (%v-str-render-one x))))
;; bound? — native (the overlay's (get v :root) is nil on a var-cell record).
(define (jolt-var-bound-one? v) (and (var-cell? v) (not (eq? (var-cell-root v) jolt-unbound))))
(define (jolt-bound? . vars) (if (for-all jolt-var-bound-one? vars) #t #f))
(def-var! "clojure.core" "var?" jolt-var-pred?)
(def-var! "clojure.core" "var-get" jolt-var-get)
(def-var! "clojure.core" "deref" jolt-deref)