iter: fused for/for-collect/for-fold clauses for pvec/pmap/pset
ober
6cd0ad5feb70d03085f5ebe112607b63f453a8c3
--- a/lib/std/iter.sls +++ b/lib/std/iter.sls @@ -18,11 +18,21 @@ in-hash-keys in-hash-values in-hash-pairs in-naturals in-indexed ;; better2 #7: I/O iterators - in-port in-lines in-chars in-bytes in-producer) + in-port in-lines in-chars in-bytes in-producer + ;; Round 4 Phase 28: persistent-collection iterators (re-exported from + ;; (std pmap) / (std pvec) / (std pset) so syntax-case literal matching + ;; inside this library resolves to the same binding user code sees). + in-pmap in-pmap-keys in-pmap-values in-pmap-pairs + in-pvec in-pset) (import (except (chezscheme) make-hash-table hash-table? iota 1+ 1-) - (jerboa runtime)) + (jerboa runtime) + (only (std pmap) in-pmap in-pmap-keys in-pmap-values in-pmap-pairs + persistent-map-for-each) + (only (std pvec) in-pvec persistent-vector? + persistent-vector-length persistent-vector-ref) + (only (std pset) in-pset persistent-set-for-each)) ;; Iterator constructors — return plain lists for simplicity @@ -179,8 +189,45 @@ (or (= (string-length str) 0) (not (char=? (string-ref str (- (string-length str) 1)) #\:)))))))) (lambda (stx) - (syntax-case stx (in-range in-vector in-string in-list) + (syntax-case stx (in-range in-vector in-string in-list + in-pmap in-pmap-keys in-pmap-values in-pmap-pairs + in-pvec in-pset) ;; --- Fused iterators --- + [(_ ((var (in-pvec pv-expr))) body ...) + (binding-id? #'var) + #'(let ([v pv-expr]) + (let ([n (persistent-vector-length v)]) + (let loop ([i 0]) + (when (fx< i n) + (let ([var (persistent-vector-ref v i)]) body ...) + (loop (fx+ i 1))))))] + [(_ ((var (in-pmap m-expr))) body ...) + (binding-id? #'var) + #'(persistent-map-for-each + (lambda (__k __v) + (let ([var (cons __k __v)]) body ...)) + m-expr)] + [(_ ((var (in-pmap-pairs m-expr))) body ...) + (binding-id? #'var) + #'(persistent-map-for-each + (lambda (__k __v) + (let ([var (cons __k __v)]) body ...)) + m-expr)] + [(_ ((var (in-pmap-keys m-expr))) body ...) + (binding-id? #'var) + #'(persistent-map-for-each + (lambda (__k __v) (let ([var __k]) body ...)) + m-expr)] + [(_ ((var (in-pmap-values m-expr))) body ...) + (binding-id? #'var) + #'(persistent-map-for-each + (lambda (__k __v) (let ([var __v]) body ...)) + m-expr)] + [(_ ((var (in-pset s-expr))) body ...) + (binding-id? #'var) + #'(persistent-set-for-each + (lambda (__x) (let ([var __x]) body ...)) + s-expr)] [(_ ((var (in-range end))) body ...) (binding-id? #'var) #'(let ([n end]) @@ -257,8 +304,63 @@ (not (char=? (string-ref str (- (string-length str) 1)) #\:)))))))) (lambda (stx) (syntax-case stx (in-range in-vector in-string in-list - in-hash-keys in-hash-values) + in-hash-keys in-hash-values + in-pmap in-pmap-keys in-pmap-values in-pmap-pairs + in-pvec in-pset) ;; --- Fused iterators (single-clause) --- + [(_ ((var (in-pvec pv-expr))) body ...) + (binding-id? #'var) + #'(let ([v pv-expr]) + (let ([n (persistent-vector-length v)]) + (let loop ([i 0] [acc '()]) + (if (fx>= i n) (reverse acc) + (let ([var (persistent-vector-ref v i)]) + (loop (fx+ i 1) (cons (begin body ...) acc)))))))] + [(_ ((var (in-pmap m-expr))) body ...) + (binding-id? #'var) + #'(let ([acc '()]) + (persistent-map-for-each + (lambda (__k __v) + (let ([var (cons __k __v)]) + (set! acc (cons (begin body ...) acc)))) + m-expr) + (reverse acc))] + [(_ ((var (in-pmap-pairs m-expr))) body ...) + (binding-id? #'var) + #'(let ([acc '()]) + (persistent-map-for-each + (lambda (__k __v) + (let ([var (cons __k __v)]) + (set! acc (cons (begin body ...) acc)))) + m-expr) + (reverse acc))] + [(_ ((var (in-pmap-keys m-expr))) body ...) + (binding-id? #'var) + #'(let ([acc '()]) + (persistent-map-for-each + (lambda (__k __v) + (let ([var __k]) + (set! acc (cons (begin body ...) acc)))) + m-expr) + (reverse acc))] + [(_ ((var (in-pmap-values m-expr))) body ...) + (binding-id? #'var) + #'(let ([acc '()]) + (persistent-map-for-each + (lambda (__k __v) + (let ([var __v]) + (set! acc (cons (begin body ...) acc)))) + m-expr) + (reverse acc))] + [(_ ((var (in-pset s-expr))) body ...) + (binding-id? #'var) + #'(let ([acc '()]) + (persistent-set-for-each + (lambda (__x) + (let ([var __x]) + (set! acc (cons (begin body ...) acc)))) + s-expr) + (reverse acc))] [(_ ((var (in-range end))) body ...) (binding-id? #'var) #'(let ([n end]) @@ -344,8 +446,60 @@ (or (= (string-length str) 0) (not (char=? (string-ref str (- (string-length str) 1)) #\:)))))))) (lambda (stx) - (syntax-case stx (in-range in-vector in-string in-list) + (syntax-case stx (in-range in-vector in-string in-list + in-pmap in-pmap-keys in-pmap-values in-pmap-pairs + in-pvec in-pset) ;; --- Fused iterators --- + [(_ ((acc init)) ((var (in-pvec pv-expr))) body ...) + (binding-id? #'var) + #'(let ([v pv-expr]) + (let ([n (persistent-vector-length v)]) + (let loop ([i 0] [acc init]) + (if (fx>= i n) acc + (let ([var (persistent-vector-ref v i)]) + (loop (fx+ i 1) (begin body ...)))))))] + [(_ ((acc init)) ((var (in-pmap m-expr))) body ...) + (binding-id? #'var) + #'(let ([acc init]) + (persistent-map-for-each + (lambda (__k __v) + (let ([var (cons __k __v)]) + (set! acc (begin body ...)))) + m-expr) + acc)] + [(_ ((acc init)) ((var (in-pmap-pairs m-expr))) body ...) + (binding-id? #'var) + #'(let ([acc init]) + (persistent-map-for-each + (lambda (__k __v) + (let ([var (cons __k __v)]) + (set! acc (begin body ...)))) + m-expr) + acc)] + [(_ ((acc init)) ((var (in-pmap-keys m-expr))) body ...) + (binding-id? #'var) + #'(let ([acc init]) + (persistent-map-for-each + (lambda (__k __v) + (let ([var __k]) (set! acc (begin body ...)))) + m-expr) + acc)] + [(_ ((acc init)) ((var (in-pmap-values m-expr))) body ...) + (binding-id? #'var) + #'(let ([acc init]) + (persistent-map-for-each + (lambda (__k __v) + (let ([var __v]) (set! acc (begin body ...)))) + m-expr) + acc)] + [(_ ((acc init)) ((var (in-pset s-expr))) body ...) + (binding-id? #'var) + #'(let ([acc init]) + (persistent-set-for-each + (lambda (__x) + (let ([var __x]) (set! acc (begin body ...)))) + s-expr) + acc)] [(_ ((acc init)) ((var (in-range end))) body ...) (binding-id? #'var) #'(let ([n end]) --- a/lib/std/pvec.sls +++ b/lib/std/pvec.sls @@ -21,6 +21,7 @@ persistent-vector->list persistent-vector-for-each persistent-vector-map persistent-vector-fold persistent-vector-filter persistent-vector-concat persistent-vector-slice persistent-vector-prepend + in-pvec ;; Transients: batch mutation without per-step copying transient transient? transient-ref transient-set! transient-append! persistent! ;; Structural equality / hashing @@ -221,6 +222,11 @@ ((= i count)) (proc (persistent-vector-ref v i))))) + ;; `in-pvec` — iterator compatible with (std iter). + ;; Unfused path materialises a list; iter.sls's fused clauses for + ;; `in-pvec` skip the materialise step entirely. + (define (in-pvec v) (persistent-vector->list v)) + (define (persistent-vector-map proc v) (let ([count (%pvec-count v)]) (let loop ([i 0] [result pvec-empty]) new file mode 100644 --- /dev/null +++ b/tests/test-iter-persistent.ss @@ -0,0 +1,174 @@ +#!chezscheme +;;; Tests for for/for-collect/for-fold over persistent collections. +;;; Phase 28 of Round 4. +;;; +;;; Iterators covered: +;;; in-pvec → yields elements in index order +;;; in-pmap, in-pmap-pairs → yields (k . v) pairs (iteration order = hash) +;;; in-pmap-keys → yields keys +;;; in-pmap-values → yields values +;;; in-pset → yields elements (iteration order = hash) +;;; +;;; Fused paths skip the materialize-to-list step. Correctness vs. the +;;; unfused path is the thing we test here. + +(import (chezscheme) (std iter) (std pmap) (std pvec) (std pset)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) + +(define-syntax test-setish + ;; Same as test but with set-equivalence comparison (hash iteration + ;; order for pmap/pset isn't insertion order). + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (let ([gs (list-sort < got)] [es (list-sort < expected)]) + (if (equal? gs es) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected))))))])) + +(printf "--- Round 4 Phase 28: for over persistent collections ---~%~%") + +;;; ========== pvec ========== + +(test "for in-pvec side-effect order" + (let ([acc '()]) + (for ((x (in-pvec (persistent-vector 10 20 30)))) + (set! acc (cons x acc))) + (reverse acc)) + '(10 20 30)) + +(test "for/collect in-pvec" + (for/collect ((x (in-pvec (persistent-vector 1 2 3 4 5)))) + (* x x)) + '(1 4 9 16 25)) + +(test "for/fold in-pvec sum" + (for/fold ((s 0)) ((x (in-pvec (persistent-vector 1 2 3 4 5)))) + (+ s x)) + 15) + +(test "for in-pvec empty" + (let ([acc '()]) + (for ((x (in-pvec (persistent-vector)))) + (set! acc (cons x acc))) + acc) + '()) + +(test "for/collect in-pvec large" + (for/collect ((x (in-pvec (list->persistent-vector (iota 50))))) + x) + (iota 50)) + +;;; ========== pmap (pairs) ========== + +(test "for/collect in-pmap pairs → sum of k+v" + (list-sort < + (for/collect ((kv (in-pmap (make-persistent-map 'a 1 'b 2 'c 3)))) + (cdr kv))) + '(1 2 3)) + +(test "for/fold in-pmap values sum" + (for/fold ((s 0)) + ((kv (in-pmap (make-persistent-map 'a 1 'b 2 'c 3)))) + (+ s (cdr kv))) + 6) + +(test "for in-pmap side-effect count" + (let ([n 0]) + (for ((kv (in-pmap (make-persistent-map 'a 1 'b 2 'c 3 'd 4)))) + (set! n (+ n 1))) + n) + 4) + +(test "for in-pmap empty" + (for/fold ((c 0)) ((kv (in-pmap (make-persistent-map)))) + (+ c 1)) + 0) + +;;; ========== pmap-keys / pmap-values ========== + +(test-setish "for/collect in-pmap-keys" + (for/collect ((k (in-pmap-keys (make-persistent-map 1 'a 2 'b 3 'c)))) + k) + '(1 2 3)) + +(test-setish "for/collect in-pmap-values" + (for/collect ((v (in-pmap-values (make-persistent-map 'a 10 'b 20 'c 30)))) + v) + '(10 20 30)) + +(test "for/fold in-pmap-values sum" + (for/fold ((s 0)) + ((v (in-pmap-values (make-persistent-map 'a 1 'b 2 'c 3 'd 4)))) + (+ s v)) + 10) + +;;; ========== pset ========== + +(test-setish "for/collect in-pset" + (for/collect ((x (in-pset (make-persistent-set 1 2 3 4)))) + x) + '(1 2 3 4)) + +(test "for/fold in-pset sum" + (for/fold ((s 0)) ((x (in-pset (make-persistent-set 1 2 3 4 5)))) + (+ s x)) + 15) + +(test "for in-pset count" + (let ([n 0]) + (for ((x (in-pset (make-persistent-set 'a 'b 'c)))) + (set! n (+ n 1))) + n) + 3) + +(test "for/collect in-pset empty" + (for/collect ((x (in-pset (make-persistent-set)))) + x) + '()) + +;;; ========== Mixed: pmap within larger computation ========== + +(test "for/fold in-pmap build alist" + (list-sort (lambda (a b) (< (cdr a) (cdr b))) + (for/fold ((al '())) + ((kv (in-pmap (make-persistent-map 'x 1 'y 2 'z 3)))) + (cons kv al))) + '((x . 1) (y . 2) (z . 3))) + +;;; ========== Regression: non-persistent paths still fused ========== + +(test "regression for/collect in-range" + (for/collect ((i (in-range 5))) i) + '(0 1 2 3 4)) + +(test "regression for/collect in-vector" + (for/collect ((x (in-vector (vector 'a 'b 'c)))) x) + '(a b c)) + +(test "regression for/fold in-list" + (for/fold ((s 0)) ((x (in-list '(1 2 3 4)))) (+ s x)) + 10) + +(printf "~%--- Results: ~a/~a passed, ~a failed ---~%" + pass (+ pass fail) fail) + +(exit (if (= fail 0) 0 1))