simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Chez Phase 1 (increment 3o): transducer arities

Browse source 
The 1-arg map/filter/remove/take/drop/take-while/drop-while/mapcat now return a
transducer (fn [rf] rf'), and into gets a 3-arg (into to xform from). This was
the 'cdr () is not a pair' / 'incorrect number of arguments' crash bucket: the
emitter lowers (map f) and 3-arg into at an arity the native-op gate rejects, so
they fall to the value-position path and hit the bare jolt-map/jolt-into
procedure at the wrong arity. The fix is RT-side — case-lambda those procedures
plus jolt-into.

td-* factories ported from the seed (core_coll.janet); a reduced step stops the
fold via reduce-seq's existing short-circuit (inc 3n). transduce/comp/completing
are overlay and compose over these unchanged.

Parity 1467 -> 1493/2497, 0 new divergences. emit-test 278/278.
This commit is contained in:
Yogthos 2026-06-17 23:51:06 -04:00
parent 739b219d0e
commit cbb0f2ab4a
4 changed files with 175 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

133
host/chez/natives-seq.ss
View file

@ -11,25 +11,122 @@
;; and predicate. (deref a-reduced) is handled in atoms.ss.
(define (jolt-reduced-new x) (make-jolt-reduced x))
(define (jolt-reduced-pred x) (jolt-reduced? x))
(define (ensure-reduced x) (if (jolt-reduced? x) x (make-jolt-reduced x)))
;; mapcat: (mapcat f coll & colls) — map f across the colls (stops at shortest),
;; then concat the results. Collection arity only.
;; ============================================================================
;; transducers (jolt-kxsr) — the 1-arg arity of map/filter/take/... returns a
;; transducer (fn [rf] rf') where rf' is a reducing fn with arities
;; []=init, [acc]=complete, [acc x]=step. Ported from the seed's td-* factories
;; (core_coll.janet). rf and the mapping/predicate fns are jolt values, so every
;; call routes through jolt-invoke. A `reduced` step stops the fold — reduce-seq
;; (seq.ss) already short-circuits on a jolt-reduced.
;; ============================================================================
(define (td-map f)
(lambda (rf)
(lambda a
(case (length a)
((0) (jolt-invoke rf))
((1) (jolt-invoke rf (car a)))
(else (jolt-invoke rf (car a) (jolt-invoke f (cadr a))))))))
(define (td-filter pred)
(lambda (rf)
(lambda a
(case (length a)
((0) (jolt-invoke rf))
((1) (jolt-invoke rf (car a)))
(else (if (jolt-truthy? (jolt-invoke pred (cadr a)))
(jolt-invoke rf (car a) (cadr a))
(car a)))))))
(define (td-remove pred) (td-filter (lambda (x) (jolt-not (jolt-invoke pred x)))))
(define (td-take n)
(lambda (rf)
(let ((left n))
(lambda a
(case (length a)
((0) (jolt-invoke rf))
((1) (jolt-invoke rf (car a)))
(else (if (<= left 0)
(make-jolt-reduced (car a))
(let ((r (jolt-invoke rf (car a) (cadr a))))
(set! left (- left 1))
(if (<= left 0) (ensure-reduced r) r)))))))))
(define (td-drop n)
(lambda (rf)
(let ((left n))
(lambda a
(case (length a)
((0) (jolt-invoke rf))
((1) (jolt-invoke rf (car a)))
(else (if (> left 0) (begin (set! left (- left 1)) (car a))
(jolt-invoke rf (car a) (cadr a)))))))))
(define (td-take-while pred)
(lambda (rf)
(lambda a
(case (length a)
((0) (jolt-invoke rf))
((1) (jolt-invoke rf (car a)))
(else (if (jolt-truthy? (jolt-invoke pred (cadr a)))
(jolt-invoke rf (car a) (cadr a))
(make-jolt-reduced (car a))))))))
(define (td-drop-while pred)
(lambda (rf)
(let ((dropping #t))
(lambda a
(case (length a)
((0) (jolt-invoke rf))
((1) (jolt-invoke rf (car a)))
(else (begin
(when (and dropping (not (jolt-truthy? (jolt-invoke pred (cadr a)))))
(set! dropping #f))
(if dropping (car a) (jolt-invoke rf (car a) (cadr a))))))))))
;; (mapcat f) transducer: map f, then splice (cat) f's result into rf, honoring a
;; mid-splice `reduced`.
(define (td-mapcat f)
(lambda (rf)
(lambda a
(case (length a)
((0) (jolt-invoke rf))
((1) (jolt-invoke rf (car a)))
(else (let loop ((acc (car a))
(xs (seq->list (jolt-seq (jolt-invoke f (cadr a))))))
(if (or (null? xs) (jolt-reduced? acc)) acc
(loop (jolt-invoke rf acc (car xs)) (cdr xs)))))))))
;; (into to xform from): transduce `from` through `xform` with conj as the rf.
(define (into-xform to xform from)
(let* ((conj-rf (lambda a (if (fx=? (length a) 1) (car a) ; completion = identity
(jolt-conj1 (car a) (cadr a)))))
(xrf (jolt-invoke xform conj-rf))
(res (reduce-seq xrf to (jolt-seq from))))
(jolt-invoke xrf res)))
;; mapcat: (mapcat f) -> transducer; (mapcat f coll & colls) -> map f across the
;; colls (stops at shortest), then concat the results.
(define (jolt-mapcat f . colls)
(apply jolt-concat (seq->list (apply jolt-map f colls))))
(if (null? colls)
(td-mapcat f)
(apply jolt-concat (seq->list (apply jolt-map f colls)))))
;; take-while / drop-while over the seq layer.
;; take-while / drop-while: 1-arg -> transducer; 2-arg -> a seq over the coll.
(define (take-while-seq pred s)
(if (jolt-nil? s) jolt-empty-list
(let ((x (seq-first s)))
(if (jolt-truthy? (jolt-invoke pred x))
(cseq-lazy x (lambda () (take-while-seq pred (jolt-seq (seq-more s)))))
jolt-empty-list))))
(define (jolt-take-while pred coll) (take-while-seq pred (jolt-seq coll)))
(define (jolt-drop-while pred coll)
(define jolt-take-while
(case-lambda
((pred) (td-take-while pred))
((pred coll) (take-while-seq pred (jolt-seq coll)))))
(define (drop-while-seq pred coll)
(let loop ((s (jolt-seq coll)))
(if (and (not (jolt-nil? s)) (jolt-truthy? (jolt-invoke pred (seq-first s))))
(loop (jolt-seq (seq-more s)))
(if (jolt-nil? s) jolt-empty-list s))))
(define jolt-drop-while
(case-lambda
((pred) (td-drop-while pred))
((pred coll) (drop-while-seq pred coll))))
;; partition: (partition n coll), (partition n step coll), or
;; (partition n step pad coll). Only complete partitions of size n are kept;
@ -89,6 +186,30 @@
;; values compare equal — so jolt= is the faithful port.
(define (jolt-identical? a b) (jolt= a b))
;; Give the seq.ss native procedures their transducer (1-arg) arity — the emitter
;; lowers (map f)/(filter p)/(take n) at the wrong arity to the bare procedure
;; (value-position path), so widening the procedures is what makes the 1-arg form
;; work. Capture the originals (collection arities) first, then redefine.
(define %prev-jolt-map jolt-map)
(set! jolt-map (lambda (f . colls)
(if (null? colls) (td-map f) (apply %prev-jolt-map f colls))))
(define %prev-jolt-filter jolt-filter)
(set! jolt-filter (case-lambda ((pred) (td-filter pred))
((pred coll) (%prev-jolt-filter pred coll))))
(define %prev-jolt-remove jolt-remove)
(set! jolt-remove (case-lambda ((pred) (td-remove pred))
((pred coll) (%prev-jolt-remove pred coll))))
(define %prev-jolt-take jolt-take)
(set! jolt-take (case-lambda ((n) (td-take n))
((n coll) (%prev-jolt-take n coll))))
(define %prev-jolt-drop jolt-drop)
(set! jolt-drop (case-lambda ((n) (td-drop n))
((n coll) (%prev-jolt-drop n coll))))
;; into: add the 3-arg (into to xform from). The 2-arg stays the seq.ss fold.
(define %prev-jolt-into jolt-into)
(set! jolt-into (case-lambda ((to from) (%prev-jolt-into to from))
((to xform from) (into-xform to xform from))))
(def-var! "clojure.core" "reduced" jolt-reduced-new)
(def-var! "clojure.core" "reduced?" jolt-reduced-pred)
(def-var! "clojure.core" "mapcat" jolt-mapcat)