Merge pull request #191 from jolt-lang/spike/json-conformance
JSON conformance: read-string sets, host-class dispatch, String/char interop, format %x, extend nil
This commit is contained in:
Dmitri Sotnikov
GitHub
commit
18874ce4ab
13 changed files with 210 additions and 34 deletions
|
|
@ -15,7 +15,10 @@
|
|||
;; inference when the unit opted into direct-linking (jolt build --opt). Off that
|
||||
;; path it is a pure const-fold. Loaded from the compiler image (jolt.passes).
|
||||
(define jolt-ce-run-passes (var-deref "jolt.passes" "run-passes"))
|
||||
(define jolt-ce-read (var-deref "clojure.core" "read-string"))
|
||||
;; The compiler reads source as FORMS (set literals stay {:jolt/type :jolt/set},
|
||||
;; which the analyzer lowers) — the raw reader, not clojure.core/read-string,
|
||||
;; whose data conversion would turn those into real sets.
|
||||
(define jolt-ce-read jolt-read-form-raw)
|
||||
|
||||
;; The spine ALWAYS runs with the full clojure.core prelude loaded, so a clojure.*
|
||||
;; ref must lower to var-deref (resolved from the prelude), not trip the emitter's
|
||||
|
|
|
|||
|
|
@ -32,6 +32,7 @@
|
|||
(define hc-kw-name (keyword #f "name"))
|
||||
(define hc-kw-var (keyword #f "var"))
|
||||
(define hc-kw-unresolved (keyword #f "unresolved"))
|
||||
(define hc-kw-class (keyword #f "class"))
|
||||
(define hc-kw-num-ret (keyword #f "num-ret"))
|
||||
(define hc-kw-double (keyword #f "double"))
|
||||
(define hc-kw-long (keyword #f "long"))
|
||||
|
|
@ -192,6 +193,19 @@
|
|||
((equal? t "long") hc-kw-long)
|
||||
(else #f))))))
|
||||
|
||||
;; A slash-free dotted symbol whose final segment is Capitalized is a class
|
||||
;; reference (java.util.Map, clojure.lang.Named) — Clojure has no such vars. With
|
||||
;; no JVM classes, jolt models a class as its name string, so the symbol
|
||||
;; self-evaluates to that string (the analyzer emits a :const). This lets a lib
|
||||
;; extend a protocol to / instance?-check a host class jolt has no shim for.
|
||||
(define (hc-fq-class-name? nm)
|
||||
(let ((n (string-length nm)))
|
||||
(let loop ((i (fx- n 1)))
|
||||
(cond ((fx<? i 0) #f)
|
||||
((char=? (string-ref nm i) #\.)
|
||||
(and (fx<? (fx+ i 1) n) (char-upper-case? (string-ref nm (fx+ i 1)))))
|
||||
(else (loop (fx- i 1)))))))
|
||||
|
||||
(define (hc-resolve-global ctx sym)
|
||||
(let* ((nm (symbol-t-name sym))
|
||||
(cell (hc-resolve-cell ctx sym)))
|
||||
|
|
@ -201,7 +215,9 @@
|
|||
hc-kw-name (var-cell-name cell)))
|
||||
(nr (hc-cell-num-ret cell)))
|
||||
(if nr (jolt-assoc base hc-kw-num-ret nr) base))
|
||||
(jolt-hash-map hc-kw-kind hc-kw-unresolved hc-kw-name nm))))
|
||||
(if (hc-fq-class-name? nm)
|
||||
(jolt-hash-map hc-kw-kind hc-kw-class hc-kw-name nm)
|
||||
(jolt-hash-map hc-kw-kind hc-kw-unresolved hc-kw-name nm)))))
|
||||
|
||||
(define (hc-intern! ctx ns-name nm) (declare-var! ns-name nm) jolt-nil)
|
||||
|
||||
|
|
|
|||
|
|
@ -73,12 +73,19 @@
|
|||
(cons "iterator" (lambda (self) (make-jiterator (list->cseq (al->list self)))))
|
||||
(cons "toString" (lambda (self) (jolt-pr-str (list->cseq (al->list self)))))))
|
||||
|
||||
;; Appendable.append text: append(x) renders x; append(csq,start,end) appends the
|
||||
;; subsequence csq[start,end) (data.json's writer appends string runs this way).
|
||||
(define (append-text x rest)
|
||||
(if (null? rest)
|
||||
(render-piece x)
|
||||
(substring (render-piece x) (jnum->exact (car rest)) (jnum->exact (cadr rest)))))
|
||||
|
||||
(register-class-ctor! "StringBuilder"
|
||||
(lambda args (make-jhost "string-builder"
|
||||
;; a numeric first arg is a CAPACITY hint, not content.
|
||||
(vector (if (and (pair? args) (not (number? (car args)))) (render-piece (car args)) "")))))
|
||||
(register-host-methods! "string-builder"
|
||||
(list (cons "append" (lambda (self x) (sb-set! self (string-append (sb-str self) (render-piece x))) self))
|
||||
(list (cons "append" (lambda (self x . rest) (sb-set! self (string-append (sb-str self) (append-text x rest))) self))
|
||||
(cons "toString" (lambda (self) (sb-str self)))
|
||||
(cons "length" (lambda (self) (->num (string-length (sb-str self)))))
|
||||
(cons "charAt" (lambda (self i) (string-ref (sb-str self) (jnum->exact i))))
|
||||
|
|
@ -88,6 +95,9 @@
|
|||
(substring cur 0 n)
|
||||
(string-append cur (make-string (- n (string-length cur)) #\nul)))))
|
||||
jolt-nil))))
|
||||
;; (str sb) / print a StringBuilder -> its accumulated content, like the JVM
|
||||
;; (str calls toString). Without this str renders the opaque host object.
|
||||
(register-str-render! (lambda (x) (and (jhost? x) (string=? (jhost-tag x) "string-builder"))) sb-str)
|
||||
|
||||
;; ---- StringWriter -----------------------------------------------------------
|
||||
;; Writer.write(int) writes the CHAR for that code; append(char) appends the char.
|
||||
|
|
@ -95,7 +105,7 @@
|
|||
(register-class-ctor! "StringWriter" (lambda args (make-jhost "writer" (vector ""))))
|
||||
(register-host-methods! "writer"
|
||||
(list (cons "write" (lambda (self x) (sb-set! self (string-append (sb-str self) (writer-piece x))) jolt-nil))
|
||||
(cons "append" (lambda (self x) (sb-set! self (string-append (sb-str self) (render-piece x))) self))
|
||||
(cons "append" (lambda (self x . rest) (sb-set! self (string-append (sb-str self) (append-text x rest))) self))
|
||||
(cons "flush" (lambda (self) jolt-nil))
|
||||
(cons "close" (lambda (self) jolt-nil))
|
||||
(cons "toString" (lambda (self) (sb-str self)))))
|
||||
|
|
@ -109,7 +119,7 @@
|
|||
(define (fw-flush! self) (jolt-spit (fw-path self) (fw-buf self))) ; jolt-spit: io.ss
|
||||
(register-host-methods! "file-writer"
|
||||
(list (cons "write" (lambda (self x) (fw-append! self (writer-piece x)) jolt-nil))
|
||||
(cons "append" (lambda (self x) (fw-append! self (render-piece x)) self))
|
||||
(cons "append" (lambda (self x . rest) (fw-append! self (append-text x rest)) self))
|
||||
(cons "flush" (lambda (self) (fw-flush! self) jolt-nil))
|
||||
(cons "close" (lambda (self) (fw-flush! self) jolt-nil))
|
||||
(cons "toString" (lambda (self) (fw-buf self)))))
|
||||
|
|
@ -120,7 +130,7 @@
|
|||
;; (tools.logging, selmer) compile and run.
|
||||
(register-host-methods! "port-writer"
|
||||
(list (cons "write" (lambda (self x) (display (writer-piece x) (vector-ref (jhost-state self) 0)) jolt-nil))
|
||||
(cons "append" (lambda (self x) (display (render-piece x) (vector-ref (jhost-state self) 0)) self))
|
||||
(cons "append" (lambda (self x . rest) (display (append-text x rest) (vector-ref (jhost-state self) 0)) self))
|
||||
(cons "flush" (lambda (self) (flush-output-port (vector-ref (jhost-state self) 0)) jolt-nil))
|
||||
(cons "close" (lambda (self) jolt-nil))
|
||||
(cons "toString" (lambda (self) ""))))
|
||||
|
|
@ -291,6 +301,15 @@
|
|||
(lambda (x . rest)
|
||||
(cond ((bytevector? x) (decode-bytevector x rest))
|
||||
((and (jolt-array? x) (eq? (jolt-array-kind x) 'byte)) (decode-bytevector (na-bytearray->bv x) rest))
|
||||
;; (String. char[] [offset count]) — the whole array or a slice. Buffered
|
||||
;; readers (data.json) build a string from a fill buffer this way.
|
||||
((and (jolt-array? x) (eq? (jolt-array-kind x) 'char))
|
||||
(let ((v (jolt-array-vec x)))
|
||||
(if (pair? rest)
|
||||
(let* ((off (jnum->exact (car rest))) (cnt (jnum->exact (cadr rest))) (out (make-string cnt)))
|
||||
(let loop ((i 0)) (when (fx<? i cnt) (string-set! out i (vector-ref v (fx+ off i))) (loop (fx+ i 1))))
|
||||
out)
|
||||
(list->string (vector->list v)))))
|
||||
((string? x) x)
|
||||
(else (jolt-str-render-one x)))))
|
||||
(register-class-ctor! "BigInteger"
|
||||
|
|
@ -535,6 +554,24 @@
|
|||
((string=? iface "IFn")
|
||||
(or (procedure? val) (keyword? val) (symbol-t? val)
|
||||
(pmap? val) (pset? val) (pvec? val)))
|
||||
;; host-class interfaces libraries branch on (data.json, etc.).
|
||||
;; Matched by last segment, so java.util.Map and Map both hit.
|
||||
((string=? iface "Named") (or (keyword? val) (symbol-t? val)))
|
||||
((string=? iface "CharSequence") (string? val))
|
||||
((string=? iface "Number") (number? val))
|
||||
((string=? iface "Map") (or (pmap? val) (htable-sorted-map? val)))
|
||||
((string=? iface "Set") (or (pset? val) (htable-sorted-set? val)))
|
||||
;; a Java List is a vector or a seq/list — not a set or map.
|
||||
((string=? iface "List")
|
||||
(or (and (pvec? val) (not (jolt-map-entry? val)))
|
||||
(cseq? val) (empty-list-t? val) (jolt-lazyseq? val)))
|
||||
;; a Java Collection is any of those plus a set — but NOT a map.
|
||||
((string=? iface "Collection")
|
||||
(or (pvec? val) (pset? val) (cseq? val) (empty-list-t? val)
|
||||
(jolt-lazyseq? val) (htable-sorted-set? val)))
|
||||
((string=? iface "Associative")
|
||||
(or (pmap? val) (htable-sorted-map? val)
|
||||
(and (pvec? val) (not (jolt-map-entry? val)))))
|
||||
(else 'none))))
|
||||
(if (eq? hit 'none) 'pass (if hit #t #f))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -320,6 +320,8 @@
|
|||
(list (cons "ofPattern" (lambda (p . _) (mk-formatter p)))
|
||||
(cons "ISO_LOCAL_DATE" (mk-formatter "yyyy-MM-dd"))
|
||||
(cons "ISO_LOCAL_DATE_TIME" (mk-formatter "yyyy-MM-dd'T'HH:mm:ss"))
|
||||
;; ISO_INSTANT always renders in UTC with a trailing Z (format-ms is UTC; X -> "Z").
|
||||
(cons "ISO_INSTANT" (mk-formatter "yyyy-MM-dd'T'HH:mm:ssX"))
|
||||
(cons "ofLocalizedDate" (lambda (fs) (style-fmt 'date fs)))
|
||||
(cons "ofLocalizedTime" (lambda (fs) (style-fmt 'time fs)))
|
||||
(cons "ofLocalizedDateTime" (lambda (fs) (style-fmt 'datetime fs)))))
|
||||
|
|
@ -354,8 +356,11 @@
|
|||
;; java.util.TimeZone: an opaque id holder (format-ms is UTC, so a non-UTC zone is
|
||||
;; not honored — only the UTC case the corpus uses is exercised).
|
||||
(define (timezone-of id) (make-jhost "timezone" (vector (if (string? id) id (jolt-str-render-one id)))))
|
||||
(register-class-statics! "TimeZone" (list (cons "getTimeZone" timezone-of)))
|
||||
(register-class-statics! "java.util.TimeZone" (list (cons "getTimeZone" timezone-of)))
|
||||
(define timezone-statics
|
||||
(list (cons "getTimeZone" timezone-of)
|
||||
(cons "getDefault" (lambda () (timezone-of "default")))))
|
||||
(register-class-statics! "TimeZone" timezone-statics)
|
||||
(register-class-statics! "java.util.TimeZone" timezone-statics)
|
||||
|
||||
;; java.text.SimpleDateFormat: holds a pattern; .setTimeZone is accepted (format-ms
|
||||
;; is UTC); .format(date) renders the date per the pattern via the format-ms engine.
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@
|
|||
((#\d) (number->string (->long a)))
|
||||
((#\s) (jolt-str-render-one a))
|
||||
((#\f) (fmt-float a (or prec 6)))
|
||||
((#\x) (number->string (->long a) 16))
|
||||
((#\x) (string-downcase (number->string (->long a) 16)))
|
||||
((#\X) (string-upcase (number->string (->long a) 16)))
|
||||
((#\o) (number->string (->long a) 8))
|
||||
((#\b) (if (jolt-truthy? a) "true" "false"))
|
||||
|
|
|
|||
|
|
@ -166,6 +166,18 @@
|
|||
((or (string=? method "getName") (string=? method "getCanonicalName")) s)
|
||||
((string=? method "getSimpleName")
|
||||
(let ((i (str-last-index-of s "."))) (if (>= i 0) (substring s (+ i 1) (string-length s)) s)))
|
||||
;; .getChars srcBegin srcEnd dst dstBegin — copy s[srcBegin,srcEnd) into the
|
||||
;; char-array dst at dstBegin (used by buffered readers, e.g. data.json).
|
||||
((string=? method "getChars")
|
||||
(let ((src-begin (jolt->idx (arg 0))) (src-end (jolt->idx (arg 1)))
|
||||
(dv (jolt-array-vec (arg 2))) (dst-begin (jolt->idx (arg 3))))
|
||||
(let loop ((i src-begin) (j dst-begin))
|
||||
(when (fx<? i src-end)
|
||||
(vector-set! dv j (string-ref s i))
|
||||
(loop (fx+ i 1) (fx+ j 1)))))
|
||||
jolt-nil)
|
||||
((string=? method "subSequence")
|
||||
(substring s (jolt->idx (arg 0)) (jolt->idx (arg 1))))
|
||||
(else (error #f (string-append "No method " method " for value")))))
|
||||
|
||||
;; --- clojure.core str-* primitives (the substrate clojure.string.clj calls) ---
|
||||
|
|
|
|||
|
|
@ -177,7 +177,21 @@
|
|||
((#\0) (loop (+ i 2) (cons #\nul acc)))
|
||||
((#\u)
|
||||
(let-values (((cp j) (rdr-hex->int s (+ i 2) 4)))
|
||||
(loop j (cons (integer->char cp) acc))))
|
||||
;; A \u escape is a UTF-16 code unit. jolt chars are Unicode scalars,
|
||||
;; so combine a high+low surrogate pair (😃 -> U+1F603) into
|
||||
;; the one scalar char. A lone surrogate has no scalar — emit U+FFFD
|
||||
;; rather than crash (the irreducible UTF-16/scalar divergence).
|
||||
(cond
|
||||
((and (fx>=? cp #xD800) (fx<=? cp #xDBFF)
|
||||
(fx<? (fx+ j 1) end)
|
||||
(char=? (string-ref s j) #\\) (char=? (string-ref s (fx+ j 1)) #\u))
|
||||
(let-values (((lo k) (rdr-hex->int s (+ j 2) 4)))
|
||||
(if (and (fx>=? lo #xDC00) (fx<=? lo #xDFFF))
|
||||
(loop k (cons (integer->char
|
||||
(fx+ #x10000 (fx* (fx- cp #xD800) 1024) (fx- lo #xDC00))) acc))
|
||||
(loop j (cons #\xFFFD acc)))))
|
||||
((and (fx>=? cp #xD800) (fx<=? cp #xDFFF)) (loop j (cons #\xFFFD acc)))
|
||||
(else (loop j (cons (integer->char cp) acc))))))
|
||||
(else (loop (+ i 2) (cons e acc))))))
|
||||
(else (loop (+ i 1) (cons c acc)))))))
|
||||
|
||||
|
|
@ -526,12 +540,62 @@
|
|||
(jolt-throw (jolt-ex-info "EOF while reading reader macro" (empty-pmap))))
|
||||
(values (jolt-list head form) j)))
|
||||
|
||||
;; --- form -> data -----------------------------------------------------------
|
||||
;; read-string/read return DATA, so set literal FORMS ({:jolt/type :jolt/set
|
||||
;; :value [...]}) become real sets, recursing through maps/vectors/lists. The
|
||||
;; COMPILER reads via rdr-read-form and keeps the set FORM (the analyzer lowers
|
||||
;; it), so this conversion runs only on the data seams. Structural sharing keeps
|
||||
;; identity (and the rdr-map-order entry + metadata) for any branch with no set.
|
||||
(define (rdr-set-form? x)
|
||||
(and (pmap? x) (eq? (jolt-get x rdr-kw-jolt-type) rdr-kw-jolt-set)
|
||||
(not (jolt-nil? (jolt-get x rdr-kw-value)))))
|
||||
|
||||
(define (rdr-conv-each xs) ; (values converted-list changed?)
|
||||
(let loop ((xs xs) (acc '()) (changed #f))
|
||||
(if (null? xs)
|
||||
(values (reverse acc) changed)
|
||||
(let ((c (rdr-form->data (car xs))))
|
||||
(loop (cdr xs) (cons c acc) (or changed (not (eq? c (car xs)))))))))
|
||||
|
||||
(define (rdr-carry-meta src dst)
|
||||
(let ((m (jolt-meta src))) (if (jolt-nil? m) dst (jolt-with-meta dst m))))
|
||||
|
||||
(define (rdr-form->data x)
|
||||
(cond
|
||||
((rdr-set-form? x)
|
||||
(let ((items (jolt-get x rdr-kw-value)))
|
||||
(rdr-carry-meta x
|
||||
(let loop ((i 0) (s empty-pset))
|
||||
(if (fx>=? i (pvec-count items)) s
|
||||
(loop (fx+ i 1) (pset-conj s (rdr-form->data (pvec-nth-d items i jolt-nil)))))))))
|
||||
((pvec? x)
|
||||
(let-values (((items changed) (rdr-conv-each (vector->list (pvec-v x)))))
|
||||
(if changed (rdr-carry-meta x (apply jolt-vector items)) x)))
|
||||
((pmap? x)
|
||||
(let ((order (hashtable-ref rdr-map-order x #f)))
|
||||
(if order
|
||||
(let-values (((kvs changed) (rdr-conv-each order)))
|
||||
(if changed
|
||||
(let ((m (rdr-make-map kvs))) (rdr-carry-meta x m))
|
||||
x))
|
||||
(let-values (((kvs changed)
|
||||
(rdr-conv-each (pmap-fold x (lambda (k v a) (cons k (cons v a))) '()))))
|
||||
(if changed (rdr-carry-meta x (apply jolt-hash-map kvs)) x)))))
|
||||
((cseq? x)
|
||||
(let-values (((items changed) (rdr-conv-each (seq->list x))))
|
||||
(if changed (rdr-carry-meta x (apply jolt-list items)) x)))
|
||||
(else x)))
|
||||
|
||||
;; --- the two host seams -----------------------------------------------------
|
||||
;; clojure.core/read-string: first form, or nil for blank / comment-only input
|
||||
;; (parse-string wart, matched deliberately).
|
||||
(define (jolt-read-string s)
|
||||
;; (parse-string wart, matched deliberately). jolt-read-form-raw keeps set FORMS
|
||||
;; for the compiler spine (compile-eval); the data seam converts them to sets.
|
||||
(define (jolt-read-form-raw s)
|
||||
(let-values (((form j) (rdr-read-form s 0 (string-length s))))
|
||||
(if (rdr-eof? form) jolt-nil form)))
|
||||
(define (jolt-read-string s)
|
||||
(let ((form (jolt-read-form-raw s)))
|
||||
(if (jolt-nil? form) form (rdr-form->data form))))
|
||||
|
||||
;; __parse-next: [form rest-of-string] or nil when only whitespace/comments left.
|
||||
(define (jolt-parse-next s)
|
||||
|
|
@ -539,7 +603,7 @@
|
|||
(let-values (((form j) (rdr-read-form s 0 end)))
|
||||
(if (rdr-eof? form)
|
||||
jolt-nil
|
||||
(jolt-vector form (substring s j end))))))
|
||||
(jolt-vector (rdr-form->data form) (substring s j end))))))
|
||||
|
||||
;; __read-tagged: apply a built-in data reader to an already-read form. The tag
|
||||
;; is the :#name keyword the reader produced; #uuid/#inst reuse the inst-time ctors.
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
|
|
@ -885,9 +885,9 @@
|
|||
(lambda (x form . more) (let fnrec1546 ((x x) (form form) (more (list->cseq more))) (let* ((step (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "seq?") form)) (let* ((_a$1547 (var-deref "clojure.core" "__sqcat")) (_a$1548 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "."))) (_a$1549 (jolt-invoke (var-deref "clojure.core" "__sq1") x)) (_a$1550 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-first form))) (_a$1551 (jolt-rest form))) (jolt-invoke _a$1547 _a$1548 _a$1549 _a$1550 _a$1551)) (let* ((_a$1552 (var-deref "clojure.core" "__sqcat")) (_a$1553 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "."))) (_a$1554 (jolt-invoke (var-deref "clojure.core" "__sq1") x)) (_a$1555 (jolt-invoke (var-deref "clojure.core" "__sq1") form))) (jolt-invoke _a$1552 _a$1553 _a$1554 _a$1555))))) (if (jolt-truthy? (jolt-seq more)) (let* ((_a$1556 (var-deref "clojure.core" "__sqcat")) (_a$1557 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" ".."))) (_a$1558 (jolt-invoke (var-deref "clojure.core" "__sq1") step)) (_a$1559 more)) (jolt-invoke _a$1556 _a$1557 _a$1558 _a$1559)) step)))))
|
||||
(mark-macro! "clojure.core" ".."))
|
||||
(guard (e (#t #f))
|
||||
(def-var! "clojure.core" "extends?" (letrec ((extends? (lambda (protocol atype) (let fnrec1560 ((protocol protocol) (atype atype)) (let* ((want (jolt-invoke (var-deref "clojure.core" "name") atype)) (dotted (jolt-invoke (var-deref "clojure.core" "str") "." want)) (dlen (jolt-count dotted))) (jolt-invoke (var-deref "clojure.core" "boolean") (let* ((_a$1562 (var-deref "clojure.core" "some")) (_a$1563 (lambda (t) (let fnrec1561 ((t t)) (let* ((tn (jolt-invoke (var-deref "clojure.core" "name") t))) (let* ((or__14__auto (jolt= tn want))) (if (jolt-truthy? or__14__auto) or__14__auto (let* ((and__13__auto (> (jolt-count tn) dlen))) (if (jolt-truthy? and__13__auto) (jolt= (jolt-invoke (var-deref "clojure.core" "subs") tn (- (jolt-count tn) dlen)) dotted) and__13__auto)))))))) (_a$1564 (jolt-invoke (var-deref "clojure.core" "extenders") protocol))) (jolt-invoke _a$1562 _a$1563 _a$1564)))))))) extends?)))
|
||||
(def-var! "clojure.core" "extends?" (letrec ((extends? (lambda (protocol atype) (let fnrec1560 ((protocol protocol) (atype atype)) (let* ((want (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "nil?") atype)) "nil" (jolt-invoke (var-deref "clojure.core" "name") atype))) (suffix? (lambda (long short) (let fnrec1561 ((long long) (short short)) (let* ((d (jolt-invoke (var-deref "clojure.core" "str") "." short))) (let* ((and__13__auto (let* ((_a$1562 (jolt-count long)) (_a$1563 (jolt-count d))) (> _a$1562 _a$1563)))) (if (jolt-truthy? and__13__auto) (jolt= (jolt-invoke (var-deref "clojure.core" "subs") long (let* ((_a$1564 (jolt-count long)) (_a$1565 (jolt-count d))) (- _a$1564 _a$1565))) d) and__13__auto))))))) (jolt-invoke (var-deref "clojure.core" "boolean") (let* ((_a$1567 (var-deref "clojure.core" "some")) (_a$1568 (lambda (t) (let fnrec1566 ((t t)) (let* ((tn (jolt-invoke (var-deref "clojure.core" "name") t))) (let* ((or__14__auto (jolt= tn want))) (if (jolt-truthy? or__14__auto) or__14__auto (let* ((or__14__auto (jolt-invoke suffix? tn want))) (if (jolt-truthy? or__14__auto) or__14__auto (jolt-invoke suffix? want tn))))))))) (_a$1569 (jolt-invoke (var-deref "clojure.core" "extenders") protocol))) (jolt-invoke _a$1567 _a$1568 _a$1569)))))))) extends?)))
|
||||
(guard (e (#t #f))
|
||||
(def-var! "clojure.core" "extend" (letrec ((extend (lambda (atype . proto+mmaps) (let fnrec1565 ((atype atype) (proto+mmaps (list->cseq proto+mmaps))) (let* ((s (jolt-seq proto+mmaps))) (let loop1566 ((s s)) (if (jolt-truthy? s) (begin (let* ((proto (jolt-first s)) (mmap (jolt-invoke (var-deref "clojure.core" "second") s)) (pname (jolt-invoke (var-deref "clojure.core" "name") (jolt-get proto (keyword #f "name"))))) (begin (jolt-count (jolt-map (lambda (G__25) (let fnrec1567 ((G__25 G__25)) (let* ((G__26 G__25) (k (jolt-nth G__26 0 jolt-nil)) (f (jolt-nth G__26 1 jolt-nil))) (begin (let* ((_a$1568 (var-deref "clojure.core" "register-method")) (_a$1569 (jolt-invoke (var-deref "clojure.core" "name") atype)) (_a$1570 pname) (_a$1571 (jolt-invoke (var-deref "clojure.core" "name") k)) (_a$1572 f)) (jolt-invoke _a$1568 _a$1569 _a$1570 _a$1571 _a$1572)) jolt-nil)))) mmap)) jolt-nil)) (loop1566 (jolt-invoke (var-deref "clojure.core" "nnext") s))) jolt-nil))))))) extend)))
|
||||
(def-var! "clojure.core" "extend" (letrec ((extend (lambda (atype . proto+mmaps) (let fnrec1570 ((atype atype) (proto+mmaps (list->cseq proto+mmaps))) (let* ((tname (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "nil?") atype)) "nil" (jolt-invoke (var-deref "clojure.core" "name") atype)))) (let* ((s (jolt-seq proto+mmaps))) (let loop1571 ((s s)) (if (jolt-truthy? s) (begin (let* ((proto (jolt-first s)) (mmap (jolt-invoke (var-deref "clojure.core" "second") s)) (pname (jolt-invoke (var-deref "clojure.core" "name") (jolt-get proto (keyword #f "name"))))) (begin (jolt-count (jolt-map (lambda (G__25) (let fnrec1572 ((G__25 G__25)) (let* ((G__26 G__25) (k (jolt-nth G__26 0 jolt-nil)) (f (jolt-nth G__26 1 jolt-nil))) (begin (jolt-invoke (var-deref "clojure.core" "register-method") tname pname (jolt-invoke (var-deref "clojure.core" "name") k) f) jolt-nil)))) mmap)) jolt-nil)) (loop1571 (jolt-invoke (var-deref "clojure.core" "nnext") s))) jolt-nil)))))))) extend)))
|
||||
(guard (e (#t #f))
|
||||
(def-var! "clojure.core" "extend-type"
|
||||
(lambda (tsym . body) (let fnrec1573 ((tsym tsym) (body (list->cseq body))) (let* ((tname (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "nil?") tsym)) "nil" (jolt-invoke (var-deref "clojure.core" "name") tsym)))) (let* ((items (jolt-seq body)) (proto jolt-nil) (forms (jolt-vector))) (let loop1574 ((items items) (proto proto) (forms forms)) (if (jolt-empty? items) (jolt-invoke (var-deref "clojure.core" "__sqcat") (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol #f "do")) forms) (let* ((x (jolt-first items))) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "symbol?") x)) (let* ((_a$1575 (jolt-rest items)) (_a$1576 (jolt-invoke (var-deref "clojure.core" "name") x)) (_a$1577 forms)) (loop1574 _a$1575 _a$1576 _a$1577)) (let* ((_a$1588 (jolt-rest items)) (_a$1589 proto) (_a$1590 (jolt-conj forms (let* ((_a$1582 (var-deref "clojure.core" "__sqcat")) (_a$1583 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "register-method"))) (_a$1584 (jolt-invoke (var-deref "clojure.core" "__sq1") tname)) (_a$1585 (jolt-invoke (var-deref "clojure.core" "__sq1") proto)) (_a$1586 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-invoke (var-deref "clojure.core" "name") (jolt-first x)))) (_a$1587 (jolt-invoke (var-deref "clojure.core" "__sq1") (let* ((_a$1578 (var-deref "clojure.core" "__sqcat")) (_a$1579 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-symbol "clojure.core" "fn"))) (_a$1580 (jolt-invoke (var-deref "clojure.core" "__sq1") (jolt-nth x 1))) (_a$1581 (jolt-drop 2 x))) (jolt-invoke _a$1578 _a$1579 _a$1580 _a$1581))))) (jolt-invoke _a$1582 _a$1583 _a$1584 _a$1585 _a$1586 _a$1587))))) (loop1574 _a$1588 _a$1589 _a$1590)))))))))))
|
||||
|
|
|
|||
|
|
@ -380,31 +380,35 @@
|
|||
step)))
|
||||
|
||||
;; True when atype's methods were registered for this protocol (via extend /
|
||||
;; extend-type). Tags are canonical host names or ns-qualified record names,
|
||||
;; so a bare record name also matches its "ns.Name" tag.
|
||||
;; extend-type). Tags are canonical host names or ns-qualified record names, so a
|
||||
;; name matches its tag when either is a dotted suffix of the other — a bare
|
||||
;; record name matches its "ns.Name" tag, and a query for a qualified host class
|
||||
;; (java.util.Map) matches the canonical short tag (Map) extend registered it as.
|
||||
(defn extends? [protocol atype]
|
||||
(let [want (name atype)
|
||||
dotted (str "." want)
|
||||
dlen (count dotted)]
|
||||
(let [want (if (nil? atype) "nil" (name atype))
|
||||
suffix? (fn [long short]
|
||||
(let [d (str "." short)]
|
||||
(and (> (count long) (count d))
|
||||
(= (subs long (- (count long) (count d))) d))))]
|
||||
(boolean (some (fn [t]
|
||||
(let [tn (name t)]
|
||||
(or (= tn want)
|
||||
(and (> (count tn) dlen)
|
||||
(= (subs tn (- (count tn) dlen)) dotted)))))
|
||||
(or (= tn want) (suffix? tn want) (suffix? want tn))))
|
||||
(extenders protocol)))))
|
||||
|
||||
;; extend, the FUNCTION (extend-type's runtime sibling): protocol + method-map
|
||||
;; pairs, methods registered under the type's (canonicalized) name — so
|
||||
;; (extend 'String P {:m (fn [x] ...)}) dispatches exactly like extend-type.
|
||||
(defn extend [atype & proto+mmaps]
|
||||
(loop [s (seq proto+mmaps)]
|
||||
(when s
|
||||
(let [proto (first s)
|
||||
mmap (second s)
|
||||
pname (name (get proto :name))]
|
||||
(doseq [[k f] mmap]
|
||||
(register-method (name atype) pname (name k) f)))
|
||||
(recur (nnext s)))))
|
||||
;; nil extends on nil values; its host tag is the string "nil" (as extend-type).
|
||||
(let [tname (if (nil? atype) "nil" (name atype))]
|
||||
(loop [s (seq proto+mmaps)]
|
||||
(when s
|
||||
(let [proto (first s)
|
||||
mmap (second s)
|
||||
pname (name (get proto :name))]
|
||||
(doseq [[k f] mmap]
|
||||
(register-method tname pname (name k) f)))
|
||||
(recur (nnext s))))))
|
||||
|
||||
(defmacro extend-type [tsym & body]
|
||||
;; register-method is a fn (clojure.core); pass type/protocol/method NAMES as
|
||||
|
|
|
|||
|
|
@ -516,6 +516,9 @@
|
|||
;; jolt.passes.numeric types a call to it (an accumulator over the result).
|
||||
:var (cond-> (var-ref (:ns r) (:name r)) (:num-ret r) (assoc :num-ret (:num-ret r)))
|
||||
:host (host-ref (:name r))
|
||||
;; a class-name symbol (java.util.Map) self-evaluates to its name
|
||||
;; string — jolt models a class as its name, with no JVM classes.
|
||||
:class (const (:name r))
|
||||
;; :unresolved — emitting a var-ref here would auto-intern an
|
||||
;; UNBOUND var, so a typo'd symbol would die later as 'Cannot call
|
||||
;; nil as a function' with no hint which symbol.
|
||||
|
|
|
|||
|
|
@ -2953,4 +2953,36 @@
|
|||
{:suite "conformance / defmacro surface + syntax-quote/ns (enabling real clojure libs)" :label "syntax-quote resolves alias" :expected "\"HI\"" :actual "(do (ns sq.lib (:require [clojure.string :as s])) (defmacro up [x] `(s/upper-case ~x)) (in-ns (quote user)) (sq.lib/up \"hi\"))"}
|
||||
{:suite "conformance / defmacro surface + syntax-quote/ns (enabling real clojure libs)" :label "ns name with ^{:map} meta" :expected "5" :actual "(do (ns ^{:author \"a\" :doc \"d\"} nm.meta) (def q 5) (in-ns (quote user)) nm.meta/q)"}
|
||||
{:suite "conformance / defmacro surface + syntax-quote/ns (enabling real clojure libs)" :label "unquote *ns* in template" :expected "true" :actual "(do (defmacro cur-ns [] `(str ~*ns*)) (string? (cur-ns)))"}
|
||||
{:suite "reader / read-string constructs sets" :label "top-level set" :expected "true" :actual "(set? (read-string \"#{:a :b}\"))"}
|
||||
{:suite "reader / read-string constructs sets" :label "set value equals" :expected "true" :actual "(= #{1 2} (read-string \"#{1 2}\"))"}
|
||||
{:suite "reader / read-string constructs sets" :label "set nested in map" :expected "true" :actual "(set? (:k (read-string \"{:k #{:a :b}}\")))"}
|
||||
{:suite "reader / read-string constructs sets" :label "set nested in vector" :expected "true" :actual "(set? (first (read-string \"[#{:a}]\")))"}
|
||||
{:suite "reader / read-string constructs sets" :label "set nested in list" :expected "true" :actual "(set? (first (read-string \"(#{:a})\")))"}
|
||||
{:suite "reader / read-string constructs sets" :label "set keeps reader metadata" :expected "true" :actual "(:s (meta (read-string \"^:s #{1 2}\")))"}
|
||||
{:suite "reader / read-string constructs sets" :label "set of sets" :expected "true" :actual "(every? set? (read-string \"#{#{1} #{2}}\"))"}
|
||||
{:suite "io / str & format" :label "format %x lowercase" :expected "\"ff\"" :actual "(format \"%x\" 255)"}
|
||||
{:suite "io / str & format" :label "format %04x zero-pad lower" :expected "\"00ff\"" :actual "(format \"%04x\" 255)"}
|
||||
{:suite "io / str & format" :label "format %X uppercase" :expected "\"00FF\"" :actual "(format \"%04X\" 255)"}
|
||||
{:suite "io / str & format" :label "format %x wide hex" :expected "\"deadbeef\"" :actual "(format \"%x\" 3735928559)"}
|
||||
{:suite "protocols / extend & extends? on nil" :label "extend nil dispatches" :expected ":nil-via-extend" :actual "(do (defprotocol P2 (q [this])) (extend nil P2 {:q (fn [_] :nil-via-extend)}) (q nil))"}
|
||||
{:suite "protocols / extend & extends? on nil" :label "extends? nil when extended" :expected "true" :actual "(do (defprotocol Pe (pe [this])) (extend nil Pe {:pe (fn [_] :x)}) (extends? Pe nil))"}
|
||||
{:suite "protocols / extend & extends? on nil" :label "extends? nil when not extended" :expected "false" :actual "(do (defprotocol P3 (r [this])) (extends? P3 nil))"}
|
||||
{:suite "protocols / extend & extends? on nil" :label "extend-type nil still works" :expected ":via-type" :actual "(do (defprotocol P4 (s [this])) (extend-type nil P4 (s [_] :via-type)) (s nil))"}
|
||||
{:suite "protocols / extend on host classes" :label "dispatch by java.util.Map/Collection/CharSequence" :expected "[:map :coll :str :obj]" :actual "(do (defprotocol W (-w [x])) (extend java.util.Map W {:-w (fn [_] :map)}) (extend java.util.Collection W {:-w (fn [_] :coll)}) (extend java.lang.CharSequence W {:-w (fn [_] :str)}) (extend java.lang.Object W {:-w (fn [_] :obj)}) [(-w {:a 1}) (-w [1 2]) (-w \"s\") (-w 42)])"}
|
||||
{:suite "protocols / extend on host classes" :label "satisfies? via java.util.Map" :expected "true" :actual "(do (defprotocol Q (qq [x])) (extend java.util.Map Q {:qq (fn [_] :m)}) (satisfies? Q {}))"}
|
||||
{:suite "protocols / extend on host classes" :label "extends? on a qualified host class" :expected "true" :actual "(do (defprotocol Qe (qe [x])) (extend java.util.Collection Qe {:qe (fn [_] :c)}) (extends? Qe java.util.Collection))"}
|
||||
{:suite "interop / instance? on host interfaces" :label "keyword is Named" :expected "true" :actual "(instance? clojure.lang.Named :a)"}
|
||||
{:suite "interop / instance? on host interfaces" :label "string is CharSequence" :expected "true" :actual "(instance? java.lang.CharSequence \"s\")"}
|
||||
{:suite "interop / instance? on host interfaces" :label "number is Number" :expected "true" :actual "(instance? java.lang.Number 42)"}
|
||||
{:suite "interop / instance? on host interfaces" :label "map is java.util.Map" :expected "true" :actual "(instance? java.util.Map {:a 1})"}
|
||||
{:suite "interop / instance? on host interfaces" :label "vector is java.util.List" :expected "true" :actual "(instance? java.util.List [1 2])"}
|
||||
{:suite "interop / instance? on host interfaces" :label "list is java.util.Collection" :expected "true" :actual "(instance? java.util.Collection (list 1))"}
|
||||
{:suite "interop / instance? on host interfaces" :label "set is java.util.Set" :expected "true" :actual "(instance? java.util.Set #{1})"}
|
||||
{:suite "interop / instance? on host interfaces" :label "map is not a Collection" :expected "false" :actual "(instance? java.util.Collection {:a 1})"}
|
||||
{:suite "interop / instance? on host interfaces" :label "vector is Associative" :expected "true" :actual "(instance? clojure.lang.Associative [1])"}
|
||||
{:suite "interop / instance? on host interfaces" :label "string is not Number" :expected "false" :actual "(instance? java.lang.Number \"s\")"}
|
||||
{:suite "interop / String & StringBuilder char ops" :label "String from char-array slice" :expected "\"abc\"" :actual "(String. (char-array [\\a \\b \\c \\d]) 0 3)"}
|
||||
{:suite "interop / String & StringBuilder char ops" :label "str of StringBuilder" :expected "\"hi\"" :actual "(let [sb (StringBuilder.)] (.append sb \"hi\") (str sb))"}
|
||||
{:suite "interop / String & StringBuilder char ops" :label "append subsequence" :expected "\"bcd\"" :actual "(let [sb (StringBuilder.)] (.append sb \"abcde\" 1 4) (.toString sb))"}
|
||||
{:suite "interop / String & StringBuilder char ops" :label "String.getChars into buffer" :expected "\"abc\"" :actual "(let [a (char-array 4)] (.getChars \"abcd\" 0 3 a 0) (String. a 0 3))"}
|
||||
]
|
||||
|
|
|
|||
|
|
@ -316,8 +316,8 @@
|
|||
{:suite "reader" :expr "(= [1 2 3] (read-string \"[1 2 3]\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(= (quote (+ 1 2)) (read-string \"(+ 1 2)\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(= {:a 1 :b 2} (read-string \"{:a 1 :b 2}\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(:value (read-string \"#{1 2 3}\"))" :expected "[1 2 3]"}
|
||||
{:suite "reader" :expr "(= :jolt/set (:jolt/type (read-string \"#{1 2 3}\")))" :expected "true"}
|
||||
{:suite "reader" :expr "(set? (read-string \"#{1 2 3}\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(= #{1 2 3} (read-string \"#{1 2 3}\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(= [1 [2 3] {:k :v}] (read-string \"[1 [2 3] {:k :v}]\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(= (quote (quote x)) (read-string \"'x\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(= (quote (clojure.core/deref a)) (read-string \"@a\"))" :expected "true"}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue