mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Fix R6RS `fold-left' so the accumulator is the first argument.

Browse source 
* module/rnrs/lists.scm (fold-left): New procedure.

* module/rnrs/records/syntactic.scm (define-record-type): Fix to use
  corrected `fold-left'.

* test-suite/tests/r6rs-lists.test: Add tests.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Ian Price 2011-10-26 20:24:05 +01:00 • committed by Ludovic Courtès
parent 2be3feb17e
commit d825841db0
3 changed files with 37 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

12
module/rnrs/lists.scm
View file

@ -22,8 +22,7 @@
remv remq memp member memv memq assp assoc assv assq cons*) remv remq memp member memv memq assp assoc assv assq cons*)
(import (rnrs base (6)) (import (rnrs base (6))
(only (guile) filter member memv memq assoc assv assq cons*) (only (guile) filter member memv memq assoc assv assq cons*)
(rename (only (srfi srfi-1) fold (rename (only (srfi srfi-1) any
any
every every
remove remove
member member
@ -32,7 +31,6 @@
partition partition
fold-right fold-right
filter-map) filter-map)
(fold fold-left)
(any exists) (any exists)
(every for-all) (every for-all)
(remove remp) (remove remp)
@ -40,6 +38,14 @@
(member memp-internal) (member memp-internal)
(assoc assp-internal))) (assoc assp-internal)))
(define (fold-left combine nil list . lists)
(define (fold nil lists)
(if (exists null? lists)
nil
(fold (apply combine nil (map car lists))
(map cdr lists))))
(fold nil (cons list lists)))
(define (remove obj list) (remp (lambda (elt) (equal? obj elt)) list)) (define (remove obj list) (remp (lambda (elt) (equal? obj elt)) list))
(define (remv obj list) (remp (lambda (elt) (eqv? obj elt)) list)) (define (remv obj list) (remp (lambda (elt) (eqv? obj elt)) list))
(define (remq obj list) (remp (lambda (elt) (eq? obj elt)) list)) (define (remq obj list) (remp (lambda (elt) (eq? obj elt)) list))

4
module/rnrs/records/syntactic.scm
View file

@ -134,13 +134,13 @@
(let* ((fields (if (unspecified? _fields) '() _fields)) (let* ((fields (if (unspecified? _fields) '() _fields))
(field-names (list->vector (map car fields))) (field-names (list->vector (map car fields)))
(field-accessors (field-accessors
(fold-left (lambda (x c lst) (fold-left (lambda (lst x c)
(cons #`(define #,(cadr x) (cons #`(define #,(cadr x)
(record-accessor record-name #,c)) (record-accessor record-name #,c))
lst)) lst))
'() fields (sequence (length fields)))) '() fields (sequence (length fields))))
(field-mutators (field-mutators
(fold-left (lambda (x c lst) (fold-left (lambda (lst x c)
(if (caddr x) (if (caddr x)
(cons #`(define #,(caddr x) (cons #`(define #,(caddr x)
(record-mutator record-name (record-mutator record-name

26
test-suite/tests/r6rs-lists.test
View file

@ -30,3 +30,29 @@
(let ((d '((3 a) (1 b) (4 c)))) (let ((d '((3 a) (1 b) (4 c))))
(equal? (assp even? d) '(4 c))))) (equal? (assp even? d) '(4 c)))))
(with-test-prefix "fold-left"
(pass-if "fold-left sum"
(equal? (fold-left + 0 '(1 2 3 4 5))
15))
(pass-if "fold-left reverse"
(equal? (fold-left (lambda (a e) (cons e a)) '() '(1 2 3 4 5))
'(5 4 3 2 1)))
(pass-if "fold-left max-length"
(equal? (fold-left (lambda (max-len s)
(max max-len (string-length s)))
0
'("longest" "long" "longer"))
7))
(pass-if "fold-left with-cons"
(equal? (fold-left cons '(q) '(a b c))
'((((q) . a) . b) . c)))
(pass-if "fold-left sum-multiple"
(equal? (fold-left + 0 '(1 2 3) '(4 5 6))
21))
(pass-if "fold-left pairlis"
(equal? (fold-left (lambda (accum e1 e2)
(cons (cons e1 e2) accum))
'((d . 4))
'(a b c)
'(1 2 3))
'((c . 3) (b . 2) (a . 1) (d . 4)))))