summaryrefslogtreecommitdiffstats
path: root/srfi-1.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commit8466d8cfa486fb30d1755c4261b781135083787b (patch)
treec8c12c67246f543c3cc4f64d1c07e003cb1d45ae /srfi-1.scm
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-8466d8cfa486fb30d1755c4261b781135083787b.tar.gz
slib-8466d8cfa486fb30d1755c4261b781135083787b.zip
Import Upstream version 3a1upstream/3a1
Diffstat (limited to 'srfi-1.scm')
-rw-r--r--srfi-1.scm230
1 files changed, 218 insertions, 12 deletions
diff --git a/srfi-1.scm b/srfi-1.scm
index 1cebd9a..d0f436f 100644
--- a/srfi-1.scm
+++ b/srfi-1.scm
@@ -1,5 +1,6 @@
;;; "srfi-1.scm" SRFI-1 list-processing library -*-scheme-*-
-; Copyright 2001 Aubrey Jaffer
+;; Copyright 2001 Aubrey Jaffer
+;; Copyright 2003 Sven Hartrumpf
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
@@ -8,7 +9,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -48,7 +49,10 @@
((< i 0) ans)))
;;@args obj1 obj2
-(define cons* comlist:list*)
+(define cons* list*)
+
+;;@args flist
+(define list-copy copy-list)
;;@args count start step
;;@args count start
@@ -112,9 +116,13 @@
;;@args pair
(define first car)
+;;@args pair
(define second cadr)
+;;@args pair
(define third caddr)
+;;@args pair
(define fourth cadddr)
+;;@args pair
(define (fifth obj) (car (cddddr obj)))
(define (sixth obj) (cadr (cddddr obj)))
(define (seventh obj) (caddr (cddddr obj)))
@@ -126,17 +134,21 @@
(define (car+cdr pair) (values (car pair) (cdr pair)))
;;@body
-(define (take lst k) (comlist:butnthcdr k lst))
+(define (drop lst k) (nthcdr k lst))
+(define (take lst k) (butnthcdr k lst))
+;;@args lst k
(define take! take)
-(define (drop lst k) (comlist:nthcdr k lst))
;;@args lst k
-(define take-right comlist:butlast)
-(define drop-right comlist:last)
+(define take-right last)
+;;@args lst k
+(define drop-right butlast)
+;;@args lst k
(define drop-right! drop-right)
-;;@body
+;;@args lst k
(define (split-at lst k) (values (take lst k) (drop lst k)))
+;;@args lst k
(define split-at! split-at)
;;@args lst
@@ -144,7 +156,7 @@
(define (last lst . k)
(if (null? k)
(car (last-pair lst))
- (apply comlist:last lst k)))
+ (apply take-right lst k)))
;;@subheading Miscellaneous
@@ -159,7 +171,7 @@
;;Reverse is provided by R4RS.
;;@args lst
-(define reverse! comlist:nreverse)
+(define reverse! nreverse)
;;@body
(define (append-reverse rev-head tail)
@@ -202,16 +214,159 @@
;;@subheading Fold and Unfold
+
+;;; We stop when LIS1 runs out, not when any list runs out.
+;;@args f list1 clist2 ...
+(define (map! f lis1 . lists)
+ (if (pair? lists)
+ (let lp ((lis1 lis1) (lists lists))
+ (if (not (null-list? lis1))
+ (call-with-values ; expanded a receive call
+ (lambda () (%cars+cdrs/no-test lists))
+ (lambda (heads tails)
+ (set-car! lis1 (apply f (car lis1) heads))
+ (lp (cdr lis1) tails)))))
+
+ ;; Fast path.
+ (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1))
+ lis1)
+
+;;@args f clist1 clist2 ...
+(define (pair-for-each proc lis1 . lists)
+ (if (pair? lists)
+ (let lp ((lists (cons lis1 lists)))
+ (let ((tails (%cdrs lists)))
+ (if (pair? tails)
+ (begin (apply proc lists)
+ (lp tails)))))
+ ;; Fast path.
+ (let lp ((lis lis1))
+ (if (not (null-list? lis))
+ (let ((tail (cdr lis))) ; Grab the cdr now,
+ (proc lis) ; in case PROC SET-CDR!s LIS.
+ (lp tail))))))
+
+
;;@subheading Filtering and Partitioning
+;;@body
+(define (filter pred lis) ; Sleazing with EQ? makes this one faster.
+ (let recur ((lis lis))
+ (if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists.
+ (let ((head (car lis))
+ (tail (cdr lis)))
+ (if (pred head)
+ (let ((new-tail (recur tail))) ; Replicate the RECUR call so
+ (if (eq? tail new-tail) lis
+ (cons head new-tail)))
+ (recur tail)))))) ; this one can be a tail call.
+;;@body
+(define (filter! pred l)
+ (if (null? l)
+ l
+ (let ((l2 l)
+ (l3 (cdr l)))
+ (do ((end #f)
+ (result '()))
+ (end result)
+ (cond ((pred (car l2)) ; keep the first element of l2
+ (cond ((null? result)
+ (set! result l2))) ; first pair of remaining elements
+ (cond ((pair? l3)
+ (set! l2 l3)
+ (set! l3 (cdr l2)))
+ (else
+ (set! end #t))))
+ (else ; remove the first element of l2
+ (cond ((pair? l3)
+ (set-car! l2 (car l3))
+ (set! l3 (cdr l3))
+ (set-cdr! l2 l3))
+ (else
+ (cond ((pair? result)
+ (list-remove-last! result)))
+ (set! end #t)))))))))
+
+;;@args pred list
+(define (partition pred lis)
+ (let recur ((lis lis))
+ (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists.
+ (let ((elt (car lis))
+ (tail (cdr lis)))
+ (call-with-values ; expanded a receive call
+ (lambda () (recur tail))
+ (lambda (in out)
+ (if (pred elt)
+ (values (if (pair? out) (cons elt in) lis) out)
+ (values in (if (pair? in) (cons elt out) lis)))))))))
+
;;@subheading Searching
;;@args pred list
-(define find comlist:find-if)
+(define find find-if)
;;@args pred list
-(define find-tail comlist:member-if)
+(define find-tail member-if)
+;;@body
+(define remove
+ (let ((comlist:remove remove))
+ (lambda (pred l)
+ (if (procedure? pred)
+ (filter (lambda (x) (not (pred x))) l)
+ (comlist:remove pred l))))) ; 'remove' has incompatible semantics in comlist of SLIB!
+;;@body
+(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l))
+
+;;@args pred clist1 clist2 ...
+(define (any pred lis1 . lists)
+ (if (pair? lists)
+ ;; N-ary case
+ (call-with-values ; expanded a receive call
+ (lambda () (%cars+cdrs (cons lis1 lists)))
+ (lambda (heads tails)
+ (and (pair? heads)
+ (let lp ((heads heads) (tails tails))
+ (call-with-values ; expanded a receive call
+ (lambda () (%cars+cdrs tails))
+ (lambda (next-heads next-tails)
+ (if (pair? next-heads)
+ (or (apply pred heads) (lp next-heads next-tails))
+ (apply pred heads)))))))) ; Last PRED app is tail call.
+ ;; Fast path
+ (and (not (null-list? lis1))
+ (let lp ((head (car lis1)) (tail (cdr lis1)))
+ (if (null-list? tail)
+ (pred head) ; Last PRED app is tail call.
+ (or (pred head) (lp (car tail) (cdr tail))))))))
+
+;;@args pred clist1 clist2 ...
+(define (list-index pred lis1 . lists)
+ (if (pair? lists)
+ ;; N-ary case
+ (let lp ((lists (cons lis1 lists)) (n 0))
+ (call-with-values ; expanded a receive call
+ (lambda () (%cars+cdrs lists))
+ (lambda (heads tails)
+ (and (pair? heads)
+ (if (apply pred heads) n
+ (lp tails (+ n 1)))))))
+ ;; Fast path
+ (let lp ((lis lis1) (n 0))
+ (and (not (null-list? lis))
+ (if (pred (car lis)) n (lp (cdr lis) (+ n 1)))))))
+
+;;@args pred list
+(define (span pred lis)
+ (let recur ((lis lis))
+ (if (null-list? lis) (values '() '())
+ (let ((x (car lis)))
+ (if (pred x)
+ (call-with-values ; eliminated a receive call
+ (lambda () (recur (cdr lis)))
+ (lambda (prefix suffix)
+ (values (cons x prefix) suffix)))
+ (values '() lis))))))
;;@args obj list pred
;;@args obj list
@@ -251,3 +406,54 @@
(find (lambda (pair) (pred obj (car pair))) alist))))))
;;@subheading Set operations
+
+
+;;;; helper functions from the reference implementation:
+
+;;; LISTS is a (not very long) non-empty list of lists.
+;;; Return two lists: the cars & the cdrs of the lists.
+;;; However, if any of the lists is empty, just abort and return [() ()].
+
+(define (%cars+cdrs lists)
+ (call-with-current-continuation
+ (lambda (abort)
+ (let recur ((lists lists))
+ (if (pair? lists)
+ (call-with-values ; expanded a receive call
+ (lambda () (car+cdr lists))
+ (lambda (list other-lists)
+ (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
+ (call-with-values ; expanded a receive call
+ (lambda () (car+cdr list))
+ (lambda (a d)
+ (call-with-values ; expanded a receive call
+ (lambda () (recur other-lists))
+ (lambda (cars cdrs)
+ (values (cons a cars) (cons d cdrs)))))))))
+ (values '() '()))))))
+
+;;; Like %CARS+CDRS, but blow up if any list is empty.
+(define (%cars+cdrs/no-test lists)
+ (let recur ((lists lists))
+ (if (pair? lists)
+ (call-with-values ; expanded a receive call
+ (lambda () (car+cdr lists))
+ (lambda (list other-lists)
+ (call-with-values ; expanded a receive call
+ (lambda () (car+cdr list))
+ (lambda (a d)
+ (call-with-values ; expanded a receive call
+ (lambda () (recur other-lists))
+ (lambda (cars cdrs)
+ (values (cons a cars) (cons d cdrs))))))))
+ (values '() '()))))
+
+(define (%cdrs lists)
+ (call-with-current-continuation
+ (lambda (abort)
+ (let recur ((lists lists))
+ (if (pair? lists)
+ (let ((lis (car lists)))
+ (if (null-list? lis) (abort '())
+ (cons (cdr lis) (recur (cdr lists)))))
+ '())))))