deftype/record: clojure.lang collection interfaces + protocol identity
Running clojure.core.match (a macro-heavy library that builds its compiler out of deftypes implementing clojure.lang interfaces) shook out a cluster of general gaps. Its own suite goes from not-loading to 111/115 assertions. - deftype/defrecord implementing a clojure.lang collection interface now drives the core fns: Indexed -> nth, Counted -> count, Associative -> assoc, ILookup -> get/valAt (non-field keys only, so a method's own field bindings don't recurse), ISeq -> seq/first/rest, IPersistentCollection -> conj, IFn -> the value is callable. A jrec is still a map of fields by default; the interface method wins when declared. - Multi-arity inline methods are grouped into one fn (a type with (nth [_ i]) and (nth [_ i x]) kept only the last before). Built as data, not a nested syntax-quote, so a `(= ~ocr ~l) method body keeps its unquotes. - instance?/satisfies? recognize a protocol a type implements, including a MARKER protocol with no methods (core.match's IPseudoPattern) — deftype/defrecord now record protocol satisfaction even with zero methods. Added ILookup/Indexed/ Counted to the instance? taxonomy for the built-in collections. - Syntax-quote: a fully-qualified class name (clojure.lang.ILookup) stays bare instead of being namespace-qualified; (unquote x) is detected in a lazy seq (a macro that builds its template with map, e.g. deftype's rewrite-set). - clojure.set union/intersection/difference are variadic (& sets) + union 0-arity. - java map view methods: keySet/values/entrySet/size/isEmpty. - deprecated java.util.Date getters (getYear/getMonth/...) + the multi-arg (Date. year-1900 month0 date hrs min) constructor. Seed change (deftype/defrecord macros + clojure.set) -> re-minted; the rest are runtime. 11 JVM-certified corpus rows; make test + shakesmoke green.
This commit is contained in:
parent
3cbfa8719c
commit
f5455115a0
12 changed files with 1044 additions and 907 deletions
|
|
@ -215,6 +215,7 @@
|
||||||
((and (pvec? x) (fx=? 2 (pvec-count x)))
|
((and (pvec? x) (fx=? 2 (pvec-count x)))
|
||||||
(pmap-assoc coll (pvec-nth-d x 0 jolt-nil) (pvec-nth-d x 1 jolt-nil)))
|
(pmap-assoc coll (pvec-nth-d x 0 jolt-nil) (pvec-nth-d x 1 jolt-nil)))
|
||||||
(else (error 'conj "conj on a map expects a [k v] pair or a map"))))
|
(else (error 'conj "conj on a map expects a [k v] pair or a map"))))
|
||||||
|
((rec-coll-method coll "cons") => (lambda (m) (jolt-invoke m coll x)))
|
||||||
(else (error 'conj "unsupported collection"))))
|
(else (error 'conj "unsupported collection"))))
|
||||||
;; (conj) -> []; (conj nil a b ...) builds a list (conj prepending -> (b a)).
|
;; (conj) -> []; (conj nil a b ...) builds a list (conj prepending -> (b a)).
|
||||||
(define (jolt-conj . args)
|
(define (jolt-conj . args)
|
||||||
|
|
@ -248,6 +249,13 @@
|
||||||
((coll k) (jolt-get-dispatch coll k jolt-nil))
|
((coll k) (jolt-get-dispatch coll k jolt-nil))
|
||||||
((coll k d) (jolt-get-dispatch coll k d))))
|
((coll k d) (jolt-get-dispatch coll k d))))
|
||||||
|
|
||||||
|
;; A deftype implementing a clojure.lang collection interface (Indexed/Counted/
|
||||||
|
;; Associative/ILookup/ISeq/IPersistentCollection) carries the interface method
|
||||||
|
;; as an inline impl; the core collection fns fall back to it. find-method-any-
|
||||||
|
;; protocol / jolt-invoke load later — resolved at call time.
|
||||||
|
(define (rec-coll-method coll name)
|
||||||
|
(and (jrec? coll) (find-method-any-protocol (jrec-tag coll) name)))
|
||||||
|
|
||||||
(define jolt-nth
|
(define jolt-nth
|
||||||
(case-lambda
|
(case-lambda
|
||||||
((coll i)
|
((coll i)
|
||||||
|
|
@ -258,12 +266,14 @@
|
||||||
((string? coll) (if (and (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i)
|
((string? coll) (if (and (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i)
|
||||||
(error 'nth "index out of bounds")))
|
(error 'nth "index out of bounds")))
|
||||||
((or (cseq? coll) (empty-list-t? coll)) (seq-nth coll i #f jolt-nil))
|
((or (cseq? coll) (empty-list-t? coll)) (seq-nth coll i #f jolt-nil))
|
||||||
|
((rec-coll-method coll "nth") => (lambda (m) (jolt-invoke m coll i)))
|
||||||
(else (error 'nth "unsupported collection")))))
|
(else (error 'nth "unsupported collection")))))
|
||||||
((coll i d)
|
((coll i d)
|
||||||
(let ((i (->idx i)))
|
(let ((i (->idx i)))
|
||||||
(cond ((pvec? coll) (pvec-nth-d coll i d))
|
(cond ((pvec? coll) (pvec-nth-d coll i d))
|
||||||
((string? coll) (if (and (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i) d))
|
((string? coll) (if (and (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i) d))
|
||||||
((or (cseq? coll) (empty-list-t? coll)) (seq-nth coll i #t d))
|
((or (cseq? coll) (empty-list-t? coll)) (seq-nth coll i #t d))
|
||||||
|
((rec-coll-method coll "nth") => (lambda (m) (jolt-invoke m coll i d)))
|
||||||
(else d))))))
|
(else d))))))
|
||||||
|
|
||||||
;; a count is an exact integer (JVM parity: count returns a long). jolt= is
|
;; a count is an exact integer (JVM parity: count returns a long). jolt= is
|
||||||
|
|
@ -279,12 +289,14 @@
|
||||||
((empty-list-t? coll) 0)
|
((empty-list-t? coll) 0)
|
||||||
((cseq? coll) (let loop ((s coll) (n 0)) ; walk (forces a finite seq)
|
((cseq? coll) (let loop ((s coll) (n 0)) ; walk (forces a finite seq)
|
||||||
(if (jolt-nil? s) n (loop (jolt-seq (seq-more s)) (fx+ n 1)))))
|
(if (jolt-nil? s) n (loop (jolt-seq (seq-more s)) (fx+ n 1)))))
|
||||||
|
((rec-coll-method coll "count") => (lambda (m) (jolt-invoke m coll)))
|
||||||
(else (error 'count "uncountable")))))
|
(else (error 'count "uncountable")))))
|
||||||
|
|
||||||
(define (jolt-assoc1 coll k v)
|
(define (jolt-assoc1 coll k v)
|
||||||
(cond ((pmap? coll) (pmap-assoc coll k v))
|
(cond ((pmap? coll) (pmap-assoc coll k v))
|
||||||
((pvec? coll) (pvec-assoc coll k v))
|
((pvec? coll) (pvec-assoc coll k v))
|
||||||
((jolt-nil? coll) (pmap-assoc empty-pmap k v))
|
((jolt-nil? coll) (pmap-assoc empty-pmap k v))
|
||||||
|
((rec-coll-method coll "assoc") => (lambda (m) (jolt-invoke m coll k v)))
|
||||||
(else (error 'assoc "unsupported collection"))))
|
(else (error 'assoc "unsupported collection"))))
|
||||||
(define (jolt-assoc coll . kvs)
|
(define (jolt-assoc coll . kvs)
|
||||||
(meta-carry coll
|
(meta-carry coll
|
||||||
|
|
|
||||||
|
|
@ -38,6 +38,14 @@
|
||||||
((or (string=? name "get") (string=? name "valAt"))
|
((or (string=? name "get") (string=? name "valAt"))
|
||||||
(list (apply jolt-get obj args)))
|
(list (apply jolt-get obj args)))
|
||||||
((string=? name "containsKey") (list (jolt-contains? obj (car args))))
|
((string=? name "containsKey") (list (jolt-contains? obj (car args))))
|
||||||
|
((string=? name "size") (list (jolt-count obj)))
|
||||||
|
((string=? name "isEmpty") (list (jolt-empty? obj)))
|
||||||
|
;; java.util.Map views: keySet (a Set), values (a Collection), entrySet.
|
||||||
|
((and (jolt-map? obj) (string=? name "keySet"))
|
||||||
|
(list (apply jolt-hash-set (seq->list (jolt-keys obj)))))
|
||||||
|
((and (jolt-map? obj) (string=? name "values"))
|
||||||
|
(list (apply jolt-vector (seq->list (jolt-vals obj)))))
|
||||||
|
((and (jolt-map? obj) (string=? name "entrySet")) (list (jolt-seq obj)))
|
||||||
;; (.iterator coll): a java.util.Iterator over the seq — for a map this is the
|
;; (.iterator coll): a java.util.Iterator over the seq — for a map this is the
|
||||||
;; entry iterator. Without this a map's .iterator falls into the map-as-object
|
;; entry iterator. Without this a map's .iterator falls into the map-as-object
|
||||||
;; branch and is mis-read as a missing :iterator key (nil). Some libraries
|
;; branch and is mis-read as a missing :iterator key (nil). Some libraries
|
||||||
|
|
|
||||||
|
|
@ -248,8 +248,12 @@
|
||||||
|
|
||||||
(define (hc-sym nm) (jolt-symbol #f nm))
|
(define (hc-sym nm) (jolt-symbol #f nm))
|
||||||
;; is `x` a non-empty list FORM whose head is the unqualified symbol `nm`?
|
;; is `x` a non-empty list FORM whose head is the unqualified symbol `nm`?
|
||||||
|
;; Detect a (unquote …) / (unquote-splicing …) form in a syntax-quote template.
|
||||||
|
;; Any seq counts, not just a proper list: a macro that builds the template with
|
||||||
|
;; map/for (e.g. deftype's rewrite-set) yields a LAZY seq, and its ~unquotes must
|
||||||
|
;; still be recognized.
|
||||||
(define (hc-head-is? x nm)
|
(define (hc-head-is? x nm)
|
||||||
(and (cseq? x) (cseq-list? x)
|
(and (cseq? x)
|
||||||
(let ((h (seq-first x)))
|
(let ((h (seq-first x)))
|
||||||
(and (symbol-t? h) (jolt-nil? (hc-sym-ns h)) (string=? (symbol-t-name h) nm)))))
|
(and (symbol-t? h) (jolt-nil? (hc-sym-ns h)) (string=? (symbol-t-name h) nm)))))
|
||||||
(define (hc-second x) (seq-first (jolt-seq (seq-more x))))
|
(define (hc-second x) (seq-first (jolt-seq (seq-more x))))
|
||||||
|
|
@ -266,6 +270,10 @@
|
||||||
(hashtable-set! gsmap nm g) g)))
|
(hashtable-set! gsmap nm g) g)))
|
||||||
((hc-special-symbol? nm) form) ; special form: leave bare
|
((hc-special-symbol? nm) form) ; special form: leave bare
|
||||||
((hc-interop-head? nm) form) ; interop (.method / Class. / .-field): bare
|
((hc-interop-head? nm) form) ; interop (.method / Class. / .-field): bare
|
||||||
|
;; a fully-qualified class name (java.util.Map, clojure.lang.ILookup) is
|
||||||
|
;; a class token, not a var to namespace-qualify — leave it bare, as
|
||||||
|
;; Clojure's syntax-quote resolves it to the class.
|
||||||
|
((hc-fq-class-name? nm) form)
|
||||||
((var-cell-lookup "clojure.core" nm) (jolt-symbol "clojure.core" nm))
|
((var-cell-lookup "clojure.core" nm) (jolt-symbol "clojure.core" nm))
|
||||||
;; a name referred into the compile ns (:require :refer / :use :only)
|
;; a name referred into the compile ns (:require :refer / :use :only)
|
||||||
;; qualifies to its SOURCE ns, not the compile ns — so a macro that
|
;; qualifies to its SOURCE ns, not the compile ns — so a macro that
|
||||||
|
|
|
||||||
|
|
@ -631,6 +631,17 @@
|
||||||
((string=? iface "Associative")
|
((string=? iface "Associative")
|
||||||
(or (pmap? val) (htable-sorted-map? val)
|
(or (pmap? val) (htable-sorted-map? val)
|
||||||
(and (pvec? val) (not (jolt-map-entry? val)))))
|
(and (pvec? val) (not (jolt-map-entry? val)))))
|
||||||
|
;; ILookup (valAt): maps and vectors; Indexed (nth): vectors;
|
||||||
|
;; Counted: the counted collections. A deftype that declares one
|
||||||
|
;; is matched by type-satisfies? in instance-check-base.
|
||||||
|
((string=? iface "ILookup")
|
||||||
|
(or (pmap? val) (htable-sorted-map? val)
|
||||||
|
(and (pvec? val) (not (jolt-map-entry? val)))))
|
||||||
|
((string=? iface "Indexed")
|
||||||
|
(and (pvec? val) (not (jolt-map-entry? val))))
|
||||||
|
((string=? iface "Counted")
|
||||||
|
(or (pmap? val) (pset? val) (pvec? val)
|
||||||
|
(htable-sorted-map? val) (htable-sorted-set? val)))
|
||||||
;; reader jhosts — data.json re-wraps a reader in a new
|
;; reader jhosts — data.json re-wraps a reader in a new
|
||||||
;; PushbackReader unless (instance? PushbackReader r), so this
|
;; PushbackReader unless (instance? PushbackReader r), so this
|
||||||
;; must hold for repeated reads from one reader to work.
|
;; must hold for repeated reads from one reader to work.
|
||||||
|
|
|
||||||
|
|
@ -435,7 +435,18 @@
|
||||||
;; or (Date. another-date) -> a jinst (ms-of accepts a number / jinst / instant), so
|
;; or (Date. another-date) -> a jinst (ms-of accepts a number / jinst / instant), so
|
||||||
;; .getTime / inst? / instance? Date|Timestamp work.
|
;; .getTime / inst? / instance? Date|Timestamp work.
|
||||||
(define (date-ctor . args)
|
(define (date-ctor . args)
|
||||||
(make-jinst (if (null? args) (now-ms) (ms->exact (ms-of (car args))))))
|
(cond
|
||||||
|
((null? args) (make-jinst (now-ms)))
|
||||||
|
((null? (cdr args)) (make-jinst (ms->exact (ms-of (car args)))))
|
||||||
|
;; deprecated (Date. year-1900 month0 date [hrs min sec]) — civil fields in UTC.
|
||||||
|
(else
|
||||||
|
(let* ((y (+ 1900 (jnum->exact (list-ref args 0))))
|
||||||
|
(mo (+ 1 (jnum->exact (list-ref args 1))))
|
||||||
|
(d (jnum->exact (list-ref args 2)))
|
||||||
|
(hh (if (> (length args) 3) (jnum->exact (list-ref args 3)) 0))
|
||||||
|
(mm (if (> (length args) 4) (jnum->exact (list-ref args 4)) 0))
|
||||||
|
(ss (if (> (length args) 5) (jnum->exact (list-ref args 5)) 0)))
|
||||||
|
(make-jinst (* 1000 (+ (* (days-from-civil y mo d) 86400) (* hh 3600) (* mm 60) ss)))))))
|
||||||
(register-class-ctor! "Date" date-ctor)
|
(register-class-ctor! "Date" date-ctor)
|
||||||
(register-class-ctor! "java.util.Date" date-ctor)
|
(register-class-ctor! "java.util.Date" date-ctor)
|
||||||
(register-class-ctor! "Timestamp" date-ctor)
|
(register-class-ctor! "Timestamp" date-ctor)
|
||||||
|
|
@ -532,6 +543,14 @@
|
||||||
(cond
|
(cond
|
||||||
((jinst? obj)
|
((jinst? obj)
|
||||||
(cond ((string=? method-name "getTime") (jinst-ms obj))
|
(cond ((string=? method-name "getTime") (jinst-ms obj))
|
||||||
|
;; deprecated java.util.Date accessors (UTC civil fields).
|
||||||
|
((string=? method-name "getYear") (- (list-ref (inst-fields (jinst-ms obj)) 0) 1900))
|
||||||
|
((string=? method-name "getMonth") (- (list-ref (inst-fields (jinst-ms obj)) 1) 1))
|
||||||
|
((string=? method-name "getDate") (list-ref (inst-fields (jinst-ms obj)) 2))
|
||||||
|
((string=? method-name "getHours") (list-ref (inst-fields (jinst-ms obj)) 3))
|
||||||
|
((string=? method-name "getMinutes") (list-ref (inst-fields (jinst-ms obj)) 4))
|
||||||
|
((string=? method-name "getSeconds") (list-ref (inst-fields (jinst-ms obj)) 5))
|
||||||
|
((string=? method-name "getDay") (list-ref (inst-fields (jinst-ms obj)) 7))
|
||||||
((string=? method-name "toInstant") (mk-instant (jinst-ms obj)))
|
((string=? method-name "toInstant") (mk-instant (jinst-ms obj)))
|
||||||
((string=? method-name "toLocalDate") (mk-local-date (jinst-ms obj)))
|
((string=? method-name "toLocalDate") (mk-local-date (jinst-ms obj)))
|
||||||
((string=? method-name "toLocalDateTime") (mk-local (jinst-ms obj)))
|
((string=? method-name "toLocalDateTime") (mk-local (jinst-ms obj)))
|
||||||
|
|
|
||||||
|
|
@ -66,7 +66,12 @@
|
||||||
(let ((tag (jrec-tag val)))
|
(let ((tag (jrec-tag val)))
|
||||||
(or (string=? tag tname)
|
(or (string=? tag tname)
|
||||||
(and (> (string-length tag) (string-length tname))
|
(and (> (string-length tag) (string-length tname))
|
||||||
(string=? (substring tag (- (string-length tag) (string-length tname)) (string-length tag)) tname)))))
|
(string=? (substring tag (- (string-length tag) (string-length tname)) (string-length tag)) tname))
|
||||||
|
;; a protocol/interface the type implements (defprotocol generates an
|
||||||
|
;; interface; (instance? SomeProtocol record) is true when the record
|
||||||
|
;; implements it — core.match dispatches on instance? IPatternCompile).
|
||||||
|
(type-satisfies? tag tname)
|
||||||
|
(type-satisfies? tag (last-dot tname)))))
|
||||||
((jreify? val) (let ((short (last-dot tname)))
|
((jreify? val) (let ((short (last-dot tname)))
|
||||||
;; every Clojure reify implements IObj/IMeta (carries metadata).
|
;; every Clojure reify implements IObj/IMeta (carries metadata).
|
||||||
(or (member short '("IObj" "IMeta"))
|
(or (member short '("IObj" "IMeta"))
|
||||||
|
|
|
||||||
|
|
@ -65,24 +65,47 @@
|
||||||
(register-eq-arm! (lambda (a b) (or (jrec? a) (jrec? b)))
|
(register-eq-arm! (lambda (a b) (or (jrec? a) (jrec? b)))
|
||||||
(lambda (a b) (and (jrec? a) (jrec? b) (jrec=? a b))))
|
(lambda (a b) (and (jrec? a) (jrec? b) (jrec=? a b))))
|
||||||
(register-hash-arm! jrec? jrec-hash)
|
(register-hash-arm! jrec? jrec-hash)
|
||||||
(register-get-arm! jrec? (lambda (coll k d) (jrec-lookup coll k d)))
|
;; 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.
|
||||||
|
(register-get-arm! jrec?
|
||||||
|
(lambda (coll k d)
|
||||||
|
(cond ((jrec-has? coll k) (jrec-lookup coll k d))
|
||||||
|
((find-method-any-protocol (jrec-tag coll) "valAt")
|
||||||
|
=> (lambda (m) (jolt-invoke m coll k d)))
|
||||||
|
(else d))))
|
||||||
|
;; 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)
|
(define %r-jolt-count jolt-count)
|
||||||
(set! jolt-count (lambda (coll) (if (jrec? coll) (length (jrec-pairs coll)) (%r-jolt-count coll))))
|
(set! jolt-count (lambda (coll)
|
||||||
|
(cond ((jrec-cl coll "count") => (lambda (m) (jolt-invoke m coll)))
|
||||||
|
((jrec? coll) (length (jrec-pairs coll)))
|
||||||
|
(else (%r-jolt-count coll)))))
|
||||||
(define %r-jolt-contains? jolt-contains?)
|
(define %r-jolt-contains? jolt-contains?)
|
||||||
(set! jolt-contains? (lambda (coll k) (if (jrec? coll) (jrec-has? coll k) (%r-jolt-contains? coll k))))
|
(set! jolt-contains? (lambda (coll k) (if (jrec? coll) (jrec-has? coll k) (%r-jolt-contains? coll k))))
|
||||||
(define %r-jolt-assoc1 jolt-assoc1)
|
(define %r-jolt-assoc1 jolt-assoc1)
|
||||||
(set! jolt-assoc1 (lambda (coll k v)
|
(set! jolt-assoc1 (lambda (coll k v)
|
||||||
(if (jrec? coll) (make-jrec (jrec-tag coll) (jrec-replace (jrec-pairs coll) k v)) (%r-jolt-assoc1 coll k v))))
|
(cond ((jrec-cl coll "assoc") => (lambda (m) (jolt-invoke m coll k v)))
|
||||||
|
((jrec? coll) (make-jrec (jrec-tag coll) (jrec-replace (jrec-pairs coll) k v)))
|
||||||
|
(else (%r-jolt-assoc1 coll k v)))))
|
||||||
(define %r-jolt-keys jolt-keys)
|
(define %r-jolt-keys jolt-keys)
|
||||||
(set! jolt-keys (lambda (m) (if (jrec? m) (list->cseq (map car (jrec-pairs m))) (%r-jolt-keys m))))
|
(set! jolt-keys (lambda (m) (if (jrec? m) (list->cseq (map car (jrec-pairs m))) (%r-jolt-keys m))))
|
||||||
(define %r-jolt-vals jolt-vals)
|
(define %r-jolt-vals jolt-vals)
|
||||||
(set! jolt-vals (lambda (m) (if (jrec? m) (list->cseq (map cdr (jrec-pairs m))) (%r-jolt-vals m))))
|
(set! jolt-vals (lambda (m) (if (jrec? m) (list->cseq (map cdr (jrec-pairs m))) (%r-jolt-vals m))))
|
||||||
(define %r-jolt-seq jolt-seq)
|
(define %r-jolt-seq jolt-seq)
|
||||||
(set! jolt-seq (lambda (x)
|
(set! jolt-seq (lambda (x)
|
||||||
(if (jrec? x) (list->cseq (map (lambda (p) (make-map-entry (car p) (cdr p))) (jrec-pairs x))) (%r-jolt-seq x))))
|
(cond ((jrec-cl x "seq") => (lambda (m) (jolt-seq (jolt-invoke m x))))
|
||||||
|
((jrec? x) (list->cseq (map (lambda (p) (make-map-entry (car p) (cdr p))) (jrec-pairs x))))
|
||||||
|
(else (%r-jolt-seq x)))))
|
||||||
(define %r-jolt-conj1 jolt-conj1)
|
(define %r-jolt-conj1 jolt-conj1)
|
||||||
(set! jolt-conj1 (lambda (coll x)
|
(set! jolt-conj1 (lambda (coll x)
|
||||||
(if (jrec? coll) (jolt-assoc1 coll (jolt-nth x 0) (jolt-nth x 1)) (%r-jolt-conj1 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)))))
|
||||||
(register-pr-arm! jrec? jrec-pr)
|
(register-pr-arm! jrec? jrec-pr)
|
||||||
|
|
||||||
;; records are map? and coll? (Clojure: a record IS an associative map). The
|
;; records are map? and coll? (Clojure: a record IS an associative map). The
|
||||||
|
|
@ -253,6 +276,16 @@
|
||||||
(define (register-inline-method type-name proto-name method-name fn)
|
(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)
|
(register-protocol-method (string-append (chez-current-ns) "." type-name) proto-name method-name fn)
|
||||||
jolt-nil)
|
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-dispatch: look up the impl by the value's type tag (record) or host
|
;; protocol-dispatch: look up the impl by the value's type tag (record) or host
|
||||||
;; candidates, invoke it; reified objects carry instance-local methods.
|
;; candidates, invoke it; reified objects carry instance-local methods.
|
||||||
|
|
@ -479,6 +512,7 @@
|
||||||
(def-var! "clojure.core" "register-protocol-methods!" register-protocol-methods!)
|
(def-var! "clojure.core" "register-protocol-methods!" register-protocol-methods!)
|
||||||
(def-var! "clojure.core" "register-method" register-method)
|
(def-var! "clojure.core" "register-method" register-method)
|
||||||
(def-var! "clojure.core" "register-inline-method" register-inline-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! "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-dispatch" (lambda (pn mn obj rest) (protocol-dispatch pn mn obj rest)))
|
||||||
(def-var! "clojure.core" "satisfies?" jolt-satisfies?)
|
(def-var! "clojure.core" "satisfies?" jolt-satisfies?)
|
||||||
|
|
|
||||||
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
|
|
@ -323,16 +323,31 @@
|
||||||
;; inline impls register for dispatch but are NOT extenders of the
|
;; inline impls register for dispatch but are NOT extenders of the
|
||||||
;; protocol (the JVM compiles them into the class) — register-inline-method,
|
;; protocol (the JVM compiles them into the class) — register-inline-method,
|
||||||
;; not extend-type.
|
;; not extend-type.
|
||||||
|
;; Several bodies for one method name are distinct arities (a type that
|
||||||
|
;; implements clojure.lang.Indexed has (nth [_ i]) AND (nth [_ i x])):
|
||||||
|
;; group them into one multi-arity fn so dispatch picks the clause by arg
|
||||||
|
;; count, instead of the last clause clobbering the rest.
|
||||||
impl (fn [proto specs]
|
impl (fn [proto specs]
|
||||||
`(do
|
(loop [ss (seq specs) methods {} order []]
|
||||||
~@(map (fn [spec]
|
(if (empty? ss)
|
||||||
(let [argv (nth spec 1)
|
`(do (register-inline-protocol! ~(name tname) ~(name proto))
|
||||||
|
~@(map (fn [mname]
|
||||||
|
`(register-inline-method ~(name tname) ~(name proto) ~mname
|
||||||
|
(fn ~@(get methods mname))))
|
||||||
|
order))
|
||||||
|
(let [spec (first ss)
|
||||||
|
mname (name (first spec))
|
||||||
|
argv (nth spec 1)
|
||||||
inst (first argv)
|
inst (first argv)
|
||||||
binds (vec (mapcat (fn [f] [f `(get ~inst ~(keyword (name f)))]) fields))
|
binds (vec (mapcat (fn [f] [f `(get ~inst ~(keyword (name f)))]) fields))
|
||||||
mbody (map (fn [bf] (rewrite-set inst bf)) (drop 2 spec))]
|
mbody (map (fn [bf] (rewrite-set inst bf)) (drop 2 spec))
|
||||||
`(register-inline-method ~(name tname) ~(name proto) ~(name (first spec))
|
;; build the clause as DATA, not via a syntax-quote: a body
|
||||||
(fn ~argv (let [~@binds] ~@mbody)))))
|
;; that is itself a syntax-quote (`(= ~ocr ~l)) would have its
|
||||||
specs)))]
|
;; ~unquotes consumed a level early if re-spliced through one.
|
||||||
|
clause (list argv (list* 'let binds mbody))]
|
||||||
|
(recur (rest ss)
|
||||||
|
(assoc methods mname (conj (get methods mname []) clause))
|
||||||
|
(if (contains? methods mname) order (conj order mname)))))))]
|
||||||
`(do
|
`(do
|
||||||
(def ~tname (make-deftype-ctor (quote ~tname) [~@field-kws] [~@field-tags] [~@field-muts]))
|
(def ~tname (make-deftype-ctor (quote ~tname) [~@field-kws] [~@field-tags] [~@field-muts]))
|
||||||
(def ~arrow ~tname)
|
(def ~arrow ~tname)
|
||||||
|
|
@ -476,19 +491,29 @@
|
||||||
;; inline impls register for dispatch but are NOT extenders of the
|
;; inline impls register for dispatch but are NOT extenders of the
|
||||||
;; protocol (the JVM compiles them into the class) — register-inline-method,
|
;; protocol (the JVM compiles them into the class) — register-inline-method,
|
||||||
;; not extend-type.
|
;; not extend-type.
|
||||||
|
;; group multi-arity method bodies into one fn (see deftype's impl).
|
||||||
impl (fn [proto specs]
|
impl (fn [proto specs]
|
||||||
`(do
|
(loop [ss (seq specs) methods {} order []]
|
||||||
~@(map (fn [spec]
|
(if (empty? ss)
|
||||||
(let [argv (nth spec 1)
|
`(do (register-inline-protocol! ~(name name-sym) ~(name proto))
|
||||||
|
~@(map (fn [mname]
|
||||||
|
`(register-inline-method ~(name name-sym) ~(name proto) ~mname
|
||||||
|
(fn ~@(get methods mname))))
|
||||||
|
order))
|
||||||
|
(let [spec (first ss)
|
||||||
|
mname (name (first spec))
|
||||||
|
argv (nth spec 1)
|
||||||
inst (first argv)
|
inst (first argv)
|
||||||
;; hint `this` with the record type so the inference
|
;; hint `this` with the record type so the inference types it
|
||||||
;; types it and its field reads bare-index
|
;; and its field reads bare-index instead of the runtime guard.
|
||||||
;; instead of going through the runtime tag guard.
|
|
||||||
hinted (assoc argv 0 (vary-meta inst assoc :tag (name name-sym)))
|
hinted (assoc argv 0 (vary-meta inst assoc :tag (name name-sym)))
|
||||||
binds (vec (mapcat (fn [f] [f `(get ~inst ~(keyword (name f)))]) fields))]
|
binds (vec (mapcat (fn [f] [f `(get ~inst ~(keyword (name f)))]) fields))
|
||||||
`(register-inline-method ~(name name-sym) ~(name proto) ~(name (first spec))
|
;; clause as DATA (see deftype): a syntax-quote body must not
|
||||||
(fn ~hinted (let [~@binds] ~@(drop 2 spec))))))
|
;; be re-spliced through another syntax-quote.
|
||||||
specs)))]
|
clause (list hinted (list* 'let binds (drop 2 spec)))]
|
||||||
|
(recur (rest ss)
|
||||||
|
(assoc methods mname (conj (get methods mname []) clause))
|
||||||
|
(if (contains? methods mname) order (conj order mname)))))))]
|
||||||
`(do
|
`(do
|
||||||
;; deftype already defines ->name (= the ctor); no (name. …) interop needed,
|
;; deftype already defines ->name (= the ctor); no (name. …) interop needed,
|
||||||
;; so defrecord compiles too. map->name builds via that ctor.
|
;; so defrecord compiles too. map->name builds via that ctor.
|
||||||
|
|
|
||||||
|
|
@ -1,18 +1,22 @@
|
||||||
; Jolt Standard Library: clojure.set
|
; Jolt Standard Library: clojure.set
|
||||||
; Set operations. Note: no & rest arities (evaluator limitation).
|
; Set operations.
|
||||||
|
|
||||||
(defn union
|
(defn union
|
||||||
|
([] #{})
|
||||||
([s1] s1)
|
([s1] s1)
|
||||||
([s1 s2] (reduce conj s2 s1)))
|
([s1 s2] (if (< (count s1) (count s2)) (reduce conj s2 s1) (reduce conj s1 s2)))
|
||||||
|
([s1 s2 & sets] (reduce union (union s1 s2) sets)))
|
||||||
|
|
||||||
(defn intersection
|
(defn intersection
|
||||||
([s1] s1)
|
([s1] s1)
|
||||||
([s1 s2]
|
([s1 s2]
|
||||||
(reduce (fn [acc item] (if (contains? s2 item) acc (disj acc item))) s1 s1)))
|
(reduce (fn [acc item] (if (contains? s2 item) acc (disj acc item))) s1 s1))
|
||||||
|
([s1 s2 & sets] (reduce intersection (intersection s1 s2) sets)))
|
||||||
|
|
||||||
(defn difference
|
(defn difference
|
||||||
([s1] s1)
|
([s1] s1)
|
||||||
([s1 s2] (reduce disj s1 s2)))
|
([s1 s2] (reduce disj s1 s2))
|
||||||
|
([s1 s2 & sets] (reduce difference (difference s1 s2) sets)))
|
||||||
|
|
||||||
(defn select
|
(defn select
|
||||||
[pred s]
|
[pred s]
|
||||||
|
|
|
||||||
|
|
@ -3066,4 +3066,15 @@
|
||||||
{:suite "clojure.edn / unknown tags" :label "unknown tag throws naming the tag" :expected "\"No reader function for tag foobar\"" :actual "(do (require (quote [clojure.edn :as e1])) (try (e1/read-string \"#foobar 1\") (catch Exception e (ex-message e))))"}
|
{:suite "clojure.edn / unknown tags" :label "unknown tag throws naming the tag" :expected "\"No reader function for tag foobar\"" :actual "(do (require (quote [clojure.edn :as e1])) (try (e1/read-string \"#foobar 1\") (catch Exception e (ex-message e))))"}
|
||||||
{:suite "clojure.edn / unknown tags" :label "object tag throws naming the tag" :expected "\"No reader function for tag object\"" :actual "(do (require (quote [clojure.edn :as e2])) (try (e2/read-string \"#object [1 2 3]\") (catch Exception e (ex-message e))))"}
|
{:suite "clojure.edn / unknown tags" :label "object tag throws naming the tag" :expected "\"No reader function for tag object\"" :actual "(do (require (quote [clojure.edn :as e2])) (try (e2/read-string \"#object [1 2 3]\") (catch Exception e (ex-message e))))"}
|
||||||
{:suite "clojure.edn / unknown tags" :label ":default opt handles an unknown tag" :expected "[\"foobar\" 9]" :actual "(do (require (quote [clojure.edn :as e3])) (e3/read-string {:default (fn [t v] [(name t) v])} \"#foobar 9\"))"}
|
{:suite "clojure.edn / unknown tags" :label ":default opt handles an unknown tag" :expected "[\"foobar\" 9]" :actual "(do (require (quote [clojure.edn :as e3])) (e3/read-string {:default (fn [t v] [(name t) v])} \"#foobar 9\"))"}
|
||||||
|
{:suite "deftype / clojure.lang interfaces" :label "Indexed + Counted dispatch" :expected "[3 20]" :actual "(do (deftype Row [v] clojure.lang.Indexed (nth [_ i] (nth v i)) (nth [_ i x] (nth v i x)) clojure.lang.Counted (count [_] (count v))) [(count (->Row [10 20 30])) (nth (->Row [10 20 30]) 1)])"}
|
||||||
|
{:suite "deftype / clojure.lang interfaces" :label "multi-arity inline method" :expected "[5 11]" :actual "(do (defprotocol PMul (mm [this a] [this a b])) (deftype TMul [] PMul (mm [_ a] a) (mm [_ a b] (+ a b))) [(mm (->TMul) 5) (mm (->TMul) 5 6)])"}
|
||||||
|
{:suite "deftype / clojure.lang interfaces" :label "ILookup valAt computes a non-field key" :expected "[1 :miss]" :actual "(do (deftype TL [a] clojure.lang.ILookup (valAt [this k] (.valAt this k nil)) (valAt [_ k nf] (case k :a a :computed 99 nf))) [(:a (->TL 1)) (get (->TL 1) :nope :miss)])"}
|
||||||
|
{:suite "deftype / clojure.lang interfaces" :label "marker protocol satisfies?" :expected "true" :actual "(do (defprotocol PMark) (deftype TM [] PMark) (satisfies? PMark (->TM)))"}
|
||||||
|
{:suite "deftype / clojure.lang interfaces" :label "IFn record is callable" :expected "7" :actual "(do (deftype Adder [n] clojure.lang.IFn (invoke [_ x] (+ n x))) ((->Adder 5) 2))"}
|
||||||
|
{:suite "interop / collections" :label "Map keySet" :expected "true" :actual "(= (set (.keySet {:a 1 :b 2})) #{:a :b})"}
|
||||||
|
{:suite "interop / collections" :label "instance? ILookup on a map" :expected "true" :actual "(instance? clojure.lang.ILookup {:a 1})"}
|
||||||
|
{:suite "interop / collections" :label "instance? Indexed on a vector" :expected "true" :actual "(instance? clojure.lang.Indexed [1 2 3])"}
|
||||||
|
{:suite "interop / java.util.Date" :label "deprecated getYear/getMonth" :expected "[110 0]" :actual "(let [d (java.util.Date. 110 0 15)] [(.getYear d) (.getMonth d)])"}
|
||||||
|
{:suite "clojure.set / variadic" :label "union of 4 sets" :expected "#{1 2 3 4}" :actual "(do (require (quote clojure.set)) (clojure.set/union #{1} #{2} #{3} #{4}))"}
|
||||||
|
{:suite "clojure.set / variadic" :label "intersection of 3 sets" :expected "#{3}" :actual "(do (require (quote clojure.set)) (clojure.set/intersection #{1 2 3} #{2 3 4} #{3 4 5}))"}
|
||||||
]
|
]
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue