Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-08 05:27:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

various srfi-1 fixes

Browse source
This commit is contained in:
Alex Shinn 2012-01-22 11:38:49 +09:00
parent 29b461bb44
commit ad46061a5b
6 changed files with 26 additions and 24 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lib/srfi/1/constructors.scm
View file

@ -16,7 +16,7 @@
(if (<= n 0) res (lp (- n 1) (cons default res))))))
(define (list-tabulate n proc)
(let lp ((n n) (res '()))
(let lp ((n (- n 1)) (res '()))
(if (< n 0) res (lp (- n 1) (cons (proc n) res)))))
(define (list-copy ls) (reverse! (reverse ls)))

5
lib/srfi/1/deletion.scm
View file

@ -1,5 +1,5 @@
;; deletion.scm -- list deletion utilities
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; Copyright (c) 2009-2012 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (delete x ls . o)
@ -18,8 +18,7 @@
(let ((eq (if (pair? o) (car o) equal?)))
(let lp ((ls ls) (res '()))
(if (pair? ls)
(lp (cdr ls) (if (member (car ls) res) res (cons (car ls) res)))
(lp (cdr ls) (if (member (car ls) res eq) res (cons (car ls) res)))
(reverse! res)))))
(define delete-duplicates! delete-duplicates)

12
lib/srfi/1/fold.scm
View file

@ -1,5 +1,5 @@
;; fold.scm -- list fold/reduce utilities
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; Copyright (c) 2009-2012 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (fold kons knil ls . lists)
@ -17,7 +17,7 @@
(if (pair? ls) (kons (car ls) (lp (cdr ls))) knil))
(let lp ((lists (cons ls lists)))
(if (every pair? lists)
(apply kons (map-onto car lists (lp (map cdr lists))))
(apply kons (map-onto car lists (list (lp (map cdr lists)))))
knil))))
(define (pair-fold kons knil ls . lists)
@ -32,10 +32,10 @@
(define (pair-fold-right kons knil ls . lists)
(if (null? lists)
(let lp ((ls ls))
(if (pair? ls) (kons (car ls) (lp (cdr ls))) knil))
(if (pair? ls) (kons ls (lp (cdr ls))) knil))
(let lp ((lists (cons ls lists)))
(if (every pair? lists)
(apply kons (append lists (lp (map cdr lists))))
(apply kons (append lists (list (lp (map cdr lists)))))
knil))))
(define (reduce f identity ls)
@ -77,13 +77,13 @@
(define map-in-order map)
(define (pair-for-each f ls . lists)
(apply pair-fold (lambda (x _) (f x)) ls lists))
(apply pair-fold (lambda (x _) (f x)) #f ls lists))
(define (filter-map f ls . lists)
(if (null? lists)
(let lp ((ls ls) (res '()))
(if (pair? ls)
(let ((x (f (car ls)))) (lp (cdr ls) (if f (cons f res) res)))
(let ((x (f (car ls)))) (lp (cdr ls) (if x (cons x res) res)))
(reverse! res)))
(filter (lambda (x) x) (apply map f ls lists))))

17
lib/srfi/1/lset.scm
View file

@ -1,5 +1,5 @@
;; lset.scm -- list set library
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
;; Copyright (c) 2009-2012 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (lset<= eq . sets)
@ -18,7 +18,7 @@
(and (apply lset<= eq sets) (apply lset<= eq (reverse sets))))
(define (lset-adjoin eq set . elts)
(lset-union2 eq elts set))
(lset-union2 eq set elts))
(define (lset-union2 eq a b)
(if (null? b)
@ -26,18 +26,19 @@
(lset-union2 eq (if (member (car b) a eq) a (cons (car b) a)) (cdr b))))
(define (lset-union eq . sets)
(reduce (lambda (a b) (lset-union2 eq a b)) '() sets))
(reduce (lambda (a b) (lset-union2 eq b a)) '() sets))
(define (lset-intersection eq . sets)
(reduce (lambda (a b) (filter (lambda (x) (member x b eq)) a)) '() sets))
(reduce (lambda (a b) (filter (lambda (x) (member x a eq)) b)) '() sets))
(define (lset-diff2 eq a b)
(remove (lambda (x) (member x a eq)) b))
(define (lset-difference eq . sets)
(reduce (lambda (a b) (remove (lambda (x) (member x b eq)) a)) '() sets))
(reduce (lambda (a b) (lset-diff2 eq a b)) '() sets))
(define (lset-xor eq . sets)
(reduce (lambda (a b)
(append (filter (lambda (x) (member x b eq)) a)
(filter (lambda (x) (member x a eq)) b)))
(reduce (lambda (a b) (append (lset-diff2 eq a b) (lset-diff2 eq b a)))
'()
sets))

5
lib/srfi/1/misc.scm
View file

@ -1,5 +1,5 @@
;; misc.scm -- miscellaneous list utilities
;; Copyright (c) 2009-2011 Alex Shinn. All rights reserved.
;; Copyright (c) 2009-2012 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (map-onto proc ls init)
@ -17,7 +17,7 @@
'()
(let lp ((ls lists))
(cond ((not (pair? (cdr ls)))
lists)
(car lists))
(else
(set-cdr! (last-pair (car ls)) (cadr ls))
(lp (cdr ls)))))))
@ -51,4 +51,3 @@
(if (every pair? lists)
(lp (map cdr lists) (if (apply pred (map car lists)) (+ res 1) res))
res))))

9
tests/srfi-1-tests.scm
View file

@ -18,7 +18,9 @@
(test '(0 1 2 3) (list-tabulate 4 values))
(test '(z q z q z q) (take (circular-list 'z 'q) 6))
(test '(0 1 2 3 4) (iota 5))
(test '(0 -0.1 -0.2 -0.3 -0.4) (iota 5 0 -0.1))
(test '(0 -0.1 -0.2 -0.3 -0.4)
(let ((res (iota 5 0 -0.1)))
(cons (inexact->exact (car res)) (cdr res))))
(test '#t (pair? '(a . b)))
(test '#t (pair? '(a b c)))
(test '#f (pair? '()))
@ -72,6 +74,7 @@
(test '(c 3 b 2 a 1) (fold cons* '() '(a b c) '(1 2 3 4 5)))
(test '(a 1 b 2 c 3) (fold-right cons* '() '(a b c) '(1 2 3 4 5)))
(test '((a b c) (b c) (c)) (pair-fold-right cons '() '(a b c)))
(test '((a b c) (1 2 3) (b c) (2 3) (c) (3)) (pair-fold-right cons* '() '(a b c) '(1 2 3)))
(test '(b e h) (map cadr '((a b) (d e) (g h))))
(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5)))
(test '(5 7 9) (map + '(1 2 3) '(4 5 6)))
@ -94,7 +97,7 @@
(test '#t (any even? '(1 2 3)))
(test '#f (find even? '(1 7 3)))
(test '#f (any even? '(1 7 3)))
(test-error (find even? '(1 3 . x)))
;(test-error (find even? '(1 3 . x)))
(test-error (any even? '(1 3 . x)))
;(test 'error/undefined (find even? '(1 2 . x)))
;(test 'error/undefined (any even? '(1 2 . x))) ; success, error or other
@ -148,7 +151,7 @@
(test '(a b c) (lset-intersection eq? '(a b c)))
(test '(b c d) (lset-difference eq? '(a b c d e) '(a e i o u)))
(test '(a b c) (lset-difference eq? '(a b c)))
(test '(d c b i o u) (lset-xor eq? '(a b c d e) '(a e i o u)))
(test #t (lset= eq? '(d c b i o u) (lset-xor eq? '(a b c d e) '(a e i o u))))
(test '() (lset-xor eq?))
(test '(a b c d e) (lset-xor eq? '(a b c d e)))
(let ((f (lambda () (list 'not-a-constant-list)))