Make clojure.spec.alpha load and run

Four general gaps, shaken out by loading clojure.spec.alpha:

- Special forms were shadowable by a same-named macro. analyze-list
  macroexpanded before checking special forms, so a ns that redefs def/and/or
  (spec excludes them via :refer-clojure :exclude) made a bare def resolve to
  the macro instead of the special form, breaking every defn after. Now a head
  in the special-form set is never macroexpanded, matching the reference
  macroexpand1 isSpecial check.

- reify dropped all but the last arity of a multi-arity protocol method (spec
  reifies (specize* [s]) and (specize* [s _])). The macro keyed methods by name
  and overwrote; now it groups arities into one multi-arity fn.

- reify instances did not implement IObj: with-meta threw and (instance?
  clojure.lang.IObj r) was false. Every Clojure reify carries metadata. with-meta
  now copies the reify to a fresh identity (shared method table) and keys its
  meta; instance? IObj/IMeta is true for any reify. This was the registry bug —
  spec's with-name returned nil for specs, so get-spec missed.

- (set! (. Class field) val) was rejected. spec toggles
  clojure.lang.RT/checkSpecAsserts this way; the analyzer now lowers it to a
  jolt.host/set-static-field! call over a mutable-statics table, and a plain
  Class/field read consults that table.

Also: .name/.getName on a Namespace and .ns/.sym on a Var (spec's ns-qualify /
->sym). analyzer + reify are seed sources (re-minted). spec.alpha now does
valid?/conform/cat/keys/explain-str/check-asserts. tick.alpha.interval-test still
needs time-literals data readers (separate).
This commit is contained in:
Yogthos 2026-06-24 19:46:22 -04:00
parent f417516148
commit 7a343351d6
11 changed files with 598 additions and 532 deletions

View file

@ -595,7 +595,7 @@
;; values that carry metadata (mirrors jolt-with-meta's set in natives-meta.ss).
(define (hsc-imeta? x)
(or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x)
(jolt-lazyseq? x) (jrec? x) (procedure? x) (symbol-t? x)))
(jolt-lazyseq? x) (jrec? x) (jreify? x) (procedure? x) (symbol-t? x)))
(register-instance-check-arm!
(lambda (type-sym val)
(let ((iface (hsc-last-segment (symbol-t-name type-sym))))

View file

@ -90,13 +90,35 @@
((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 ((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)))))
(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))

View file

@ -22,7 +22,7 @@
(jolt-assoc (if user user (jolt-hash-map))
jolt-kw-var-ns (var-cell-ns x)
jolt-kw-var-name (var-cell-name x))))
((or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jolt-lazyseq? x) (jrec? x) (procedure? x))
((or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jolt-lazyseq? x) (jrec? x) (jreify? x) (procedure? x))
(hashtable-ref meta-table x jolt-nil))
(else jolt-nil)))
@ -34,6 +34,10 @@
((pmap? x) (make-pmap (pmap-root x) (pmap-cnt x)))
((pset? x) (make-pset (pset-m x)))
((jrec? x) (make-jrec (jrec-tag x) (jrec-pairs x)))
;; a reify shares its (read-only) method table + protos but gets a fresh
;; identity, so attaching meta leaves the original's meta untouched. Every
;; Clojure reify implements IObj.
((jreify? x) (make-jreify (jreify-methods x) (jreify-protos x)))
;; () is a shared singleton — a fresh instance keeps meta off every other ().
((empty-list-t? x) (fresh-empty-list))
(else x))) ; cseq / procedure
@ -41,7 +45,7 @@
(define (jolt-with-meta x m)
(cond
((symbol-t? x) (make-symbol-t (symbol-t-ns x) (symbol-t-name x) m))
((or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jolt-lazyseq? x) (jrec? x) (procedure? x))
((or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jolt-lazyseq? x) (jrec? x) (jreify? x) (procedure? x))
(let ((c (meta-copy x)))
(if (jolt-nil? m) (hashtable-delete! meta-table c) (hashtable-set! meta-table c m))
c))

View file

@ -68,7 +68,9 @@
(and (> (string-length tag) (string-length tname))
(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)))
;; every Clojure reify implements IObj/IMeta (carries metadata).
(or (member short '("IObj" "IMeta"))
(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)))))

View file

@ -359,6 +359,23 @@
(symbol-t-name obj)))
((string=? method-name "equals") (and (pair? rest) (jolt=2 obj (car rest))))
(else (error #f (string-append "No method " method-name " on Symbol")))))
;; clojure.lang.Namespace: name/getName yield the ns name as a Symbol (JVM:
;; Namespace.name is a Symbol). clojure.spec.alpha reads (.name *ns*).
((jns? obj)
(cond ((or (string=? method-name "name") (string=? method-name "getName"))
(jolt-symbol #f (jns-name obj)))
((string=? method-name "toString") (jns-name obj))
(else (error #f (string-append "No method " method-name " on Namespace")))))
;; clojure.lang.Var: ns -> its Namespace, sym -> the simple-name Symbol.
;; clojure.spec.alpha's ->sym reads (.name (.ns v)) and (.sym v).
((var-cell? obj)
(cond ((string=? method-name "ns") (intern-ns! (var-cell-ns obj)))
((or (string=? method-name "sym") (string=? method-name "name"))
(jolt-symbol #f (var-cell-name obj)))
((string=? method-name "getName")
(jolt-symbol (var-cell-ns obj) (var-cell-name obj)))
((string=? method-name "toString") (string-append "#'" (var-cell-ns obj) "/" (var-cell-name obj)))
(else (error #f (string-append "No method " method-name " on Var")))))
;; java.lang.Throwable interop over a Chez condition. A jolt host error
;; (`error`/`assertion-violationf`) raises a Chez condition; Clojure code
;; that catches it as a Throwable reads (.getMessage e) / (.toString e).

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long