Chez Phase 3 inc7: corpus on the Chez-hosted analyzer + a 50x-faster gate
Point the Chez-HOSTED analyzer at the full parity corpus (read -> analyze ->
emit -> eval, all on Chez, no Janet) and close the divergences so the
self-hosted compiler is faithful: 0 divergences, 2159/2494 pass.
Keystone: the on-Chez emitter ran with prelude-mode off, so every call to a
non-native clojure.core fn tripped the "unsupported stdlib fn" out-of-subset
guard. The zero-Janet spine always has the full prelude loaded, so turn
prelude mode on in compile-eval.ss (22% -> 84% pass on a sample).
Faithfulness fixes (each was the Chez host/reader diverging from the Janet
analyzer; fixed in the keeper, not the seed):
- emit-const read a char's codepoint via (get v :ch) — the Janet rep; on Chez a
char is native. Route through a new form-char-code host-contract fn (41 cases).
- next over a lazy seq returned the empty-list terminator (truthy), not nil, so
butlast and other (if (next s) ...) loops ran one step too far — broke
some->/some->>/cond->>.
- reader: radix literals (2r1010/16rFF/36rZ), #^ deprecated metadata, ^meta on
collections (lowers to a runtime with-meta form like the Janet reader),
map-literal source order (values eval left-to-right), and nested syntax-quote
over a literal collapses at read time.
- keyword "a/b" splits into ns/name like the seed (destructure {:keys [x/y]}).
- form-syntax-quote-lower implemented on Chez (was a throwing stub).
7 divergences allowlisted: the same print-method-multimethod / host-class set
the prelude gate defers. 328 crashes remain = shared runtime breadth (host
interop, missing core fns, eval/load-string) deferred to Phase 4 / jolt-r8ku,
not compiler faithfulness.
Gate + speedup: test/chez/run-corpus-zero-janet.janet (floor 2159). Its batched
runner (driver/eval-corpus-zero-janet) runs every case in ONE chez process —
load the runtime once, guard + reset the user namespace per case — instead of a
fresh process per case: 1379s -> 1.6s.
spine-test 35/35; Janet gate 151/0; prelude parity 2295/2494 unchanged, 0 new
divergences.
This commit is contained in:
Yogthos
parent
d165198969
commit
8b86174b91
9 changed files with 460 additions and 19 deletions
|
|
@ -13,6 +13,13 @@
|
|||
(define jolt-ce-emit (var-deref "jolt.backend-scheme" "emit"))
|
||||
(define jolt-ce-read (var-deref "clojure.core" "read-string"))
|
||||
|
||||
;; The zero-Janet 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 "unsupported stdlib fn (no core on Chez yet)" out-of-subset guard —
|
||||
;; that guard is only for the bare -e subset with no prelude. Turn prelude mode on
|
||||
;; once, here, so every analyze->emit on this spine sees the full core (jolt-qjr0).
|
||||
((var-deref "jolt.backend-scheme" "set-prelude-mode!") #t)
|
||||
|
||||
;; Source string -> Scheme source string (read -> analyze -> emit, all on Chez).
|
||||
;; `ns` is the compile namespace unqualified symbols resolve against.
|
||||
(define (jolt-analyze-emit src ns)
|
||||
|
|
|
|||
|
|
@ -47,7 +47,17 @@
|
|||
(cond
|
||||
((jolt-nil? a) jolt-nil)
|
||||
((keyword? a) a)
|
||||
((string? a) (keyword #f a))
|
||||
;; a 1-arg string splits on the FIRST "/" into ns/name, like the seed
|
||||
;; (keyword "x/y") => :x/y with ns "x" — destructure's {:keys [x/y]} builds
|
||||
;; the key this way, so without the split the namespaced key never matches.
|
||||
((string? a)
|
||||
(let ((si (let loop ((i 0))
|
||||
(cond ((>= i (string-length a)) #f)
|
||||
((char=? (string-ref a i) #\/) i)
|
||||
(else (loop (+ i 1)))))))
|
||||
(if (and si (> si 0) (< si (- (string-length a) 1)))
|
||||
(keyword (substring a 0 si) (substring a (+ si 1) (string-length a)))
|
||||
(keyword #f a))))
|
||||
((jolt-symbol? a)
|
||||
(let ((ns (symbol-t-ns a)))
|
||||
(keyword (if (or (jolt-nil? ns) (not ns) (eq? ns '())) #f ns) (symbol-t-name a))))
|
||||
|
|
|
|||
|
|
@ -364,6 +364,118 @@
|
|||
(def code (os/proc-wait proc))
|
||||
[code (string/trim out) (string/trim err)])
|
||||
|
||||
# --- batched zero-Janet corpus runner (jolt-qjr0, inc7) -----------------------
|
||||
# eval-zero-janet spawns a fresh chez per case, each reloading rt.ss + the prelude
|
||||
# (~282KB) + the compiler image (~89KB) from source — ~0.5s of pure reload per
|
||||
# case, the entire cost. This runs ALL cases in ONE chez process: load the runtime
|
||||
# once, then loop. Each case is guarded (errors isolated) and the user namespace is
|
||||
# reset between cases (var-table keys added by a case are removed, *ns* restored) so
|
||||
# there is no state leakage vs the per-process path. ~10-30x faster.
|
||||
|
||||
(defn program-corpus-zero-janet
|
||||
"A Chez program that loads the zero-Janet runtime once, then runs every case in
|
||||
`cases-tsv` (label<TAB>src per line) through jolt-compile-eval, printing one
|
||||
result line per case: PASS<TAB>label | DIVERGE<TAB>label<TAB>value |
|
||||
CRASH<TAB>label<TAB>message."
|
||||
[prelude-path image-path cases-tsv]
|
||||
(string
|
||||
"(import (chezscheme))\n"
|
||||
"(load \"host/chez/rt.ss\")\n"
|
||||
"(set-chez-ns! \"clojure.core\")\n"
|
||||
"(load " (string/format "%j" prelude-path) ")\n"
|
||||
"(load \"host/chez/post-prelude.ss\")\n"
|
||||
"(set-chez-ns! \"user\")\n"
|
||||
"(load \"host/chez/host-contract.ss\")\n"
|
||||
"(load " (string/format "%j" image-path) ")\n"
|
||||
"(load \"host/chez/compile-eval.ss\")\n"
|
||||
# Snapshot mutable global state after setup so each case sees a clean world (as
|
||||
# if it ran in its own process): (1) var-table keys a case ADDS (its defs) are
|
||||
# removed; (2) a base cell whose ROOT a case mutated (e.g. in-ns rebinds
|
||||
# clojure.core/*ns*) is restored; (3) the ns + type registries are pruned back to
|
||||
# their base keys. Without this, *ns*/find-ns/all-ns/satisfies? leak across cases.
|
||||
"(define zj-base (let ((h (make-hashtable string-hash string=?)))\n"
|
||||
" (vector-for-each (lambda (k) (hashtable-set! h k #t)) (hashtable-keys var-table)) h))\n"
|
||||
"(define zj-roots '())\n"
|
||||
"(vector-for-each (lambda (k) (let ((c (hashtable-ref var-table k #f)))\n"
|
||||
" (when c (set! zj-roots (cons (cons c (var-cell-root c)) zj-roots)))))\n"
|
||||
" (hashtable-keys var-table))\n"
|
||||
"(define (zj-snap ht) (let ((h (make-hashtable string-hash string=?)))\n"
|
||||
" (vector-for-each (lambda (k) (hashtable-set! h k #t)) (hashtable-keys ht)) h))\n"
|
||||
"(define (zj-prune! ht base) (vector-for-each\n"
|
||||
" (lambda (k) (unless (hashtable-ref base k #f) (hashtable-delete! ht k))) (hashtable-keys ht)))\n"
|
||||
"(define zj-ns-base (zj-snap ns-registry))\n"
|
||||
"(define zj-type-base (zj-snap type-registry))\n"
|
||||
# global-hierarchy is a core atom whose CONTENTS `derive` mutates (its var root
|
||||
# stays the same atom object, so the root-restore above misses it). Reset its
|
||||
# contents to a fresh hierarchy each case.
|
||||
"(define zj-ghier (var-cell-lookup \"clojure.core\" \"global-hierarchy\"))\n"
|
||||
"(define (zj-reset!)\n"
|
||||
" (vector-for-each (lambda (k) (unless (hashtable-ref zj-base k #f) (hashtable-delete! var-table k)))\n"
|
||||
" (hashtable-keys var-table))\n"
|
||||
" (for-each (lambda (cr) (unless (eq? (var-cell-root (car cr)) (cdr cr))\n"
|
||||
" (var-cell-root-set! (car cr) (cdr cr)))) zj-roots)\n"
|
||||
" (zj-prune! ns-registry zj-ns-base)\n"
|
||||
" (zj-prune! type-registry zj-type-base)\n"
|
||||
" (when zj-ghier (jolt-invoke (var-deref \"clojure.core\" \"reset!\")\n"
|
||||
" (var-cell-root zj-ghier) (jolt-invoke (var-deref \"clojure.core\" \"make-hierarchy\"))))\n"
|
||||
" (set-chez-ns! \"user\"))\n"
|
||||
"(define kw-message (keyword #f \"message\"))\n"
|
||||
"(define (zj-err->str e)\n"
|
||||
" (cond ((and (pmap? e) (string? (jolt-get e kw-message))) (jolt-get e kw-message))\n"
|
||||
" ((condition? e) (call-with-string-output-port (lambda (p) (display-condition e p))))\n"
|
||||
" ((string? e) e)\n"
|
||||
" (else (call-with-string-output-port (lambda (p) (write e p))))))\n"
|
||||
"(define (zj-clean s)\n" # strip tabs/newlines from a message so it stays one TSV line
|
||||
" (list->string (map (lambda (c) (if (or (char=? c #\\tab) (char=? c #\\newline)) #\\space c))\n"
|
||||
" (string->list s))))\n"
|
||||
"(define (zj-run label src)\n"
|
||||
" (guard (e (#t (printf \"CRASH\\t~a\\t~a\\n\" label (zj-clean (zj-err->str e)))))\n"
|
||||
" (let ((v (jolt-compile-eval src \"user\")))\n"
|
||||
" (if (string=? (jolt-final-str v) \"true\")\n"
|
||||
" (printf \"PASS\\t~a\\n\" label)\n"
|
||||
" (printf \"DIVERGE\\t~a\\t~a\\n\" label (zj-clean (jolt-final-str v))))))\n"
|
||||
" (zj-reset!))\n"
|
||||
"(let ((p (open-input-file " (string/format "%j" cases-tsv) ")))\n"
|
||||
" (let loop ()\n"
|
||||
" (let ((line (get-line p)))\n"
|
||||
" (unless (eof-object? line)\n"
|
||||
" (let find ((i 0))\n"
|
||||
" (cond ((>= i (string-length line)) #f)\n"
|
||||
" ((char=? (string-ref line i) #\\tab)\n"
|
||||
" (zj-run (substring line 0 i) (substring line (+ i 1) (string-length line))))\n"
|
||||
" (else (find (+ i 1)))))\n"
|
||||
" (loop)))))\n"))
|
||||
|
||||
(defn eval-corpus-zero-janet
|
||||
"Run all `cases` ([label src] pairs) through the ON-CHEZ analyzer in ONE chez
|
||||
process. Returns a struct mapping label -> [:pass] | [:diverge value] |
|
||||
[:crash message]. Vastly faster than per-case eval-zero-janet (single runtime
|
||||
load); use eval-zero-janet to isolate a single case for debugging."
|
||||
[prelude-path image-path cases &opt scheme-out cases-out]
|
||||
(def tsv-path (or cases-out (string "/tmp/jolt-zj-cases-" (os/getpid) ".tsv")))
|
||||
(def buf @"")
|
||||
(each [label src] cases (buffer/push buf label "\t" src "\n"))
|
||||
(spit tsv-path buf)
|
||||
(def prog (program-corpus-zero-janet prelude-path image-path tsv-path))
|
||||
(def path (or scheme-out (string "/tmp/jolt-zj-runner-" (os/getpid) ".ss")))
|
||||
(spit path prog)
|
||||
(def proc (os/spawn ["chez" "--script" path] :p {:out :pipe :err :pipe}))
|
||||
(def out (drain (proc :out)))
|
||||
(def err (drain (proc :err)))
|
||||
(def code (os/proc-wait proc))
|
||||
(def res @{})
|
||||
(each line (string/split "\n" (string/trim out))
|
||||
(when (> (length line) 0)
|
||||
(def parts (string/split "\t" line))
|
||||
(def status (in parts 0))
|
||||
(def label (get parts 1 ""))
|
||||
(cond
|
||||
(= status "PASS") (put res label [:pass])
|
||||
(= status "DIVERGE") (put res label [:diverge (get parts 2 "")])
|
||||
(= status "CRASH") (put res label [:crash (get parts 2 "")]))))
|
||||
# If chez died mid-run (e.g. an uncatchable error), surface what we have + stderr.
|
||||
{:results res :code code :stderr (string/trim err) :count (length res)})
|
||||
|
||||
(defn program-with-prelude
|
||||
"Assemble a runnable Chez program that loads rt.ss, loads the assembled core
|
||||
prelude from `prelude-path` (a file written once), then prints `final-scm`."
|
||||
|
|
|
|||
|
|
@ -60,6 +60,7 @@
|
|||
(define (hc-uuid? x) (hc-tagged-of x hc-kw-uuid))
|
||||
|
||||
;; --- form accessors ---------------------------------------------------------
|
||||
(define (hc-char-code x) (char->integer x)) ; native Chez char -> codepoint
|
||||
(define (hc-sym-name x) (symbol-t-name x))
|
||||
;; The reader stores an unqualified symbol's ns inconsistently (#f, '(), or
|
||||
;; jolt-nil — see converters.ss). The contract is jolt-nil for unqualified (the
|
||||
|
|
@ -82,10 +83,18 @@
|
|||
(apply jolt-vector (pset-fold x cons '()))
|
||||
(jolt-get x hc-kw-value)))
|
||||
(define (hc-map-pairs x)
|
||||
(let loop ((ks (if (jolt-nil? (jolt-seq (jolt-keys x))) '()
|
||||
(seq->list (jolt-seq (jolt-keys x))))) (acc '()))
|
||||
(if (null? ks) (apply jolt-vector (reverse acc))
|
||||
(loop (cdr ks) (cons (jolt-vector (car ks) (jolt-get x (car ks))) acc)))))
|
||||
(let ((kv (hashtable-ref rdr-map-order x #f)))
|
||||
(if kv
|
||||
;; reader-built map literal: emit pairs in SOURCE order (kv = k1 v1 k2 v2 …)
|
||||
;; so the analyzer evaluates the values left-to-right (jolt-qjr0).
|
||||
(let loop ((kv kv) (acc '()))
|
||||
(if (null? kv) (apply jolt-vector (reverse acc))
|
||||
(loop (cddr kv) (cons (jolt-vector (car kv) (cadr kv)) acc))))
|
||||
;; a runtime/non-reader map: pmap iteration order
|
||||
(let loop ((ks (if (jolt-nil? (jolt-seq (jolt-keys x))) '()
|
||||
(seq->list (jolt-seq (jolt-keys x))))) (acc '()))
|
||||
(if (null? ks) (apply jolt-vector (reverse acc))
|
||||
(loop (cdr ks) (cons (jolt-vector (car ks) (jolt-get x (car ks))) acc)))))))
|
||||
(define (hc-regex-source x) (jolt-get x hc-kw-form))
|
||||
(define (hc-inst-source x) (jolt-get x hc-kw-form))
|
||||
(define (hc-uuid-source x) (jolt-get x hc-kw-form))
|
||||
|
|
@ -158,11 +167,84 @@
|
|||
|
||||
(define (hc-intern! ctx ns-name nm) (declare-var! ns-name nm) jolt-nil)
|
||||
|
||||
;; syntax-quote lowering + record hints land in later increments (6b+); stub so
|
||||
;; the contract is complete (not on the macro-free spine).
|
||||
;; --- syntax-quote lowering (jolt-qjr0, inc7) ---------------------------------
|
||||
;; Mirrors src/jolt/eval_base.janet syntax-quote-lower/sq-symbol. Lowers a `form
|
||||
;; to CONSTRUCTION CODE — Chez reader forms calling __sqcat/__sqvec/__sqmap/
|
||||
;; __sqset/__sq1 + quote — that the analyzer re-analyzes, so a backtick compiles
|
||||
;; with zero runtime cost (read -> macroexpand -> compile). Symbols resolve to
|
||||
;; clojure.core / the compile ns; a foo# auto-gensym is stable within one `.
|
||||
(define hc-special-symbols
|
||||
'("quote" "syntax-quote" "unquote" "unquote-splicing" "do" "if" "def"
|
||||
"defmacro" "fn*" "let*" "loop*" "recur" "throw" "try" "set!" "var" "eval"
|
||||
"new" "."))
|
||||
(define (hc-special-symbol? nm) (and (member nm hc-special-symbols) #t))
|
||||
|
||||
(define hc-sq-gensym-counter 0)
|
||||
(define (hc-sq-gensym base)
|
||||
(set! hc-sq-gensym-counter (+ hc-sq-gensym-counter 1))
|
||||
(jolt-symbol #f (string-append base "__" (number->string hc-sq-gensym-counter) "__auto")))
|
||||
|
||||
(define (hc-sym nm) (jolt-symbol #f nm))
|
||||
;; is `x` a non-empty list FORM whose head is the unqualified symbol `nm`?
|
||||
(define (hc-head-is? x nm)
|
||||
(and (cseq? x) (cseq-list? x)
|
||||
(let ((h (seq-first x)))
|
||||
(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-sq-symbol ctx form gsmap)
|
||||
(let ((sns (hc-sym-ns form)) (nm (symbol-t-name form)))
|
||||
(if (jolt-nil? sns)
|
||||
(cond
|
||||
;; foo# -> a stable per-` auto-gensym
|
||||
((and (> (string-length nm) 0)
|
||||
(char=? (string-ref nm (- (string-length nm) 1)) #\#))
|
||||
(or (hashtable-ref gsmap nm #f)
|
||||
(let ((g (hc-sq-gensym (substring nm 0 (- (string-length nm) 1)))))
|
||||
(hashtable-set! gsmap nm g) g)))
|
||||
((hc-special-symbol? nm) form) ; special form: leave bare
|
||||
((var-cell-lookup "clojure.core" nm) (jolt-symbol "clojure.core" nm))
|
||||
(else (jolt-symbol (chez-actx-cns ctx) nm))) ; else: qualify to compile ns
|
||||
;; qualified (a real ns or an alias): ns aliases aren't modeled on the Chez
|
||||
;; data layer yet, so leave a qualified symbol as written (jolt-qjr0).
|
||||
form)))
|
||||
|
||||
(define (hc-sq-lower ctx form gsmap)
|
||||
(cond
|
||||
((hc-head-is? form "unquote") (hc-second form))
|
||||
((hc-head-is? form "unquote-splicing")
|
||||
(jolt-throw (jolt-ex-info "~@ used outside of a list or vector in syntax-quote"
|
||||
(jolt-hash-map))))
|
||||
((hc-literal? form) form)
|
||||
((symbol-t? form) (jolt-list (hc-sym "quote") (hc-sq-symbol ctx form gsmap)))
|
||||
((hc-list? form)
|
||||
(apply jolt-list (hc-sym "__sqcat")
|
||||
(map (lambda (it) (hc-sq-lower-part ctx it gsmap)) (seq->list form))))
|
||||
((hc-vec? form)
|
||||
(apply jolt-list (hc-sym "__sqvec")
|
||||
(map (lambda (it) (hc-sq-lower-part ctx it gsmap)) (seq->list form))))
|
||||
((hc-set? form)
|
||||
(apply jolt-list (hc-sym "__sqset")
|
||||
(map (lambda (it) (hc-sq-lower-part ctx it gsmap)) (seq->list (hc-set-items form)))))
|
||||
((hc-map? form)
|
||||
(apply jolt-list (hc-sym "__sqmap")
|
||||
(let loop ((pairs (seq->list (hc-map-pairs form))) (acc '()))
|
||||
(if (null? pairs) (reverse acc)
|
||||
(let ((p (seq->list (car pairs))))
|
||||
(loop (cdr pairs)
|
||||
(cons (hc-sq-lower ctx (cadr p) gsmap)
|
||||
(cons (hc-sq-lower ctx (car p) gsmap) acc))))))))
|
||||
(else (jolt-list (hc-sym "quote") form)))) ; tagged (char/regex/...) etc.
|
||||
|
||||
;; a list/vector/set element: a ~@ splice passes through (its seq is spliced by
|
||||
;; __sqcat), any other item is wrapped (__sq1 <lowered>) so __sqcat flattens it.
|
||||
(define (hc-sq-lower-part ctx item gsmap)
|
||||
(if (hc-head-is? item "unquote-splicing")
|
||||
(hc-second item)
|
||||
(jolt-list (hc-sym "__sq1") (hc-sq-lower ctx item gsmap))))
|
||||
|
||||
(define (hc-syntax-quote-lower ctx inner)
|
||||
(jolt-throw (jolt-ex-info "form-syntax-quote-lower: not on Chez yet (jolt-r8ku)"
|
||||
(jolt-hash-map))))
|
||||
(hc-sq-lower ctx inner (make-hashtable string-hash string=?)))
|
||||
(define (hc-record-type? ctx name) #f)
|
||||
(define (hc-record-ctor-key ctx name) jolt-nil)
|
||||
(define (hc-record-shapes ctx) (jolt-hash-map))
|
||||
|
|
@ -191,6 +273,7 @@
|
|||
(def-var! "jolt.host" "form-map?" hc-map?)
|
||||
(def-var! "jolt.host" "form-set?" hc-set?)
|
||||
(def-var! "jolt.host" "form-char?" hc-char?)
|
||||
(def-var! "jolt.host" "form-char-code" hc-char-code)
|
||||
(def-var! "jolt.host" "form-literal?" hc-literal?)
|
||||
(def-var! "jolt.host" "form-regex?" hc-regex?)
|
||||
(def-var! "jolt.host" "form-inst?" hc-inst?)
|
||||
|
|
|
|||
|
|
@ -83,6 +83,20 @@
|
|||
(rdr-digit? (string-ref tok start))
|
||||
(rdr-number-body tok start signed c0))))))
|
||||
|
||||
;; parse DDD in base `radix` (2..36); #f on a bad digit. Scheme string->number only
|
||||
;; does radix 2/8/10/16, so Clojure's NrDDD (e.g. 36rZ) needs a manual parse.
|
||||
(define (rdr-parse-radix digits radix)
|
||||
(let ((len (string-length digits)))
|
||||
(and (> len 0)
|
||||
(let loop ((i 0) (acc 0))
|
||||
(if (>= i len)
|
||||
acc
|
||||
(let* ((c (char-downcase (string-ref digits i)))
|
||||
(d (cond ((and (char>=? c #\0) (char<=? c #\9)) (- (char->integer c) 48))
|
||||
((and (char>=? c #\a) (char<=? c #\z)) (+ 10 (- (char->integer c) 97)))
|
||||
(else #f))))
|
||||
(and d (< d radix) (loop (+ i 1) (+ (* acc radix) d)))))))))
|
||||
|
||||
(define (rdr-number-body tok start signed sign-ch)
|
||||
(let* ((sign (if (and signed (char=? sign-ch #\-)) -1 1))
|
||||
(len (string-length tok))
|
||||
|
|
@ -101,6 +115,14 @@
|
|||
(or (char=? (string-ref body 1) #\x) (char=? (string-ref body 1) #\X)))
|
||||
(let ((h (string->number (substring body 2 blen) 16)))
|
||||
(and h (* sign h))))
|
||||
;; radix NrDDD (Clojure 2r1010 / 16rFF / 36rZ): N in decimal, DDD in base N
|
||||
((let ((ri (or (rdr-string-index-char body #\r) (rdr-string-index-char body #\R))))
|
||||
(and ri (> ri 0) (< (+ ri 1) blen) ri))
|
||||
=> (lambda (ri)
|
||||
(let ((radix (string->number (substring body 0 ri))))
|
||||
(and radix (integer? radix) (>= radix 2) (<= radix 36)
|
||||
(let ((v (rdr-parse-radix (substring body (+ ri 1) blen) radix)))
|
||||
(and v (* sign v)))))))
|
||||
;; bigint suffix N
|
||||
((and (> blen 1) (char=? (string-ref body (- blen 1)) #\N))
|
||||
(let ((n (string->number (substring body 0 (- blen 1)))))
|
||||
|
|
@ -222,6 +244,16 @@
|
|||
(loop j acc) ; a #_ discard or close — re-check at j
|
||||
(loop j (cons form acc)))))))))
|
||||
|
||||
;; Map literals must preserve SOURCE key order so the analyzer emits the value
|
||||
;; expressions in source order (Clojure guarantees left-to-right map-literal eval).
|
||||
;; A pmap is hash-ordered, so record each reader-built map's (k1 v1 k2 v2 ...) form
|
||||
;; sequence in a weak side-table the host contract's form-map-pairs consults.
|
||||
(define rdr-map-order (make-weak-eq-hashtable))
|
||||
(define (rdr-make-map es)
|
||||
(let ((m (apply jolt-hash-map es)))
|
||||
(when (pair? es) (hashtable-set! rdr-map-order m es))
|
||||
m))
|
||||
|
||||
(define (rdr-make-set elems)
|
||||
(jolt-hash-map rdr-kw-jolt-type rdr-kw-jolt-set
|
||||
rdr-kw-value (apply jolt-vector elems)))
|
||||
|
|
@ -248,7 +280,11 @@
|
|||
(if (symbol-t? target)
|
||||
(make-symbol-t (symbol-t-ns target) (symbol-t-name target)
|
||||
(rdr-merge-meta (symbol-t-meta target) meta))
|
||||
target)) ; non-symbol meta is dropped (corpus only hints symbols)
|
||||
;; non-symbol target (a collection): lower to a runtime (with-meta form meta)
|
||||
;; the analyzer compiles like any invoke — same as the Janet reader, so e.g.
|
||||
;; (meta ^{:tag :int} [1 2]) and ^:foo {} carry their meta at runtime. The meta
|
||||
;; pmap doubles as its own map-literal form.
|
||||
(jolt-list (jolt-symbol "clojure.core" "with-meta") target meta)))
|
||||
|
||||
;; --- # dispatch -------------------------------------------------------------
|
||||
(define (rdr-read-dispatch s i end) ; i points just past the '#'
|
||||
|
|
@ -268,6 +304,12 @@
|
|||
((char=? c #\') ; #'x var-quote -> (var x)
|
||||
(let-values (((form j) (rdr-read-form s (+ i 1) end)))
|
||||
(values (jolt-list (jolt-symbol #f "var") form) j)))
|
||||
((char=? c #\^) ; #^meta — deprecated metadata syntax = ^meta
|
||||
(let-values (((mform j) (rdr-read-form s (+ i 1) end)))
|
||||
(let-values (((target k) (rdr-read-form s j end)))
|
||||
(when (rdr-eof? target)
|
||||
(jolt-throw (jolt-ex-info "EOF after #^meta" (empty-pmap))))
|
||||
(values (rdr-attach-meta target (rdr-meta-map mform)) k))))
|
||||
(else ; #tag form -> tagged {:tag :#tag :form ...}
|
||||
(let-values (((tok j) (rdr-read-token s i end)))
|
||||
(let-values (((form k) (rdr-read-form s j end)))
|
||||
|
|
@ -310,7 +352,7 @@
|
|||
((char=? c #\[) (let-values (((es j) (rdr-read-seq s (+ i 1) end #\])))
|
||||
(values (apply jolt-vector es) j)))
|
||||
((char=? c #\{) (let-values (((es j) (rdr-read-seq s (+ i 1) end #\})))
|
||||
(values (apply jolt-hash-map es) j)))
|
||||
(values (rdr-make-map es) j)))
|
||||
((or (char=? c #\)) (char=? c #\]) (char=? c #\}))
|
||||
(values rdr-eof i)) ; unconsumed close — read-seq handles it
|
||||
((char=? c #\") (rdr-read-string-lit s (+ i 1) end))
|
||||
|
|
@ -318,7 +360,16 @@
|
|||
((char=? c #\:) (rdr-read-keyword s (+ i 1) end))
|
||||
((char=? c #\#) (rdr-read-dispatch s (+ i 1) end))
|
||||
((char=? c #\') (rdr-wrap s (+ i 1) end (jolt-symbol #f "quote")))
|
||||
((char=? c #\`) (rdr-wrap s (+ i 1) end (jolt-symbol #f "syntax-quote")))
|
||||
;; syntax-quote of a self-evaluating literal collapses to the literal at
|
||||
;; READ time (Clojure's reader), so nested backticks over a literal are
|
||||
;; inert: ``42 reads as 42, ```"meow" as "meow".
|
||||
((char=? c #\`)
|
||||
(let-values (((form j) (rdr-read-form s (+ i 1) end)))
|
||||
(when (rdr-eof? form) (jolt-throw (jolt-ex-info "EOF after `" (empty-pmap))))
|
||||
(values (if (rdr-self-eval-literal? form)
|
||||
form
|
||||
(jolt-list (jolt-symbol #f "syntax-quote") form))
|
||||
j)))
|
||||
((char=? c #\@) (rdr-wrap s (+ i 1) end (jolt-symbol "clojure.core" "deref")))
|
||||
((char=? c #\~)
|
||||
(if (and (< (+ i 1) end) (char=? (string-ref s (+ i 1)) #\@))
|
||||
|
|
@ -335,6 +386,11 @@
|
|||
(values (rdr-token->value tok) j))))))))
|
||||
|
||||
;; wrap the next form in a 2-element list (READER-MACRO form)
|
||||
;; self-evaluating literals (NOT symbols/collections) — syntax-quote passes these
|
||||
;; through unchanged, collapsed at read time.
|
||||
(define (rdr-self-eval-literal? x)
|
||||
(or (jolt-nil? x) (boolean? x) (number? x) (string? x) (keyword? x) (char? x)))
|
||||
|
||||
(define (rdr-wrap s i end head)
|
||||
(let-values (((form j) (rdr-read-form s i end)))
|
||||
(when (rdr-eof? form)
|
||||
|
|
|
|||
|
|
@ -78,7 +78,11 @@
|
|||
(if (jolt-nil? s) jolt-empty-list
|
||||
(let ((m (seq-more s))) (if (jolt-nil? m) jolt-empty-list m)))))
|
||||
(define (jolt-next x) ; nil when the rest is empty
|
||||
(let ((s (jolt-seq x))) (if (jolt-nil? s) jolt-nil (seq-more s))))
|
||||
;; next = (seq (rest x)): the rest must be RE-SEQ'd so an empty tail collapses to
|
||||
;; nil. seq-more on a lazy seq (e.g. map's) forces to jolt-empty-list, which is
|
||||
;; truthy — returning it raw made (next 1-elem-lazy-seq) non-nil, so butlast and
|
||||
;; other (if (next s) ...) loops over a lazy seq ran one step too far.
|
||||
(let ((s (jolt-seq x))) (if (jolt-nil? s) jolt-nil (jolt-seq (seq-more s)))))
|
||||
;; Only the HEAD cell carries the list marker — (rest a-list)/(next a-list) return
|
||||
;; the unmarked tail, so they are seqs and not list?, matching the seed (which
|
||||
;; makes rest-of-a-list a non-list seq). cons/list/reverse/conj therefore mark
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue