Merge pull request #189 from jolt-lang/spike/auto-resolved-keywords
Auto-resolved keywords, edn reader opts, and related reader/runtime fixes
This commit is contained in:
Dmitri Sotnikov
GitHub
commit
5b55c7f7b0
25 changed files with 948 additions and 748 deletions
|
|
@ -59,8 +59,9 @@ keyword := ':' name | ':' ns '/' name | '::' name | '::' alias '/' name
|
|||
. $ & %` (with `%` and `&` further constrained inside `#()`); a symbol
|
||||
MUST NOT begin with a digit; `.` and `/` have positional restrictions.
|
||||
- S7. `::kw` MUST resolve to the current namespace at *read* time
|
||||
(`::k` in ns `user` reads as `:user/k`); `::alias/k` resolves the alias or
|
||||
MUST be a read error if the alias does not exist.
|
||||
(`::k` in ns `user` reads as `:user/k`); `::alias/k` resolves `alias` through
|
||||
the current namespace's aliases. (Clojure raises a read error for an unknown
|
||||
alias; jolt reads it as `:alias/k`.)
|
||||
|
||||
### Strings and characters
|
||||
|
||||
|
|
|
|||
|
|
@ -46,7 +46,8 @@ HELLO FROM A BUILT BINARY!
|
|||
args: [alpha bb ccc]
|
||||
sum: 10
|
||||
greet-default: greet:default
|
||||
greet-loud: greet:loud'
|
||||
greet-loud: greet:loud
|
||||
greet-soft: greet:soft'
|
||||
if [ "$got" != "$want" ]; then
|
||||
echo " FAIL: binary output mismatch"
|
||||
echo "--- want ---"; echo "$want"
|
||||
|
|
|
|||
|
|
@ -185,10 +185,26 @@
|
|||
(let loop ((xs (cdr items)))
|
||||
(when (and (pair? xs) (pair? (cdr xs)))
|
||||
(let ((k (car xs)) (v (cadr xs)))
|
||||
(when (and (keyword? k) (string=? (keyword-t-name k) "as") (symbol-t? v))
|
||||
(emit! (string-append "(chez-register-alias! " (ei-str-lit ns-name)
|
||||
" " (ei-str-lit (symbol-t-name v))
|
||||
" " (ei-str-lit target) ")"))))
|
||||
(when (keyword? k)
|
||||
(cond
|
||||
((and (string=? (keyword-t-name k) "as") (symbol-t? v))
|
||||
(emit! (string-append "(chez-register-alias! " (ei-str-lit ns-name)
|
||||
" " (ei-str-lit (symbol-t-name v))
|
||||
" " (ei-str-lit target) ")")))
|
||||
;; :refer [a b] / :refer :all — a defmethod on a referred multifn
|
||||
;; resolves the bare name through the refer table at runtime.
|
||||
((or (string=? (keyword-t-name k) "refer") (string=? (keyword-t-name k) "only"))
|
||||
(cond
|
||||
((and (keyword? v) (string=? (keyword-t-name v) "all"))
|
||||
(emit! (string-append "(chez-register-refer-all! " (ei-str-lit ns-name)
|
||||
" " (ei-str-lit target) ")")))
|
||||
((or (pvec? v) (and (cseq? v) (cseq-list? v)))
|
||||
(for-each (lambda (n)
|
||||
(when (symbol-t? n)
|
||||
(emit! (string-append "(chez-register-refer! " (ei-str-lit ns-name)
|
||||
" " (ei-str-lit (symbol-t-name n))
|
||||
" " (ei-str-lit target) ")"))))
|
||||
(seq->list v))))))))
|
||||
(loop (cddr xs))))))))
|
||||
|
||||
(define (bld-ns-prelude ns-name src)
|
||||
|
|
|
|||
|
|
@ -25,3 +25,6 @@
|
|||
|
||||
;; *print-readably* — bound by pr-family / with-out-str-style code; default true.
|
||||
(def-var! "clojure.core" "*print-readably*" #t)
|
||||
|
||||
;; *print-meta* — when true, pr prints metadata with a ^ prefix; default false.
|
||||
(def-var! "clojure.core" "*print-meta*" #f)
|
||||
|
|
|
|||
|
|
@ -59,6 +59,10 @@
|
|||
;; that fails to emit) and `jolt build` (bld-emit-ns: optimize? #t, guard? #f —
|
||||
;; strict, a failing form errors the build).
|
||||
(define (ei-emit-ns* ns-name src optimize? guard?)
|
||||
;; set the ns before reading so ::kw auto-resolves against this ns (the runtime
|
||||
;; loader reads form-by-form after the ns form sets it; the cross-compile reads
|
||||
;; all forms up front, so set it here).
|
||||
(set-chez-ns! ns-name)
|
||||
(let loop ((forms (ei-read-all src)) (acc '()))
|
||||
(if (null? forms)
|
||||
(reverse acc)
|
||||
|
|
@ -92,6 +96,7 @@
|
|||
;; record whose refs are roots. A macro is prunable — its expander isn't called at
|
||||
;; runtime in an AOT build.
|
||||
(define (ei-emit-ns-records ns-name src)
|
||||
(set-chez-ns! ns-name) ; ::kw resolves against this ns (see ei-emit-ns*)
|
||||
(let loop ((forms (ei-read-all src)) (acc '()))
|
||||
(if (null? forms)
|
||||
(reverse acc)
|
||||
|
|
|
|||
|
|
@ -86,6 +86,10 @@
|
|||
(define (hc-sym-meta x)
|
||||
(let ((m (symbol-t-meta x)))
|
||||
(if (and m (not (jolt-nil? m)) (not (null? m))) m jolt-nil)))
|
||||
;; Metadata the reader attached to a collection literal (vec/map/set/list), or
|
||||
;; jolt-nil. The analyzer re-emits a runtime (with-meta ..) for a meta-carrying
|
||||
;; vector/map/set so the value keeps its metadata.
|
||||
(define (hc-coll-meta x) (jolt-meta x))
|
||||
|
||||
;; list items -> jolt vector (pvec); the analyzer mapv's over the result.
|
||||
(define (hc-elements x)
|
||||
|
|
@ -327,6 +331,7 @@
|
|||
(def-var! "jolt.host" "form-sym-name" hc-sym-name)
|
||||
(def-var! "jolt.host" "form-sym-ns" hc-sym-ns)
|
||||
(def-var! "jolt.host" "form-sym-meta" hc-sym-meta)
|
||||
(def-var! "jolt.host" "form-coll-meta" hc-coll-meta)
|
||||
(def-var! "jolt.host" "form-list?" hc-list?)
|
||||
(def-var! "jolt.host" "form-vec?" hc-vec?)
|
||||
(def-var! "jolt.host" "form-map?" hc-map?)
|
||||
|
|
|
|||
|
|
@ -218,6 +218,12 @@
|
|||
;; state: a vector #(wrapped-reader pushed-list)
|
||||
(register-class-ctor! "PushbackReader"
|
||||
(lambda (rdr . _) (make-jhost "pushback-reader" (vector rdr '()))))
|
||||
;; LineNumberingPushbackReader: a pushback-reader (jolt doesn't track line
|
||||
;; numbers; getLineNumber is a stub for error-reporting paths that read it).
|
||||
(register-class-ctor! "LineNumberingPushbackReader"
|
||||
(lambda (rdr . _) (make-jhost "pushback-reader" (vector rdr '()))))
|
||||
(register-class-ctor! "clojure.lang.LineNumberingPushbackReader"
|
||||
(lambda (rdr . _) (make-jhost "pushback-reader" (vector rdr '()))))
|
||||
(define (read-unit r) ; read one code unit (flonum) from any reader, -1 at EOF
|
||||
(record-method-dispatch r "read" jolt-nil))
|
||||
(register-host-methods! "pushback-reader"
|
||||
|
|
@ -230,7 +236,8 @@
|
|||
(vector-set! (jhost-state self) 1
|
||||
(cons (if (char? ch) (->num (char->integer ch)) ch) (vector-ref (jhost-state self) 1)))
|
||||
jolt-nil))
|
||||
(cons "close" (lambda (self) jolt-nil))))
|
||||
(cons "close" (lambda (self) jolt-nil))
|
||||
(cons "getLineNumber" (lambda (self) 0))))
|
||||
|
||||
;; ---- StringTokenizer --------------------------------------------------------
|
||||
;; state: a vector #(tokens-list pos)
|
||||
|
|
@ -499,5 +506,37 @@
|
|||
(def-var! "clojure.core" "__register-instance-check!"
|
||||
(lambda (f) (set! user-instance-checks (append user-instance-checks (list f))) jolt-nil))
|
||||
|
||||
;; (instance? clojure.lang.IFoo x) for the core clojure.lang interfaces libraries
|
||||
;; branch on — jolt's value model satisfies them, so report it. Matched by the
|
||||
;; interface's last dotted segment, so "clojure.lang.IObj" and "IObj" both hit.
|
||||
(define (hsc-last-segment 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))))))
|
||||
;; values that carry metadata (mirrors jolt-with-meta's set in natives-meta.ss).
|
||||
(define (hsc-imeta? x)
|
||||
(or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x)
|
||||
(jolt-lazyseq? x) (jrec? x) (procedure? x) (symbol-t? x)))
|
||||
(register-instance-check-arm!
|
||||
(lambda (type-sym val)
|
||||
(let ((iface (hsc-last-segment (symbol-t-name type-sym))))
|
||||
(let ((hit (cond
|
||||
((or (string=? iface "IObj") (string=? iface "IMeta")) (hsc-imeta? val))
|
||||
((or (string=? iface "IMapEntry") (string=? iface "MapEntry")) (jolt-map-entry? val))
|
||||
((string=? iface "IRecord") (jrec? val))
|
||||
((string=? iface "IPersistentMap") (or (pmap? val) (htable-sorted-map? val)))
|
||||
((string=? iface "IPersistentVector") (and (pvec? val) (not (jolt-map-entry? val))))
|
||||
((string=? iface "IPersistentSet") (or (pset? val) (htable-sorted-set? val)))
|
||||
((or (string=? iface "ISeq") (string=? iface "Seqable"))
|
||||
(or (cseq? val) (empty-list-t? val) (jolt-lazyseq? val)))
|
||||
((string=? iface "Sequential")
|
||||
(or (pvec? val) (cseq? val) (empty-list-t? val) (jolt-lazyseq? val)))
|
||||
((string=? iface "IFn")
|
||||
(or (procedure? val) (keyword? val) (symbol-t? val)
|
||||
(pmap? val) (pset? val) (pvec? val)))
|
||||
(else 'none))))
|
||||
(if (eq? hit 'none) 'pass (if hit #t #f))))))
|
||||
|
||||
;; (jolt.host/table? x) — is x a host tagged-table?
|
||||
(def-var! "jolt.host" "table?" (lambda (x) (if (htable? x) #t #f)))
|
||||
|
|
|
|||
|
|
@ -388,3 +388,11 @@
|
|||
((string=? method-name "after") (> (jinst-ms obj) (ms-of (car (seq->list rest-args)))))
|
||||
(else (error #f (string-append "No method " method-name " on Date")))))
|
||||
(else (%it-rmd obj method-name rest-args)))))
|
||||
|
||||
;; Clojure's built-in data readers, so a library that merges default-data-readers
|
||||
;; or binds *data-readers* (e.g. aero's reader opts) resolves #inst / #uuid.
|
||||
;; Keyed by symbol, like Clojure. *data-readers* is the bindable user table.
|
||||
(def-var! "clojure.core" "default-data-readers"
|
||||
(jolt-hash-map (jolt-symbol #f "inst") jolt-inst-from-string
|
||||
(jolt-symbol #f "uuid") jolt-uuid-from-string))
|
||||
(def-var! "clojure.core" "*data-readers*" empty-pmap)
|
||||
|
|
|
|||
|
|
@ -100,6 +100,7 @@
|
|||
((string=? name "exists") (list (if (file-exists? p) #t #f)))
|
||||
((string=? name "isDirectory") (list (if (file-directory? p) #t #f)))
|
||||
((string=? name "isFile") (list (if (and (file-exists? p) (not (file-directory? p))) #t #f)))
|
||||
((string=? name "isAbsolute") (list (if (and (> (string-length p) 0) (char=? (string-ref p 0) #\/)) #t #f)))
|
||||
((string=? name "listFiles") (list (list->cseq (map make-jfile (jolt-list-dir p)))))
|
||||
((string=? name "getParent")
|
||||
(let loop ((i (- (string-length p) 1)))
|
||||
|
|
@ -211,7 +212,7 @@
|
|||
;; a byte input-stream shim (e.g. clj-http-lite's :as :stream body): drain it.
|
||||
((and (htable? src) (jolt-truthy? (jolt-ref-get src (keyword "jolt" "input-stream"))))
|
||||
(decode-bytevector (drain-byte-stream src) (slurp-encoding opts)))
|
||||
((string? src) (read-file-string src))
|
||||
((string? src) (read-file-string (project-relative src)))
|
||||
(else (error #f "slurp: unsupported source" src))))
|
||||
|
||||
(define (spit-append? opts)
|
||||
|
|
@ -300,7 +301,7 @@
|
|||
((embedded-res? x) (host-new "StringReader" (embedded-res-content x)))
|
||||
((and (jhost? x) (string=? (jhost-tag x) "url"))
|
||||
(host-new "StringReader" (read-file-string (url-strip-scheme (url-spec x)))))
|
||||
((string? x) (host-new "StringReader" (read-file-string x)))
|
||||
((string? x) (host-new "StringReader" (read-file-string (project-relative x))))
|
||||
((or (cseq? x) (empty-list-t? x) (pvec? x))
|
||||
(host-new "StringReader" (seq-source->string x)))
|
||||
(else (host-new "StringReader" (jolt-str-render-one x)))))
|
||||
|
|
|
|||
|
|
@ -73,8 +73,14 @@
|
|||
(sns (symbol-t-ns mm-sym))
|
||||
(qns (and sns (not (jolt-nil? sns)) (not (null? sns)) sns))
|
||||
;; qualified (cf.mm/ext) resolves in its own ns (cross-ns defmethod);
|
||||
;; unqualified stays in the current ns (a shadow, as before).
|
||||
(mns (if qns (or (chez-resolve-alias (chez-current-ns) qns) qns) (chez-current-ns)))
|
||||
;; unqualified resolves in the current ns, else a :refer's home ns (so a
|
||||
;; defmethod on a referred multifn lands on the real one), else stays in
|
||||
;; the current ns (a shadow, as before).
|
||||
(mns (cond
|
||||
(qns (or (chez-resolve-alias (chez-current-ns) qns) qns))
|
||||
((var-cell-lookup (chez-current-ns) nm) (chez-current-ns))
|
||||
((chez-resolve-refer (chez-current-ns) nm) => values)
|
||||
(else (chez-current-ns))))
|
||||
(cur (var-deref mns nm))
|
||||
(mf (if (jolt-multifn? cur) cur
|
||||
;; auto-create: copy the dispatch fn + default from a same-named
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@
|
|||
(jolt-assoc (if user user (jolt-hash-map))
|
||||
jolt-kw-var-ns (var-cell-ns x)
|
||||
jolt-kw-var-name (var-cell-name x))))
|
||||
((or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jrec? x) (procedure? x))
|
||||
((or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jolt-lazyseq? x) (jrec? x) (procedure? x))
|
||||
(hashtable-ref meta-table x jolt-nil))
|
||||
(else jolt-nil)))
|
||||
|
||||
|
|
@ -36,7 +36,7 @@
|
|||
(define (jolt-with-meta x m)
|
||||
(cond
|
||||
((symbol-t? x) (make-symbol-t (symbol-t-ns x) (symbol-t-name x) m))
|
||||
((or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jrec? x) (procedure? x))
|
||||
((or (pvec? x) (pmap? x) (pset? x) (cseq? x) (empty-list-t? x) (jolt-lazyseq? x) (jrec? x) (procedure? x))
|
||||
(let ((c (meta-copy x)))
|
||||
(if (jolt-nil? m) (hashtable-delete! meta-table c) (hashtable-set! meta-table c m))
|
||||
c))
|
||||
|
|
|
|||
|
|
@ -82,6 +82,13 @@
|
|||
(else d))))
|
||||
(define (jtagged-pr t) (string-append "#" (jolt-pr-str (jtagged-tag t)) " " (jolt-pr-readable (jtagged-form t))))
|
||||
(register-pr-arm! jtagged? jtagged-pr)
|
||||
;; two tagged literals are = iff same tag and (recursively) = form, like the JVM's
|
||||
;; TaggedLiteral — so they work as map keys / set members. (jolt-hash already
|
||||
;; hashes the fields structurally, so eq/hash stay consistent.)
|
||||
(register-eq-arm! (lambda (a b) (or (jtagged? a) (jtagged? b)))
|
||||
(lambda (a b) (and (jtagged? a) (jtagged? b)
|
||||
(jolt=2 (jtagged-tag a) (jtagged-tag b))
|
||||
(jolt=2 (jtagged-form a) (jtagged-form b)))))
|
||||
(def-var! "clojure.core" "tagged-literal" jolt-tagged-literal)
|
||||
;; tagged-literal? is OVERLAY (reads :jolt/type) — asserted in post-prelude.ss.
|
||||
|
||||
|
|
|
|||
|
|
@ -64,12 +64,14 @@
|
|||
;; realized? reads :jolt/type and throws on a jolt-lazyseq record.
|
||||
((jolt-lazyseq? x) (jolt-lazyseq-realized? x))
|
||||
(else (jolt-invoke overlay-realized? x))))))
|
||||
;; clojure.edn/read over a reader: the overlay edn.clj drain-reader reads
|
||||
;; :jolt/type; the native version (io.ss) drains the jhost reader instead.
|
||||
;; clojure.edn/read over a reader: drain the jhost reader, then read through the
|
||||
;; overlay read-string so the opts map (:readers/:default/:eof) is honored.
|
||||
(def-var! "clojure.edn" "read"
|
||||
(case-lambda
|
||||
((reader) (chez-edn-read reader))
|
||||
((opts reader) (chez-edn-read reader))))
|
||||
((opts reader)
|
||||
(jolt-invoke (var-deref "clojure.edn" "read-string") opts
|
||||
(if (reader-jhost? reader) (drain-reader reader) (jolt-str-render-one reader))))))
|
||||
;; line-seq: a jhost reader (io/reader result) -> drain+split; a map-reader (the
|
||||
;; overlay's :read-line-fn model, e.g. with-in-str) -> the overlay version.
|
||||
(let ((overlay-line-seq (var-deref "clojure.core" "line-seq")))
|
||||
|
|
|
|||
|
|
@ -67,12 +67,31 @@
|
|||
(if (jolt-nil? s) (reverse acc)
|
||||
(loop (jolt-seq (seq-more s)) (cons (jolt-pr-readable (seq-first s)) acc))))) ")"))
|
||||
(else (jolt-pr-str x))))
|
||||
(define (jolt-pr-readable x)
|
||||
(define (jolt-pr-readable-dispatch x)
|
||||
(let loop ((as jolt-pr-readable-arms))
|
||||
(cond ((null? as) (jolt-pr-readable-base x))
|
||||
(((caar as) x) ((cdar as) x))
|
||||
(else (loop (cdr as))))))
|
||||
|
||||
;; *print-meta* support. The var is def'd after this file loads, so capture its
|
||||
;; cell lazily; jolt-var-get (patched by dyn-binding.ss) honors a `binding`.
|
||||
(define pr-meta-cell #f)
|
||||
(define (pr-print-meta?)
|
||||
(unless pr-meta-cell (set! pr-meta-cell (jolt-var "clojure.core" "*print-meta*")))
|
||||
(jolt-truthy? (jolt-var-get pr-meta-cell)))
|
||||
;; The metadata to print before x, or jolt-nil. A var prints as #'ns/name (its
|
||||
;; {:ns :name} is derived, not user metadata) and a procedure is opaque — skip both.
|
||||
(define (pr-user-meta x)
|
||||
(if (or (var-cell? x) (procedure? x)) jolt-nil (jolt-meta x)))
|
||||
|
||||
(define (jolt-pr-readable x)
|
||||
(if (pr-print-meta?)
|
||||
(let ((m (pr-user-meta x)))
|
||||
(if (jolt-nil? m)
|
||||
(jolt-pr-readable-dispatch x)
|
||||
(string-append "^" (jolt-pr-readable-dispatch m) " " (jolt-pr-readable-dispatch x))))
|
||||
(jolt-pr-readable-dispatch x)))
|
||||
|
||||
;; __pr-str1: render ONE value readably (the overlay's pr-str joins these).
|
||||
(define (jolt-pr-str1 x) (jolt-pr-readable x))
|
||||
|
||||
|
|
|
|||
|
|
@ -290,20 +290,22 @@
|
|||
((symbol-t? target)
|
||||
(make-symbol-t (symbol-t-ns target) (symbol-t-name target)
|
||||
(rdr-merge-meta (symbol-t-meta target) meta)))
|
||||
;; A LIST form is code: ^Type (expr) is a compile-time hint on the FORM, not a
|
||||
;; runtime operation. Attach the metadata to the form itself (so a quoted list
|
||||
;; keeps it and the analyzer can read :tag) — never lower to a runtime
|
||||
;; (with-meta (expr) meta), which would mis-apply the hint to the call's RESULT
|
||||
;; and throw when that result is a string/number (e.g. ^String (to-str x)).
|
||||
;; Matches Clojure: a tag hint on an evaluated form is discarded at runtime.
|
||||
((cseq? target) (jolt-with-meta target meta))
|
||||
((empty-list-t? target) target)
|
||||
;; A vector/map/set LITERAL: Clojure attaches the metadata to the runtime value
|
||||
;; ((meta ^{:tag :int} [1 2]) / ^:foo {}), so lower to a runtime (with-meta form
|
||||
;; meta). Use the BARE `with-meta` symbol (ns #f) — the fn/defn macros unwrap a
|
||||
;; (with-meta <arglist-vec> _) return-hint by matching the unqualified head, so a
|
||||
;; qualified clojure.core/with-meta would slip past them (^bytes [b]).
|
||||
(else (jolt-list (jolt-symbol #f "with-meta") target meta))))
|
||||
;; Lists/vectors/maps/sets attach metadata to the value itself, as Clojure's
|
||||
;; reader does. Reading DATA (read-string, edn) then preserves it. A list form
|
||||
;; is code: ^Type (expr) is a compile-time hint on the FORM, read off the form
|
||||
;; for :tag and discarded at runtime (a hint on an evaluated form is dropped).
|
||||
;; A vector/map/set LITERAL keeps it as a runtime value: the analyzer re-emits a
|
||||
;; (with-meta form meta) for a meta-carrying collection literal in code, so
|
||||
;; (meta ^{:tag :int} [1 2]) / ^:foo {} still works.
|
||||
(else
|
||||
(let ((c (jolt-with-meta target meta)))
|
||||
;; jolt-with-meta copies a pmap, giving it a fresh identity the rdr-map-order
|
||||
;; side-table (source key order for left-to-right map-literal eval) loses —
|
||||
;; carry the order entry over to the copy.
|
||||
(let ((order (and (pmap? target) (hashtable-ref rdr-map-order target #f))))
|
||||
(when order (hashtable-set! rdr-map-order c order)))
|
||||
c))))
|
||||
|
||||
;; --- # dispatch -------------------------------------------------------------
|
||||
;; #(...) anonymous fn shorthand: % -> p1, %N -> pN, %& -> rest. The
|
||||
|
|
@ -451,11 +453,19 @@
|
|||
|
||||
;; --- keyword ----------------------------------------------------------------
|
||||
(define (rdr-read-keyword s i end) ; i points just past the leading ':'
|
||||
;; ::kw auto-resolves; drop the ns, so skip a second ':'
|
||||
(let ((i (if (and (< i end) (char=? (string-ref s i) #\:)) (+ i 1) i)))
|
||||
(let-values (((tok j) (rdr-read-token s i end)))
|
||||
(let-values (((ns name) (rdr-sym-parts tok)))
|
||||
(values (keyword ns name) j)))))
|
||||
;; ::kw is auto-resolved against the current ns: ::name -> current-ns/name,
|
||||
;; ::alias/name -> the alias's target ns / name (Clojure's reader semantics).
|
||||
(let ((auto? (and (< i end) (char=? (string-ref s i) #\:))))
|
||||
(let ((i (if auto? (+ i 1) i)))
|
||||
(let-values (((tok j) (rdr-read-token s i end)))
|
||||
(let-values (((ns name) (rdr-sym-parts tok)))
|
||||
(if auto?
|
||||
(let* ((cur (chez-current-ns))
|
||||
(rns (if (string? ns)
|
||||
(let ((a (chez-resolve-alias cur ns))) (if a a ns))
|
||||
cur)))
|
||||
(values (keyword rns name) j))
|
||||
(values (keyword ns name) j)))))))
|
||||
|
||||
;; --- the main dispatch ------------------------------------------------------
|
||||
;; Returns (values form j). form is rdr-eof at end-of-input or at an unconsumed
|
||||
|
|
|
|||
|
|
@ -255,10 +255,21 @@
|
|||
;; &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) '())))
|
||||
(let loop ((xs irr) (acc m))
|
||||
(if (null? xs) acc (loop (cdr xs) (string-append acc " " (jolt-pr-str (car xs)))))))
|
||||
(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
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
|
|
@ -26,7 +26,7 @@
|
|||
form-bigdec? form-bigdec-source
|
||||
form-ns-value? form-ns-value-name
|
||||
form-macro? form-expand-1 resolve-global
|
||||
form-sym-meta host-intern! form-syntax-quote-lower
|
||||
form-sym-meta form-coll-meta host-intern! form-syntax-quote-lower
|
||||
record-type? record-ctor-key form-position late-bind?
|
||||
resolve-class-hint]]))
|
||||
|
||||
|
|
@ -590,17 +590,31 @@
|
|||
p (form-position form)]
|
||||
(if p (assoc n :pos p) n)))))))
|
||||
|
||||
;; A vector/map/set literal carrying reader metadata (^:foo {…}, ^{:tag :int} [1])
|
||||
;; keeps it as a runtime value: wrap the collection node in (with-meta coll meta).
|
||||
;; The metadata is itself a form (its values may be expressions, ^{:a (f)}), so
|
||||
;; analyze it. nil meta passes the node through. Arglist vectors never reach here —
|
||||
;; analyze-arity reads their items directly — so a ^Type [args] hint is not wrapped.
|
||||
(defn- with-coll-meta [ctx form env node]
|
||||
(let [m (form-coll-meta form)]
|
||||
(if (nil? m)
|
||||
node
|
||||
(invoke (var-ref "clojure.core" "with-meta") [node (analyze ctx m env)]))))
|
||||
|
||||
(defn analyze
|
||||
([ctx form] (analyze ctx form (empty-env)))
|
||||
([ctx form env]
|
||||
(cond
|
||||
(form-literal? form) (const form)
|
||||
(form-sym? form) (analyze-symbol ctx form env)
|
||||
(form-vec? form) (vector-node (mapv #(analyze ctx % env) (form-vec-items form)))
|
||||
(form-map? form) (map-node (mapv (fn [p] [(analyze ctx (first p) env)
|
||||
(analyze ctx (second p) env)])
|
||||
(form-map-pairs form)))
|
||||
(form-set? form) (set-node (mapv #(analyze ctx % env) (form-set-items form)))
|
||||
(form-vec? form) (with-coll-meta ctx form env
|
||||
(vector-node (mapv #(analyze ctx % env) (form-vec-items form))))
|
||||
(form-map? form) (with-coll-meta ctx form env
|
||||
(map-node (mapv (fn [p] [(analyze ctx (first p) env)
|
||||
(analyze ctx (second p) env)])
|
||||
(form-map-pairs form))))
|
||||
(form-set? form) (with-coll-meta ctx form env
|
||||
(set-node (mapv #(analyze ctx % env) (form-set-items form))))
|
||||
(form-list? form) (analyze-list ctx form env)
|
||||
;; regex literal #"…" -> a :regex IR node (leaf). The Chez back end emits a
|
||||
;; jolt-regex value over the vendored irregex.
|
||||
|
|
|
|||
|
|
@ -8,12 +8,15 @@
|
|||
;; The reader yields set literals as a FORM ({:jolt/type :jolt/set :value [...]})
|
||||
;; rather than a constructed set, so build the actual values, recursing into
|
||||
;; maps/vectors/lists. (Lists stay lists — EDN never evaluates them as code.)
|
||||
;; Re-attach the source value's metadata to each rebuilt collection — read-string
|
||||
;; preserves reader metadata (^:ref […]) but this rebuild would otherwise drop it,
|
||||
;; which a metadata-driven config lib (aero/integrant) relies on.
|
||||
(defn- edn->value [opts x]
|
||||
(cond
|
||||
;; Reader FORMS are detected by :jolt/type tag, never by map? — strict map?
|
||||
;; (correctly) excludes tagged structs, so the old (and (map? x) ...) guard
|
||||
;; would skip them.
|
||||
(= :jolt/set (get x :jolt/type)) (set (map (fn [v] (edn->value opts v)) (get x :value)))
|
||||
(= :jolt/set (get x :jolt/type)) (with-meta (set (map (fn [v] (edn->value opts v)) (get x :value))) (meta x))
|
||||
;; Tagged elements: a reader from the :readers opt wins, then the built-in
|
||||
;; data readers (#uuid/#inst + registered); an unknown tag falls to the
|
||||
;; :default opt fn (called with tag and value, as in Clojure) or throws.
|
||||
|
|
@ -27,12 +30,13 @@
|
|||
custom (get (get opts :readers) tag-sym)]
|
||||
(cond
|
||||
custom (custom v)
|
||||
(get opts :default) ((get opts :default) tag v)
|
||||
;; Clojure calls :default with the tag as a SYMBOL and the value.
|
||||
(get opts :default) ((get opts :default) tag-sym v)
|
||||
:else (__read-tagged tag v)))
|
||||
(map? x)
|
||||
(into {} (map (fn [e] [(edn->value opts (key e)) (edn->value opts (val e))]) x))
|
||||
(vector? x) (mapv (fn [v] (edn->value opts v)) x)
|
||||
(seq? x) (map (fn [v] (edn->value opts v)) x)
|
||||
(with-meta (into {} (map (fn [e] [(edn->value opts (key e)) (edn->value opts (val e))]) x)) (meta x))
|
||||
(vector? x) (with-meta (mapv (fn [v] (edn->value opts v)) x) (meta x))
|
||||
(seq? x) (with-meta (map (fn [v] (edn->value opts v)) x) (meta x))
|
||||
:else x))
|
||||
|
||||
;; Private helper, NOT named read-string: an unqualified (read-string …) call
|
||||
|
|
|
|||
|
|
@ -46,6 +46,14 @@
|
|||
(defn n-error [] (:error @counters))
|
||||
(defn failures [] (:fails @counters))
|
||||
|
||||
;; Message of a thrown value: ex-info's message, else a raw host condition's text
|
||||
;; (ex-message is nil for those), else its printed form — so a crash is never
|
||||
;; reported with a blank message.
|
||||
(defn err-text [e]
|
||||
(or (ex-message e)
|
||||
(jolt.host/condition-message e)
|
||||
(str e)))
|
||||
|
||||
;; clojure.test/report multimethod — present so suites that add reporting
|
||||
;; methods (defmethod clojure.test/report :begin-test-var ...) load. The runner
|
||||
;; below does its own console output and doesn't dispatch through it.
|
||||
|
|
@ -110,7 +118,7 @@
|
|||
(clojure.test/inc-pass!)
|
||||
(clojure.test/fail! (str (pr-str '~form) (when ~msg (str " — " ~msg)))))
|
||||
(catch Throwable e#
|
||||
(clojure.test/err! (str (pr-str '~form) " threw: " (clojure.core/ex-message e#))))))))
|
||||
(clojure.test/err! (str (pr-str '~form) " threw: " (clojure.test/err-text e#))))))))
|
||||
|
||||
(defmacro testing [s & body]
|
||||
`(do
|
||||
|
|
@ -152,7 +160,7 @@
|
|||
(try
|
||||
((:fn t))
|
||||
(catch Throwable e
|
||||
(err! (str (:name t) " crashed: " (clojure.core/ex-message e))))))))
|
||||
(err! (str (:name t) " crashed: " (err-text e))))))))
|
||||
|
||||
(defn run-registered []
|
||||
(doseq [t @registry] (run-one t))
|
||||
|
|
|
|||
|
|
@ -5,19 +5,21 @@
|
|||
[inner outer form]
|
||||
(cond
|
||||
; vectors/maps first so seq? can't swallow them (a vector is not seq? on
|
||||
; jolt, but keep the concrete branches authoritative)
|
||||
(vector? form) (outer (vec (map inner form)))
|
||||
; jolt, but keep the concrete branches authoritative). Re-attach the form's
|
||||
; metadata to the rebuilt collection, as Clojure does — a metadata-driven walk
|
||||
; (aero/spec) needs ^:ref and friends to survive the rebuild.
|
||||
(vector? form) (outer (with-meta (vec (map inner form)) (meta form)))
|
||||
; a record is also map?, but (empty record) yields a plain map — rebuild by
|
||||
; conj-ing the walked entries back onto the original so the record TYPE
|
||||
; survives. Type-dispatched walks depend on it (e.g. integrant resolves
|
||||
; #ig/ref by detecting its Ref record while postwalking the config).
|
||||
(record? form) (outer (reduce (fn [r x] (conj r (inner x))) form form))
|
||||
(map? form) (outer (into (empty form) (map inner form)))
|
||||
(map? form) (outer (with-meta (into (empty form) (map inner form)) (meta form)))
|
||||
; lists rebuild as lists, other seqs (incl. macro/template output: cons/
|
||||
; concat/lazy-seq) walk too — without this, postwalk-replace silently no-op'd
|
||||
; a quoted list, breaking clojure.template/apply-template
|
||||
(list? form) (outer (apply list (map inner form)))
|
||||
(seq? form) (outer (map inner form))
|
||||
(list? form) (outer (with-meta (apply list (map inner form)) (meta form)))
|
||||
(seq? form) (outer (with-meta (map inner form) (meta form)))
|
||||
:else (outer form)))
|
||||
|
||||
(defn postwalk
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(ns app.core
|
||||
(:require [app.util :as util]
|
||||
(:require [app.util :as util :refer [greet]]
|
||||
[clojure.java.io :as io]))
|
||||
|
||||
;; An aliased cross-ns defmethod: 'util/greet is passed quoted to defmethod-setup,
|
||||
|
|
@ -7,6 +7,10 @@
|
|||
;; ns "util" and never reaches app.util/greet (the dispatch falls to :default).
|
||||
(defmethod util/greet :loud [_] "greet:loud")
|
||||
|
||||
;; A defmethod on a REFERRED multifn (bare `greet`): the AOT build must register
|
||||
;; the :refer so the bare name resolves to app.util/greet, not a shadow.
|
||||
(defmethod greet :soft [_] "greet:soft")
|
||||
|
||||
(defn -main [& args]
|
||||
;; the resource is baked into the binary (deps.edn :jolt/build :embed), so this
|
||||
;; resolves with no resources/ dir on disk, run from any cwd.
|
||||
|
|
@ -15,4 +19,5 @@
|
|||
(println "args:" (vec args))
|
||||
(println "sum:" (reduce + (map count args)))
|
||||
(println "greet-default:" (util/greet :unknown))
|
||||
(println "greet-loud:" (util/greet :loud)))
|
||||
(println "greet-loud:" (util/greet :loud))
|
||||
(println "greet-soft:" (util/greet :soft)))
|
||||
|
|
|
|||
|
|
@ -1046,6 +1046,23 @@
|
|||
{:suite "metadata / type hints" :label "type hint in destructure" :expected "3" :actual "(let [{:keys [^long a]} {:a 3}] a)"}
|
||||
{:suite "metadata / type hints" :label "symbol hint -> :tag" :expected "\"String\"" :actual "(:tag (meta (read-string \"^String x\")))"}
|
||||
{:suite "metadata / type hints" :label "keyword hint -> true" :expected "true" :actual "(:foo (meta (read-string \"^:foo x\")))"}
|
||||
{:suite "metadata / read data metadata" :label "vector data meta" :expected "{:ref true}" :actual "(meta (read-string \"^:ref [:greeting]\"))"}
|
||||
{:suite "metadata / read data metadata" :label "map data meta" :expected "{:k 1}" :actual "(meta (read-string \"^{:k 1} {:a 2}\"))"}
|
||||
{:suite "metadata / read data metadata" :label "set data meta" :expected "{:s true}" :actual "(meta (read-string \"^:s #{1 2}\"))"}
|
||||
{:suite "metadata / read data metadata" :label "nested vector data meta" :expected "{:x true}" :actual "(meta (second (read-string \"[1 ^:x {:a 2}]\")))"}
|
||||
{:suite "metadata / read data metadata" :label "collection value unchanged" :expected "[:greeting]" :actual "(read-string \"^:ref [:greeting]\")"}
|
||||
{:suite "metadata / coll literal in code keeps meta" :label "vector literal meta" :expected "{:foo true}" :actual "(meta ^:foo [1 2])"}
|
||||
{:suite "metadata / coll literal in code keeps meta" :label "map literal meta with expr" :expected "{:a 3}" :actual "(meta ^{:a (+ 1 2)} [1])"}
|
||||
{:suite "metadata / coll literal in code keeps meta" :label "map literal value-eval order" :expected "[1 2]" :actual "(let [a (atom [])] ^:t {(do (swap! a conj 1) :a) 1 (do (swap! a conj 2) :b) 2} @a)"}
|
||||
{:suite "metadata / *print-meta*" :label "pr-str prefixes ^meta" :expected "\"^{:ref true} [:g]\"" :actual "(binding [*print-meta* true] (pr-str (with-meta [:g] {:ref true})))"}
|
||||
{:suite "metadata / *print-meta*" :label "off by default" :expected "\"[:g]\"" :actual "(pr-str (with-meta [:g] {:ref true}))"}
|
||||
{:suite "metadata / *print-meta*" :label "symbol meta prefixed" :expected "\"^{:k 1} x\"" :actual "(binding [*print-meta* true] (pr-str (with-meta (quote x) {:k 1})))"}
|
||||
{:suite "metadata / *print-meta*" :label "print then read round-trips" :expected "{:ref true}" :actual "(meta (read-string (binding [*print-meta* true] (pr-str (with-meta [:g] {:ref true})))))"}
|
||||
{:suite "metadata / clojure.walk preserves meta" :label "postwalk keeps vector meta" :expected "{:ref true}" :actual "(do (require (quote [clojure.walk :as w])) (meta (w/postwalk identity (with-meta [:b] {:ref true}))))"}
|
||||
{:suite "metadata / clojure.walk preserves meta" :label "postwalk keeps map meta" :expected "{:m 1}" :actual "(do (require (quote [clojure.walk :as w])) (meta (w/postwalk identity (with-meta {:a 2} {:m 1}))))"}
|
||||
{:suite "metadata / clojure.edn preserves meta" :label "edn vector meta" :expected "{:ref true}" :actual "(do (require (quote [clojure.edn :as e1])) (meta (e1/read-string \"^:ref [:greeting]\")))"}
|
||||
{:suite "metadata / clojure.edn preserves meta" :label "edn map meta" :expected "{:m true}" :actual "(do (require (quote [clojure.edn :as e1])) (meta (e1/read-string \"^:m {:a 1}\")))"}
|
||||
{:suite "metadata / clojure.edn preserves meta" :label "edn set meta" :expected "{:s true}" :actual "(do (require (quote [clojure.edn :as e1])) (meta (e1/read-string \"^:s #{1}\")))"}
|
||||
{:suite "metadata / def metadata" :label "^:dynamic var binds" :expected "9" :actual "(do (def ^:dynamic *d* 1) (binding [*d* 9] *d*))"}
|
||||
{:suite "metadata / def metadata" :label "^:private on var" :expected "true" :actual "(do (def ^:private pv 1) (:private (meta (var pv))))"}
|
||||
{:suite "metadata / def metadata" :label "^Type tag on var" :expected "java.lang.String" :actual "(do (def ^String tv \"a\") (:tag (meta (var tv))))"}
|
||||
|
|
@ -2645,6 +2662,20 @@
|
|||
{:suite "clojure.walk / records keep their type" :label "instance? survives a walk" :expected "true" :actual "(do (require (quote [clojure.walk :as w])) (defrecord R [a]) (instance? R (w/postwalk identity (->R 1))))"}
|
||||
{:suite "clojure.walk / records keep their type" :label "a record nested in a map keeps its type" :expected "true" :actual "(do (require (quote [clojure.walk :as w])) (defrecord R [a]) (record? (:r (w/postwalk identity {:r (->R 1)}))))"}
|
||||
{:suite "clojure.walk / records keep their type" :label "prewalk preserves record type" :expected "true" :actual "(do (require (quote [clojure.walk :as w])) (defrecord R [a]) (record? (w/prewalk identity (->R 1))))"}
|
||||
{:suite "reader / auto-resolved keywords" :label "::kw is namespace-qualified" :expected "true" :actual "(some? (namespace ::foo))"}
|
||||
{:suite "reader / auto-resolved keywords" :label "::kw keeps its name" :expected "\"foo\"" :actual "(name ::foo)"}
|
||||
{:suite "reader / auto-resolved keywords" :label "::kw resolves to the current ns" :expected "true" :actual "(= ::a ::a)"}
|
||||
{:suite "clojure.edn / reader opts" :label ":default receives the tag as a symbol" :expected "[true \"foo\" 5]" :actual "(do (require (quote [clojure.edn :as edn])) (let [r (edn/read-string {:default (fn [t v] [t v])} \"#foo 5\")] [(symbol? (first r)) (name (first r)) (second r)]))"}
|
||||
{:suite "metadata / lazy seqs carry meta" :label "with-meta on a lazy seq" :expected "{:k 1}" :actual "(meta (with-meta (map inc [1 2 3]) {:k 1}))"}
|
||||
{:suite "dynamic vars / *print-meta*" :label "*print-meta* is a bindable dynamic var" :expected "true" :actual "(binding [*print-meta* true] (true? *print-meta*))"}
|
||||
{:suite "tagged literals / value equality" :label "equal tag+form are =" :expected "true" :actual "(= (tagged-literal (quote x) [1 2]) (tagged-literal (quote x) [1 2]))"}
|
||||
{:suite "tagged literals / value equality" :label "different tag is not =" :expected "false" :actual "(= (tagged-literal (quote x) [1]) (tagged-literal (quote y) [1]))"}
|
||||
{:suite "tagged literals / value equality" :label "dedup as map keys" :expected "1" :actual "(count {(tagged-literal (quote x) [1]) :a (tagged-literal (quote x) [1]) :b})"}
|
||||
{:suite "interop / clojure.lang interfaces" :label "vector is IObj" :expected "true" :actual "(instance? clojure.lang.IObj [1])"}
|
||||
{:suite "interop / clojure.lang interfaces" :label "map entry is IMapEntry" :expected "true" :actual "(instance? clojure.lang.IMapEntry (first {:a 1}))"}
|
||||
{:suite "interop / clojure.lang interfaces" :label "record is IRecord" :expected "true" :actual "(do (defrecord R [a]) (instance? clojure.lang.IRecord (->R 1)))"}
|
||||
{:suite "interop / clojure.lang interfaces" :label "number is not IObj" :expected "false" :actual "(instance? clojure.lang.IObj 5)"}
|
||||
{:suite "reader / default data readers" :label "#inst is in default-data-readers" :expected "true" :actual "(boolean (get default-data-readers (quote inst)))"}
|
||||
{:suite "conformance / CRITICAL: lazy sequences" :label "self-ref lazy-cat fib" :expected "[0 1 1 2 3 5 8 13 21 34]" :actual "(do (def fib-seq (lazy-cat [0 1] (map + (rest fib-seq) fib-seq))) (take 10 fib-seq))"}
|
||||
{:suite "conformance / CRITICAL: multi-collection map" :label "map two colls" :expected "[11 22 33]" :actual "(map + [1 2 3] [10 20 30])"}
|
||||
{:suite "conformance / CRITICAL: multi-collection map" :label "map three colls" :expected "[12 24 36]" :actual "(map + [1 2 3] [10 20 30] [1 2 3])"}
|
||||
|
|
|
|||
|
|
@ -303,7 +303,7 @@
|
|||
{:suite "reader" :expr "(integer? (read-string \"7\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(= :foo (read-string \":foo\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(= :a/b (read-string \":a/b\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(= :foo (read-string \"::foo\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(= [true \"foo\"] [(some? (namespace (read-string \"::foo\"))) (name (read-string \"::foo\"))])" :expected "true"}
|
||||
{:suite "reader" :expr "(= (quote sym) (read-string \"sym\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(= (quote ns/sym) (read-string \"ns/sym\"))" :expected "true"}
|
||||
{:suite "reader" :expr "(nil? (read-string \"nil\"))" :expected "true"}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue