Chez Phase 1 (increment 3a): persistent collections on the Chez RT
Broaden the Scheme back end past the numeric/functional subset to vectors,
maps, and sets. host/chez/collections.ss adds a copy-on-write persistent
vector and a bitmap HAMT (the structure 0c measured self-hostable) backing
both maps and sets, keyed by jolt-hash and compared by jolt=. emit.janet
emits :vector/:map/:set literals to the rt constructors and lowers the leaf
ops (conj/get/nth/count/assoc/dissoc/contains?/empty?/peek/pop) via the
native-ops path, with a per-op arity gate.
Also: keyword/map literals in fn position lower to jolt-get ((:k m), ({:k v} k));
arity-1 comparisons emit the vacuous jolt truth (Scheme < rejects a non-number
even at arity 1); count returns a flonum and vector indices coerce from flonum,
both consequences of the all-double number model; values.ss = / hash and the
rt printer learn collections (maps/sets render in HAMT order, so the probe
compares unordered values via =, not printed form).
Subset parity 182 -> 433/436 compiled cases (2219/2655 out of subset), 0 new
divergences. The 3 known divergences are dynamic IFn dispatch (a keyword/vector
held in a local, called as a fn) — deferred to the IFn/protocol increment and
allowlisted in the probe. emit-test 31/31, full run-tests green (125 files).
This commit is contained in:
Yogthos
parent
9bbcc07c8f
commit
5c5d2cd1fc
7 changed files with 473 additions and 18 deletions
310
host/chez/collections.ss
Normal file
310
host/chez/collections.ss
Normal file
|
|
@ -0,0 +1,310 @@
|
|||
;; Phase 1 (jolt-cf1q.2, inc 3a) — persistent collections on the Chez RT.
|
||||
;;
|
||||
;; The vector / map / set the emitted programs construct from literals and
|
||||
;; operate on via the lowered leaf ops (conj/get/nth/count/assoc/...). Loaded by
|
||||
;; rt.ss after values.ss; jolt=2 / jolt-hash (values.ss) call into the
|
||||
;; jolt-coll? / jolt-coll=? / jolt-coll-hash hooks defined here (forward refs,
|
||||
;; resolved at run time — nothing is CALLED during load).
|
||||
;;
|
||||
;; Phase note: the persistent vector is a copy-on-write Scheme vector and the
|
||||
;; map/set are a bitmap HAMT (the structure 0c measured self-hostable). They live
|
||||
;; in Scheme for the Phase-1 bootstrap; the 0c decision is to SELF-HOST them in
|
||||
;; Clojure once core is up on Chez (Phase 3 shim shrink). Correctness, not perf,
|
||||
;; is the Phase-1 gate.
|
||||
|
||||
;; ============================================================================
|
||||
;; small immutable-vector helpers (manual; avoid stdlib arg-order ambiguity)
|
||||
;; ============================================================================
|
||||
(define (vec-copy-range v start end)
|
||||
(let ((out (make-vector (fx- end start))))
|
||||
(let loop ((i start))
|
||||
(when (fx<? i end) (vector-set! out (fx- i start) (vector-ref v i)) (loop (fx+ i 1))))
|
||||
out))
|
||||
(define (vec-insert v i x) ; copy of v with x spliced in at index i
|
||||
(let* ((n (vector-length v)) (out (make-vector (fx+ n 1))))
|
||||
(let loop ((j 0)) (when (fx<? j i) (vector-set! out j (vector-ref v j)) (loop (fx+ j 1))))
|
||||
(vector-set! out i x)
|
||||
(let loop ((j i)) (when (fx<? j n) (vector-set! out (fx+ j 1) (vector-ref v j)) (loop (fx+ j 1))))
|
||||
out))
|
||||
(define (vec-set v i x) ; functional update at index i
|
||||
(let ((out (vec-copy-range v 0 (vector-length v)))) (vector-set! out i x) out))
|
||||
(define (vec-remove v i) ; copy of v with index i dropped
|
||||
(let* ((n (vector-length v)) (out (make-vector (fx- n 1))))
|
||||
(let loop ((j 0)) (when (fx<? j i) (vector-set! out j (vector-ref v j)) (loop (fx+ j 1))))
|
||||
(let loop ((j (fx+ i 1))) (when (fx<? j n) (vector-set! out (fx- j 1) (vector-ref v j)) (loop (fx+ j 1))))
|
||||
out))
|
||||
|
||||
;; ============================================================================
|
||||
;; persistent vector — copy-on-write over a Scheme vector
|
||||
;; ============================================================================
|
||||
(define-record-type pvec (fields v) (nongenerative chez-pvec-v1))
|
||||
(define empty-pvec (make-pvec (vector)))
|
||||
(define (jolt-vector . xs) (make-pvec (list->vector xs)))
|
||||
(define (pvec-count p) (vector-length (pvec-v p)))
|
||||
;; jolt models every number as a double, so vector indices arrive as flonums —
|
||||
;; coerce an integer-valued index to a Scheme fixnum before bounds math.
|
||||
(define (->idx i) (if (fixnum? i) i (if (flonum? i) (exact (floor i)) i)))
|
||||
(define (pvec-nth-d p i d)
|
||||
(let ((v (pvec-v p)) (i (->idx i)))
|
||||
(if (and (fixnum? i) (fx>=? i 0) (fx<? i (vector-length v))) (vector-ref v i) d)))
|
||||
(define (pvec-conj p x)
|
||||
(let* ((v (pvec-v p)) (n (vector-length v)) (out (make-vector (fx+ n 1))))
|
||||
(let loop ((i 0)) (when (fx<? i n) (vector-set! out i (vector-ref v i)) (loop (fx+ i 1))))
|
||||
(vector-set! out n x)
|
||||
(make-pvec out)))
|
||||
(define (pvec-assoc p i x) ; i in [0,count]; =count appends
|
||||
(let* ((v (pvec-v p)) (n (vector-length v)) (i (->idx i)))
|
||||
(cond ((and (fx>=? i 0) (fx<? i n)) (make-pvec (vec-set v i x)))
|
||||
((fx=? i n) (pvec-conj p x))
|
||||
(else (error 'assoc "vector index out of bounds")))))
|
||||
(define (pvec-peek p)
|
||||
(let ((n (pvec-count p))) (if (fx=? n 0) jolt-nil (vector-ref (pvec-v p) (fx- n 1)))))
|
||||
(define (pvec-pop p)
|
||||
(let ((n (pvec-count p)))
|
||||
(if (fx=? n 0) (error 'pop "can't pop empty vector")
|
||||
(make-pvec (vec-copy-range (pvec-v p) 0 (fx- n 1))))))
|
||||
|
||||
;; ============================================================================
|
||||
;; bitmap HAMT — keys hashed by jolt-hash, leaves compared by jolt=
|
||||
;; arr slot is one of: leaf (cons k v) | hnode (branch) | hcoll (hash bucket)
|
||||
;; ============================================================================
|
||||
(define-record-type hnode (fields bm arr) (nongenerative chez-hnode-v1))
|
||||
(define-record-type hcoll (fields hash alist) (nongenerative chez-hcoll-v1))
|
||||
(define empty-hnode (make-hnode 0 (vector)))
|
||||
(define hmask #x3FFFFFFFFFFFFFF) ; 58-bit non-negative hash window
|
||||
(define max-shift 55)
|
||||
(define (key-hash k) (fxand (jolt-hash k) hmask))
|
||||
(define (chunk h shift) (fxand (fxsra h shift) 31))
|
||||
(define (bitpos h shift) (fxsll 1 (chunk h shift)))
|
||||
(define (popcount n) (let loop ((n n) (c 0)) (if (fx=? n 0) c (loop (fxand n (fx- n 1)) (fx+ c 1)))))
|
||||
(define (arr-index bm bit) (popcount (fxand bm (fx- bit 1))))
|
||||
|
||||
;; jolt= alist ops (for hash-collision buckets)
|
||||
(define (assoc-jolt k al) (cond ((null? al) #f) ((jolt= (caar al) k) (car al)) (else (assoc-jolt k (cdr al)))))
|
||||
(define (alist-replace k v al) (if (jolt= (caar al) k) (cons (cons k v) (cdr al)) (cons (car al) (alist-replace k v (cdr al)))))
|
||||
(define (alist-remove k al) (cond ((null? al) '()) ((jolt= (caar al) k) (cdr al)) (else (cons (car al) (alist-remove k (cdr al))))))
|
||||
|
||||
;; split two leaves that collided at `shift` into a subtree (or hcoll if the
|
||||
;; full hashes are equal / the hash is exhausted).
|
||||
(define (split-leaf shift ek ev h k v)
|
||||
(let ((eh (key-hash ek)))
|
||||
(if (or (fx>? shift max-shift) (fx=? eh h))
|
||||
(make-hcoll h (list (cons ek ev) (cons k v)))
|
||||
(let ((ei (chunk eh shift)) (ni (chunk h shift)))
|
||||
(if (fx=? ei ni)
|
||||
(make-hnode (fxsll 1 ei) (vector (split-leaf (fx+ shift 5) ek ev h k v)))
|
||||
(let ((eb (fxsll 1 ei)) (nb (fxsll 1 ni)))
|
||||
(if (fx<? ei ni)
|
||||
(make-hnode (fxior eb nb) (vector (cons ek ev) (cons k v)))
|
||||
(make-hnode (fxior eb nb) (vector (cons k v) (cons ek ev))))))))))
|
||||
|
||||
(define (node-assoc node shift h k v added)
|
||||
(let* ((bit (bitpos h shift)) (bm (hnode-bm node)) (arr (hnode-arr node)))
|
||||
(if (fx=? 0 (fxand bm bit))
|
||||
(begin (set-box! added #t)
|
||||
(make-hnode (fxior bm bit) (vec-insert arr (arr-index bm bit) (cons k v))))
|
||||
(let* ((i (arr-index bm bit)) (child (vector-ref arr i)))
|
||||
(cond
|
||||
((hnode? child) (make-hnode bm (vec-set arr i (node-assoc child (fx+ shift 5) h k v added))))
|
||||
((hcoll? child)
|
||||
(let ((al (hcoll-alist child)))
|
||||
(if (assoc-jolt k al)
|
||||
(make-hnode bm (vec-set arr i (make-hcoll (hcoll-hash child) (alist-replace k v al))))
|
||||
(begin (set-box! added #t)
|
||||
(make-hnode bm (vec-set arr i (make-hcoll (hcoll-hash child) (cons (cons k v) al))))))))
|
||||
((jolt= (car child) k) (make-hnode bm (vec-set arr i (cons k v)))) ; replace
|
||||
(else (set-box! added #t)
|
||||
(make-hnode bm (vec-set arr i (split-leaf (fx+ shift 5) (car child) (cdr child) h k v)))))))))
|
||||
|
||||
(define (node-get node shift h k default)
|
||||
(let* ((bit (bitpos h shift)) (bm (hnode-bm node)))
|
||||
(if (fx=? 0 (fxand bm bit)) default
|
||||
(let ((child (vector-ref (hnode-arr node) (arr-index bm bit))))
|
||||
(cond ((hnode? child) (node-get child (fx+ shift 5) h k default))
|
||||
((hcoll? child) (let ((p (assoc-jolt k (hcoll-alist child)))) (if p (cdr p) default)))
|
||||
((jolt= (car child) k) (cdr child))
|
||||
(else default))))))
|
||||
|
||||
(define (node-dissoc node shift h k removed)
|
||||
(let* ((bit (bitpos h shift)) (bm (hnode-bm node)) (arr (hnode-arr node)))
|
||||
(if (fx=? 0 (fxand bm bit)) node
|
||||
(let* ((i (arr-index bm bit)) (child (vector-ref arr i)))
|
||||
(cond
|
||||
((hnode? child) (make-hnode bm (vec-set arr i (node-dissoc child (fx+ shift 5) h k removed))))
|
||||
((hcoll? child)
|
||||
(if (assoc-jolt k (hcoll-alist child))
|
||||
(begin (set-box! removed #t)
|
||||
(let ((nal (alist-remove k (hcoll-alist child))))
|
||||
(cond ((null? nal) (make-hnode (fxand bm (fxnot bit)) (vec-remove arr i)))
|
||||
((null? (cdr nal)) (make-hnode bm (vec-set arr i (car nal)))) ; collapse to leaf
|
||||
(else (make-hnode bm (vec-set arr i (make-hcoll (hcoll-hash child) nal)))))))
|
||||
node))
|
||||
((jolt= (car child) k)
|
||||
(set-box! removed #t) (make-hnode (fxand bm (fxnot bit)) (vec-remove arr i)))
|
||||
(else node))))))
|
||||
|
||||
(define (node-fold node proc acc) ; (proc k v acc) over every leaf
|
||||
(let ((arr (hnode-arr node)))
|
||||
(let loop ((i 0) (acc acc))
|
||||
(if (fx<? i (vector-length arr))
|
||||
(let ((child (vector-ref arr i)))
|
||||
(loop (fx+ i 1)
|
||||
(cond ((hnode? child) (node-fold child proc acc))
|
||||
((hcoll? child)
|
||||
(let cl ((al (hcoll-alist child)) (a acc))
|
||||
(if (null? al) a (cl (cdr al) (proc (caar al) (cdar al) a)))))
|
||||
(else (proc (car child) (cdr child) acc)))))
|
||||
acc))))
|
||||
|
||||
;; ============================================================================
|
||||
;; persistent map / set over the HAMT
|
||||
;; ============================================================================
|
||||
(define-record-type pmap (fields root cnt) (nongenerative chez-pmap-v1))
|
||||
(define empty-pmap (make-pmap empty-hnode 0))
|
||||
(define pmap-absent (list 'absent)) ; unique missing-key sentinel
|
||||
(define (pmap-assoc m k v)
|
||||
(let* ((added (box #f)) (r (node-assoc (pmap-root m) 0 (key-hash k) k v added)))
|
||||
(make-pmap r (if (unbox added) (fx+ (pmap-cnt m) 1) (pmap-cnt m)))))
|
||||
(define (pmap-dissoc m k)
|
||||
(let* ((removed (box #f)) (r (node-dissoc (pmap-root m) 0 (key-hash k) k removed)))
|
||||
(make-pmap r (if (unbox removed) (fx- (pmap-cnt m) 1) (pmap-cnt m)))))
|
||||
(define (pmap-get m k default) (node-get (pmap-root m) 0 (key-hash k) k default))
|
||||
(define (pmap-contains? m k) (not (eq? pmap-absent (node-get (pmap-root m) 0 (key-hash k) k pmap-absent))))
|
||||
(define (pmap-fold m proc acc) (node-fold (pmap-root m) proc acc))
|
||||
(define (jolt-hash-map . kvs)
|
||||
(let loop ((m empty-pmap) (kvs kvs))
|
||||
(cond ((null? kvs) m)
|
||||
((null? (cdr kvs)) (error 'hash-map "odd number of map literal entries"))
|
||||
(else (loop (pmap-assoc m (car kvs) (cadr kvs)) (cddr kvs))))))
|
||||
|
||||
(define-record-type pset (fields m) (nongenerative chez-pset-v1))
|
||||
(define empty-pset (make-pset empty-pmap))
|
||||
(define (pset-conj s e) (if (pmap-contains? (pset-m s) e) s (make-pset (pmap-assoc (pset-m s) e e))))
|
||||
(define (pset-disj s e) (make-pset (pmap-dissoc (pset-m s) e)))
|
||||
(define (pset-contains? s e) (pmap-contains? (pset-m s) e))
|
||||
(define (pset-count s) (pmap-cnt (pset-m s)))
|
||||
(define (pset-fold s proc acc) (pmap-fold (pset-m s) (lambda (k v a) (proc k a)) acc))
|
||||
(define (jolt-hash-set . xs) (let loop ((s empty-pset) (xs xs)) (if (null? xs) s (loop (pset-conj s (car xs)) (cdr xs)))))
|
||||
|
||||
;; ============================================================================
|
||||
;; leaf ops the emitter lowers core/clojure fns to (mirrors native-ops)
|
||||
;; ============================================================================
|
||||
(define (jolt-conj1 coll x)
|
||||
(cond ((pvec? coll) (pvec-conj coll x)) ; nil is a valid vector/set element
|
||||
((pset? coll) (pset-conj coll x))
|
||||
((pmap? coll)
|
||||
(cond ((jolt-nil? x) coll) ; (conj m nil) = m
|
||||
((pmap? x) (pmap-fold x (lambda (k v m) (pmap-assoc m k v)) coll)) ; merge
|
||||
((and (pvec? x) (fx=? 2 (pvec-count x)))
|
||||
(pmap-assoc coll (pvec-nth-d x 0 jolt-nil) (pvec-nth-d x 1 jolt-nil)))
|
||||
(else (error 'conj "conj on a map expects a [k v] pair or a map"))))
|
||||
(else (error 'conj "unsupported collection"))))
|
||||
;; (conj nil a b ...) builds a list in Clojure, conj prepending -> (b a). We have
|
||||
;; no list type until inc 3b; a reversed pvec is = to that list (sequential =).
|
||||
(define (jolt-conj coll . xs)
|
||||
(if (jolt-nil? coll)
|
||||
(make-pvec (list->vector (reverse xs)))
|
||||
(fold-left jolt-conj1 coll xs)))
|
||||
|
||||
(define jolt-get
|
||||
(case-lambda
|
||||
((coll k) (jolt-get coll k jolt-nil))
|
||||
((coll k d)
|
||||
(cond ((pmap? coll) (pmap-get coll k d))
|
||||
((pset? coll) (if (pset-contains? coll k) k d))
|
||||
((pvec? coll) (pvec-nth-d coll k d))
|
||||
((string? coll) (let ((i (->idx k)))
|
||||
(if (and (fixnum? i) (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i) d)))
|
||||
(else d)))))
|
||||
|
||||
(define jolt-nth
|
||||
(case-lambda
|
||||
((coll i)
|
||||
(let ((i (->idx i)))
|
||||
(cond ((pvec? coll) (let ((v (pvec-v coll)))
|
||||
(if (and (fx>=? i 0) (fx<? i (vector-length v))) (vector-ref v i)
|
||||
(error 'nth "index out of bounds"))))
|
||||
((string? coll) (string-ref coll i))
|
||||
(else (error 'nth "unsupported collection")))))
|
||||
((coll i d)
|
||||
(let ((i (->idx i)))
|
||||
(cond ((pvec? coll) (pvec-nth-d coll i d))
|
||||
((string? coll) (if (and (fx>=? i 0) (fx<? i (string-length coll))) (string-ref coll i) d))
|
||||
(else d))))))
|
||||
|
||||
;; jolt models every number as a double, so a count is a flonum — else
|
||||
;; (= 2 (count m)) is false (jolt= is exactness-aware: 2.0 vs exact 2).
|
||||
(define (jolt-count coll)
|
||||
(exact->inexact
|
||||
(cond ((pvec? coll) (pvec-count coll))
|
||||
((pmap? coll) (pmap-cnt coll))
|
||||
((pset? coll) (pset-count coll))
|
||||
((string? coll) (string-length coll))
|
||||
((jolt-nil? coll) 0)
|
||||
(else (error 'count "uncountable")))))
|
||||
|
||||
(define (jolt-assoc1 coll k v)
|
||||
(cond ((pmap? coll) (pmap-assoc coll k v))
|
||||
((pvec? coll) (pvec-assoc coll k v))
|
||||
((jolt-nil? coll) (pmap-assoc empty-pmap k v))
|
||||
(else (error 'assoc "unsupported collection"))))
|
||||
(define (jolt-assoc coll . kvs)
|
||||
(let loop ((coll coll) (kvs kvs))
|
||||
(cond ((null? kvs) coll)
|
||||
((null? (cdr kvs)) (error 'assoc "assoc expects an even number of key/vals"))
|
||||
(else (loop (jolt-assoc1 coll (car kvs) (cadr kvs)) (cddr kvs))))))
|
||||
|
||||
(define (jolt-dissoc coll . ks)
|
||||
(cond ((jolt-nil? coll) jolt-nil)
|
||||
((pmap? coll) (fold-left pmap-dissoc coll ks))
|
||||
(else (error 'dissoc "unsupported collection"))))
|
||||
|
||||
(define (jolt-contains? coll k)
|
||||
(cond ((pmap? coll) (pmap-contains? coll k))
|
||||
((pset? coll) (pset-contains? coll k))
|
||||
((pvec? coll) (let ((k (->idx k))) (and (fixnum? k) (fx>=? k 0) (fx<? k (pvec-count coll)))))
|
||||
((jolt-nil? coll) #f)
|
||||
(else #f)))
|
||||
|
||||
(define (jolt-empty? coll)
|
||||
(cond ((jolt-nil? coll) #t)
|
||||
((pvec? coll) (fx=? 0 (pvec-count coll)))
|
||||
((pmap? coll) (fx=? 0 (pmap-cnt coll)))
|
||||
((pset? coll) (fx=? 0 (pset-count coll)))
|
||||
((string? coll) (fx=? 0 (string-length coll)))
|
||||
(else (error 'empty? "unsupported collection"))))
|
||||
|
||||
(define (jolt-peek coll)
|
||||
(cond ((pvec? coll) (pvec-peek coll)) ((jolt-nil? coll) jolt-nil) (else (error 'peek "unsupported collection"))))
|
||||
(define (jolt-pop coll)
|
||||
(cond ((pvec? coll) (pvec-pop coll)) (else (error 'pop "unsupported collection"))))
|
||||
|
||||
;; ============================================================================
|
||||
;; equality / hash hooks called from values.ss (jolt=2 / jolt-hash)
|
||||
;; ============================================================================
|
||||
(define (jolt-coll? x) (or (pvec? x) (pmap? x) (pset? x)))
|
||||
(define (jolt-coll=? a b)
|
||||
(cond
|
||||
((and (pvec? a) (pvec? b))
|
||||
(let ((va (pvec-v a)) (vb (pvec-v b)))
|
||||
(and (fx=? (vector-length va) (vector-length vb))
|
||||
(let loop ((i 0))
|
||||
(or (fx=? i (vector-length va))
|
||||
(and (jolt= (vector-ref va i) (vector-ref vb i)) (loop (fx+ i 1))))))))
|
||||
((and (pmap? a) (pmap? b))
|
||||
(and (fx=? (pmap-cnt a) (pmap-cnt b))
|
||||
(pmap-fold a (lambda (k v ok) (and ok (jolt= (pmap-get b k pmap-absent) v))) #t)))
|
||||
((and (pset? a) (pset? b))
|
||||
(and (fx=? (pset-count a) (pset-count b))
|
||||
(pset-fold a (lambda (e ok) (and ok (pset-contains? b e))) #t)))
|
||||
(else #f)))
|
||||
(define (jolt-coll-hash x)
|
||||
(cond
|
||||
((pvec? x)
|
||||
(let ((v (pvec-v x)))
|
||||
(let loop ((i 0) (h 1))
|
||||
(if (fx=? i (vector-length v)) (bitwise-and h hmask)
|
||||
(loop (fx+ i 1) (bitwise-and (+ (* 31 h) (key-hash (vector-ref v i))) hmask))))))
|
||||
;; maps/sets hash order-independently (sum), consistent with unordered =
|
||||
((pmap? x) (bitwise-and (pmap-fold x (lambda (k v a) (+ a (fxxor (key-hash k) (key-hash v)))) 0) hmask))
|
||||
((pset? x) (bitwise-and (pset-fold x (lambda (e a) (+ a (key-hash e))) 0) hmask))))
|
||||
|
|
@ -29,12 +29,22 @@
|
|||
"<" "<" ">" ">" "<=" "<=" ">=" ">="
|
||||
"=" "jolt=" "inc" "jolt-inc" "dec" "jolt-dec" "not" "jolt-not"
|
||||
"min" "min" "max" "max"
|
||||
"mod" "modulo" "rem" "remainder" "quot" "quotient"})
|
||||
"mod" "modulo" "rem" "remainder" "quot" "quotient"
|
||||
# persistent-collection leaf ops (jolt-wgbz) -> rt prims in collections.ss
|
||||
"vector" "jolt-vector" "hash-map" "jolt-hash-map" "hash-set" "jolt-hash-set"
|
||||
"conj" "jolt-conj" "get" "jolt-get" "nth" "jolt-nth" "count" "jolt-count"
|
||||
"assoc" "jolt-assoc" "dissoc" "jolt-dissoc" "contains?" "jolt-contains?"
|
||||
"empty?" "jolt-empty?" "peek" "jolt-peek" "pop" "jolt-pop"})
|
||||
|
||||
# Unary ops only legal at arity 1; binary at arity 2. Others (arith/compare) are
|
||||
# variadic in both Scheme and jolt, so any arity is fine.
|
||||
(def- unary-ops {"inc" true "dec" true "not" true})
|
||||
(def- binary-ops {"mod" true "rem" true "quot" true})
|
||||
# Per-op arity gate: only lower when the Scheme prim and the jolt fn agree at
|
||||
# this arity. Ops absent from the table are variadic (arith/compare/=, the
|
||||
# collection constructors, conj/assoc/dissoc) and legal at any arity.
|
||||
(def- op-arity
|
||||
{"inc" |(= $ 1) "dec" |(= $ 1) "not" |(= $ 1)
|
||||
"count" |(= $ 1) "empty?" |(= $ 1) "peek" |(= $ 1) "pop" |(= $ 1)
|
||||
"mod" |(= $ 2) "rem" |(= $ 2) "quot" |(= $ 2) "contains?" |(= $ 2)
|
||||
"get" |(or (= $ 2) (= $ 3)) "nth" |(or (= $ 2) (= $ 3))
|
||||
"assoc" |(and (>= $ 3) (odd? $)) "dissoc" |(>= $ 1) "conj" |(>= $ 1)})
|
||||
|
||||
# If fnode is a clojure.core (or host) ref to a native-op primitive, return the
|
||||
# Scheme op string — only at an arity where the Scheme op and the jolt fn agree.
|
||||
|
|
@ -44,10 +54,10 @@
|
|||
:host (get fnode :name)
|
||||
nil))
|
||||
(def op (and nm (get native-ops nm)))
|
||||
(def arity-ok (get op-arity nm))
|
||||
(cond
|
||||
(nil? op) nil
|
||||
(and (get unary-ops nm) (not= nargs 1)) nil
|
||||
(and (get binary-ops nm) (not= nargs 2)) nil
|
||||
(and arity-ok (not (arity-ok nargs))) nil
|
||||
op))
|
||||
|
||||
(var- recur-target nil)
|
||||
|
|
@ -74,6 +84,15 @@
|
|||
s
|
||||
(string s ".0")))
|
||||
(string? v) (string/format "%j" v) # quoted+escaped string literal
|
||||
# keyword literal -> (keyword ns name); ns is everything before the first "/"
|
||||
(keyword? v) (let [s (string v) idx (string/find "/" s)]
|
||||
(if (and idx (> idx 0))
|
||||
(string "(keyword " (string/format "%j" (string/slice s 0 idx)) " "
|
||||
(string/format "%j" (string/slice s (inc idx))) ")")
|
||||
(string "(keyword #f " (string/format "%j" s) ")")))
|
||||
# jolt char value {:ch <codepoint> :jolt/type :jolt/char}
|
||||
(and (struct? v) (= :jolt/char (get v :jolt/type)))
|
||||
(string "(integer->char " (get v :ch) ")")
|
||||
(errorf "emit-const: unsupported literal %p" v)))
|
||||
|
||||
(defn- emit-binding [b]
|
||||
|
|
@ -136,16 +155,37 @@
|
|||
(defn- stdlib-var? [n]
|
||||
(and (= :var (get n :op)) (string/has-prefix? "clojure." (or (get n :ns) ""))))
|
||||
|
||||
# jolt's comparison ops are vacuously true at arity 1 and DON'T inspect the arg
|
||||
# (so (< :kw) is true), but Scheme's < demands a number even there — special-case.
|
||||
(def- cmp1-ops {"<" true ">" true "<=" true ">=" true})
|
||||
|
||||
# IFn dispatch for a LITERAL callee (Clojure's "value as fn"): a keyword looks
|
||||
# itself up in its arg ((:k m) = (get m :k)); a map/set/vector literal looks up
|
||||
# its arg ((m :k) = (get m :k)). The general dynamic case — a local/var holding a
|
||||
# keyword — is runtime IFn dispatch, a later increment, and stays out of subset.
|
||||
(defn- ifn-kind [fnode]
|
||||
(case (get fnode :op)
|
||||
:const (when (keyword? (get fnode :val)) :keyword)
|
||||
:map :coll :set :coll :vector :coll
|
||||
nil))
|
||||
|
||||
(defn- emit-invoke [node]
|
||||
(def fnode (nn (get node :fn)))
|
||||
(def args (map emit (vv (get node :args))))
|
||||
(def nop (native-op fnode (length args)))
|
||||
(def kind (ifn-kind fnode))
|
||||
(def default (if (> (length args) 1) (string " " (in args 1)) ""))
|
||||
(cond
|
||||
# zero-arg + / * : Scheme's identity is the EXACT 0 / 1, but jolt models every
|
||||
# number as a double, so emit the flonum identity to keep (= 0 (+)) true.
|
||||
(and nop (empty? args) (= nop "+")) "0.0"
|
||||
(and nop (empty? args) (= nop "*")) "1.0"
|
||||
(and nop (= 1 (length args)) (get cmp1-ops nop)) (string "(begin " (first args) " #t)")
|
||||
nop (string "(" nop " " (string/join args " ") ")")
|
||||
# (:k coll [default]) -> (jolt-get coll :k [default])
|
||||
(= kind :keyword) (string "(jolt-get " (first args) " " (emit fnode) default ")")
|
||||
# (coll k [default]) -> (jolt-get coll k [default])
|
||||
(= kind :coll) (string "(jolt-get " (emit fnode) " " (first args) default ")")
|
||||
(stdlib-var? fnode)
|
||||
(errorf "emit: unsupported stdlib fn `%s/%s` (no core on Chez yet)" (get fnode :ns) (get fnode :name))
|
||||
(= :host (get fnode :op))
|
||||
|
|
@ -172,6 +212,15 @@
|
|||
(if (empty? (vv (get node :statements))) "" " ")
|
||||
(emit (get node :ret)) ")")
|
||||
:invoke (emit-invoke node)
|
||||
# collection literals -> rt constructors (collections.ss)
|
||||
:vector (string "(jolt-vector " (string/join (map emit (vv (get node :items))) " ") ")")
|
||||
:set (string "(jolt-hash-set " (string/join (map emit (vv (get node :items))) " ") ")")
|
||||
:map (let [flat @[]]
|
||||
(each p (vv (get node :pairs))
|
||||
(def p (vv p))
|
||||
(array/push flat (emit (get p 0)))
|
||||
(array/push flat (emit (get p 1))))
|
||||
(string "(jolt-hash-map " (string/join flat " ") ")"))
|
||||
:let (emit-let node)
|
||||
:loop (emit-loop node)
|
||||
:recur (emit-recur node)
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@
|
|||
;; Emitted programs do `(load "host/chez/rt.ss")`; this loads values.ss in turn.
|
||||
|
||||
(load "host/chez/values.ss")
|
||||
(load "host/chez/collections.ss")
|
||||
|
||||
;; --- rt arithmetic / logic shims (named in emit.janet's native-ops) ----------
|
||||
(define (jolt-inc x) (+ x 1))
|
||||
|
|
@ -41,7 +42,17 @@
|
|||
(number->string (exact x))
|
||||
(number->string x)))
|
||||
|
||||
;; Minimal pr-str for the program's final value (full printer is Phase 2).
|
||||
;; Program-final-value printer. jolt's `-e` prints in str-style: strings raw (no
|
||||
;; quotes), chars as `\c`/`\newline`, collections recursively. NOTE: maps/sets
|
||||
;; render in HAMT-iteration order, which does NOT match the Janet host's order —
|
||||
;; so unordered values are compared via `=` (true/false), not printed form.
|
||||
;; The full canonical printer is Phase 2.
|
||||
(define (jolt-str-join strs)
|
||||
(cond ((null? strs) "") ((null? (cdr strs)) (car strs))
|
||||
(else (string-append (car strs) " " (jolt-str-join (cdr strs))))))
|
||||
(define (jolt-char->string c)
|
||||
(string-append "\\" (case c ((#\newline) "newline") ((#\space) "space") ((#\tab) "tab")
|
||||
((#\return) "return") (else (string c)))))
|
||||
(define (jolt-pr-str x)
|
||||
(cond
|
||||
((jolt-nil? x) "nil")
|
||||
|
|
@ -49,4 +60,16 @@
|
|||
((eq? x #f) "false")
|
||||
((number? x) (jolt-num->string x))
|
||||
((string? x) x)
|
||||
((char? x) (jolt-char->string x))
|
||||
((keyword? x) (let ((ns (keyword-t-ns x)))
|
||||
(if ns (string-append ":" ns "/" (keyword-t-name x)) (string-append ":" (keyword-t-name x)))))
|
||||
((jolt-symbol? x) (let ((ns (symbol-t-ns x)))
|
||||
(if (or (jolt-nil? ns) (not ns) (eq? ns '())) (symbol-t-name x)
|
||||
(string-append ns "/" (symbol-t-name x)))))
|
||||
((pvec? x) (let ((acc '())) (let loop ((i (fx- (pvec-count x) 1)))
|
||||
(when (fx>=? i 0) (set! acc (cons (jolt-pr-str (pvec-nth-d x i jolt-nil)) acc)) (loop (fx- i 1))))
|
||||
(string-append "[" (jolt-str-join acc) "]")))
|
||||
((pset? x) (string-append "#{" (jolt-str-join (pset-fold x (lambda (e a) (cons (jolt-pr-str e) a)) '())) "}"))
|
||||
((pmap? x) (string-append "{" (jolt-str-join
|
||||
(pmap-fold x (lambda (k v a) (cons (string-append (jolt-pr-str k) " " (jolt-pr-str v)) a)) '())) "}"))
|
||||
(else (format "~a" x))))
|
||||
|
|
|
|||
|
|
@ -56,6 +56,8 @@
|
|||
((and (char? a) (char? b)) (char=? a b))
|
||||
((and (string? a) (string? b)) (string=? a b))
|
||||
((and (boolean? a) (boolean? b)) (eq? a b))
|
||||
;; collections: forward to collections.ss (loaded after this file by rt.ss).
|
||||
((and (jolt-coll? a) (jolt-coll? b)) (jolt-coll=? a b))
|
||||
(else (eq? a b))))
|
||||
(define (jolt= a . rest)
|
||||
(let loop ((a a) (rest rest))
|
||||
|
|
@ -78,4 +80,5 @@
|
|||
((string? x) (string-hash x))
|
||||
((char? x) (char->integer x))
|
||||
((boolean? x) (if x 1 2))
|
||||
((jolt-coll? x) (jolt-coll-hash x)) ; forward to collections.ss
|
||||
(else (equal-hash x))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue