d38402eb57
algo.monads' writer monad extends a protocol to clojure.lang.IPersistentList,
but jolt's lists only reported ASeq/ISeq in value-host-tags, so writer-m-add
didn't dispatch ("No method writer-m-add"). jolt models every seq as a list (no
distinct LazySeq — (class (map inc xs)) is PersistentList), so a seq now also
reports PersistentList / IPersistentList / IPersistentStack, in value-host-tags
and host-type-set. extend-protocol clojure.lang.IPersistentList then dispatches
on a list.
algo.monads passes its whole suite (11/11) over tools.macro. Listed in docs +
site. Runtime only, no re-mint. make test green (+1 corpus row, 0 new
divergences), shakesmoke byte-identical.
1007 lines
61 KiB
Scheme
1007 lines
61 KiB
Scheme
;; records + protocols — the deftype/defrecord + defprotocol/extend-type
|
|
;; subsystem.
|
|
;;
|
|
;; A record is a `jrec`: a shared per-type descriptor + a flat vector of field
|
|
;; values in declared order, plus an extension map for any non-field keys assoc'd
|
|
;; on (jolt-nil when there are none — the common case). This lays fields out like a
|
|
;; native struct: construction allocates one vector, not a chain of cons cells, and
|
|
;; a field read is an index lookup, not a list scan. It is map?/coll?, equal to
|
|
;; another jrec of the same type with equal fields (never equal to a plain map),
|
|
;; and prints as #ns.Name{...}.
|
|
;; The collection dispatchers (jolt-get/count/keys/vals/seq/assoc/contains?/=/
|
|
;; hash/conj + the printers) are set!-extended with a jrec arm that delegates to
|
|
;; the original — the transients.ss pattern — so all record logic lives here and
|
|
;; the hot collection paths are untouched. (get r :jolt/deftype) returns the tag,
|
|
;; so the overlay record? predicate works unchanged.
|
|
;;
|
|
;; Loaded after collections/seq/values/converters/printing/transients/multimethods
|
|
;; (the dispatchers it wraps + chez-current-ns).
|
|
|
|
;; The per-type descriptor: built once at deftype/defrecord definition and shared
|
|
;; by every instance. Holds the tag, the field keywords in declared order, and an
|
|
;; eq?-keyed keyword->index table (field keys are interned, so identity lookup).
|
|
(define-record-type (jrdesc make-jrdesc-rec jrdesc?)
|
|
(fields tag fkeys index) (nongenerative chez-jrdesc-v1))
|
|
(define (make-jrdesc tag fkey-list)
|
|
(let ((index (make-eq-hashtable)))
|
|
(let loop ((ks fkey-list) (i 0))
|
|
(unless (null? ks) (hashtable-set! index (car ks) i) (loop (cdr ks) (+ i 1))))
|
|
(make-jrdesc-rec tag (list->vector fkey-list) index)))
|
|
;; An instance: the shared descriptor, the field-value vector, and an extension
|
|
;; map (jolt-nil unless non-field keys have been assoc'd on).
|
|
(define-record-type (jrec make-jrec jrec?) (fields desc vals ext) (nongenerative chez-jrec-v2))
|
|
(define (jrec-tag r) (jrdesc-tag (jrec-desc r)))
|
|
|
|
;; defrecord vs deftype: a defrecord IS a map (map?/seq/keys/assoc over its
|
|
;; fields); a bare deftype is an opaque object with only its declared interfaces,
|
|
;; never a map (Clojure semantics). defrecord registers its type tag here; the
|
|
;; default jrec-as-map behaviour (map?/record?/field-seq) is gated on it, while
|
|
;; method dispatch (a deftype implementing ISeq/Counted/…) stays open to any jrec.
|
|
(define chez-record-type-tbl (make-hashtable string-hash string=?))
|
|
(define (jrec-record? x) (and (jrec? x) (hashtable-ref chez-record-type-tbl (jrec-tag x) #f) #t))
|
|
;; every deftype/defrecord tag, and a simple-name -> tag index. An extend-protocol
|
|
;; in a DIFFERENT ns names the type bare (it is :import-ed), so register-method
|
|
;; resolves "Raw" to its real tag "a.util.Raw" here instead of prepending the
|
|
;; calling ns. The local ns is preferred, so a same-named local type still wins.
|
|
(define chez-deftype-tag-set (make-hashtable string-hash string=?))
|
|
(define chez-simple-name-tag (make-hashtable string-hash string=?))
|
|
;; a jrec that is coll? — a record, or a deftype implementing a collection
|
|
;; interface (its seq/count/nth/valAt/cons method is registered). find-method-any-
|
|
;; protocol is defined later; resolved at call time. An opaque deftype is not coll?.
|
|
(define (jrec-collection? x)
|
|
(and (jrec? x)
|
|
(or (jrec-record? x)
|
|
(let ((tag (jrec-tag x)))
|
|
;; coll? is instance? IPersistentCollection — its marker is `cons`
|
|
;; (and ISeq's `first`). ILookup(valAt) / Indexed(nth) / Counted(count)
|
|
;; / Seqable(seq) alone do NOT make a value coll?, matching the JVM
|
|
;; (e.g. core.logic's LVar implements only valAt and is not coll?).
|
|
(or (find-method-any-protocol tag "cons")
|
|
(find-method-any-protocol tag "first"))))
|
|
#t))
|
|
;; a jrec that is map? — a record, or a deftype implementing clojure.lang
|
|
;; .IPersistentMap (clojure.core.cache's caches do). `without` (dissoc) is the
|
|
;; map-distinctive method: vectors/sets implement Associative/ILookup but not it.
|
|
(define (jrec-maplike? x)
|
|
(and (jrec? x)
|
|
(or (jrec-record? x)
|
|
(find-method-any-protocol (jrec-tag x) "without"))
|
|
#t))
|
|
(define jolt-deftype-kw (keyword "jolt" "deftype"))
|
|
;; unique present-vs-absent sentinel for extension-map lookups (so a present nil
|
|
;; in the extension map is distinguished from a genuine miss).
|
|
(define jrec-absent (list 'jrec-absent))
|
|
|
|
;; --- whole-program inference registries -------------------------------------
|
|
;; Populated at definition/load time (deftype/defrecord and defprotocol forms run
|
|
;; before `jolt build` re-emits), read by the inference driver to seed record and
|
|
;; protocol-method types across fn boundaries. A no-op for the runtime itself; the
|
|
;; tables just accumulate. jolt.host/record-shapes and /protocol-methods (host-
|
|
;; contract.ss) materialize them into the shape jolt.passes.types expects.
|
|
|
|
;; ctor-key "ns/->Name" -> (vector field-kw-list field-tag-list type-tag).
|
|
;; field-tag-list parallels the fields: "num", a record simple-name string, or #f.
|
|
(define chez-record-shapes-tbl (make-hashtable string-hash string=?))
|
|
;; method var-key "ns/method" -> (cons proto-name method-name).
|
|
(define chez-protocol-methods-tbl (make-hashtable string-hash string=?))
|
|
;; type-tag "ns.Name" -> #(bool ...) marking which fields are ^double, so the ctor
|
|
;; and set! coerce them to flonums (JVM primitive-field semantics, and what makes
|
|
;; reading the field back as :double sound for fl-ops).
|
|
(define chez-record-dbl-tbl (make-hashtable string-hash string=?))
|
|
(define (chez-double-tag? t) (and (string? t) (string=? t "double")))
|
|
|
|
(define (register-record-shape! ctor-key field-kws field-tags type-tag)
|
|
(hashtable-set! chez-record-shapes-tbl ctor-key
|
|
(vector field-kws field-tags type-tag))
|
|
(hashtable-set! chez-record-dbl-tbl type-tag
|
|
(list->vector (map chez-double-tag? field-tags))))
|
|
|
|
;; simple name of a dotted/slashed string: the segment after the last . or /.
|
|
(define (chez-shape-simple-name s)
|
|
(let loop ((i (- (string-length s) 1)))
|
|
(cond ((< i 0) s)
|
|
((or (char=? (string-ref s i) #\.) (char=? (string-ref s i) #\/))
|
|
(substring s (+ i 1) (string-length s)))
|
|
(else (loop (- i 1))))))
|
|
|
|
;; resolve a field's declared type tag to what jolt.passes.types wants: "num"
|
|
;; passes through; a record name (simple "Vec3" or qualified "ns.Vec3") resolves
|
|
;; to its ctor-key (so the field reads back as that record); anything else -> nil.
|
|
(define (chez-resolve-field-tag tag by-name)
|
|
(cond ((or (not tag) (jolt-nil-t? tag)) jolt-nil)
|
|
((string=? tag "num") "num")
|
|
((string=? tag "double") "double") ; a ^double field reads back as a flonum
|
|
(else (let ((ck (hashtable-ref by-name (chez-shape-simple-name tag) #f)))
|
|
(if ck ck jolt-nil)))))
|
|
|
|
;; materialize chez-record-shapes-tbl into "ns/->Name" -> {:fields :tags :type},
|
|
;; the shape record-type-from-entry consumes.
|
|
(define (chez-record-shapes-map)
|
|
(let ((by-name (make-hashtable string-hash string=?))
|
|
(kw-fields (keyword #f "fields")) (kw-tags (keyword #f "tags")) (kw-type (keyword #f "type"))
|
|
(out (jolt-hash-map)))
|
|
;; index simple record name (from the type tag "ns.Name") -> ctor-key for
|
|
;; nested-field-tag resolution.
|
|
(let-values (((ks vs) (hashtable-entries chez-record-shapes-tbl)))
|
|
(vector-for-each
|
|
(lambda (k v) (hashtable-set! by-name (chez-shape-simple-name (vector-ref v 2)) k)) ks vs)
|
|
(vector-for-each
|
|
(lambda (k v)
|
|
(let* ((fields (vector-ref v 0)) (tags (vector-ref v 1)) (type-tag (vector-ref v 2))
|
|
(rtags (map (lambda (t) (chez-resolve-field-tag t by-name)) tags)))
|
|
(set! out (jolt-assoc out k
|
|
(jolt-hash-map kw-fields (apply jolt-vector fields)
|
|
kw-tags (apply jolt-vector rtags)
|
|
kw-type type-tag)))))
|
|
ks vs))
|
|
out))
|
|
|
|
;; resolve a record TYPE name (a ^Type param hint's tag) to the ctor-key
|
|
;; "ns/->Name" the inference seeds with. Prefer the ctor in `ns` (the compile ns);
|
|
;; else any registered record with that simple name (cross-ns / imported). #f if
|
|
;; the name isn't a record type (so a ^double/^String hint resolves to nil).
|
|
(define (chez-find-ctor-key name ns)
|
|
(let* ((simple (chez-shape-simple-name name))
|
|
(target (string-append "->" simple))
|
|
(preferred (string-append ns "/->" simple)))
|
|
(if (hashtable-ref chez-record-shapes-tbl preferred #f)
|
|
preferred
|
|
(let loop ((ks (vector->list (hashtable-keys chez-record-shapes-tbl))))
|
|
(cond ((null? ks) #f)
|
|
((string=? (chez-shape-simple-name (car ks)) target) (car ks))
|
|
(else (loop (cdr ks))))))))
|
|
|
|
;; materialize chez-protocol-methods-tbl into "ns/method" -> [proto method].
|
|
(define (chez-protocol-methods-map)
|
|
(let ((out (jolt-hash-map)))
|
|
(let-values (((ks vs) (hashtable-entries chez-protocol-methods-tbl)))
|
|
(vector-for-each
|
|
(lambda (k v) (set! out (jolt-assoc out k (jolt-vector (car v) (cdr v)))))
|
|
ks vs))
|
|
out))
|
|
|
|
;; index of a declared field key, or #f (only an interned keyword can be one).
|
|
(define (jrec-field-index r k) (hashtable-ref (jrdesc-index (jrec-desc r)) k #f))
|
|
;; a vector-copy that doesn't depend on the optional rnrs vector-copy being present.
|
|
(define (jrec-vec-copy v)
|
|
(let* ((n (vector-length v)) (out (make-vector n)))
|
|
(let loop ((i 0)) (when (< i n) (vector-set! out i (vector-ref v i)) (loop (+ i 1))))
|
|
out))
|
|
;; extension-map entries as an (k . v) alist in iteration order.
|
|
(define (jrec-ext-pairs ext)
|
|
(let loop ((s (jolt-seq ext)) (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))))))
|
|
|
|
;; lookup with default d: a declared field reads index+vector-ref (a present nil
|
|
;; returns nil), then the extension map, then d.
|
|
(define (jrec-lookup r k d)
|
|
(if (eq? k jolt-deftype-kw)
|
|
(jrec-tag r)
|
|
(let ((i (jrec-field-index r k)))
|
|
(if i (vector-ref (jrec-vals r) i)
|
|
(let ((ext (jrec-ext r)))
|
|
(if (jolt-nil? ext) d
|
|
(let ((v (jolt-get ext k jrec-absent)))
|
|
(if (eq? v jrec-absent) d v))))))))
|
|
(define (jrec-has? r k)
|
|
(and (not (eq? k jolt-deftype-kw))
|
|
(or (and (jrec-field-index r k) #t)
|
|
(let ((ext (jrec-ext r)))
|
|
(and (not (jolt-nil? ext))
|
|
(not (eq? jrec-absent (jolt-get ext k jrec-absent))))))))
|
|
;; The get path: like jrec-lookup, but a deftype's ILookup valAt runs when a key
|
|
;; is genuinely missing from both the fields and the extension map.
|
|
(define (jrec-ref coll k d)
|
|
(if (eq? k jolt-deftype-kw)
|
|
(jrec-tag coll)
|
|
(let ((i (jrec-field-index coll k)))
|
|
(if i (vector-ref (jrec-vals coll) i)
|
|
(let* ((ext (jrec-ext coll))
|
|
(v (if (jolt-nil? ext) jrec-absent (jolt-get ext k jrec-absent))))
|
|
(if (eq? v jrec-absent)
|
|
(cond ((find-method-any-protocol (jrec-tag coll) "valAt")
|
|
=> (lambda (m) (jolt-invoke m coll k d)))
|
|
(else d))
|
|
v))))))
|
|
;; bare-index field read for a statically-known record field — emitted by `jolt
|
|
;; build --opt` for a struct-typed receiver, where i is the field's declared slot.
|
|
;; When r is the expected record it reads the value vector directly: no field-key
|
|
;; hashtable lookup, no jolt-get dispatch. Falls back to jolt-get otherwise (a map
|
|
;; downgraded by dissoc, or a value the inference mistyped), so it stays correct
|
|
;; even if the static type is wrong.
|
|
(define (jrec-field-at r i k)
|
|
(if (and (jrec? r) (fx< i (vector-length (jrec-vals r))))
|
|
(vector-ref (jrec-vals r) i)
|
|
(jolt-get r k)))
|
|
|
|
;; mutate a deftype's mutable field in place: the value vector is mutable, so
|
|
;; vector-set! updates the field. (set! field v) inside a method lowers to this;
|
|
;; returns v, as set! does.
|
|
(define (jolt-set-field! inst k v)
|
|
(if (jrec? inst)
|
|
(let ((i (jrec-field-index inst k)))
|
|
(if i (let* ((flags (hashtable-ref chez-record-dbl-tbl (jrec-tag inst) #f))
|
|
;; a ^double field stays a flonum across set!, like the ctor —
|
|
;; keeps a later field read sound to unbox.
|
|
(v2 (if (and flags (fx< i (vector-length flags)) (vector-ref flags i)
|
|
(number? v) (not (flonum? v)))
|
|
(exact->inexact v) v)))
|
|
(vector-set! (jrec-vals inst) i v2) v2)
|
|
(error #f "set! of an unknown field" k)))
|
|
(error #f "set! of a field on a non-record" inst)))
|
|
(define (jrec-ext=? ea eb)
|
|
(cond ((and (jolt-nil? ea) (jolt-nil? eb)) #t)
|
|
((or (jolt-nil? ea) (jolt-nil? eb)) #f)
|
|
(else (jolt=2 ea eb))))
|
|
(define (jrec=? a b)
|
|
(and (string=? (jrec-tag a) (jrec-tag b))
|
|
(= (vector-length (jrec-vals a)) (vector-length (jrec-vals b)))
|
|
(let ((va (jrec-vals a)) (vb (jrec-vals b)) (n (vector-length (jrec-vals a))))
|
|
(let loop ((i 0))
|
|
(or (= i n)
|
|
(and (jolt=2 (vector-ref va i) (vector-ref vb i)) (loop (+ i 1))))))
|
|
(jrec-ext=? (jrec-ext a) (jrec-ext b))))
|
|
(define (jrec-hash r)
|
|
(let* ((fkeys (jrdesc-fkeys (jrec-desc r))) (vals (jrec-vals r)) (n (vector-length vals))
|
|
(base (let loop ((i 0) (acc (string-hash (jrec-tag r))))
|
|
(if (= i n) acc
|
|
(loop (+ i 1) (+ acc (jolt-hash (vector-ref fkeys i))
|
|
(jolt-hash (vector-ref vals i))))))))
|
|
(let ((ext (jrec-ext r)))
|
|
(if (jolt-nil? ext) base (+ base (jolt-hash ext))))))
|
|
(define (jrec-pr r) ; #ns.Name{:k v, :k v}
|
|
(let ((fkeys (jrdesc-fkeys (jrec-desc r))) (vals (jrec-vals r)))
|
|
(string-append "#" (jrec-tag r) "{"
|
|
(let ((n (vector-length vals)))
|
|
(let loop ((i 0) (first #t) (acc ""))
|
|
(if (= i n)
|
|
(let ((ext (jrec-ext r)))
|
|
(if (jolt-nil? ext) acc
|
|
(let eloop ((es (jrec-ext-pairs ext)) (first first) (acc acc))
|
|
(if (null? es) acc
|
|
(eloop (cdr es) #f
|
|
(string-append acc (if first "" ", ")
|
|
(jolt-pr-readable (caar es)) " " (jolt-pr-readable (cdar es))))))))
|
|
(loop (+ i 1) #f
|
|
(string-append acc (if first "" ", ")
|
|
(jolt-pr-readable (vector-ref fkeys i)) " " (jolt-pr-readable (vector-ref vals i)))))))
|
|
"}")))
|
|
|
|
;; ---- extend the collection dispatchers with a jrec arm ----------------------
|
|
;; equality for a jrec: a deftype implementing IPersistentCollection/equiv (e.g.
|
|
;; core.cache's caches, which equiv to their backing map) compares through that
|
|
;; method, so (= cache {…}) works; a plain record has no equiv and falls back to
|
|
;; field-wise jrec=? (and a record is never = a plain map).
|
|
(register-eq-arm! (lambda (a b) (or (jrec? a) (jrec? b)))
|
|
(lambda (a b)
|
|
(cond ((and (jrec? a) (jrec-cl a "equiv")) => (lambda (m) (if (jolt-truthy? (jolt-invoke m a b)) #t #f)))
|
|
((and (jrec? b) (jrec-cl b "equiv")) => (lambda (m) (if (jolt-truthy? (jolt-invoke m b a)) #t #f)))
|
|
;; a deftype with a custom Object.equals (but no equiv) governs
|
|
;; its own value equality and map-key identity — core.logic's
|
|
;; LVar/LCons key substitutions on id, ignoring metadata, so
|
|
;; structural jrec=? (which sees the meta field) is wrong here.
|
|
((and (jrec? a) (jrec-cl a "equals")) => (lambda (m) (if (jolt-truthy? (jolt-invoke m a b)) #t #f)))
|
|
((and (jrec? b) (jrec-cl b "equals")) => (lambda (m) (if (jolt-truthy? (jolt-invoke m b a)) #t #f)))
|
|
((and (jrec? a) (jrec? b)) (jrec=? a b))
|
|
(else #f))))
|
|
;; a deftype's declared hashCode governs its map/set hashing (paired with the
|
|
;; equals/equiv above so the hash/eq contract holds); a plain record hashes its
|
|
;; fields structurally via jrec-hash.
|
|
(register-hash-arm! jrec?
|
|
(lambda (x) (let ((m (jrec-cl x "hashCode")))
|
|
(if m (jolt-invoke m x) (jrec-hash x)))))
|
|
;; get on a jrec: a real field reads raw (so a deftype method's own field bindings,
|
|
;; compiled to (get inst :field), never recurse); a NON-field key on a deftype that
|
|
;; implements clojure.lang.ILookup routes to its valAt (core.match's pattern types
|
|
;; compute ::tag in valAt), else the default.
|
|
;; jrec is the hottest get target (every record field read); jolt-get-dispatch
|
|
;; (collections.ss) checks jrec? directly and calls jrec-ref, skipping the get-arm
|
|
;; walk. This registration is the equivalent fallback for any other caller.
|
|
(register-get-arm! jrec? jrec-ref)
|
|
;; A jrec is a defrecord (map of fields) by default, BUT a deftype that
|
|
;; implements a clojure.lang collection interface carries the op as an inline
|
|
;; method — prefer that method, else fall back to the field/map behavior. (jrec-cl
|
|
;; finds the method; find-method-any-protocol / jolt-invoke resolve at call time.)
|
|
(define (jrec-cl coll name) (and (jrec? coll) (find-method-any-protocol (jrec-tag coll) name)))
|
|
(define %r-jolt-count jolt-count)
|
|
(set! jolt-count (lambda (coll)
|
|
(cond ((jrec-cl coll "count") => (lambda (m) (jolt-invoke m coll)))
|
|
((jrec? coll) (+ (vector-length (jrec-vals coll))
|
|
(let ((ext (jrec-ext coll))) (if (jolt-nil? ext) 0 (%r-jolt-count ext)))))
|
|
(else (%r-jolt-count coll)))))
|
|
;; contains?: a deftype implementing Associative/containsKey (e.g. core.cache's
|
|
;; caches) answers through that; a plain defrecord checks its fields.
|
|
(define %r-jolt-contains? jolt-contains?)
|
|
(set! jolt-contains? (lambda (coll k)
|
|
(cond ((jrec-cl coll "containsKey") => (lambda (m) (if (jolt-truthy? (jolt-invoke m coll k)) #t #f)))
|
|
((jrec? coll) (jrec-has? coll k))
|
|
(else (%r-jolt-contains? coll k)))))
|
|
;; assoc: replacing a declared field copies the value vector; any other key grows
|
|
;; the extension map (the value vector is shared — fields are immutable).
|
|
(define %r-jolt-assoc1 jolt-assoc1)
|
|
(set! jolt-assoc1 (lambda (coll k v)
|
|
(cond ((jrec-cl coll "assoc") => (lambda (m) (jolt-invoke m coll k v)))
|
|
((jrec? coll)
|
|
(let ((i (and (keyword? k) (jrec-field-index coll k))))
|
|
(if i
|
|
(let ((nv (jrec-vec-copy (jrec-vals coll))))
|
|
(vector-set! nv i v)
|
|
(make-jrec (jrec-desc coll) nv (jrec-ext coll)))
|
|
(let ((ext (jrec-ext coll)))
|
|
(make-jrec (jrec-desc coll) (jrec-vals coll)
|
|
(%r-jolt-assoc1 (if (jolt-nil? ext) empty-pmap ext) k v))))))
|
|
(else (%r-jolt-assoc1 coll k v)))))
|
|
;; dissoc: a deftype implementing IPersistentMap/without answers through it.
|
|
;; Removing a declared field downgrades a plain record to a map (JVM parity); an
|
|
;; extension key drops from the ext map (normalized back to jolt-nil when empty).
|
|
(define (jrec->map-without r drop-k)
|
|
(let* ((fkeys (jrdesc-fkeys (jrec-desc r))) (vals (jrec-vals r)) (n (vector-length vals)))
|
|
(let loop ((i 0) (m empty-pmap))
|
|
(if (= i n)
|
|
(let ((ext (jrec-ext r)))
|
|
(if (jolt-nil? ext) m
|
|
(fold-left (lambda (mm p) (%r-jolt-assoc1 mm (car p) (cdr p))) m (jrec-ext-pairs ext))))
|
|
(let ((fk (vector-ref fkeys i)))
|
|
(loop (+ i 1) (if (eq? fk drop-k) m (%r-jolt-assoc1 m fk (vector-ref vals i)))))))))
|
|
(define %r-jolt-dissoc jolt-dissoc)
|
|
(define (jrec-dissoc1 coll k)
|
|
(if (not (jrec? coll))
|
|
(%r-jolt-dissoc coll k) ; an earlier declared-field dissoc downgraded it
|
|
(let ((i (and (keyword? k) (jrec-field-index coll k))))
|
|
(if i (jrec->map-without coll k)
|
|
(let ((ext (jrec-ext coll)))
|
|
(if (jolt-nil? ext) coll
|
|
(let ((ne (%r-jolt-dissoc ext k)))
|
|
(make-jrec (jrec-desc coll) (jrec-vals coll)
|
|
(if (= 0 (%r-jolt-count ne)) jolt-nil ne)))))))))
|
|
(set! jolt-dissoc (lambda (coll . ks)
|
|
(cond ((jrec-cl coll "without")
|
|
=> (lambda (m) (fold-left (lambda (c k) (jolt-invoke m c k)) coll ks)))
|
|
((jrec? coll) (fold-left jrec-dissoc1 coll ks))
|
|
(else (apply %r-jolt-dissoc coll ks)))))
|
|
;; keys/vals over a jrec read its entry seq (jolt-seq is method-first, so a
|
|
;; map-like deftype delegates to its Seqable; a defrecord's seq is its fields, so
|
|
;; the result is unchanged for records).
|
|
(define (jrec-seq-col m which)
|
|
(let loop ((s (jolt-seq m)) (acc '()))
|
|
(if (jolt-nil? s) (list->cseq (reverse acc))
|
|
(loop (jolt-seq (seq-more s)) (cons (jolt-nth (seq-first s) which) acc)))))
|
|
(define %r-jolt-keys jolt-keys)
|
|
(set! jolt-keys (lambda (m) (if (jrec? m) (jrec-seq-col m 0) (%r-jolt-keys m))))
|
|
(define %r-jolt-vals jolt-vals)
|
|
(set! jolt-vals (lambda (m) (if (jrec? m) (jrec-seq-col m 1) (%r-jolt-vals m))))
|
|
;; a record's seq is its field map-entries in declared order, then any extensions.
|
|
(define (jrec-entry-list r)
|
|
(let* ((fkeys (jrdesc-fkeys (jrec-desc r))) (vals (jrec-vals r)) (n (vector-length vals)))
|
|
(let loop ((i 0) (acc '()))
|
|
(if (= i n)
|
|
(let ((ext (jrec-ext r)))
|
|
(append (reverse acc)
|
|
(if (jolt-nil? ext) '()
|
|
(map (lambda (p) (make-map-entry (car p) (cdr p))) (jrec-ext-pairs ext)))))
|
|
(loop (+ i 1) (cons (make-map-entry (vector-ref fkeys i) (vector-ref vals i)) acc))))))
|
|
(define %r-jolt-seq jolt-seq)
|
|
(set! jolt-seq (lambda (x)
|
|
(cond ((jrec-cl x "seq") => (lambda (m) (jolt-seq (jolt-invoke m x))))
|
|
;; a record seqs its fields; a bare deftype is not seqable (falls through
|
|
;; to %r-jolt-seq, which errors like the JVM).
|
|
((jrec-record? x) (list->cseq (jrec-entry-list x)))
|
|
(else (%r-jolt-seq x)))))
|
|
(define %r-jolt-conj1 jolt-conj1)
|
|
(set! jolt-conj1 (lambda (coll x)
|
|
(cond ((jrec-cl coll "cons") => (lambda (m) (jolt-invoke m coll x)))
|
|
((jrec? coll) (jolt-assoc1 coll (jolt-nth x 0) (jolt-nth x 1)))
|
|
(else (%r-jolt-conj1 coll x)))))
|
|
;; peek/pop on a deftype implementing IPersistentStack (data.priority-map, which
|
|
;; core.cache's LRU/LU caches lean on) dispatch to its methods.
|
|
;; empty? over a jrec: a map-like deftype is empty iff its entry seq is (data
|
|
;; .priority-map's peek calls (.isEmpty this) -> empty?). jolt-seq is method-first.
|
|
(define %r-jolt-empty? jolt-empty?)
|
|
(set! jolt-empty? (lambda (coll)
|
|
(if (jrec-collection? coll) (jolt-nil? (jolt-seq coll)) (%r-jolt-empty? coll))))
|
|
(define %r-jolt-peek jolt-peek)
|
|
(set! jolt-peek (lambda (coll)
|
|
(cond ((jrec-cl coll "peek") => (lambda (m) (jolt-invoke m coll)))
|
|
(else (%r-jolt-peek coll)))))
|
|
(define %r-jolt-pop jolt-pop)
|
|
(set! jolt-pop (lambda (coll)
|
|
(cond ((jrec-cl coll "pop") => (lambda (m) (jolt-invoke m coll)))
|
|
(else (%r-jolt-pop coll)))))
|
|
(register-pr-arm! jrec? jrec-pr)
|
|
|
|
;; records are map? and coll? (Clojure: a record IS an associative map). The
|
|
;; predicates.ss vars hold a snapshot, so re-def-var! after extending. record? is
|
|
;; the overlay's (some? (get x :jolt/deftype)) — works for free since the get
|
|
;; override returns the tag for that key.
|
|
;; only a defrecord is a map (Clojure: a record IS an associative map); a bare
|
|
;; deftype is not. coll? additionally covers a deftype implementing a collection
|
|
;; interface. predicates.ss vars hold a snapshot, so re-def-var! after extending.
|
|
(define %r-jolt-map? jolt-map?)
|
|
(set! jolt-map? (lambda (x) (or (jrec-maplike? x) (%r-jolt-map? x))))
|
|
(def-var! "clojure.core" "map?" jolt-map?)
|
|
(def-var! "clojure.core" "coll?" (lambda (x) (or (jrec-collection? x) (jolt-coll-pred? x))))
|
|
|
|
;; ---- protocol registry ------------------------------------------------------
|
|
;; type-tag -> (proto-name -> (method-name -> fn))
|
|
(define type-registry (make-hashtable string-hash string=?))
|
|
(define (register-protocol-method type-tag proto method fn)
|
|
(let* ((ti (or (hashtable-ref type-registry type-tag #f)
|
|
(let ((h (make-hashtable string-hash string=?))) (hashtable-set! type-registry type-tag h) h)))
|
|
(pi (or (hashtable-ref ti proto #f)
|
|
(let ((h (make-hashtable string-hash string=?))) (hashtable-set! ti proto h) h))))
|
|
(hashtable-set! pi method fn)))
|
|
(define (find-protocol-method type-tag proto method)
|
|
(let ((ti (hashtable-ref type-registry type-tag #f)))
|
|
(and ti (let ((pi (hashtable-ref ti proto #f))) (and pi (hashtable-ref pi method #f))))))
|
|
(define (find-method-any-protocol type-tag method)
|
|
(let ((ti (hashtable-ref type-registry type-tag #f)))
|
|
(and ti (let loop ((protos (vector->list (hashtable-keys ti))))
|
|
(and (pair? protos)
|
|
(let ((f (hashtable-ref (hashtable-ref ti (car protos) #f) method #f)))
|
|
(or f (loop (cdr protos)))))))))
|
|
;; A deftype can implement a method NAME at two arities from two interfaces (e.g.
|
|
;; data.priority-map's seq: Seqable.seq[this] and Sorted.seq[this ascending]),
|
|
;; registered under different protocols. Pick the impl whose procedure accepts
|
|
;; the call's arg count (this + args); fall back to any same-named impl.
|
|
(define (proc-accepts? f n)
|
|
(and (procedure? f) (bitwise-bit-set? (procedure-arity-mask f) n)))
|
|
(define (find-method-any-protocol-arity type-tag method nargs)
|
|
(let ((ti (hashtable-ref type-registry type-tag #f)))
|
|
(and ti (let loop ((protos (vector->list (hashtable-keys ti))) (fallback #f))
|
|
(if (null? protos)
|
|
fallback
|
|
(let ((f (hashtable-ref (hashtable-ref ti (car protos) #f) method #f)))
|
|
(cond ((and f (proc-accepts? f nargs)) f)
|
|
(else (loop (cdr protos) (or fallback f))))))))))
|
|
(define (type-satisfies? type-tag proto)
|
|
(let ((ti (hashtable-ref type-registry type-tag #f)))
|
|
(and ti (hashtable-ref ti proto #f) #t)))
|
|
;; True when a deftype/record instance DECLARES a method by this name (an inline
|
|
;; protocol impl), so clojure.core can prefer it over generic collection behavior
|
|
;; — e.g. (empty priority-map) must use the type's own empty, not return {}.
|
|
(def-var! "jolt.host" "jrec-method?"
|
|
(lambda (v name) (if (and (jrec? v) (find-method-any-protocol (jrec-tag v) name)) #t #f)))
|
|
|
|
;; host type-tag candidates for a non-record value (extend-protocol on builtins).
|
|
(define (value-host-tags obj)
|
|
;; numbers dispatch by actual type (a Double is NOT a Long): flonum -> Double,
|
|
;; exact ratio -> Ratio, exact integer -> Long.
|
|
(cond ((flonum? obj) '("Double" "Float" "Number" "Object"))
|
|
((and (number? obj) (exact? obj) (not (integer? obj))) '("Ratio" "Number" "Object"))
|
|
((number? obj) '("Long" "Integer" "BigInteger" "BigInt" "Number" "Object"))
|
|
((string? obj) '("String" "CharSequence" "Object"))
|
|
((boolean? obj) '("Boolean" "Object"))
|
|
((keyword? obj) '("Keyword" "Named" "Object"))
|
|
((jolt-symbol? obj) '("Symbol" "Named" "Object"))
|
|
((pvec? obj) '("PersistentVector" "APersistentVector" "IPersistentVector" "IPersistentCollection"
|
|
"List" "java.util.List" "Sequential" "Collection" "Iterable" "java.lang.Iterable" "Object"))
|
|
((pmap? obj) '("PersistentArrayMap" "APersistentMap" "IPersistentMap" "Associative"
|
|
"Map" "java.util.Map" "Iterable" "java.lang.Iterable" "Object"))
|
|
((pset? obj) '("PersistentHashSet" "APersistentSet" "IPersistentSet" "Set" "java.util.Set" "Collection" "Iterable" "java.lang.Iterable" "Object"))
|
|
;; jolt models every seq as a list (no distinct LazySeq), so a seq also
|
|
;; reports PersistentList / IPersistentList / IPersistentStack — extend-protocol
|
|
;; clojure.lang.IPersistentList (algo.monads' writer monad) dispatches on one.
|
|
((or (cseq? obj) (empty-list-t? obj)) '("PersistentList" "IPersistentList" "IPersistentStack" "ASeq" "ISeq" "IPersistentCollection" "Sequential" "Collection" "Iterable" "java.lang.Iterable" "Object"))
|
|
;; a var is clojure.lang.Var (also IDeref / IFn) — reitit's Expand protocol
|
|
;; extends to Var so a #'handler route dispatches.
|
|
((var-cell? obj) '("Var" "clojure.lang.Var" "IDeref" "IFn" "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 ByteBuffer — extend-protocol java.nio.ByteBuffer (aws-api util).
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "byte-buffer")) '("ByteBuffer" "java.nio.ByteBuffer" "Object"))
|
|
;; java.io readers/writers — so (extend-protocol java.io.Reader …) (data.csv)
|
|
;; and the like dispatch on one. A PushbackReader is also a Reader.
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "string-reader"))
|
|
'("StringReader" "java.io.StringReader" "Reader" "java.io.Reader" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "pushback-reader"))
|
|
'("PushbackReader" "java.io.PushbackReader" "FilterReader" "java.io.FilterReader" "Reader" "java.io.Reader" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "char-reader"))
|
|
'("Reader" "java.io.Reader" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "char-writer"))
|
|
'("Writer" "java.io.Writer" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "writer"))
|
|
'("Writer" "java.io.Writer" "Object"))
|
|
;; arrays dispatch by their JVM array-class name — extend-protocol to
|
|
;; (Class/forName "[B") for byte[] (data.json, aws-api), "[C" for char[].
|
|
((and (jolt-array? obj) (eq? (jolt-array-kind obj) 'byte)) '("[B" "Object"))
|
|
((and (jolt-array? obj) (eq? (jolt-array-kind obj) 'char)) '("[C" "Object"))
|
|
((jolt-array? obj) '("[Ljava.lang.Object;" "Object"))
|
|
;; a regex VALUE — extend-protocol java.util.regex.Pattern (core.match.regex).
|
|
((regex-t? obj) '("Pattern" "java.util.regex.Pattern" "Object"))
|
|
;; host value types a library may extend a protocol to by class (data.json
|
|
;; extends JSONWriter to java.util.UUID / java.util.Date / java.math.BigDecimal).
|
|
((juuid? obj) '("UUID" "java.util.UUID" "Object"))
|
|
((jinst? obj) '("Date" "java.util.Date" "Timestamp" "java.sql.Timestamp" "Object"))
|
|
((jbigdec? obj) '("BigDecimal" "java.math.BigDecimal" "Number" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "instant")) '("Instant" "java.time.Instant" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "local-date")) '("LocalDate" "java.time.LocalDate" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "local-time")) '("LocalTime" "java.time.LocalTime" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "local-date-time")) '("LocalDateTime" "java.time.LocalDateTime" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "duration")) '("Duration" "java.time.Duration" "TemporalAmount" "java.time.temporal.TemporalAmount" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "period")) '("Period" "java.time.Period" "TemporalAmount" "java.time.temporal.TemporalAmount" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "month-enum")) '("Month" "java.time.Month" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "dow-enum")) '("DayOfWeek" "java.time.DayOfWeek" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "year")) '("Year" "java.time.Year" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "year-month")) '("YearMonth" "java.time.YearMonth" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "chrono-unit")) '("ChronoUnit" "java.time.temporal.ChronoUnit" "TemporalUnit" "java.time.temporal.TemporalUnit" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "chrono-field")) '("ChronoField" "java.time.temporal.ChronoField" "TemporalField" "java.time.temporal.TemporalField" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "zone-offset")) '("ZoneOffset" "java.time.ZoneOffset" "ZoneId" "java.time.ZoneId" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "zone-id")) '("ZoneId" "java.time.ZoneId" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "zoned-date-time")) '("ZonedDateTime" "java.time.ZonedDateTime" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "offset-date-time")) '("OffsetDateTime" "java.time.OffsetDateTime" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "offset-time")) '("OffsetTime" "java.time.OffsetTime" "Object"))
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "clock")) '("Clock" "java.time.Clock" "Object"))
|
|
;; java.sql.Date — a distinct class from java.util.Date so a protocol
|
|
;; extended to both (data.json's JSONWriter) routes a sql.Date to its impl.
|
|
((and (jhost? obj) (string=? (jhost-tag obj) "sql-date")) '("java.sql.Date" "Date" "java.util.Date" "Object"))
|
|
;; a bare procedure (fn) — extend-protocol to clojure.lang.{Fn,IFn,AFn}.
|
|
((procedure? obj) '("Fn" "IFn" "AFn" "Object"))
|
|
((jolt-nil? obj) '("nil"))
|
|
;; a defrecord IS the clojure.lang map/record interfaces, so a protocol
|
|
;; extended to IRecord / IPersistentMap / Associative / Seqable / … (and not
|
|
;; to the record's own type) dispatches to it — e.g. core.logic extends
|
|
;; IWalkTerm to clojure.lang.IRecord, and walking a record value must hit
|
|
;; that, not the Object default (which would recur forever). The record's
|
|
;; own type is tried first (dispatch checks jrec-tag before these tags).
|
|
((jrec-record? obj)
|
|
(cons (jrec-tag obj)
|
|
'("IRecord" "clojure.lang.IRecord" "IPersistentMap" "clojure.lang.IPersistentMap"
|
|
"APersistentMap" "Associative" "ILookup" "Seqable" "Counted"
|
|
"IPersistentCollection" "IObj" "IMeta" "Map" "java.util.Map"
|
|
"Iterable" "java.lang.Iterable" "Object")))
|
|
;; a bare deftype is opaque — its declared interfaces dispatch via the
|
|
;; inline methods registered under its own tag (tried before these tags).
|
|
((jrec? obj) (list (jrec-tag obj) "Object"))
|
|
(else '("Object"))))
|
|
|
|
(define (record-tag obj) (and (jrec? obj) (jrec-tag obj)))
|
|
|
|
;; ---- the native that handles the analyzer/overlay call ----------------------
|
|
;; make-deftype-ctor: (name-sym field-kws field-tags field-muts) -> ctor closure.
|
|
;; The tag is baked at definition time in the type's ns (chez-current-ns).
|
|
(define (make-deftype-ctor name-sym field-kws . rest-args)
|
|
(let* ((tag (string-append (chez-current-ns) "." (symbol-t-name name-sym)))
|
|
(kws (seq->list field-kws))
|
|
(field-tags (if (pair? rest-args) (seq->list (car rest-args)) '()))
|
|
;; which fields are ^double — coerced to a flonum on construction (JVM
|
|
;; primitive-field parity), so reading them back is a genuine flonum.
|
|
(dbl-flags (list->vector (map chez-double-tag? field-tags)))
|
|
(ndbl (vector-length dbl-flags))
|
|
(desc (make-jrdesc tag kws))
|
|
(nf (length kws))
|
|
(ctor (lambda args
|
|
;; fill the value vector from the positional args, padding missing
|
|
;; trailing fields with nil and ignoring any extras.
|
|
(let ((v (make-vector nf jolt-nil)))
|
|
(let loop ((as args) (i 0))
|
|
(if (or (null? as) (= i nf)) (make-jrec desc v jolt-nil)
|
|
(let ((a (car as)))
|
|
(vector-set! v i
|
|
(if (and (fx< i ndbl) (vector-ref dbl-flags i)
|
|
(number? a) (not (flonum? a)))
|
|
(exact->inexact a) a))
|
|
(loop (cdr as) (+ i 1)))))))))
|
|
;; Register the ctor globally by simple class name (like StringBuilder) so
|
|
;; (Name. …) interop resolves ns-agnostically: a deftype used across files works
|
|
;; even when the runtime current ns is the caller's, not the defining ns
|
|
;; (host-new checks class-ctors-tbl before the current-ns var fallback).
|
|
(register-class-ctor! (symbol-t-name name-sym) ctor)
|
|
;; index the tag so a cross-ns extend-protocol resolves the bare type name.
|
|
(hashtable-set! chez-deftype-tag-set tag #t)
|
|
(hashtable-set! chez-simple-name-tag (symbol-t-name name-sym) tag)
|
|
;; record the shape for whole-program inference, keyed by the positional
|
|
;; ctor var "ns/->Name" the analyzer resolves a (->Name …) call to.
|
|
(register-record-shape! (string-append (chez-current-ns) "/->" (symbol-t-name name-sym))
|
|
kws field-tags tag)
|
|
ctor))
|
|
|
|
;; make-protocol: a protocol value the overlay reads via (get p :name)/(get p :methods).
|
|
(define (make-protocol name-str methods)
|
|
(jolt-hash-map (keyword #f "jolt/type") (keyword #f "jolt/protocol")
|
|
(keyword #f "name") (jolt-symbol jolt-nil name-str)
|
|
(keyword #f "methods") methods))
|
|
|
|
;; register-protocol-methods!: record each method's var-key -> [proto method] for
|
|
;; the inference driver (devirtualization). Dispatch itself is by the receiver's
|
|
;; type tag at call time, so this table is read only by `jolt build` inference.
|
|
;; Called by defprotocol-emitted code in the protocol's ns.
|
|
(define (register-protocol-methods! proto-name method-names)
|
|
(let ((ns (chez-current-ns)))
|
|
(for-each (lambda (mn)
|
|
(let ((m (if (symbol-t? mn) (symbol-t-name mn) mn)))
|
|
(hashtable-set! chez-protocol-methods-tbl
|
|
(string-append ns "/" m) (cons proto-name m))))
|
|
(seq->list method-names)))
|
|
jolt-nil)
|
|
|
|
;; register-method: extend-type/extend register an impl. Host type names keep a
|
|
;; bare canonical tag; record names qualify to the current ns.
|
|
(define host-type-set
|
|
(let ((h (make-hashtable string-hash string=?)))
|
|
(for-each (lambda (n) (hashtable-set! h n #t))
|
|
'("Long" "Integer" "Number" "Double" "Ratio" "BigInt" "BigInteger"
|
|
"String" "CharSequence" "Boolean" "Character"
|
|
"Keyword" "Symbol" "Named" "Object" "nil"
|
|
"Fn" "IFn" "AFn" "URI" "Var" "IDeref"
|
|
"PersistentVector" "APersistentVector" "IPersistentVector"
|
|
"PersistentArrayMap" "APersistentMap" "IPersistentMap"
|
|
"PersistentHashSet" "APersistentSet" "IPersistentSet"
|
|
"ASeq" "ISeq" "IPersistentCollection" "Associative" "Sequential"
|
|
"PersistentList" "IPersistentList" "IPersistentStack"
|
|
"Map" "java.util.Map" "List" "java.util.List" "Set" "java.util.Set"
|
|
"Collection" "java.util.Collection" "Iterable" "java.lang.Iterable"
|
|
"UUID" "BigDecimal" "Date" "Timestamp" "Instant" "java.sql.Date"
|
|
"Pattern" "java.util.regex.Pattern"
|
|
;; java.time value types (extend-protocol Duration / ZonedDateTime / …)
|
|
"Duration" "Period" "LocalDate" "LocalTime" "LocalDateTime"
|
|
"ZonedDateTime" "OffsetDateTime" "OffsetTime" "ZoneId" "ZoneOffset"
|
|
"Clock" "Year" "YearMonth" "Month" "DayOfWeek"
|
|
"ChronoUnit" "ChronoField" "TemporalAmount" "TemporalUnit" "TemporalField"
|
|
;; ByteBuffer + JVM array classes (extend-protocol to (Class/forName "[B"))
|
|
"ByteBuffer" "java.nio.ByteBuffer"
|
|
"[B" "[C" "[I" "[J" "[D" "[Ljava.lang.Object;"
|
|
;; java.io readers/writers — extend-protocol java.io.Reader (data.csv)
|
|
"Reader" "java.io.Reader" "Writer" "java.io.Writer"
|
|
"StringReader" "java.io.StringReader" "PushbackReader" "java.io.PushbackReader"
|
|
"BufferedReader" "java.io.BufferedReader" "FilterReader" "java.io.FilterReader"
|
|
"InputStream" "java.io.InputStream" "OutputStream" "java.io.OutputStream"))
|
|
h))
|
|
(define (strip-prefix s p)
|
|
(let ((pl (string-length p)))
|
|
(and (> (string-length s) pl) (string=? (substring s 0 pl) p) (substring s pl (string-length s)))))
|
|
(define (canonical-host-tag type-name)
|
|
(let ((base (or (strip-prefix type-name "java.lang.")
|
|
(strip-prefix type-name "java.util.regex.")
|
|
(strip-prefix type-name "java.util.")
|
|
(strip-prefix type-name "java.net.")
|
|
(strip-prefix type-name "java.math.")
|
|
(strip-prefix type-name "java.time.")
|
|
(strip-prefix type-name "clojure.lang.")
|
|
type-name)))
|
|
(and (hashtable-ref host-type-set base #f) base)))
|
|
;; An extend/extend-type/extend-protocol registration marks the tag as an
|
|
;; extender of the protocol (recorded inside type-registry so the per-case prune
|
|
;; restores it). deftype/defrecord inline impls go through register-inline-method
|
|
;; and skip the mark: the JVM compiles inline protocol methods into the class, so
|
|
;; extenders excludes them.
|
|
(define extend-mark "__jolt_extend__")
|
|
(define (mark-extend! tag proto-name)
|
|
(let ((ti (hashtable-ref type-registry tag #f)))
|
|
(when ti (let ((pi (hashtable-ref ti proto-name #f)))
|
|
(when pi (hashtable-set! pi extend-mark #t))))))
|
|
(define (register-method type-name proto-name method-name fn)
|
|
(let* ((host (canonical-host-tag type-name))
|
|
(local (string-append (chez-current-ns) "." type-name))
|
|
;; a host class -> its canonical tag; a deftype defined in THIS ns -> the
|
|
;; local tag; an :import-ed deftype from another ns -> its real tag via the
|
|
;; simple-name index; otherwise the local tag (a forward extend).
|
|
(tag (cond (host host)
|
|
((hashtable-ref chez-deftype-tag-set local #f) local)
|
|
((hashtable-ref chez-simple-name-tag type-name #f))
|
|
(else local))))
|
|
(register-protocol-method tag proto-name method-name fn)
|
|
(mark-extend! tag proto-name)
|
|
jolt-nil))
|
|
|
|
;; register-inline-method: a deftype/defrecord inline impl. Registers for dispatch
|
|
;; under the ns-qualified record tag but does NOT mark it as an extender.
|
|
(define (register-inline-method type-name proto-name method-name fn)
|
|
(register-protocol-method (string-append (chez-current-ns) "." type-name) proto-name method-name fn)
|
|
jolt-nil)
|
|
;; record that a deftype/defrecord implements a protocol even when it adds no
|
|
;; methods (a MARKER protocol, e.g. core.match's IPseudoPattern) — so
|
|
;; instance?/satisfies? on the protocol hold.
|
|
(define (register-inline-protocol! type-name proto-name)
|
|
(let* ((tag (string-append (chez-current-ns) "." type-name))
|
|
(ti (or (hashtable-ref type-registry tag #f)
|
|
(let ((h (make-hashtable string-hash string=?))) (hashtable-set! type-registry tag h) h))))
|
|
(unless (hashtable-ref ti proto-name #f)
|
|
(hashtable-set! ti proto-name (make-hashtable string-hash string=?))))
|
|
jolt-nil)
|
|
|
|
;; protocol-resolve: the impl procedure for obj — by record type tag, a reify's
|
|
;; instance-local method, or the protocol's extended impls over obj's host tags.
|
|
;; Raises if none implements the method. The dispatchN entry points apply it
|
|
;; directly so a protocol call doesn't cons a rest-list (the impl fn is always a
|
|
;; procedure, registered by register-(inline-)method/extend).
|
|
(define (protocol-resolve proto-name method-name obj)
|
|
(cond
|
|
((and (jrec? obj) (find-protocol-method (jrec-tag obj) proto-name method-name)))
|
|
((reified-methods obj)
|
|
=> (lambda (rm)
|
|
(or (hashtable-ref rm method-name #f)
|
|
;; not implemented on the reify — fall back to the protocol's
|
|
;; extended impls over the reify's host tags (e.g. an Object/default
|
|
;; extension). malli reifies some protocols and leans on the default.
|
|
(let loop ((tags (value-host-tags obj)))
|
|
(cond ((null? tags) (error #f (string-append "No reified method " method-name)))
|
|
((find-protocol-method (car tags) proto-name method-name))
|
|
(else (loop (cdr tags))))))))
|
|
(else
|
|
(let loop ((tags (value-host-tags obj)))
|
|
(cond ((null? tags) (error #f (string-append "No method " method-name " in " proto-name)))
|
|
((find-protocol-method (car tags) proto-name method-name))
|
|
(else (loop (cdr tags))))))))
|
|
;; Fixed-arity entry points the protocol-method shims call: no rest-list, no seq
|
|
;; round-trip — apply the resolved impl directly. defprotocol emits one clause per
|
|
;; declared arity that calls the matching dispatchN.
|
|
(define (protocol-dispatch1 proto-name method-name obj)
|
|
((protocol-resolve proto-name method-name obj) obj))
|
|
(define (protocol-dispatch2 proto-name method-name obj a)
|
|
((protocol-resolve proto-name method-name obj) obj a))
|
|
(define (protocol-dispatch3 proto-name method-name obj a b)
|
|
((protocol-resolve proto-name method-name obj) obj a b))
|
|
;; the variadic fallback (a declared arity of 4+ args) takes a seqable rest.
|
|
(define (protocol-dispatch proto-name method-name obj rest-args)
|
|
(let ((rest (if (jolt-nil? rest-args) '() (seq->list rest-args))))
|
|
(apply (protocol-resolve proto-name method-name obj) obj rest)))
|
|
|
|
;; devirt-resolve: the impl for a call the inference proved monomorphic. Try the
|
|
;; static type tag directly (the fast path that skips receiver-type computation),
|
|
;; and fall back to ordinary dispatch when it misses — a record can satisfy a
|
|
;; protocol via an Object/host-tag default rather than a direct impl, which
|
|
;; find-protocol-method on its own tag wouldn't see. Mirrors jrec-field-at falling
|
|
;; back to jolt-get: correct regardless of how precise the inference was.
|
|
(define (devirt-resolve type-tag proto-name method-name obj)
|
|
(or (find-protocol-method type-tag proto-name method-name)
|
|
(protocol-resolve proto-name method-name obj)))
|
|
|
|
;; dot-dispatch fallback used by emit for (.method record args): find the method
|
|
;; in ANY protocol the record's type implements.
|
|
;; java.util.Iterator over a jolt seqable: (.iterator coll) returns a jiterator
|
|
;; holding a mutable cursor over (seq coll); (.hasNext it)/(.next it) walk it.
|
|
;; hiccup/compiler's run! loop iterates collections this way.
|
|
(define-record-type jiterator (fields (mutable cur)) (nongenerative jolt-iterator-v1))
|
|
;; (seq an-iterator) / (iterator-seq it): a jiterator wraps the remaining seq in
|
|
;; cur, so seq just yields it — clojure.test's (iterator-seq (.iterator coll)).
|
|
(let ((prev-seq jolt-seq))
|
|
(set! jolt-seq (lambda (x) (if (jiterator? x) (jiterator-cur x) (prev-seq x)))))
|
|
;; A Chez condition's message string (for Throwable .getMessage/.toString): the
|
|
;; &message text plus any &irritants, or display-condition output as a fallback.
|
|
(define (condition->message-string c)
|
|
(if (message-condition? c)
|
|
(let* ((m (condition-message c))
|
|
(irr (if (irritants-condition? c) (condition-irritants c) '()))
|
|
(append-irr (lambda ()
|
|
(let loop ((xs irr) (acc m))
|
|
(if (null? xs) acc
|
|
(loop (cdr xs) (string-append acc " " (jolt-pr-str (car xs)))))))))
|
|
;; some Chez conditions (open-input-file etc.) carry a format-template
|
|
;; message ("failed for ~a: ~(~a~)") whose irritants fill the directives;
|
|
;; format it in. Fall back to appending the irritants if that fails.
|
|
(if (and (string? m) (let scan ((i 0))
|
|
(cond ((>= i (string-length m)) #f)
|
|
((char=? (string-ref m i) #\~) #t)
|
|
(else (scan (+ i 1))))))
|
|
(guard (e (#t (append-irr))) (apply format m irr))
|
|
(append-irr)))
|
|
(with-output-to-string (lambda () (display-condition c)))))
|
|
;; expose a Chez condition's message to Clojure (ex-message returns nil for raw
|
|
;; host conditions): the nREPL eval handler surfaces it instead of an opaque
|
|
;; "#<compound condition>".
|
|
(def-var! "jolt.host" "condition-message"
|
|
(lambda (c) (if (condition? c) (condition->message-string c) jolt-nil)))
|
|
(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-arity (jrec-tag obj) method-name (+ 1 (length rest))))
|
|
=> (lambda (f) (apply jolt-invoke f obj rest)))
|
|
;; (.field inst): a deftype/record field read with no matching method.
|
|
;; Clojure reads the field for (.q x) just like (.-q x); a declared method
|
|
;; (above) wins, this is the field-accessor fallback.
|
|
((and (jrec? obj) (null? rest) (jrec-has? obj (keyword #f method-name)))
|
|
(jrec-lookup obj (keyword #f method-name) jolt-nil))
|
|
;; a defrecord is Associative / ILookup / IPersistentMap / Seqable / Counted,
|
|
;; so its clojure.lang interface methods delegate to the map fns when not
|
|
;; overridden by a declared method — reitit's impl calls (.assoc match k v),
|
|
;; (.valAt …), (.without …) directly. A bare deftype implements these via its
|
|
;; own declared methods (handled above), so this is record-only.
|
|
((and (jrec-record? obj)
|
|
(member method-name '("valAt" "assoc" "without" "containsKey" "cons"
|
|
"count" "seq" "equiv" "entryAt" "empty")))
|
|
(cond
|
|
((string=? method-name "valAt")
|
|
(if (null? (cdr rest)) (jolt-get obj (car rest) jolt-nil) (jolt-get obj (car rest) (cadr rest))))
|
|
((string=? method-name "assoc") (jolt-assoc1 obj (car rest) (cadr rest)))
|
|
((string=? method-name "without") (jolt-dissoc obj (car rest)))
|
|
((string=? method-name "containsKey") (if (jolt-truthy? (jolt-contains? obj (car rest))) #t #f))
|
|
((string=? method-name "cons") (jolt-conj1 obj (car rest)))
|
|
((string=? method-name "count") (jolt-count obj))
|
|
((string=? method-name "seq") (jolt-seq obj))
|
|
((string=? method-name "equiv") (if (jolt= obj (car rest)) #t #f))
|
|
((string=? method-name "entryAt")
|
|
(if (jolt-truthy? (jolt-contains? obj (car rest)))
|
|
(make-map-entry (car rest) (jolt-get obj (car rest) jolt-nil)) jolt-nil))
|
|
(else jolt-nil))) ; .empty of a record is nil on the JVM
|
|
((reified-methods obj)
|
|
=> (lambda (rm) (let ((f (hashtable-ref rm method-name #f)))
|
|
(if f (apply jolt-invoke f obj rest) (error #f (string-append "No method " method-name))))))
|
|
;; java.lang.String interop: defined in natives-str.ss, loaded
|
|
;; after this file (free reference, resolved at call time).
|
|
((string? obj) (jolt-string-method method-name obj rest))
|
|
((jiterator? obj)
|
|
(cond ((string=? method-name "hasNext") (not (jolt-nil? (jolt-seq (jiterator-cur obj)))))
|
|
((string=? method-name "next")
|
|
(let ((s (jolt-seq (jiterator-cur obj))))
|
|
(if (jolt-nil? s) (error #f "iterator exhausted")
|
|
(let ((v (jolt-first s))) (jiterator-cur-set! obj (jolt-rest s)) v))))
|
|
(else (error #f (string-append "No method " method-name " on Iterator")))))
|
|
((string=? method-name "iterator") (make-jiterator (jolt-seq obj)))
|
|
;; clojure.lang.Keyword interop: a Keyword carries an interned `sym` field
|
|
;; (the symbol form, ns + name) plus the Named methods. honeysql/reitit read
|
|
;; (.sym k) on their :clj branch to recover the symbol without the colon.
|
|
((keyword-t? obj)
|
|
(cond ((string=? method-name "sym")
|
|
(jolt-symbol (keyword-t-ns obj) (keyword-t-name obj)))
|
|
((string=? method-name "getName") (keyword-t-name obj))
|
|
((string=? method-name "getNamespace") (or (keyword-t-ns obj) jolt-nil))
|
|
((string=? method-name "toString")
|
|
(string-append ":" (if (keyword-t-ns obj) (string-append (keyword-t-ns obj) "/") "")
|
|
(keyword-t-name obj)))
|
|
((string=? method-name "hashCode") (keyword-t-khash obj))
|
|
((string=? method-name "equals") (and (pair? rest) (eq? obj (car rest))))
|
|
(else (error #f (string-append "No method " method-name " on Keyword")))))
|
|
;; clojure.lang.Symbol interop: the Named methods + getName/getNamespace.
|
|
((symbol-t? obj)
|
|
(cond ((string=? method-name "getName") (symbol-t-name obj))
|
|
((string=? method-name "getNamespace") (or (symbol-t-ns obj) jolt-nil))
|
|
((string=? method-name "toString")
|
|
(string-append (if (symbol-t-ns obj) (string-append (symbol-t-ns obj) "/") "")
|
|
(symbol-t-name obj)))
|
|
((string=? method-name "equals") (and (pair? rest) (jolt=2 obj (car rest))))
|
|
((string=? method-name "hashCode")
|
|
(java-symbol-hash (symbol-t-name obj) (symbol-t-ns obj)))
|
|
(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).
|
|
((condition? obj)
|
|
(cond ((or (string=? method-name "getMessage") (string=? method-name "getLocalizedMessage"))
|
|
(condition->message-string obj))
|
|
((string=? method-name "toString") (condition->message-string obj))
|
|
((string=? method-name "getCause") jolt-nil)
|
|
;; java.sql.SQLException chaining — jolt errors don't chain (nil).
|
|
((string=? method-name "getNextException") jolt-nil)
|
|
((string=? method-name "getStackTrace") (jolt-vector))
|
|
((string=? method-name "printStackTrace") jolt-nil)
|
|
(else (error #f (string-append "No method " method-name " on Throwable")))))
|
|
;; java.lang.Character interop: (.toString \+) -> "+", etc.
|
|
((char? obj)
|
|
(cond ((string=? method-name "toString") (string obj))
|
|
((string=? method-name "charValue") obj)
|
|
((string=? method-name "hashCode") (char->integer obj))
|
|
((string=? method-name "equals") (and (pair? rest) (char? (car rest)) (char=? obj (car rest))))
|
|
((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))))))
|
|
;; java.util.Collection.contains over a list/seq (vectors/sets handle it in
|
|
;; dot-coll-method): value membership, like the JVM.
|
|
((string=? method-name "contains")
|
|
(let ((target (car rest)))
|
|
(let loop ((s (jolt-seq obj)))
|
|
(cond ((jolt-nil? s) #f)
|
|
((jolt=2 (seq-first s) target) #t)
|
|
(else (loop (jolt-seq (seq-more s))))))))
|
|
;; 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)))))))
|
|
|
|
;; reify: instance-local method table. obj is a jreify carrying a method ht +
|
|
;; the protocol short-names it implements (for satisfies?/instance?).
|
|
(define-record-type jreify (fields methods protos) (nongenerative chez-jreify-v1))
|
|
(define (reified-methods obj) (and (jreify? obj) (jreify-methods obj)))
|
|
(define (make-reified methods-map . proto-names)
|
|
(let ((ht (make-hashtable string-hash string=?))
|
|
(protos (if (and (pair? proto-names) (null? (cdr proto-names)) (jolt-coll-pred? (car proto-names)))
|
|
(seq->list (car proto-names)) proto-names)))
|
|
(for-each (lambda (p) (hashtable-set! ht (if (keyword? p) (keyword-t-name p) p)
|
|
(jolt-get methods-map p jolt-nil)))
|
|
(seq->list (jolt-keys methods-map)))
|
|
(make-jreify ht (map (lambda (p) (if (symbol-t? p) (symbol-t-name p) p)) protos))))
|
|
|
|
;; satisfies?: does obj's type implement the protocol?
|
|
(define (jolt-satisfies? proto obj)
|
|
(let* ((pn (jolt-get proto (keyword #f "name") jolt-nil))
|
|
(pn-str (if (symbol-t? pn) (symbol-t-name pn) pn)))
|
|
(cond
|
|
((jrec? obj) (type-satisfies? (jrec-tag obj) pn-str))
|
|
((jreify? obj)
|
|
(let ((short (last-dot pn-str)))
|
|
(and (memp (lambda (p) (string=? (last-dot p) short)) (jreify-protos obj)) #t)))
|
|
(else (let loop ((tags (value-host-tags obj)))
|
|
(cond ((null? tags) #f)
|
|
((type-satisfies? (car tags) pn-str) #t)
|
|
(else (loop (cdr tags)))))))))
|
|
(define (last-dot 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 (memp pred lst) (cond ((null? lst) #f) ((pred (car lst)) lst) (else (memp pred (cdr lst)))))
|
|
|
|
;; extenders: type-tags that extend a protocol via extend/extend-type/extend-
|
|
;; protocol, as symbols (extends? reads this). Inline deftype/defrecord impls are
|
|
;; excluded — only tags carrying the extend mark count, matching the JVM.
|
|
(define (extenders proto)
|
|
(let* ((pn (jolt-get proto (keyword #f "name") jolt-nil))
|
|
(pn-str (if (symbol-t? pn) (symbol-t-name pn) pn))
|
|
(out '()))
|
|
(vector-for-each
|
|
(lambda (tag)
|
|
(let ((ti (hashtable-ref type-registry tag #f)))
|
|
(when ti (let ((pi (hashtable-ref ti pn-str #f)))
|
|
(when (and pi (hashtable-ref pi extend-mark #f))
|
|
(set! out (cons (jolt-symbol jolt-nil tag) out)))))))
|
|
(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.
|
|
(register-str-render! jrec?
|
|
(lambda (v)
|
|
(let ((f (find-protocol-method (jrec-tag v) "Object" "toString")))
|
|
(if f (jolt-invoke f v)
|
|
(let ((s (jrec-pr v))) (substring s 1 (string-length s)))))))
|
|
|
|
;; `type` lives in natives-meta.ss: it needs jolt-meta for the :type
|
|
;; override and a total value->taxonomy mapping, so it sits with meta — a record
|
|
;; yields (jolt-symbol #f (jrec-tag x)), the ns.Name class-name symbol.
|
|
|
|
(def-var! "clojure.core" "make-deftype-ctor" make-deftype-ctor)
|
|
|
|
;; defrecord marks its type a record (deftype does not), keyed by the same
|
|
;; "ns.Name" tag make-deftype-ctor bakes — so jrec-record? distinguishes the two.
|
|
(define (register-record-type! name-sym)
|
|
(hashtable-set! chez-record-type-tbl
|
|
(string-append (chez-current-ns) "." (symbol-t-name name-sym)) #t)
|
|
jolt-nil)
|
|
(def-var! "clojure.core" "register-record-type!" register-record-type!)
|
|
(def-var! "clojure.core" "make-protocol" make-protocol)
|
|
(def-var! "clojure.core" "register-protocol-methods!" register-protocol-methods!)
|
|
(def-var! "clojure.core" "register-method" register-method)
|
|
(def-var! "clojure.core" "register-inline-method" register-inline-method)
|
|
(def-var! "clojure.core" "register-inline-protocol!" register-inline-protocol!)
|
|
(def-var! "jolt.host" "set-field!" jolt-set-field!)
|
|
(def-var! "clojure.core" "protocol-dispatch" (lambda (pn mn obj rest) (protocol-dispatch pn mn obj rest)))
|
|
(def-var! "clojure.core" "protocol-dispatch1" (lambda (pn mn obj) (protocol-dispatch1 pn mn obj)))
|
|
(def-var! "clojure.core" "protocol-dispatch2" (lambda (pn mn obj a) (protocol-dispatch2 pn mn obj a)))
|
|
(def-var! "clojure.core" "protocol-dispatch3" (lambda (pn mn obj a b) (protocol-dispatch3 pn mn obj a b)))
|
|
(def-var! "clojure.core" "satisfies?" jolt-satisfies?)
|
|
(def-var! "clojure.core" "extenders" extenders)
|
|
(def-var! "clojure.core" "make-reified" (lambda (mm . rest) (apply make-reified mm rest)))
|
|
(def-var! "clojure.core" "record-method-dispatch" (lambda (obj m rest) (record-method-dispatch obj m rest)))
|