Dead-code removal, perf fixes, deterministic seed emission
Round 1 (correctness + dead code): - Fix duplicate java.util.HashMap registration in host-static.ss: the alist impl shadowed the hashtable ctor while leaving the hashtable methods bound, so .keySet/.values/.remove/.clear crashed. Drop the alist version. - Delete jolt-core/jolt/reader.clj: a 463-line dead duplicate reader, never required or compiled (the live reader is host/chez/reader.ss) and drifted. - Remove dead defs: ir/rt + :rt op + unused ir/op; the Janet branch in clojure.edn/drain-reader; a shadowed first clojure.string/trim-newline; io.ss jolt-char-array + the reader def-var (both shadowed by natives-array); concurrency.ss jolt-future-done?*; compile-eval.ss jolt-analyze-emit. Round 2 (perf + determinism): - emit-quoted-map-value / quoted sets now emit sorted by emitted text instead of host-hash order, which isn't stable across Chez versions (jolt-8479). - jolt-into folds through a transient, so into/vec/mapv/filterv onto a vector are O(n) instead of O(n^2). - deps resolve-deps walks its queue with an index cursor (was subvec-per-pop). - async channel and agent action queues use amortized-O(1) FIFOs; ArrayList is backed by a growable vector (O(1) add/get) instead of a list.
This commit is contained in:
Yogthos
parent
adafe04072
commit
e93006b4be
14 changed files with 199 additions and 656 deletions
|
|
@ -21,20 +21,39 @@
|
|||
(define (jolt-async-sliding-buffer n) (make-async-buffer n 'sliding))
|
||||
|
||||
;; --- channels ---------------------------------------------------------------
|
||||
;; items: a FIFO list of (value . box); box is #f for a buffered value or a 1-slot
|
||||
;; vector for an unbuffered rendezvous put (set #t when taken, waking the putter).
|
||||
;; items: an amortized-O(1) FIFO held as a mutable #(out in len) — `out` is the
|
||||
;; front (pop from its head), `in` holds pushed entries reversed onto it, `len` is
|
||||
;; the count (an append-to-a-list FIFO is O(n) per push and O(n) to measure).
|
||||
;; Each entry is (value . box); box is #f for a buffered value or a 1-slot vector
|
||||
;; for an unbuffered rendezvous put (set #t when taken, waking the putter).
|
||||
;; cap 0 + kind 'unbuffered = rendezvous; cap>0 with kind fixed/dropping/sliding.
|
||||
(define-record-type async-chan
|
||||
(fields mu cv (mutable items) cap kind (mutable closed?) (mutable xrf))
|
||||
(nongenerative async-chan-v1))
|
||||
|
||||
(define (ac-qlen ch) (length (async-chan-items ch)))
|
||||
(define (ac-qempty? ch) (null? (async-chan-items ch)))
|
||||
(define (ac-qpush! ch entry) (async-chan-items-set! ch (append (async-chan-items ch) (list entry))))
|
||||
(define (ac-qnew) (vector '() '() 0))
|
||||
(define (ac-qlen ch) (vector-ref (async-chan-items ch) 2))
|
||||
(define (ac-qempty? ch) (fx=? 0 (vector-ref (async-chan-items ch) 2)))
|
||||
(define (ac-qpush! ch entry)
|
||||
(let ((q (async-chan-items ch)))
|
||||
(vector-set! q 1 (cons entry (vector-ref q 1)))
|
||||
(vector-set! q 2 (fx+ 1 (vector-ref q 2)))))
|
||||
(define (ac-qfront! q) ; ensure `out` is non-empty: out := reverse in
|
||||
(when (null? (vector-ref q 0))
|
||||
(vector-set! q 0 (reverse (vector-ref q 1)))
|
||||
(vector-set! q 1 '())))
|
||||
(define (ac-qpop! ch)
|
||||
(let ((e (car (async-chan-items ch))))
|
||||
(async-chan-items-set! ch (cdr (async-chan-items ch))) e))
|
||||
(define (ac-qdrop-oldest! ch) (async-chan-items-set! ch (cdr (async-chan-items ch))))
|
||||
(let ((q (async-chan-items ch)))
|
||||
(ac-qfront! q)
|
||||
(let ((out (vector-ref q 0)))
|
||||
(vector-set! q 0 (cdr out))
|
||||
(vector-set! q 2 (fx- (vector-ref q 2) 1))
|
||||
(car out))))
|
||||
(define (ac-qdrop-oldest! ch)
|
||||
(let ((q (async-chan-items ch)))
|
||||
(ac-qfront! q)
|
||||
(vector-set! q 0 (cdr (vector-ref q 0)))
|
||||
(vector-set! q 2 (fx- (vector-ref q 2) 1))))
|
||||
|
||||
;; enqueue honoring the buffer kind (used by the transducer step + buffered puts).
|
||||
(define (ac-buf-give! ch v)
|
||||
|
|
@ -54,7 +73,7 @@
|
|||
((null? (cdr args)) (car args)) ; completion
|
||||
(else (ac-buf-give! ch (cadr args)) (car args))))) ; step
|
||||
|
||||
(define (ac-make cap kind xrf) (make-async-chan (make-mutex) (make-condition) '() cap kind #f xrf))
|
||||
(define (ac-make cap kind xrf) (make-async-chan (make-mutex) (make-condition) (ac-qnew) cap kind #f xrf))
|
||||
|
||||
;; (chan) | (chan n) | (chan buf) | (chan n|buf xform)
|
||||
(define (jolt-async-chan . args)
|
||||
|
|
|
|||
|
|
@ -62,10 +62,6 @@
|
|||
(ir (jolt-ce-analyze ctx form)))
|
||||
(jolt-ce-emit ir)))
|
||||
|
||||
;; Source string -> Scheme source string (read then analyze -> emit, all on Chez).
|
||||
(define (jolt-analyze-emit src ns)
|
||||
(jolt-analyze-emit-form (jolt-ce-read src) ns))
|
||||
|
||||
;; --- runtime defmacro -------------------------------------------------------
|
||||
;; Shared with emit-image.ss (loaded after this). A defmacro lowers to a def of
|
||||
;; its expander fn + a macro flag, exactly as the prelude emits build-time macros.
|
||||
|
|
|
|||
|
|
@ -96,7 +96,6 @@
|
|||
#t)))))
|
||||
cancelled))
|
||||
|
||||
(define (jolt-future-done?* f) (and (jolt-future? f) (jolt-future-done? f)))
|
||||
(define (jolt-native-future-done? x)
|
||||
(if (jolt-future? x) (jolt-future-done? x)
|
||||
(jolt-throw (jolt-ex-info "future-done? requires a future" (jolt-hash-map)))))
|
||||
|
|
@ -158,22 +157,34 @@
|
|||
(let loop ((o opts) (validator jolt-nil))
|
||||
(cond
|
||||
((or (null? o) (null? (cdr o)))
|
||||
(make-jolt-agent state jolt-nil validator '() #f (make-mutex) (make-condition)))
|
||||
(make-jolt-agent state jolt-nil validator (vector '() '()) #f (make-mutex) (make-condition)))
|
||||
((and (keyword-t? (car o)) (string=? (keyword-t-name (car o)) "validator"))
|
||||
(loop (cddr o) (cadr o)))
|
||||
(else (loop (cddr o) validator)))))
|
||||
|
||||
;; The action queue is an amortized-O(1) FIFO held as a mutable #(out in): `out` is
|
||||
;; the front, `in` holds sends reversed onto it (an append-to-a-list send was O(n)).
|
||||
;; All three helpers run under the agent mutex.
|
||||
(define (jagent-q-empty? a)
|
||||
(let ((q (jolt-agent-queue a))) (and (null? (vector-ref q 0)) (null? (vector-ref q 1)))))
|
||||
(define (jagent-q-push! a entry)
|
||||
(let ((q (jolt-agent-queue a))) (vector-set! q 1 (cons entry (vector-ref q 1)))))
|
||||
(define (jagent-q-pop! a)
|
||||
(let ((q (jolt-agent-queue a)))
|
||||
(when (null? (vector-ref q 0))
|
||||
(vector-set! q 0 (reverse (vector-ref q 1))) (vector-set! q 1 '()))
|
||||
(let ((out (vector-ref q 0))) (vector-set! q 0 (cdr out)) (car out))))
|
||||
|
||||
;; Drain the queue, applying each action (f state arg*) outside the lock (an action
|
||||
;; may send/deref the same agent). A validator rejection or a thrown action puts the
|
||||
;; agent in an error state and halts the queue (JVM :fail mode).
|
||||
(define (jolt-agent-worker a)
|
||||
(let loop ()
|
||||
(let ((act (with-mutex (jolt-agent-mu a)
|
||||
(if (or (not (jolt-nil? (jolt-agent-err a))) (null? (jolt-agent-queue a)))
|
||||
(if (or (not (jolt-nil? (jolt-agent-err a))) (jagent-q-empty? a))
|
||||
(begin (jolt-agent-running?-set! a #f)
|
||||
(condition-broadcast (jolt-agent-cv a)) #f)
|
||||
(let ((x (car (jolt-agent-queue a))))
|
||||
(jolt-agent-queue-set! a (cdr (jolt-agent-queue a))) x)))))
|
||||
(jagent-q-pop! a)))))
|
||||
(when act
|
||||
(guard (e (#t (with-mutex (jolt-agent-mu a)
|
||||
(jolt-agent-err-set! a e)
|
||||
|
|
@ -190,7 +201,7 @@
|
|||
;; the JVM's fixed/cached pool split.)
|
||||
(define (jolt-agent-send a f . args)
|
||||
(with-mutex (jolt-agent-mu a)
|
||||
(jolt-agent-queue-set! a (append (jolt-agent-queue a) (list (cons f args))))
|
||||
(jagent-q-push! a (cons f args))
|
||||
(unless (jolt-agent-running? a)
|
||||
(jolt-agent-running?-set! a #t)
|
||||
(fork-thread (lambda () (jolt-agent-worker a)))))
|
||||
|
|
@ -202,7 +213,7 @@
|
|||
(lambda (a)
|
||||
(with-mutex (jolt-agent-mu a)
|
||||
(let loop ()
|
||||
(when (or (jolt-agent-running? a) (pair? (jolt-agent-queue a)))
|
||||
(when (or (jolt-agent-running? a) (not (jagent-q-empty? a)))
|
||||
(condition-wait (jolt-agent-cv a) (jolt-agent-mu a)) (loop)))))
|
||||
agents)
|
||||
jolt-nil)
|
||||
|
|
|
|||
|
|
@ -427,12 +427,41 @@
|
|||
(register-class-ctor! "Object" (lambda _ (make-jhost "object" (vector))))
|
||||
|
||||
;; ---- java.util.ArrayList ----------------------------------------------------
|
||||
;; A mutable list backed by a Scheme list in a box. medley's stateful transducers
|
||||
;; (window / partition-between) build one with .add / .size / .toArray / .clear /
|
||||
;; .remove. (ArrayList.) | (ArrayList. n) | (ArrayList. coll).
|
||||
(define (al-list self) (vector-ref (jhost-state self) 0))
|
||||
(define (al-set! self xs) (vector-set! (jhost-state self) 0 xs))
|
||||
(define (make-arraylist xs) (make-jhost "arraylist" (vector xs)))
|
||||
;; A mutable list backed by a growable Scheme vector. State is #(backing count);
|
||||
;; .add amortizes O(1) and .get is O(1) (a list backing made both O(n)). medley's
|
||||
;; stateful transducers (window / partition-between) build one with .add / .size /
|
||||
;; .toArray / .clear / .remove. (ArrayList.) | (ArrayList. n) | (ArrayList. coll).
|
||||
(define al-min-cap 8)
|
||||
(define (al-vec self) (vector-ref (jhost-state self) 0))
|
||||
(define (al-cnt self) (vector-ref (jhost-state self) 1))
|
||||
(define (al-cnt! self n) (vector-set! (jhost-state self) 1 n))
|
||||
(define (make-arraylist xs) ; xs: a Scheme list of initial elements
|
||||
(let* ((n (length xs)) (cap (fxmax al-min-cap n)) (v (make-vector cap jolt-nil)))
|
||||
(let loop ((i 0) (xs xs)) (when (pair? xs) (vector-set! v i (car xs)) (loop (fx+ i 1) (cdr xs))))
|
||||
(make-jhost "arraylist" (vector v n))))
|
||||
(define (al-ensure! self need) ; grow the backing vector (doubling) to fit `need`
|
||||
(let ((v (al-vec self)))
|
||||
(when (fx>? need (vector-length v))
|
||||
(let grow ((cap (fxmax al-min-cap (vector-length v))))
|
||||
(if (fx<? cap need) (grow (fx* cap 2))
|
||||
(let ((nv (make-vector cap jolt-nil)))
|
||||
(let cp ((i 0)) (when (fx<? i (al-cnt self)) (vector-set! nv i (vector-ref v i)) (cp (fx+ i 1))))
|
||||
(vector-set! (jhost-state self) 0 nv)))))))
|
||||
(define (al-push! self x)
|
||||
(let ((n (al-cnt self))) (al-ensure! self (fx+ n 1)) (vector-set! (al-vec self) n x) (al-cnt! self (fx+ n 1))))
|
||||
(define (al-insert-at! self i x)
|
||||
(let ((n (al-cnt self)))
|
||||
(al-ensure! self (fx+ n 1))
|
||||
(let ((v (al-vec self)))
|
||||
(let shift ((j n)) (when (fx>? j i) (vector-set! v j (vector-ref v (fx- j 1))) (shift (fx- j 1))))
|
||||
(vector-set! v i x) (al-cnt! self (fx+ n 1)))))
|
||||
(define (al-remove-at! self i)
|
||||
(let ((n (al-cnt self)) (v (al-vec self)))
|
||||
(let shift ((j i)) (when (fx<? j (fx- n 1)) (vector-set! v j (vector-ref v (fx+ j 1))) (shift (fx+ j 1))))
|
||||
(vector-set! v (fx- n 1) jolt-nil) (al-cnt! self (fx- n 1))))
|
||||
(define (al->list self) ; first `count` elements as a Scheme list
|
||||
(let ((v (al-vec self)))
|
||||
(let loop ((i (fx- (al-cnt self) 1)) (acc '())) (if (fx<? i 0) acc (loop (fx- i 1) (cons (vector-ref v i) acc))))))
|
||||
(register-class-ctor! "ArrayList"
|
||||
(lambda args
|
||||
(cond ((null? args) (make-arraylist '()))
|
||||
|
|
@ -443,34 +472,28 @@
|
|||
(cond ((null? args) (make-arraylist '()))
|
||||
((number? (car args)) (make-arraylist '()))
|
||||
(else (make-arraylist (seq->list (jolt-seq (car args))))))))
|
||||
(define (al-remove-at xs i)
|
||||
(let loop ((xs xs) (i i) (acc '()))
|
||||
(cond ((null? xs) (reverse acc))
|
||||
((= i 0) (append (reverse acc) (cdr xs)))
|
||||
(else (loop (cdr xs) (- i 1) (cons (car xs) acc))))))
|
||||
(register-host-methods! "arraylist"
|
||||
(list
|
||||
(cons "add" (lambda (self . a)
|
||||
;; (.add x) -> append+true; (.add i x) -> insert at i, returns nil.
|
||||
(if (= 1 (length a))
|
||||
(begin (al-set! self (append (al-list self) (list (car a)))) #t)
|
||||
(let ((i (jnum->exact (car a))) (x (cadr a)) (xs (al-list self)))
|
||||
(al-set! self (append (list-head xs i) (list x) (list-tail xs i))) jolt-nil))))
|
||||
(cons "add!" (lambda (self x) (al-set! self (append (al-list self) (list x))) #t))
|
||||
(cons "get" (lambda (self i) (list-ref (al-list self) (jnum->exact i))))
|
||||
(begin (al-push! self (car a)) #t)
|
||||
(begin (al-insert-at! self (jnum->exact (car a)) (cadr a)) jolt-nil))))
|
||||
(cons "add!" (lambda (self x) (al-push! self x) #t))
|
||||
(cons "get" (lambda (self i) (vector-ref (al-vec self) (jnum->exact i))))
|
||||
(cons "set" (lambda (self i x)
|
||||
(let* ((xs (al-list self)) (idx (jnum->exact i)) (old (list-ref xs idx)))
|
||||
(al-set! self (append (list-head xs idx) (list x) (list-tail xs (+ idx 1)))) old)))
|
||||
(cons "size" (lambda (self) (->num (length (al-list self)))))
|
||||
(cons "isEmpty" (lambda (self) (null? (al-list self))))
|
||||
(let* ((idx (jnum->exact i)) (old (vector-ref (al-vec self) idx)))
|
||||
(vector-set! (al-vec self) idx x) old)))
|
||||
(cons "size" (lambda (self) (->num (al-cnt self))))
|
||||
(cons "isEmpty" (lambda (self) (fx=? 0 (al-cnt self))))
|
||||
(cons "remove" (lambda (self i)
|
||||
(let* ((xs (al-list self)) (idx (jnum->exact i)) (old (list-ref xs idx)))
|
||||
(al-set! self (al-remove-at xs idx)) old)))
|
||||
(cons "clear" (lambda (self) (al-set! self '()) jolt-nil))
|
||||
(cons "contains" (lambda (self x) (and (memp (lambda (e) (jolt=2 e x)) (al-list self)) #t)))
|
||||
(cons "toArray" (lambda (self . _) (apply jolt-vector (al-list self))))
|
||||
(cons "iterator" (lambda (self) (make-jiterator (list->cseq (al-list self)))))
|
||||
(cons "toString" (lambda (self) (jolt-pr-str (list->cseq (al-list self)))))))
|
||||
(let* ((idx (jnum->exact i)) (old (vector-ref (al-vec self) idx)))
|
||||
(al-remove-at! self idx) old)))
|
||||
(cons "clear" (lambda (self) (vector-set! (jhost-state self) 0 (make-vector al-min-cap jolt-nil)) (al-cnt! self 0) jolt-nil))
|
||||
(cons "contains" (lambda (self x) (and (memp (lambda (e) (jolt=2 e x)) (al->list self)) #t)))
|
||||
(cons "toArray" (lambda (self . _) (apply jolt-vector (al->list self))))
|
||||
(cons "iterator" (lambda (self) (make-jiterator (list->cseq (al->list self)))))
|
||||
(cons "toString" (lambda (self) (jolt-pr-str (list->cseq (al->list self)))))))
|
||||
|
||||
(register-class-ctor! "StringBuilder"
|
||||
(lambda args (make-jhost "string-builder"
|
||||
|
|
@ -631,32 +654,6 @@
|
|||
jolt-nil))
|
||||
(cons "close" (lambda (self) jolt-nil))))
|
||||
|
||||
;; ---- HashMap ----------------------------------------------------------------
|
||||
;; state: a box holding an alist of (k . v), jolt= keyed.
|
||||
(define (hm-alist self) (vector-ref (jhost-state self) 0))
|
||||
(define (hm-set! self al) (vector-set! (jhost-state self) 0 al))
|
||||
(define (hm-assoc al k v)
|
||||
(let loop ((ps al) (acc '()) (hit #f))
|
||||
(cond ((null? ps) (reverse (if hit acc (cons (cons k v) acc))))
|
||||
((jolt=2 (caar ps) k) (loop (cdr ps) (cons (cons k v) acc) #t))
|
||||
(else (loop (cdr ps) (cons (car ps) acc) hit)))))
|
||||
(define (hm-get al k) (let loop ((ps al)) (cond ((null? ps) jolt-nil) ((jolt=2 (caar ps) k) (cdar ps)) (else (loop (cdr ps))))))
|
||||
(define (coll->pairs m)
|
||||
(if (jolt-nil? m) '()
|
||||
(let loop ((s (jolt-seq m)) (acc '()))
|
||||
(if (jolt-nil? s) (reverse acc)
|
||||
(let ((e (seq-first s))) (loop (jolt-seq (seq-more s)) (cons (cons (jolt-nth e 0) (jolt-nth e 1)) acc)))))))
|
||||
(register-class-ctor! "HashMap"
|
||||
(lambda args
|
||||
(let ((init (and (pair? args) (car args))))
|
||||
(make-jhost "hashmap" (vector (if (and init (not (number? init))) (coll->pairs init) '()))))))
|
||||
(register-host-methods! "hashmap"
|
||||
(list (cons "get" (lambda (self k) (hm-get (hm-alist self) k)))
|
||||
(cons "put" (lambda (self k v) (hm-set! self (hm-assoc (hm-alist self) k v)) v))
|
||||
(cons "putAll" (lambda (self m) (for-each (lambda (p) (hm-set! self (hm-assoc (hm-alist self) (car p) (cdr p)))) (coll->pairs m)) jolt-nil))
|
||||
(cons "containsKey" (lambda (self k) (not (jolt-nil? (hm-get (hm-alist self) k)))))
|
||||
(cons "size" (lambda (self) (->num (length (hm-alist self)))))))
|
||||
|
||||
;; ---- StringTokenizer --------------------------------------------------------
|
||||
;; state: a vector #(tokens-list pos)
|
||||
(define (tokenize s delims)
|
||||
|
|
|
|||
|
|
@ -261,18 +261,6 @@
|
|||
(def-var! "clojure.core" "spit" jolt-spit)
|
||||
(def-var! "clojure.core" "flush" jolt-flush)
|
||||
|
||||
;; --- char-array: a seq of chars over a string (the JVM char[]). io/reader's
|
||||
;; char[] branch + selmer's (char-array template) feed on this.
|
||||
;; char-array (string -> chars). A leaf array native; lives here as io/reader
|
||||
;; is its only Chez consumer so far.
|
||||
(define (jolt-char-array a . rest)
|
||||
(cond
|
||||
((string? a) (list->cseq (string->list a)))
|
||||
((number? a) (list->cseq (make-list (exact (truncate a)) #\nul)))
|
||||
(else (list->cseq (map (lambda (c) (if (char? c) c (integer->char (exact (truncate c)))))
|
||||
(seq->list a))))))
|
||||
(def-var! "clojure.core" "char-array" jolt-char-array)
|
||||
|
||||
;; --- with-open's close seam (__close): a map-like value closes via its :close
|
||||
;; fn; a jhost reader/writer/file via its .close method (a no-op here); anything
|
||||
;; else is an error.
|
||||
|
|
@ -323,7 +311,8 @@
|
|||
;; --- clojure.java.io ns -----------------------------------------------------
|
||||
(def-var! "clojure.java.io" "file" jolt-make-file)
|
||||
(def-var! "clojure.java.io" "as-file" (lambda (x) (if (jfile? x) x (make-jfile (file-path-of x)))))
|
||||
(def-var! "clojure.java.io" "reader" jolt-io-reader)
|
||||
;; "reader" is bound by natives-array.ss (loaded later) so a char[] argument is
|
||||
;; handled; that binding delegates here via jolt-io-reader for everything else.
|
||||
(def-var! "clojure.java.io" "writer" jolt-io-writer)
|
||||
(def-var! "clojure.java.io" "input-stream" jolt-io-reader)
|
||||
(def-var! "clojure.java.io" "output-stream" jolt-io-writer)
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
|
|
@ -1063,7 +1063,7 @@
|
|||
(guard (e (#t #f))
|
||||
(def-var! "clojure.edn" "read-string" (letrec ((read-string (case-lambda ((s) (let fnrec93 ((s s)) (jolt-invoke (var-deref "clojure.edn" "read-edn") (jolt-hash-map) s))) ((opts s) (let fnrec94 ((opts opts) (s s)) (jolt-invoke (var-deref "clojure.edn" "read-edn") opts s)))))) read-string)))
|
||||
(guard (e (#t #f))
|
||||
(def-var! "clojure.edn" "drain-reader" (letrec ((drain-reader (lambda (reader) (let fnrec95 ((reader reader)) (if (jolt= (keyword "core" "file") (host-static-call "janet" "type" reader)) (host-static-call "janet.file" "read" reader (keyword #f "all")) (let* ((acc (jolt-invoke (var-deref "clojure.core" "transient") (jolt-vector))) (c (record-method-dispatch reader "read" (jolt-vector)))) (let loop96 ((acc acc) (c c)) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "==") -1 c)) (jolt-apply (var-deref "clojure.core" "str") (jolt-map (var-deref "clojure.core" "char") (jolt-invoke (var-deref "clojure.core" "persistent!") acc))) (let* ((_a$97 (jolt-invoke (var-deref "clojure.core" "conj!") acc c)) (_a$98 (record-method-dispatch reader "read" (jolt-vector)))) (loop96 _a$97 _a$98)))))))))) drain-reader)))
|
||||
(def-var! "clojure.edn" "drain-reader" (letrec ((drain-reader (lambda (reader) (let fnrec95 ((reader reader)) (let* ((acc (jolt-invoke (var-deref "clojure.core" "transient") (jolt-vector))) (c (record-method-dispatch reader "read" (jolt-vector)))) (let loop96 ((acc acc) (c c)) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "==") -1 c)) (jolt-apply (var-deref "clojure.core" "str") (jolt-map (var-deref "clojure.core" "char") (jolt-invoke (var-deref "clojure.core" "persistent!") acc))) (let* ((_a$97 (jolt-invoke (var-deref "clojure.core" "conj!") acc c)) (_a$98 (record-method-dispatch reader "read" (jolt-vector)))) (loop96 _a$97 _a$98))))))))) drain-reader)))
|
||||
(guard (e (#t #f))
|
||||
(def-var! "clojure.edn" "read" (letrec ((read (case-lambda ((reader) (let fnrec99 ((reader reader)) (jolt-invoke read (jolt-hash-map) reader))) ((opts reader) (let fnrec100 ((opts opts) (reader reader)) (jolt-invoke (var-deref "clojure.edn" "read-edn") opts (jolt-invoke (var-deref "clojure.edn" "drain-reader") reader))))))) read)))
|
||||
(guard (e (#t #f))
|
||||
|
|
|
|||
|
|
@ -206,7 +206,13 @@
|
|||
(if (jolt-reduced? r) (jolt-reduced-val r) r))))
|
||||
(else (reduce-seq f init (jolt-seq coll)))))))
|
||||
|
||||
(define (jolt-into to from) (reduce-seq (lambda (acc x) (jolt-conj1 acc x)) to (jolt-seq from)))
|
||||
;; Fold through a transient so a pvec/pmap/pset target is built in O(n): a
|
||||
;; persistent pvec-conj copies its whole backing vector each step, making a naive
|
||||
;; fold O(n^2) (and into/vec/mapv/filterv all route here). jolt-transient-new
|
||||
;; falls back to a copy-on-write wrapper for other targets (lists, sorted colls,
|
||||
;; nil), so those keep the old per-step jolt-conj behaviour.
|
||||
(define (jolt-into to from)
|
||||
(jolt-persistent! (reduce-seq (lambda (t x) (jolt-conj! t x)) (jolt-transient-new to) (jolt-seq from))))
|
||||
|
||||
(define (range-from n) (cseq-lazy n (lambda () (range-from (+ n 1)))))
|
||||
(define (range-bounded n end step)
|
||||
|
|
|
|||
|
|
@ -210,10 +210,12 @@
|
|||
(str/join " " (mapcat (fn [p] [(emit-quoted (nth p 0)) (emit-quoted (nth p 1))]) pairs))
|
||||
")"))
|
||||
(defn- emit-quoted-map-value [m]
|
||||
;; a jolt map VALUE (def/symbol metadata is a value, not a reader form)
|
||||
(str "(jolt-hash-map "
|
||||
(str/join " " (mapcat (fn [k] [(emit-quoted k) (emit-quoted (get m k))]) (keys m)))
|
||||
")"))
|
||||
;; A jolt map VALUE (def/symbol metadata is a value, not a reader form). (keys m)
|
||||
;; iterates in host-hash order, which is not stable across Chez versions, so emit
|
||||
;; the pairs sorted by their emitted Scheme text — keeps the seed byte-fixed
|
||||
;; regardless of the host hash (jolt-8479).
|
||||
(let [pairs (sort (map (fn [k] (str (emit-quoted k) " " (emit-quoted (get m k)))) (keys m)))]
|
||||
(str "(jolt-hash-map " (str/join " " pairs) ")")))
|
||||
;; emit-quoted reconstructs both raw reader forms (from :quote) AND plain jolt
|
||||
;; values (def/symbol :meta). Reader forms are walked via the jolt.host form-*
|
||||
;; contract; the native-predicate branches below catch genuine jolt collection
|
||||
|
|
@ -230,14 +232,16 @@
|
|||
(str "(jolt-symbol/meta " (if sns (chez-str-lit sns) "#f") " " (chez-str-lit nm) " "
|
||||
(emit-quoted m) ")")
|
||||
(str "(jolt-symbol " (if sns (chez-str-lit sns) "#f") " " (chez-str-lit nm) ")")))
|
||||
(form-set? form) (str "(jolt-hash-set " (str/join " " (map emit-quoted (form-set-items form))) ")")
|
||||
;; sort items by emitted text: a set has no source order, and host-hash order
|
||||
;; is not stable across Chez versions (jolt-8479).
|
||||
(form-set? form) (str "(jolt-hash-set " (str/join " " (sort (map emit-quoted (form-set-items form)))) ")")
|
||||
(form-list? form) (str "(jolt-list " (str/join " " (map emit-quoted (form-elements form))) ")")
|
||||
(form-vec? form) (str "(jolt-vector " (str/join " " (map emit-quoted (form-vec-items form))) ")")
|
||||
(form-map? form) (emit-quoted-map (form-map-pairs form))
|
||||
;; plain jolt VALUES (metadata maps and anything nested in them)
|
||||
(map? form) (emit-quoted-map-value form)
|
||||
(vector? form) (str "(jolt-vector " (str/join " " (map emit-quoted form)) ")")
|
||||
(set? form) (str "(jolt-hash-set " (str/join " " (map emit-quoted form)) ")")
|
||||
(set? form) (str "(jolt-hash-set " (str/join " " (sort (map emit-quoted form))) ")")
|
||||
(seq? form) (str "(jolt-list " (str/join " " (map emit-quoted form)) ")")
|
||||
:else (throw (ex-info (str "emit-quoted: unsupported quoted form " (pr-str form)) {}))))
|
||||
|
||||
|
|
|
|||
|
|
@ -83,22 +83,26 @@
|
|||
declarations from every dep's deps.edn. `base-dir` resolves :local/root and is
|
||||
replaced by a dep's own root as the walk descends."
|
||||
[deps base-dir]
|
||||
;; queue grows by appending children at the tail; an index cursor walks it so
|
||||
;; each dequeue is O(1) (was (subvec (vec queue) 1) per pop -> O(n^2)).
|
||||
(loop [queue (mapv (fn [[c s]] [c s base-dir]) (seq deps))
|
||||
i 0
|
||||
seen #{}
|
||||
roots []
|
||||
natives []]
|
||||
(if (empty? queue)
|
||||
(if (>= i (count queue))
|
||||
{:roots (distinct roots) :natives natives}
|
||||
(let [[coord spec bd] (first queue)
|
||||
queue (subvec (vec queue) 1)]
|
||||
(let [[coord spec bd] (nth queue i)
|
||||
i (inc i)]
|
||||
(if (contains? seen coord)
|
||||
(recur queue seen roots natives)
|
||||
(recur queue i seen roots natives)
|
||||
(let [root (coord-root coord spec bd)]
|
||||
(if (nil? root)
|
||||
(recur queue (conj seen coord) roots natives)
|
||||
(recur queue i (conj seen coord) roots natives)
|
||||
(let [edn (read-edn (str root "/deps.edn"))
|
||||
child (mapv (fn [[c s]] [c s root]) (seq (:deps edn)))]
|
||||
(recur (into queue child)
|
||||
i
|
||||
(conj seen coord)
|
||||
(into roots (dep-source-roots root))
|
||||
(into natives (:jolt/native edn)))))))))))
|
||||
|
|
|
|||
|
|
@ -20,9 +20,6 @@
|
|||
;; end emits the embedded var cell so `binding`'s thread-binding frame can key on it.
|
||||
(defn the-var [ns name] {:op :the-var :ns ns :name name})
|
||||
|
||||
;; A runtime primitive (cons, +, get, apply, …) the back end maps to the host RT.
|
||||
(defn rt [name] {:op :rt :name name})
|
||||
|
||||
;; A name that resolves only via the host's own environment (e.g. + or int?) —
|
||||
;; the back end emits a host-appropriate reference.
|
||||
(defn host-ref [name] {:op :host :name name})
|
||||
|
|
@ -69,8 +66,6 @@
|
|||
(defn quote-node [form] {:op :quote :form form})
|
||||
(defn throw-node [expr] {:op :throw :expr expr})
|
||||
|
||||
(defn op [node] (:op node))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; Structural recursion over IR child nodes.
|
||||
;;
|
||||
|
|
@ -127,5 +122,5 @@
|
|||
n (if (get node :catch-body) (assoc n :catch-body (f (get node :catch-body))) n)
|
||||
n (if (get node :finally) (assoc n :finally (f (get node :finally))) n)]
|
||||
n)
|
||||
;; :const :local :var :host :host-static :the-var :rt :quote — no child nodes
|
||||
;; :const :local :var :host :host-static :the-var :quote — no child nodes
|
||||
:else node)))
|
||||
|
|
|
|||
|
|
@ -1,463 +0,0 @@
|
|||
(ns jolt.reader
|
||||
"Reads Clojure source text into reader forms.
|
||||
|
||||
The lexing and parsing is portable Clojure; form construction and
|
||||
string->number parsing delegate to the jolt.host contract (form-make-symbol/
|
||||
char, form-char-from-name, form-scan-number). A Clojure source file can't write
|
||||
a {:jolt/type :symbol} literal — it would parse as a tagged reader form — and
|
||||
the concrete form representation belongs to the host. The analyzer uses the same
|
||||
split. Once cross-compiled this runs on Chez to drive compile-from-source.
|
||||
|
||||
Positions are character indices; for ASCII source they coincide with byte
|
||||
indices, and form values are identical either way — the parity gate compares
|
||||
values, not positions."
|
||||
(:require [clojure.string :as str]
|
||||
[jolt.host :refer [form-make-symbol form-make-char form-char-from-name
|
||||
form-scan-number form-make-list form-make-vector
|
||||
form-make-map form-sym-merge-meta form-make-set
|
||||
form-make-tagged form-gensym-name
|
||||
form-sym? form-sym-name form-sym-ns form-char?
|
||||
form-list? form-vec? form-set? form-map?
|
||||
form-elements form-vec-items form-set-items
|
||||
form-map-pairs]]))
|
||||
|
||||
;; Source access by CHARACTER codepoint
|
||||
;; (identical to byte access for ASCII). cp = codepoint at i; len = character count.
|
||||
(defn- cp [s i] (int (nth s i)))
|
||||
(defn- len [s] (count s))
|
||||
|
||||
(defn- whitespace? [c] (or (= c 32) (= c 9) (= c 10) (= c 13) (= c 44))) ; space tab nl cr ,
|
||||
(defn- digit? [c] (and (>= c 48) (<= c 57)))
|
||||
(defn- hex-digit? [c]
|
||||
(or (digit? c) (and (>= c 65) (<= c 70)) (and (>= c 97) (<= c 102))))
|
||||
(defn- symbol-start? [c]
|
||||
(or (and (>= c 65) (<= c 90)) (and (>= c 97) (<= c 122))
|
||||
(= c 42) (= c 43) (= c 33) (= c 95) (= c 45) (= c 63) (= c 46)
|
||||
(= c 60) (= c 62) (= c 61) (= c 38) (= c 124) (= c 36) (= c 37) (= c 47)))
|
||||
(defn- symbol-char? [c]
|
||||
(or (symbol-start? c) (digit? c) (= c 35) (= c 39) (= c 58))) ; + # ' :
|
||||
|
||||
(defn- skip-whitespace [s pos]
|
||||
(if (and (< pos (len s)) (whitespace? (cp s pos)))
|
||||
(recur s (inc pos))
|
||||
pos))
|
||||
|
||||
(defn- read-until-newline [s pos]
|
||||
(if (or (>= pos (len s)) (= (cp s pos) 10)) pos (recur s (inc pos))))
|
||||
|
||||
;; --- symbols -----------------------------------------------------------------
|
||||
(defn- read-symbol-name [s pos end]
|
||||
(if (and (< end (len s)) (symbol-char? (cp s end))) (recur s pos (inc end)) end))
|
||||
|
||||
(defn- read-symbol* [s pos]
|
||||
(let [end (read-symbol-name s pos pos)]
|
||||
(when (= end pos)
|
||||
(throw (ex-info (str "Unrecognized character: " (char (cp s pos))) {})))
|
||||
(let [nm (subs s pos end)]
|
||||
(cond
|
||||
(= nm "nil") [nil end]
|
||||
(= nm "true") [true end]
|
||||
(= nm "false") [false end]
|
||||
:else [(form-make-symbol nm) end]))))
|
||||
|
||||
;; --- keywords ----------------------------------------------------------------
|
||||
(defn- read-keyword-name [s pos end]
|
||||
(if (and (< end (len s)) (symbol-char? (cp s end))) (recur s pos (inc end)) end))
|
||||
|
||||
(defn- read-keyword* [s pos]
|
||||
;; pos is at the first colon; ::foo is treated as :foo (no auto-resolution).
|
||||
(let [start (if (and (< (inc pos) (len s)) (= (cp s (inc pos)) 58)) (+ pos 2) (inc pos))
|
||||
end (read-keyword-name s start start)]
|
||||
[(keyword (subs s start end)) end]))
|
||||
|
||||
;; --- strings -----------------------------------------------------------------
|
||||
(defn- escape-char [c]
|
||||
(cond (= c 110) "\n" (= c 116) "\t" (= c 114) "\r" (= c 92) "\\" (= c 34) "\""
|
||||
:else (str (char c))))
|
||||
|
||||
(defn- read-string* [s pos]
|
||||
;; pos at opening double-quote
|
||||
(loop [p (inc pos) acc []]
|
||||
(when (>= p (len s)) (throw (ex-info "Unterminated string" {})))
|
||||
(let [c (cp s p)]
|
||||
(cond
|
||||
(= c 92) (let [np (inc p)]
|
||||
(when (>= np (len s)) (throw (ex-info "Unterminated escape" {})))
|
||||
(recur (+ p 2) (conj acc (escape-char (cp s np)))))
|
||||
(= c 34) [(apply str acc) (inc p)]
|
||||
:else (recur (inc p) (conj acc (str (char c))))))))
|
||||
|
||||
;; --- numbers -----------------------------------------------------------------
|
||||
(defn- read-digits [s pos end]
|
||||
(if (and (< end (len s)) (digit? (cp s end))) (recur s pos (inc end)) end))
|
||||
(defn- read-hex-digits [s pos end]
|
||||
(if (and (< end (len s)) (hex-digit? (cp s end))) (recur s pos (inc end)) end))
|
||||
|
||||
;; Value of an alphanumeric digit for radix parsing (0-9, a-z/A-Z = 10-35).
|
||||
(defn- radix-digit-val [c]
|
||||
(cond
|
||||
(and (>= c 48) (<= c 57)) (- c 48)
|
||||
(and (>= c 97) (<= c 122)) (+ 10 (- c 97))
|
||||
(and (>= c 65) (<= c 90)) (+ 10 (- c 65))
|
||||
:else nil))
|
||||
(defn- read-alnum [s pos end]
|
||||
(if (and (< end (len s)) (radix-digit-val (cp s end))) (recur s pos (inc end)) end))
|
||||
|
||||
(defn- read-exponent [s end]
|
||||
;; if s[end] is e/E (optionally signed) followed by digits, return index past it
|
||||
(if (and (< end (len s)) (let [c (cp s end)] (or (= c 101) (= c 69))))
|
||||
(let [p (if (and (< (inc end) (len s)) (let [c (cp s (inc end))] (or (= c 43) (= c 45))))
|
||||
(+ end 2) (inc end))
|
||||
de (read-digits s p p)]
|
||||
(if (> de p) de end))
|
||||
end))
|
||||
|
||||
;; Jolt has no bignum/ratio: N (bigint) / M (bigdec) suffixes read as the plain
|
||||
;; number, a ratio a/b reads as the double quotient, radixed ints by base.
|
||||
(defn- read-number* [s pos]
|
||||
(let [length (len s)
|
||||
;; optional leading sign: - negates; + is a positive no-op (Clojure reads
|
||||
;; +5 as 5). read-form only dispatches +digit/-digit, so the sign is real.
|
||||
neg (and (< pos length) (= (cp s pos) 45))
|
||||
plus (and (< pos length) (= (cp s pos) 43))
|
||||
start (if (or neg plus) (inc pos) pos)
|
||||
hex? (and (< (inc start) length) (= (cp s start) 48)
|
||||
(let [c1 (cp s (inc start))] (or (= c1 120) (= c1 88))))] ; 0x / 0X
|
||||
(if hex?
|
||||
(let [hs (+ start 2) he (read-hex-digits s hs hs)]
|
||||
(when (= he hs) (throw (ex-info "Expected hex digits" {})))
|
||||
(let [he2 (if (and (< he length) (= (cp s he) 78)) (inc he) he) ; trailing N
|
||||
val (form-scan-number (str "0x" (subs s hs he)))]
|
||||
[(if neg (- val) val) he2]))
|
||||
(let [iend (read-digits s start start)]
|
||||
(when (= iend start) (throw (ex-info "Expected number" {})))
|
||||
(cond
|
||||
;; radix integer <base>r<digits>
|
||||
(and (< iend length) (let [c (cp s iend)] (or (= c 114) (= c 82))))
|
||||
(let [base (form-scan-number (subs s start iend))
|
||||
ds (inc iend) de (read-alnum s ds ds)]
|
||||
(when (= de ds) (throw (ex-info "Expected radix digits" {})))
|
||||
(let [acc (reduce (fn [a i] (+ (* a base) (radix-digit-val (cp s i)))) 0 (range ds de))]
|
||||
[(if neg (- acc) acc) de]))
|
||||
;; ratio <int>/<int> (only when a digit follows the slash)
|
||||
(and (< (inc iend) length) (= (cp s iend) 47) (digit? (cp s (inc iend))))
|
||||
(let [ds (inc iend) de (read-digits s ds ds)
|
||||
numr (form-scan-number (subs s start iend))
|
||||
den (form-scan-number (subs s ds de))]
|
||||
[(if neg (- (/ numr den)) (/ numr den)) de])
|
||||
;; fractional and/or exponent, optional trailing N/M
|
||||
:else
|
||||
(let [frac-end (if (and (< iend length) (= (cp s iend) 46))
|
||||
(let [fs (inc iend) fe (read-digits s fs fs)]
|
||||
(when (= fe fs) (throw (ex-info "Expected digit after ." {})))
|
||||
fe)
|
||||
iend)
|
||||
exp-end (read-exponent s frac-end)
|
||||
val (form-scan-number (subs s start exp-end))
|
||||
fin (if (and (< exp-end length) (let [c (cp s exp-end)] (or (= c 78) (= c 77))))
|
||||
(inc exp-end) exp-end)]
|
||||
[(if neg (- val) val) fin]))))))
|
||||
|
||||
;; --- characters --------------------------------------------------------------
|
||||
(defn- read-char-name-end [s pos]
|
||||
(if (and (< pos (len s)) (symbol-char? (cp s pos))) (recur s (inc pos)) pos))
|
||||
|
||||
(defn- read-char* [s pos]
|
||||
(when (>= (inc pos) (len s)) (throw (ex-info "unexpected end of input after \\" {})))
|
||||
(let [end (read-char-name-end s (inc pos))]
|
||||
(if (= end (inc pos))
|
||||
;; a non-symbol char right after \ is a one-character literal of itself
|
||||
[(form-make-char (cp s (inc pos))) (+ pos 2)]
|
||||
[(form-char-from-name (subs s (inc pos) end)) end])))
|
||||
|
||||
;; --- dispatcher --------------------------------------------------------------
|
||||
;; read-form returns a CONTROL triple [kind payload pos]:
|
||||
;; :form payload=the form a real datum
|
||||
;; :skip payload=nil a comment (;) or #_ discard — produced nothing
|
||||
;; :splice payload=items-vector #?@ — contributes 0+ items to the enclosing coll
|
||||
;; Out-of-band control (rather than :jolt/skip / :jolt/splice sentinel
|
||||
;; FORMS) keeps it collision-free and host-neutral — no tagged-struct to build or
|
||||
;; recognize. Collection readers dispatch on kind; read-next-form skips :skip.
|
||||
(declare read-form)
|
||||
|
||||
(defn- number-start? [s pos c]
|
||||
(or (digit? c)
|
||||
(and (= c 45) (< (inc pos) (len s)) (digit? (cp s (inc pos))))
|
||||
(and (= c 43) (< (inc pos) (len s)) (digit? (cp s (inc pos))))))
|
||||
|
||||
;; Read items until `close`, dispatching control kinds. Returns [items-vec end].
|
||||
(defn- read-delimited [s start-pos close errmsg]
|
||||
(loop [pos start-pos items []]
|
||||
(let [pos (skip-whitespace s pos)]
|
||||
(when (>= pos (len s)) (throw (ex-info errmsg {})))
|
||||
(if (= (cp s pos) close)
|
||||
[items (inc pos)]
|
||||
(let [[kind payload np] (read-form s pos)]
|
||||
(case kind
|
||||
:skip (recur np items)
|
||||
:splice (recur np (into items payload))
|
||||
:form (recur np (conj items payload))))))))
|
||||
|
||||
(defn- read-list* [s pos]
|
||||
(let [[items end] (read-delimited s (inc pos) 41 "Unterminated list")] ; )
|
||||
[:form (form-make-list items) end]))
|
||||
|
||||
(defn- read-vector* [s pos]
|
||||
(let [[items end] (read-delimited s (inc pos) 93 "Unterminated vector")] ; ]
|
||||
[:form (form-make-vector items) end]))
|
||||
|
||||
;; Map: pair up keys and values, skipping comments/#_ in either slot while keeping
|
||||
;; the pending key (dropping both desyncs the pairing). A key/value is always a
|
||||
;; single :form (or :skip) — splice in a map slot is not supported.
|
||||
(defn- read-map* [s pos]
|
||||
(loop [pos (inc pos) kvs []]
|
||||
(let [pos (skip-whitespace s pos)]
|
||||
(when (>= pos (len s)) (throw (ex-info "Unterminated map" {})))
|
||||
(if (= (cp s pos) 125) ; }
|
||||
[:form (form-make-map kvs) (inc pos)]
|
||||
(let [[kk kp knp] (read-form s pos)]
|
||||
(if (= kk :skip)
|
||||
(recur knp kvs)
|
||||
;; key in hand; read the value slot, skipping trivia but keeping the key
|
||||
(let [[v vnp]
|
||||
(loop [vp (skip-whitespace s knp)]
|
||||
(when (>= vp (len s)) (throw (ex-info "Unterminated map" {})))
|
||||
(let [[vk vp2 vnp2] (read-form s vp)]
|
||||
(if (= vk :skip) (recur (skip-whitespace s vnp2)) [vp2 vnp2])))]
|
||||
(recur vnp (conj (conj kvs kp) v)))))))))
|
||||
|
||||
;; Read the next REAL form (skip :skip), returning [form pos]. Used wherever a
|
||||
;; single datum is needed (quote/meta/top level).
|
||||
(defn- read-next-form [s pos]
|
||||
(let [[kind payload np] (read-form s pos)]
|
||||
(case kind
|
||||
:skip (recur s np)
|
||||
:form [payload np]
|
||||
:splice (throw (ex-info "splice (#?@) not inside a collection" {})))))
|
||||
|
||||
;; syntax-quote of a self-evaluating literal collapses to the literal at read time
|
||||
;; (so nested backticks over literals are inert). NOT symbols (they qualify) or
|
||||
;; collections (they template).
|
||||
(defn- self-evaluating-literal? [form]
|
||||
(or (nil? form) (true? form) (false? form) (number? form)
|
||||
(string? form) (keyword? form) (form-char? form)))
|
||||
|
||||
(defn- read-quote* [s newpos token-sym]
|
||||
(let [[form finalpos] (read-next-form s newpos)]
|
||||
(if (and (= "syntax-quote" (form-sym-name token-sym)) (self-evaluating-literal? form))
|
||||
[:form form finalpos]
|
||||
[:form (form-make-list [token-sym form]) finalpos])))
|
||||
|
||||
;; Normalize a metadata reader form: keyword -> {kw true}; symbol/string -> {:tag …}
|
||||
;; (a symbol tag keeps its ns qualifier); else nil (a map-literal meta).
|
||||
(defn- meta-form->map [meta-form]
|
||||
(cond
|
||||
(keyword? meta-form) {meta-form true}
|
||||
(form-sym? meta-form) {:tag (if (form-sym-ns meta-form)
|
||||
(str (form-sym-ns meta-form) "/" (form-sym-name meta-form))
|
||||
(form-sym-name meta-form))}
|
||||
(string? meta-form) {:tag meta-form}
|
||||
:else nil))
|
||||
|
||||
(defn- read-meta* [s pos]
|
||||
;; pos at ^
|
||||
(let [[meta-form np] (read-next-form s (inc pos))
|
||||
[form np2] (read-next-form s np)
|
||||
m (meta-form->map meta-form)]
|
||||
(if (and m (form-sym? form))
|
||||
;; attach to the symbol itself (^Type x / ^:dynamic) — stays a bare symbol
|
||||
[:form (form-sym-merge-meta form m) np2]
|
||||
;; non-symbol target -> a runtime with-meta form (normalized map, or the
|
||||
;; raw map-literal meta when m is nil)
|
||||
[:form (form-make-list [(form-make-symbol "with-meta") form (if m m meta-form)]) np2])))
|
||||
|
||||
;; --- dispatch (#) ------------------------------------------------------------
|
||||
;; Reader-conditional feature set (spec 02-reader). jolt's portable default; the
|
||||
;; JOLT_FEATURES env override is a host concern wired later. :default always honored.
|
||||
(def reader-features (atom #{:jolt :default}))
|
||||
(defn set-reader-features! [features] (reset! reader-features (conj (set features) :default)))
|
||||
|
||||
(defn- read-set* [s pos]
|
||||
;; pos at #, next char {
|
||||
(let [[items end] (read-delimited s (+ pos 2) 125 "Unterminated set")] ; }
|
||||
[:form (form-make-set items) end]))
|
||||
|
||||
(defn- read-var-quote* [s pos]
|
||||
;; pos at #, next char '
|
||||
(let [[form np] (read-next-form s (+ pos 2))]
|
||||
[:form (form-make-list [(form-make-symbol "var") form]) np]))
|
||||
|
||||
(defn- read-regex* [s pos]
|
||||
;; pos at #, next char "; read raw to the unescaped closing " (backslashes kept)
|
||||
(loop [i (+ pos 2)]
|
||||
(when (>= i (len s)) (throw (ex-info "Unterminated regex literal" {})))
|
||||
(let [c (cp s i)]
|
||||
(cond
|
||||
(= c 92) (recur (+ i 2)) ; backslash escapes next char
|
||||
(= c 34) [:form (form-make-tagged :regex (subs s (+ pos 2) i)) (inc i)]
|
||||
:else (recur (inc i))))))
|
||||
|
||||
;; #?(…) / #?@(…): pick the first clause whose feature key is active (clause order,
|
||||
;; like Clojure). #? -> :skip when the result is nil (e.g. a :cljs branch); #?@ ->
|
||||
;; :splice the resolved items into the enclosing collection.
|
||||
(defn- rc-resolve [clauses]
|
||||
;; clauses: a jolt vector of [feature-kw form feature-kw form ...]
|
||||
(loop [i 0]
|
||||
(if (>= i (count clauses))
|
||||
[false nil]
|
||||
(if (contains? @reader-features (nth clauses i))
|
||||
[true (nth clauses (inc i))]
|
||||
(recur (+ i 2))))))
|
||||
|
||||
(defn- read-reader-conditional* [s pos]
|
||||
;; pos at #, next char ? (optionally ?@)
|
||||
(let [splice? (and (< (+ pos 2) (len s)) (= (cp s (+ pos 2)) 64)) ; @
|
||||
form-start (if splice? (+ pos 3) (+ pos 2))
|
||||
[form np] (read-next-form s form-start)]
|
||||
(if (form-list? form)
|
||||
(let [clauses (form-elements form)
|
||||
[matched result] (rc-resolve clauses)]
|
||||
(if splice?
|
||||
(let [items (cond (not matched) []
|
||||
(form-list? result) (vec (form-elements result))
|
||||
(form-vec? result) (vec (form-vec-items result))
|
||||
:else [result])]
|
||||
[:splice items np])
|
||||
(if (or (not matched) (nil? result)) [:skip nil np] [:form result np])))
|
||||
(throw (ex-info "reader conditional body must be a list" {})))))
|
||||
|
||||
;; Symbolic values ##Inf ##-Inf ##NaN.
|
||||
(defn- read-symbolic* [s pos]
|
||||
(let [end (read-symbol-name s (+ pos 2) (+ pos 2))
|
||||
nm (subs s (+ pos 2) end)]
|
||||
(cond
|
||||
(= nm "Inf") [:form ##Inf end]
|
||||
(= nm "-Inf") [:form ##-Inf end]
|
||||
(= nm "NaN") [:form ##NaN end]
|
||||
:else (throw (ex-info (str "Invalid symbolic value: ##" nm) {})))))
|
||||
|
||||
(defn- read-tagged* [s pos]
|
||||
;; unknown dispatch -> a tagged literal (#inst, #uuid, #foo). The tag includes
|
||||
;; the leading # (read-symbol-name starts at #).
|
||||
(let [end (read-symbol-name s pos pos)
|
||||
tag (subs s pos end)
|
||||
[form np] (read-next-form s end)]
|
||||
[:form (form-make-tagged (keyword tag) form) np]))
|
||||
|
||||
(declare read-anon-fn*)
|
||||
|
||||
(defn- read-dispatch* [s pos]
|
||||
;; pos at #
|
||||
(when (>= (inc pos) (len s)) (throw (ex-info "Unexpected end after #" {})))
|
||||
(let [c (cp s (inc pos))]
|
||||
(cond
|
||||
(= c 123) (read-set* s pos) ; #{
|
||||
(= c 40) (read-anon-fn* s pos) ; #(
|
||||
(= c 63) (read-reader-conditional* s pos) ; #?
|
||||
(= c 95) (let [[_ _ np] (read-form s (+ pos 2))] [:skip nil np]) ; #_ discard
|
||||
(= c 39) (read-var-quote* s pos) ; #'
|
||||
(= c 94) (read-meta* s (inc pos)) ; #^ (deprecated, = ^)
|
||||
(= c 34) (read-regex* s pos) ; #"
|
||||
(= c 35) (read-symbolic* s pos) ; ##
|
||||
:else (read-tagged* s pos))))
|
||||
|
||||
;; #(...) anonymous fn. Positional %-arg index: % and %1 => 1, %N => N, %& => the
|
||||
;; rest param (:rest); anything else is not positional (nil). Fixed arity = max
|
||||
;; index used (Clojure: #(do %2 %&) => [p1 p2 & rest], unused lower slots still
|
||||
;; get a placeholder param).
|
||||
(defn- pct-index [nm]
|
||||
(cond
|
||||
(= nm "%") 1
|
||||
(= nm "%&") :rest
|
||||
(and (> (count nm) 1) (= "%" (subs nm 0 1)))
|
||||
(let [n (form-scan-number (subs nm 1))]
|
||||
(if (and n (integer? n) (>= n 1)) n nil))
|
||||
:else nil))
|
||||
|
||||
;; Pass 1: collect every %-index used anywhere in the form tree.
|
||||
(defn- collect-pcts [form acc]
|
||||
(cond
|
||||
(form-sym? form) (let [i (pct-index (form-sym-name form))] (if i (conj acc i) acc))
|
||||
(form-list? form) (reduce (fn [a x] (collect-pcts x a)) acc (form-elements form))
|
||||
(form-vec? form) (reduce (fn [a x] (collect-pcts x a)) acc (form-vec-items form))
|
||||
(form-set? form) (reduce (fn [a x] (collect-pcts x a)) acc (form-set-items form))
|
||||
(form-map? form) (reduce (fn [a p] (collect-pcts (nth p 1) (collect-pcts (nth p 0) a)))
|
||||
acc (form-map-pairs form))
|
||||
:else acc))
|
||||
|
||||
;; Pass 2: replace each %-symbol with its slot's gensym (rebuilding collections).
|
||||
(defn- replace-pct [form slot-syms rest-sym]
|
||||
(cond
|
||||
(form-sym? form) (let [idx (pct-index (form-sym-name form))]
|
||||
(cond (= idx :rest) rest-sym
|
||||
idx (get slot-syms idx)
|
||||
:else form))
|
||||
(form-list? form) (form-make-list (mapv #(replace-pct % slot-syms rest-sym) (form-elements form)))
|
||||
(form-vec? form) (form-make-vector (mapv #(replace-pct % slot-syms rest-sym) (form-vec-items form)))
|
||||
(form-set? form) (form-make-set (mapv #(replace-pct % slot-syms rest-sym) (form-set-items form)))
|
||||
(form-map? form) (form-make-map
|
||||
(vec (mapcat (fn [p] [(replace-pct (nth p 0) slot-syms rest-sym)
|
||||
(replace-pct (nth p 1) slot-syms rest-sym)])
|
||||
(form-map-pairs form))))
|
||||
:else form))
|
||||
|
||||
(defn- gensym-param [] (form-make-symbol (str (form-gensym-name) "#")))
|
||||
|
||||
(defn- read-anon-fn* [s pos]
|
||||
;; pos at #, next char (
|
||||
(let [[form np] (read-next-form s (inc pos))
|
||||
pcts (collect-pcts form [])
|
||||
max-n (reduce (fn [m i] (if (and (number? i) (> i m)) i m)) 0 pcts)
|
||||
has-rest (boolean (some #(= :rest %) pcts))
|
||||
slot-syms (into {} (map (fn [i] [i (gensym-param)]) (range 1 (inc max-n))))
|
||||
rest-sym (when has-rest (gensym-param))
|
||||
replaced (replace-pct form slot-syms rest-sym)
|
||||
arg-names (let [base (mapv #(get slot-syms %) (range 1 (inc max-n)))]
|
||||
(if has-rest (conj base (form-make-symbol "&") rest-sym) base))]
|
||||
[:form (form-make-list [(form-make-symbol "fn*") (form-make-vector arg-names) replaced]) np]))
|
||||
|
||||
(defn read-form [s pos]
|
||||
(let [pos (skip-whitespace s pos)]
|
||||
(if (>= pos (len s))
|
||||
[:form nil pos]
|
||||
(let [c (cp s pos)]
|
||||
(cond
|
||||
(= c 59) [:skip nil (read-until-newline s pos)] ; ; comment
|
||||
(= c 34) (let [r (read-string* s pos)] [:form (nth r 0) (nth r 1)])
|
||||
(= c 58) (let [r (read-keyword* s pos)] [:form (nth r 0) (nth r 1)])
|
||||
(= c 92) (let [r (read-char* s pos)] [:form (nth r 0) (nth r 1)])
|
||||
(= c 40) (read-list* s pos) ; (
|
||||
(= c 91) (read-vector* s pos) ; [
|
||||
(= c 123) (read-map* s pos) ; {
|
||||
(= c 39) (read-quote* s (inc pos) (form-make-symbol "quote")) ; '
|
||||
(= c 96) (read-quote* s (inc pos) (form-make-symbol "syntax-quote")) ; `
|
||||
(= c 126) (if (and (< (inc pos) (len s)) (= (cp s (inc pos)) 64)) ; ~ / ~@
|
||||
(read-quote* s (+ pos 2) (form-make-symbol "unquote-splicing"))
|
||||
(read-quote* s (inc pos) (form-make-symbol "unquote")))
|
||||
(= c 64) (read-quote* s (inc pos) (form-make-symbol "clojure.core/deref")) ; @
|
||||
(= c 94) (read-meta* s pos) ; ^
|
||||
(= c 41) (throw (ex-info "Unmatched delimiter: )" {}))
|
||||
(= c 93) (throw (ex-info "Unmatched delimiter: ]" {}))
|
||||
(= c 125) (throw (ex-info "Unmatched delimiter: }" {}))
|
||||
(= c 35) (read-dispatch* s pos) ; #
|
||||
(number-start? s pos c) (let [r (read-number* s pos)] [:form (nth r 0) (nth r 1)])
|
||||
(symbol-start? c) (let [r (read-symbol* s pos)] [:form (nth r 0) (nth r 1)])
|
||||
:else (throw (ex-info (str "read-form: unexpected char '" (char c) "' (" c ")") {})))))))
|
||||
|
||||
(defn read-one
|
||||
"Read the first form of `s` (skipping leading trivia). Returns the form."
|
||||
[s]
|
||||
(first (read-next-form s 0)))
|
||||
|
||||
(defn read-all
|
||||
"Read every top-level form of `s`, returning them in a vector (trivia skipped)."
|
||||
[s]
|
||||
(loop [pos 0 acc []]
|
||||
(let [p (skip-whitespace s pos)]
|
||||
(if (>= p (len s))
|
||||
acc
|
||||
(let [[kind payload np] (read-form s p)]
|
||||
(case kind
|
||||
:skip (recur np acc)
|
||||
:splice (recur np (into acc payload))
|
||||
:form (recur np (conj acc payload))))))))
|
||||
|
|
@ -55,12 +55,10 @@
|
|||
PushbackReader, io/reader results) expose char-wise .read; a raw file
|
||||
handle is read whole."
|
||||
[reader]
|
||||
(if (= :core/file (janet/type reader))
|
||||
(janet.file/read reader :all)
|
||||
(loop [acc (transient []) c (.read reader)]
|
||||
(if (== -1 c)
|
||||
(apply str (map char (persistent! acc)))
|
||||
(recur (conj! acc c) (.read reader))))))
|
||||
(loop [acc (transient []) c (.read reader)]
|
||||
(if (== -1 c)
|
||||
(apply str (map char (persistent! acc)))
|
||||
(recur (conj! acc c) (.read reader)))))
|
||||
|
||||
(defn read
|
||||
"Reads one EDN object from reader (a PushbackReader or any jolt reader).
|
||||
|
|
|
|||
|
|
@ -96,15 +96,6 @@
|
|||
[s]
|
||||
(str-trimr s))
|
||||
|
||||
(defn trim-newline
|
||||
|
||||
[s]
|
||||
(var result s)
|
||||
(while (or (= (subs result (dec (count result))) "\n")
|
||||
(= (subs result (dec (count result))) "\r"))
|
||||
(set result (subs result 0 (dec (count result)))))
|
||||
result)
|
||||
|
||||
(defn escape
|
||||
|
||||
[s cmap]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue