source: project/chicken/trunk/srfi-1.scm @ 14236

Last change on this file since 14236 was 10712, checked in by felix winkelmann, 12 years ago

various tests and improvements

File size: 56.9 KB
Line 
1;;;; srfi-1.scm - Shivers' reference implementation of SRFI-1
2
3
4; Some things to make it work with CHICKEN: (flw)
5;
6
7(declare
8  (unit srfi-1)
9  (disable-interrupts)
10  (disable-warning redef)
11  (hide ##srfi1#cars+cdrs/no-test ##srfi1#cdrs ##srfi1#cars+ ##srfi1#really-append-map ##srfi1#cars+cdrs+
12        ##srfi1#cars+cdrs ##srfi1#lset2<=)
13  (extended-bindings)
14  (standard-bindings not boolean? apply call-with-current-continuation eq? eqv? equal? pair? cons car cdr caar cadr
15                     cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar
16                     cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr!
17                     null? list list? length zero? * - error + / - > < >= <= current-output-port current-input-port
18                     write-char newline write display append symbol->string char? char->integer
19                     integer->char eof-object? vector-length string-length string-ref string-set! vector-ref 
20                     vector-set! char=? char<? char>? char>=? char<=? gcd lcm reverse symbol? string->symbol
21                     number? complex? real? integer? rational? odd? even? positive? negative? exact? inexact?
22                     max min quotient remainder modulo floor ceiling truncate round exact->inexact inexact->exact
23                     exp log sin expt sqrt cos tan asin acos atan number->string string->number char-ci=?
24                     char-ci<? char-ci>? char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric?
25                     char-lower-case? char-upper-case? char-upcase char-downcase string? string=? string>? string<?
26                     string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=?
27                     string-append string->list list->string vector? vector->list list->vector string read
28                     read-char substring string-fill! vector-fill! make-string make-vector open-input-file
29                     open-output-file call-with-input-file call-with-output-file close-input-port close-output-port
30                     port? values call-with-values vector procedure? memq memv assq assv) )
31
32(cond-expand
33 [paranoia]
34 [else
35  (declare
36    (no-procedure-checks-for-usual-bindings)
37    (bound-to-procedure 
38     every any partition! reduce lset-difference! append! pair-fold lset-diff+intersection! fold
39     lset-difference filter! filter delete span! span find-tail find delete! pair-for-each car+cdr
40     reduce-right last-pair drop)
41    (no-bound-checks) ) ] )
42
43(include "unsafe-declarations.scm")
44
45(register-feature! 'srfi-1)
46
47
48;;; SRFI-1 list-processing library                      -*- Scheme -*-
49;;; Reference implementation
50;;;
51;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
52;;; this code as long as you do not remove this copyright notice or
53;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
54;;;     -Olin
55
56;;; This is a library of list- and pair-processing functions. I wrote it after
57;;; carefully considering the functions provided by the libraries found in
58;;; R4RS/R5RS Scheme, MIT Scheme, Gambit, RScheme, MzScheme, slib, Common
59;;; Lisp, Bigloo, guile, T, APL and the SML standard basis. It is a pretty
60;;; rich toolkit, providing a superset of the functionality found in any of
61;;; the various Schemes I considered.
62
63;;; This implementation is intended as a portable reference implementation
64;;; for SRFI-1. See the porting notes below for more information.
65
66;;; Exported:
67;;; xcons tree-copy make-list list-tabulate cons* list-copy
68;;; proper-list? circular-list? dotted-list? not-pair? null-list? list=
69;;; circular-list length+
70;;; iota
71;;; first second third fourth fifth sixth seventh eighth ninth tenth
72;;; car+cdr
73;;; take       drop       
74;;; take-right drop-right
75;;; take!      drop-right!
76;;; split-at   split-at!
77;;; last last-pair
78;;; zip unzip1 unzip2 unzip3 unzip4 unzip5
79;;; count
80;;; append! append-reverse append-reverse! concatenate concatenate!
81;;; unfold       fold       pair-fold       reduce
82;;; unfold-right fold-right pair-fold-right reduce-right
83;;; append-map append-map! map! pair-for-each filter-map map-in-order
84;;; filter  partition  remove
85;;; filter! partition! remove!
86;;; find find-tail any every list-index
87;;; take-while drop-while take-while!
88;;; span break span! break!
89
90;;; In principle, the following R4RS list- and pair-processing procedures
91;;; are also part of this package's exports, although they are not defined
92;;; in this file:
93;;;   Primitives: cons pair? null? car cdr set-car! set-cdr!
94;;;   Non-primitives: list length append reverse cadr ... cddddr list-ref
95;;;                   memq memv assq assv
96;;;   (The non-primitives are defined in this file, but commented out.)
97;;;
98;;; These R4RS procedures have extended definitions in SRFI-1 and are defined
99;;; in this file:
100;;;   map for-each member assoc
101;;;
102;;; The remaining two R4RS list-processing procedures are not included:
103;;;   list-tail (use drop)
104;;;   list? (use proper-list?)
105
106
107;;; A note on recursion and iteration/reversal:
108;;; Many iterative list-processing algorithms naturally compute the elements
109;;; of the answer list in the wrong order (left-to-right or head-to-tail) from
110;;; the order needed to cons them into the proper answer (right-to-left, or
111;;; tail-then-head). One style or idiom of programming these algorithms, then,
112;;; loops, consing up the elements in reverse order, then destructively
113;;; reverses the list at the end of the loop. I do not do this. The natural
114;;; and efficient way to code these algorithms is recursively. This trades off
115;;; intermediate temporary list structure for intermediate temporary stack
116;;; structure. In a stack-based system, this improves cache locality and
117;;; lightens the load on the GC system. Don't stand on your head to iterate!
118;;; Recurse, where natural. Multiple-value returns make this even more
119;;; convenient, when the recursion/iteration has multiple state values.
120
121;;; Porting:
122;;; This is carefully tuned code; do not modify casually.
123;;;   - It is careful to share storage when possible;
124;;;   - Side-effecting code tries not to perform redundant writes.
125;;;
126;;; That said, a port of this library to a specific Scheme system might wish
127;;; to tune this code to exploit particulars of the implementation.
128;;; The single most important compiler-specific optimisation you could make
129;;; to this library would be to add rewrite rules or transforms to:
130;;; - transform applications of n-ary procedures (e.g. LIST=, CONS*, APPEND,
131;;;   LSET-UNION) into multiple applications of a primitive two-argument
132;;;   variant.
133;;; - transform applications of the mapping functions (MAP, FOR-EACH, FOLD,
134;;;   ANY, EVERY) into open-coded loops. The killer here is that these
135;;;   functions are n-ary. Handling the general case is quite inefficient,
136;;;   requiring many intermediate data structures to be allocated and
137;;;   discarded.
138;;; - transform applications of procedures that take optional arguments
139;;;   into calls to variants that do not take optional arguments. This
140;;;   eliminates unnecessary consing and parsing of the rest parameter.
141;;;
142;;; These transforms would provide BIG speedups. In particular, the n-ary
143;;; mapping functions are particularly slow and cons-intensive, and are good
144;;; candidates for tuning. I have coded fast paths for the single-list cases,
145;;; but what you really want to do is exploit the fact that the compiler
146;;; usually knows how many arguments are being passed to a particular
147;;; application of these functions -- they are usually explicitly called, not
148;;; passed around as higher-order values. If you can arrange to have your
149;;; compiler produce custom code or custom linkages based on the number of
150;;; arguments in the call, you can speed these functions up a *lot*. But this
151;;; kind of compiler technology no longer exists in the Scheme world as far as
152;;; I can see.
153;;;
154;;; Note that this code is, of course, dependent upon standard bindings for
155;;; the R5RS procedures -- i.e., it assumes that the variable CAR is bound
156;;; to the procedure that takes the car of a list. If your Scheme
157;;; implementation allows user code to alter the bindings of these procedures
158;;; in a manner that would be visible to these definitions, then there might
159;;; be trouble. You could consider horrible kludgery along the lines of
160;;;    (define fact
161;;;      (let ((= =) (- -) (* *))
162;;;        (letrec ((real-fact (lambda (n)
163;;;                              (if (= n 0) 1 (* n (real-fact (- n 1)))))))
164;;;          real-fact)))
165;;; Or you could consider shifting to a reasonable Scheme system that, say,
166;;; has a module system protecting code from this kind of lossage.
167;;;
168;;; This code does a fair amount of run-time argument checking. If your
169;;; Scheme system has a sophisticated compiler that can eliminate redundant
170;;; error checks, this is no problem. However, if not, these checks incur
171;;; some performance overhead -- and, in a safe Scheme implementation, they
172;;; are in some sense redundant: if we don't check to see that the PROC
173;;; parameter is a procedure, we'll find out anyway three lines later when
174;;; we try to call the value. It's pretty easy to rip all this argument
175;;; checking code out if it's inappropriate for your implementation -- just
176;;; nuke every call to CHECK-ARG.
177;;;
178;;; On the other hand, if you *do* have a sophisticated compiler that will
179;;; actually perform soft-typing and eliminate redundant checks (Rice's systems
180;;; being the only possible candidate of which I'm aware), leaving these checks
181;;; in can *help*, since their presence can be elided in redundant cases,
182;;; and in cases where they are needed, performing the checks early, at
183;;; procedure entry, can "lift" a check out of a loop.
184;;;
185;;; Finally, I have only checked the properties that can portably be checked
186;;; with R5RS Scheme -- and this is not complete. You may wish to alter
187;;; the CHECK-ARG parameter checks to perform extra, implementation-specific
188;;; checks, such as procedure arity for higher-order values.
189;;;
190;;; The code has only these non-R4RS dependencies:
191;;;   A few calls to an ERROR procedure;
192;;;   Uses of the R5RS multiple-value procedure VALUES and the m-v binding
193;;;     RECEIVE macro (which isn't R5RS, but is a trivial macro).
194;;;   Many calls to a parameter-checking procedure check-arg:
195;;;    (define (check-arg pred val caller)
196;;;      (let lp ((val val))
197;;;        (if (pred val) val (lp (error "Bad argument" val pred caller)))))
198;;;   A few uses of the LET-OPTIONAL and :OPTIONAL macros for parsing
199;;;     optional arguments.
200;;;
201;;; Most of these procedures use the NULL-LIST? test to trigger the
202;;; base case in the inner loop or recursion. The NULL-LIST? function
203;;; is defined to be a careful one -- it raises an error if passed a
204;;; non-nil, non-pair value. The spec allows an implementation to use
205;;; a less-careful implementation that simply defines NULL-LIST? to
206;;; be NOT-PAIR?. This would speed up the inner loops of these procedures
207;;; at the expense of having them silently accept dotted lists.
208
209;;; A note on dotted lists:
210;;; I, personally, take the view that the only consistent view of lists
211;;; in Scheme is the view that *everything* is a list -- values such as
212;;; 3 or "foo" or 'bar are simply empty dotted lists. This is due to the
213;;; fact that Scheme actually has no true list type. It has a pair type,
214;;; and there is an *interpretation* of the trees built using this type
215;;; as lists.
216;;;
217;;; I lobbied to have these list-processing procedures hew to this
218;;; view, and accept any value as a list argument. I was overwhelmingly
219;;; overruled during the SRFI discussion phase. So I am inserting this
220;;; text in the reference lib and the SRFI spec as a sort of "minority
221;;; opinion" dissent.
222;;;
223;;; Many of the procedures in this library can be trivially redefined
224;;; to handle dotted lists, just by changing the NULL-LIST? base-case
225;;; check to NOT-PAIR?, meaning that any non-pair value is taken to be
226;;; an empty list. For most of these procedures, that's all that is
227;;; required.
228;;;
229;;; However, we have to do a little more work for some procedures that
230;;; *produce* lists from other lists.  Were we to extend these procedures to
231;;; accept dotted lists, we would have to define how they terminate the lists
232;;; produced as results when passed a dotted list. I designed a coherent set
233;;; of termination rules for these cases; this was posted to the SRFI-1
234;;; discussion list. I additionally wrote an earlier version of this library
235;;; that implemented that spec. It has been discarded during later phases of
236;;; the definition and implementation of this library.
237;;;
238;;; The argument *against* defining these procedures to work on dotted
239;;; lists is that dotted lists are the rare, odd case, and that by
240;;; arranging for the procedures to handle them, we lose error checking
241;;; in the cases where a dotted list is passed by accident -- e.g., when
242;;; the programmer swaps a two arguments to a list-processing function,
243;;; one being a scalar and one being a list. For example,
244;;;     (member '(1 3 5 7 9) 7)
245;;; This would quietly return #f if we extended MEMBER to accept dotted
246;;; lists.
247;;;
248;;; The SRFI discussion record contains more discussion on this topic.
249
250
251;;; Constructors
252;;;;;;;;;;;;;;;;
253
254;;; Occasionally useful as a value to be passed to a fold or other
255;;; higher-order procedure.
256(define (xcons d a) (cons a d))
257
258;;;; Recursively copy every cons.
259;(define (tree-copy x)
260;  (let recur ((x x))
261;    (if (not (pair? x)) x
262;       (cons (recur (car x)) (recur (cdr x))))))
263
264;;; Make a list of length LEN.
265
266(define (make-list len . maybe-elt)
267;  (check-arg (lambda (n) (and (integer? n) (>= n 0))) len make-list)
268  (##sys#check-exact len 'make-list)
269  (let ((elt (cond ((null? maybe-elt) #f) ; Default value
270                   ((null? (cdr maybe-elt)) (car maybe-elt))
271                   (else (##sys#error 'make-list "Too many arguments to MAKE-LIST"
272                                (cons len maybe-elt))))))
273    (do ((i len (fx- i 1))
274         (ans '() (cons elt ans)))
275        ((fx<= i 0) ans))))
276
277
278;(define (list . ans) ans)      ; R4RS
279
280
281;;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN.
282
283(define (list-tabulate len proc)
284;  (check-arg (lambda (n) (and (integer? n) (>= n 0))) len list-tabulate)
285;  (check-arg procedure? proc list-tabulate)
286  (##sys#check-exact len 'list-tabulate)
287  (do ((i (fx- len 1) (fx- i 1))
288       (ans '() (cons (proc i) ans)))
289      ((fx< i 0) ans)))
290
291;;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an)))
292;;; (cons* a1) = a1     (cons* a1 a2 ...) = (cons a1 (cons* a2 ...))
293;;;
294;;; (cons first (unfold not-pair? car cdr rest values))
295
296(define (cons* first . rest)
297  (let recur ((x first) (rest rest))
298    (if (pair? rest)
299        (cons x (recur (car rest) (cdr rest)))
300        x)))
301
302;;; (unfold not-pair? car cdr lis values)
303
304(define (list-copy lis)                         
305  (let recur ((lis lis))                       
306    (if (pair? lis)                             
307        (cons (car lis) (recur (cdr lis)))     
308        lis)))                                 
309
310;;; IOTA count [start step]     (start start+step ... start+(count-1)*step)
311
312(define (iota count . maybe-start+step)
313;  (check-arg integer? count iota)
314  (##sys#check-number count 'iota)
315  (if (< count 0) (##sys#error 'iota "Negative step count" iota count))
316  (let-optionals maybe-start+step ((start 0) ; Olin, I'm tired of fixing your stupid bugs - why didn't
317                                   (step 1) ) ; you use your own macros, then?
318    (##sys#check-number start 'iota)
319    (##sys#check-number step 'iota)
320;    (check-arg number? start iota)
321;    (check-arg number? step iota)
322    (let ((last-val (+ start (* (- count 1) step))))
323      (do ((count count (- count 1))
324           (val last-val (- val step))
325           (ans '() (cons val ans)))
326          ((<= count 0)  ans)))))
327         
328;;; I thought these were lovely, but the public at large did not share my
329;;; enthusiasm...
330;;; :IOTA to            (0 ... to-1)
331;;; :IOTA from to       (from ... to-1)
332;;; :IOTA from to step  (from from+step ...)
333
334;;; IOTA: to            (1 ... to)
335;;; IOTA: from to       (from+1 ... to)
336;;; IOTA: from to step  (from+step from+2step ...)
337
338;(define (##srfi1#parse-iota-args arg1 rest-args proc)
339;  (let ((check (lambda (n) (check-arg integer? n proc))))
340;    (check arg1)
341;    (if (pair? rest-args)
342;       (let ((arg2 (check (car rest-args)))
343;             (rest (cdr rest-args)))
344;         (if (pair? rest)
345;             (let ((arg3 (check (car rest)))
346;                   (rest (cdr rest)))
347;               (if (pair? rest) (error "Too many parameters" proc arg1 rest-args)
348;                   (values arg1 arg2 arg3)))
349;             (values arg1 arg2 1)))
350;       (values 0 arg1 1))))
351;
352;(define (iota: arg1 . rest-args)
353;  (receive (from to step) (##srfi1#parse-iota-args arg1 rest-args iota:)
354;    (let* ((numsteps (floor (/ (- to from) step)))
355;          (last-val (+ from (* step numsteps))))
356;      (if (< numsteps 0) (error "Negative step count" iota: from to step))
357;      (do ((steps-left numsteps (- steps-left 1))
358;          (val last-val (- val step))
359;          (ans '() (cons val ans)))
360;         ((<= steps-left 0) ans)))))
361;
362;
363;(define (:iota arg1 . rest-args)
364;  (receive (from to step) (##srfi1#parse-iota-args arg1 rest-args :iota)
365;    (let* ((numsteps (ceiling (/ (- to from) step)))
366;          (last-val (+ from (* step (- numsteps 1)))))
367;      (if (< numsteps 0) (error "Negative step count" :iota from to step))
368;      (do ((steps-left numsteps (- steps-left 1))
369;          (val last-val (- val step))
370;          (ans '() (cons val ans)))
371;         ((<= steps-left 0) ans)))))
372
373
374
375(define (circular-list val1 . vals)
376  (let ((ans (cons val1 vals)))
377    (set-cdr! (last-pair ans) ans)
378    ans))
379
380;;; <proper-list> ::= ()                        ; Empty proper list
381;;;               |   (cons <x> <proper-list>)  ; Proper-list pair
382;;; Note that this definition rules out circular lists -- and this
383;;; function is required to detect this case and return false.
384
385(define proper-list? list?)
386
387#;(define (proper-list? x)
388  (let lp ((x x) (lag x))
389    (if (pair? x)
390        (let ((x (cdr x)))
391          (if (pair? x)
392              (let ((x   (cdr x))
393                    (lag (cdr lag)))
394                (and (not (eq? x lag)) (lp x lag)))
395              (null? x)))
396        (null? x))))
397
398
399;;; A dotted list is a finite list (possibly of length 0) terminated
400;;; by a non-nil value. Any non-cons, non-nil value (e.g., "foo" or 5)
401;;; is a dotted list of length 0.
402;;;
403;;; <dotted-list> ::= <non-nil,non-pair>        ; Empty dotted list
404;;;               |   (cons <x> <dotted-list>)  ; Proper-list pair
405
406(define (dotted-list? x)
407  (let lp ((x x) (lag x))
408    (if (pair? x)
409        (let ((x (cdr x)))
410          (if (pair? x)
411              (let ((x   (cdr x))
412                    (lag (cdr lag)))
413                (and (not (eq? x lag)) (lp x lag)))
414              (not (null? x))))
415        (not (null? x)))))
416
417(define (circular-list? x)
418  (let lp ((x x) (lag x))
419    (and (pair? x)
420         (let ((x (cdr x)))
421           (and (pair? x)
422                (let ((x   (cdr x))
423                      (lag (cdr lag)))
424                  (or (eq? x lag) (lp x lag))))))))
425
426(define (not-pair? x) (##core#inline "C_i_not_pair_p" x))
427
428;;; This is a legal definition which is fast and sloppy:
429;;;     (define null-list? not-pair?)
430;;; but we'll provide a more careful one:
431(define (null-list? l) (##core#inline "C_i_null_list_p" l))           
432
433(define (list= = . lists)
434  (or (null? lists) ; special case
435      (let lp1 ((list-a (car lists)) (others (cdr lists)))
436        (or (null? others)
437            (let ((list-b (car others))
438                  (others (cdr others)))
439              (if (eq? list-a list-b)   ; EQ? => LIST=
440                  (lp1 list-b others)
441                  (let lp2 ((la list-a) (lb list-b))
442                    (if (null-list? la)
443                        (and (null-list? lb)
444                             (lp1 list-b others))
445                        (and (not (null-list? lb))
446                             (= (car la) (car lb))
447                             (lp2 (cdr la) (cdr lb)))))))))))
448                       
449
450
451;;; R4RS, so commented out.
452;(define (length x)                     ; LENGTH may diverge or
453;  (let lp ((x x) (len 0))              ; raise an error if X is
454;    (if (pair? x)                      ; a circular list. This version
455;        (lp (cdr x) (+ len 1))         ; diverges.
456;        len)))
457
458(define (length+ x)                     ; Returns #f if X is circular.
459  (let lp ((x x) (lag x) (len 0))
460    (if (pair? x)
461        (let ((x (cdr x))
462              (len (fx+ len 1)))
463          (if (pair? x)
464              (let ((x   (cdr x))
465                    (lag (cdr lag))
466                    (len (fx+ len 1)))
467                (and (not (eq? x lag)) (lp x lag len)))
468              len))
469        len)))
470
471(define (zip list1 . more-lists) (apply map list list1 more-lists))
472
473
474;;; Selectors
475;;;;;;;;;;;;;
476
477;;; R4RS non-primitives:
478;(define (caar   x) (car (car x)))
479;(define (cadr   x) (car (cdr x)))
480;(define (cdar   x) (cdr (car x)))
481;(define (cddr   x) (cdr (cdr x)))
482;
483;(define (caaar  x) (caar (car x)))
484;(define (caadr  x) (caar (cdr x)))
485;(define (cadar  x) (cadr (car x)))
486;(define (caddr  x) (cadr (cdr x)))
487;(define (cdaar  x) (cdar (car x)))
488;(define (cdadr  x) (cdar (cdr x)))
489;(define (cddar  x) (cddr (car x)))
490;(define (cdddr  x) (cddr (cdr x)))
491;
492;(define (caaaar x) (caaar (car x)))
493;(define (caaadr x) (caaar (cdr x)))
494;(define (caadar x) (caadr (car x)))
495;(define (caaddr x) (caadr (cdr x)))
496;(define (cadaar x) (cadar (car x)))
497;(define (cadadr x) (cadar (cdr x)))
498;(define (caddar x) (caddr (car x)))
499;(define (cadddr x) (caddr (cdr x)))
500;(define (cdaaar x) (cdaar (car x)))
501;(define (cdaadr x) (cdaar (cdr x)))
502;(define (cdadar x) (cdadr (car x)))
503;(define (cdaddr x) (cdadr (cdr x)))
504;(define (cddaar x) (cddar (car x)))
505;(define (cddadr x) (cddar (cdr x)))
506;(define (cdddar x) (cdddr (car x)))
507;(define (cddddr x) (cdddr (cdr x)))
508
509
510(define first  car)
511(define second cadr)
512(define third  caddr)
513(define fourth cadddr)
514(define (fifth   x) (car    (cddddr x)))
515(define (sixth   x) (cadr   (cddddr x)))
516(define (seventh x) (caddr  (cddddr x)))
517(define (eighth  x) (cadddr (cddddr x)))
518(define (ninth   x) (car  (cddddr (cddddr x))))
519(define (tenth   x) (cadr (cddddr (cddddr x))))
520
521(define (car+cdr pair)
522  (##sys#check-pair pair 'car+cdr)
523  (values (##sys#slot pair 0) (##sys#slot pair 1)) )
524
525;;; take & drop
526
527(define (take lis k)
528  (##sys#check-exact k 'take)
529;  (check-arg integer? k take)
530  (let recur ((lis lis) (k k))
531    (if (eq? 0 k) '()
532        (cons (car lis)
533              (recur (cdr lis) (fx- k 1))))))
534
535(define (drop lis k)
536  (##sys#check-exact k 'drop)
537;  (check-arg integer? k drop)
538  (let iter ((lis lis) (k k))
539    (if (eq? 0 k) lis (iter (cdr lis) (fx- k 1)))))
540
541(define (take! lis k)
542  (##sys#check-exact k 'take!)
543;  (check-arg integer? k take!)
544  (if (eq? 0 k) '()
545      (begin (set-cdr! (drop lis (fx- k 1)) '())
546             lis)))
547
548;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list,
549;;; off by K, then chasing down the list until the lead pointer falls off
550;;; the end.
551
552(define (take-right lis k)
553;  (check-arg integer? k take-right)
554  (let lp ((lag lis)  (lead (drop lis k)))
555    (if (pair? lead)
556        (lp (cdr lag) (cdr lead))
557        lag)))
558
559(define (drop-right lis k)
560;  (check-arg integer? k drop-right)
561  (let recur ((lag lis) (lead (drop lis k)))
562    (if (pair? lead)
563        (cons (car lag) (recur (cdr lag) (cdr lead)))
564        '())))
565
566;;; In this function, LEAD is actually K+1 ahead of LAG. This lets
567;;; us stop LAG one step early, in time to smash its cdr to ().
568(define (drop-right! lis k)
569;  (check-arg integer? k drop-right!)
570  (let ((lead (drop lis k)))
571    (if (pair? lead)
572
573        (let lp ((lag lis)  (lead (cdr lead)))  ; Standard case
574          (if (pair? lead)
575              (lp (cdr lag) (cdr lead))
576              (begin (set-cdr! lag '())
577                     lis)))
578
579        '())))  ; Special case dropping everything -- no cons to side-effect.
580
581;(define (list-ref lis i) (car (drop lis i)))   ; R4RS
582
583;;; These use the APL convention, whereby negative indices mean
584;;; "from the right." I liked them, but they didn't win over the
585;;; SRFI reviewers.
586;;; K >= 0: Take and drop  K elts from the front of the list.
587;;; K <= 0: Take and drop -K elts from the end   of the list.
588
589;(define (take lis k)
590;  (check-arg integer? k take)
591;  (if (negative? k)
592;      (list-tail lis (+ k (length lis)))
593;      (let recur ((lis lis) (k k))
594;       (if (zero? k) '()
595;           (cons (car lis)
596;                 (recur (cdr lis) (- k 1)))))))
597;
598;(define (drop lis k)
599;  (check-arg integer? k drop)
600;  (if (negative? k)
601;      (let recur ((lis lis) (nelts (+ k (length lis))))
602;       (if (zero? nelts) '()
603;           (cons (car lis)
604;                 (recur (cdr lis) (- nelts 1)))))
605;      (list-tail lis k)))
606;
607;
608;(define (take! lis k)
609;  (check-arg integer? k take!)
610;  (cond ((zero? k) '())
611;       ((positive? k)
612;        (set-cdr! (list-tail lis (- k 1)) '())
613;        lis)
614;       (else (list-tail lis (+ k (length lis))))))
615;
616;(define (drop! lis k)
617;  (check-arg integer? k drop!)
618;  (if (negative? k)
619;      (let ((nelts (+ k (length lis))))
620;       (if (zero? nelts) '()
621;           (begin (set-cdr! (list-tail lis (- nelts 1)) '())
622;                  lis)))
623;      (list-tail lis k)))
624
625(define (split-at x k)
626  (##sys#check-exact k 'split-at)
627;  (check-arg integer? k split-at)
628  (let recur ((lis x) (k k))
629    (if (eq? 0 k) (values '() lis)
630        (receive (prefix suffix) (recur (cdr lis) (fx- k 1))
631          (values (cons (car lis) prefix) suffix)))))
632
633(define (split-at! x k)
634  (##sys#check-exact k 'split-at!)
635;  (check-arg integer? k split-at!)
636  (if (eq? 0 k) (values '() x)
637      (let* ((prev (drop x (fx- k 1)))
638             (suffix (cdr prev)))
639        (set-cdr! prev '())
640        (values x suffix))))
641
642
643(define (last lis) (car (last-pair lis)))
644
645(define (last-pair lis)
646;  (check-arg pair? lis last-pair)
647  (let lp ((lis lis))
648    (let ((tail (cdr lis)))
649      (if (pair? tail) (lp tail) lis))))
650
651
652;;; Unzippers -- 1 through 5
653;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
654
655(define (unzip1 lis) (map car lis))
656
657(define (unzip2 lis)
658  (let recur ((lis lis))
659    (if (null-list? lis) (values lis lis)       ; Use NOT-PAIR? to handle
660        (let ((elt (car lis)))                  ; dotted lists.
661          (receive (a b) (recur (cdr lis))
662            (values (cons (car  elt) a)
663                    (cons (cadr elt) b)))))))
664
665(define (unzip3 lis)
666  (let recur ((lis lis))
667    (if (null-list? lis) (values lis lis lis)
668        (let ((elt (car lis)))
669          (receive (a b c) (recur (cdr lis))
670            (values (cons (car   elt) a)
671                    (cons (cadr  elt) b)
672                    (cons (caddr elt) c)))))))
673
674(define (unzip4 lis)
675  (let recur ((lis lis))
676    (if (null-list? lis) (values lis lis lis lis)
677        (let ((elt (car lis)))
678          (receive (a b c d) (recur (cdr lis))
679            (values (cons (car    elt) a)
680                    (cons (cadr   elt) b)
681                    (cons (caddr  elt) c)
682                    (cons (cadddr elt) d)))))))
683
684(define (unzip5 lis)
685  (let recur ((lis lis))
686    (if (null-list? lis) (values lis lis lis lis lis)
687        (let ((elt (car lis)))
688          (receive (a b c d e) (recur (cdr lis))
689            (values (cons (car     elt) a)
690                    (cons (cadr    elt) b)
691                    (cons (caddr   elt) c)
692                    (cons (cadddr  elt) d)
693                    (cons (car (cddddr  elt)) e)))))))
694
695
696;;; append! append-reverse append-reverse! concatenate concatenate!
697;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
698
699(define (append! . lists)
700  ;; First, scan through lists looking for a non-empty one.
701  (let lp ((lists lists) (prev '()))
702    (if (not (pair? lists)) prev
703        (let ((first (car lists))
704              (rest (cdr lists)))
705          (if (not (pair? first)) (lp rest first)
706
707              ;; Now, do the splicing.
708              (let lp2 ((tail-cons (last-pair first))
709                        (rest rest))
710                (if (pair? rest)
711                    (let ((next (car rest))
712                          (rest (cdr rest)))
713                      (set-cdr! tail-cons next)
714                      (lp2 (if (pair? next) (last-pair next) tail-cons)
715                           rest))
716                    first)))))))
717
718;;; APPEND is R4RS.
719;(define (append . lists)
720;  (if (pair? lists)
721;      (let recur ((list1 (car lists)) (lists (cdr lists)))
722;        (if (pair? lists)
723;            (let ((tail (recur (car lists) (cdr lists))))
724;              (fold-right cons tail list1)) ; Append LIST1 & TAIL.
725;            list1))
726;      '()))
727
728;(define (append-reverse rev-head tail) (fold cons tail rev-head))
729
730;(define (append-reverse! rev-head tail)
731;  (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair)
732;             tail
733;             rev-head))
734
735;;; Hand-inline the FOLD and PAIR-FOLD ops for speed.
736
737(define (append-reverse rev-head tail)
738  (let lp ((rev-head rev-head) (tail tail))
739    (if (null-list? rev-head) tail
740        (lp (cdr rev-head) (cons (car rev-head) tail)))))
741
742(define (append-reverse! rev-head tail)
743  (let lp ((rev-head rev-head) (tail tail))
744    (if (null-list? rev-head) tail
745        (let ((next-rev (cdr rev-head)))
746          (set-cdr! rev-head tail)
747          (lp next-rev rev-head)))))
748
749
750(define (concatenate  lists) (reduce-right append  '() lists))
751(define (concatenate! lists) (reduce-right append! '() lists))
752
753;;; Fold/map internal utilities
754;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
755;;; These little internal utilities are used by the general
756;;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined.
757;;; One the other hand, the n-ary cases are painfully inefficient as it is.
758;;; An aggressive implementation should simply re-write these functions
759;;; for raw efficiency; I have written them for as much clarity, portability,
760;;; and simplicity as can be achieved.
761;;;
762;;; I use the dreaded call/cc to do local aborts. A good compiler could
763;;; handle this with extreme efficiency. An implementation that provides
764;;; a one-shot, non-persistent continuation grabber could help the compiler
765;;; out by using that in place of the call/cc's in these routines.
766;;;
767;;; These functions have funky definitions that are precisely tuned to
768;;; the needs of the fold/map procs -- for example, to minimize the number
769;;; of times the argument lists need to be examined.
770
771;;; Return (map cdr lists).
772;;; However, if any element of LISTS is empty, just abort and return '().
773(define (##srfi1#cdrs lists)
774  (##sys#call-with-current-continuation
775    (lambda (abort)
776      (let recur ((lists lists))
777        (if (pair? lists)
778            (let ((lis (car lists)))
779              (if (null-list? lis) (abort '())
780                  (cons (cdr lis) (recur (cdr lists)))))
781            '())))))
782
783(define (##srfi1#cars+ lists last-elt)  ; (append! (##sys#map car lists) (list last-elt))
784  (let recur ((lists lists))
785    (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt))))
786
787;;; LISTS is a (not very long) non-empty list of lists.
788;;; Return two lists: the cars & the cdrs of the lists.
789;;; However, if any of the lists is empty, just abort and return [() ()].
790
791(define (##srfi1#cars+cdrs lists)
792  (##sys#call-with-current-continuation
793    (lambda (abort)
794      (let recur ((lists lists))
795        (if (pair? lists)
796            (receive (list other-lists) (car+cdr lists)
797              (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
798                  (receive (a d) (car+cdr list)
799                    (receive (cars cdrs) (recur other-lists)
800                      (values (cons a cars) (cons d cdrs))))))
801            (values '() '()))))))
802
803;;; Like ##srfi1#CARS+CDRS, but we pass in a final elt tacked onto the end of the
804;;; cars list. What a hack.
805(define (##srfi1#cars+cdrs+ lists cars-final)
806  (##sys#call-with-current-continuation
807    (lambda (abort)
808      (let recur ((lists lists))
809        (if (pair? lists)
810            (receive (list other-lists) (car+cdr lists)
811              (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
812                  (receive (a d) (car+cdr list)
813                    (receive (cars cdrs) (recur other-lists)
814                      (values (cons a cars) (cons d cdrs))))))
815            (values (list cars-final) '()))))))
816
817;;; Like ##srfi1#CARS+CDRS, but blow up if any list is empty.
818(define (##srfi1#cars+cdrs/no-test lists)
819  (let recur ((lists lists))
820    (if (pair? lists)
821        (receive (list other-lists) (car+cdr lists)
822          (receive (a d) (car+cdr list)
823            (receive (cars cdrs) (recur other-lists)
824              (values (cons a cars) (cons d cdrs)))))
825        (values '() '()))))
826
827
828;;; count
829;;;;;;;;;
830(define (count pred list1 . lists)
831;  (check-arg procedure? pred count)
832  (if (pair? lists)
833
834      ;; N-ary case
835      (let lp ((list1 list1) (lists lists) (i 0))
836        (if (null-list? list1) i
837            (receive (as ds) (##srfi1#cars+cdrs lists)
838              (if (null? as) i
839                  (lp (cdr list1) ds
840                      (if (apply pred (car list1) as) (fx+ i 1) i))))))
841
842      ;; Fast path
843      (let lp ((lis list1) (i 0))
844        (if (null-list? lis) i
845            (lp (cdr lis) (if (pred (car lis)) (fx+ i 1) i))))))
846
847
848;;; fold/unfold
849;;;;;;;;;;;;;;;
850
851(define (unfold-right p f g seed . maybe-tail)
852;  (check-arg procedure? p unfold-right)
853;  (check-arg procedure? f unfold-right)
854;  (check-arg procedure? g unfold-right)
855  (let lp ((seed seed) (ans (optional maybe-tail '())))
856    (if (p seed) ans
857        (lp (g seed)
858            (cons (f seed) ans)))))
859
860
861(define (unfold p f g seed . maybe-tail-gen)
862;  (check-arg procedure? p unfold)
863;  (check-arg procedure? f unfold)
864;  (check-arg procedure? g unfold)
865  (if (pair? maybe-tail-gen)
866
867      (let ((tail-gen (car maybe-tail-gen)))
868        (if (pair? (cdr maybe-tail-gen))
869            (apply error "Too many arguments" unfold p f g seed maybe-tail-gen)
870
871            (let recur ((seed seed))
872              (if (p seed) (tail-gen seed)
873                  (cons (f seed) (recur (g seed)))))))
874
875      (let recur ((seed seed))
876        (if (p seed) '()
877            (cons (f seed) (recur (g seed)))))))
878     
879
880(define (fold kons knil lis1 . lists)
881;  (check-arg procedure? kons fold)
882  (if (pair? lists)
883      (let lp ((lists (cons lis1 lists)) (ans knil))    ; N-ary case
884        (receive (cars+ans cdrs) (##srfi1#cars+cdrs+ lists ans)
885          (if (null? cars+ans) ans ; Done.
886              (lp cdrs (apply kons cars+ans)))))
887           
888      (let lp ((lis lis1) (ans knil))                   ; Fast path
889        (if (null-list? lis) ans
890            (lp (cdr lis) (kons (car lis) ans))))))
891
892
893(define (fold-right kons knil lis1 . lists)
894;  (check-arg procedure? kons fold-right)
895  (if (pair? lists)
896      (let recur ((lists (cons lis1 lists)))            ; N-ary case
897        (let ((cdrs (##srfi1#cdrs lists)))
898          (if (null? cdrs) knil
899              (apply kons (##srfi1#cars+ lists (recur cdrs))))))
900
901      (let recur ((lis lis1))                           ; Fast path
902        (if (null-list? lis) knil
903            (let ((head (car lis)))
904              (kons head (recur (cdr lis))))))))
905
906
907(define (pair-fold-right f zero lis1 . lists)
908;  (check-arg procedure? f pair-fold-right)
909  (if (pair? lists)
910      (let recur ((lists (cons lis1 lists)))            ; N-ary case
911        (let ((cdrs (##srfi1#cdrs lists)))
912          (if (null? cdrs) zero
913              (apply f (append! lists (list (recur cdrs)))))))
914
915      (let recur ((lis lis1))                           ; Fast path
916        (if (null-list? lis) zero (f lis (recur (cdr lis)))))))
917
918(define (pair-fold f zero lis1 . lists)
919;  (check-arg procedure? f pair-fold)
920  (if (pair? lists)
921      (let lp ((lists (cons lis1 lists)) (ans zero))    ; N-ary case
922        (let ((tails (##srfi1#cdrs lists)))
923          (if (null? tails) ans
924              (lp tails (apply f (append! lists (list ans)))))))
925
926      (let lp ((lis lis1) (ans zero))
927        (if (null-list? lis) ans
928            (let ((tail (cdr lis)))             ; Grab the cdr now,
929              (lp tail (f lis ans)))))))        ; in case F SET-CDR!s LIS.
930     
931
932;;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case.
933;;; These cannot meaningfully be n-ary.
934
935(define (reduce f ridentity lis)
936;  (check-arg procedure? f reduce)
937  (if (null-list? lis) ridentity
938      (fold f (car lis) (cdr lis))))
939
940(define (reduce-right f ridentity lis)
941;  (check-arg procedure? f reduce-right)
942  (if (null-list? lis) ridentity
943      (let recur ((head (car lis)) (lis (cdr lis)))
944        (if (pair? lis)
945            (f head (recur (car lis) (cdr lis)))
946            head))))
947
948
949
950;;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order
951;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
952
953(define (append-map f lis1 . lists)
954  (##srfi1#really-append-map append-map  append  f lis1 lists))
955(define (append-map! f lis1 . lists) 
956  (##srfi1#really-append-map append-map! append! f lis1 lists))
957
958(define (##srfi1#really-append-map who appender f lis1 lists)
959;  (check-arg procedure? f who)
960  (if (pair? lists)
961      (receive (cars cdrs) (##srfi1#cars+cdrs (cons lis1 lists))
962        (if (null? cars) '()
963            (let recur ((cars cars) (cdrs cdrs))
964              (let ((vals (apply f cars)))
965                (receive (cars2 cdrs2) (##srfi1#cars+cdrs cdrs)
966                  (if (null? cars2) vals
967                      (appender vals (recur cars2 cdrs2))))))))
968
969      ;; Fast path
970      (if (null-list? lis1) '()
971          (let recur ((elt (car lis1)) (rest (cdr lis1)))
972            (let ((vals (f elt)))
973              (if (null-list? rest) vals
974                  (appender vals (recur (car rest) (cdr rest)))))))))
975
976
977(define (pair-for-each proc lis1 . lists)
978;  (check-arg procedure? proc pair-for-each)
979  (if (pair? lists)
980
981      (let lp ((lists (cons lis1 lists)))
982        (let ((tails (##srfi1#cdrs lists)))
983          (if (pair? tails)
984              (begin (apply proc lists)
985                     (lp tails)))))
986
987      ;; Fast path.
988      (let lp ((lis lis1))
989        (if (not (null-list? lis))
990            (let ((tail (cdr lis)))     ; Grab the cdr now,
991              (proc lis)                ; in case PROC SET-CDR!s LIS.
992              (lp tail))))))
993
994;;; We stop when LIS1 runs out, not when any list runs out.
995(define (map! f lis1 . lists)
996;  (check-arg procedure? f map!)
997  (if (pair? lists)
998      (let lp ((lis1 lis1) (lists lists))
999        (if (not (null-list? lis1))
1000            (receive (heads tails) (##srfi1#cars+cdrs/no-test lists)
1001              (set-car! lis1 (apply f (car lis1) heads))
1002              (lp (cdr lis1) tails))))
1003
1004      ;; Fast path.
1005      (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1))
1006  lis1)
1007
1008
1009;;; Map F across L, and save up all the non-false results.
1010(define (filter-map f lis1 . lists)
1011;  (check-arg procedure? f filter-map)
1012  (if (pair? lists)
1013      (let recur ((lists (cons lis1 lists)))
1014        (receive (cars cdrs) (##srfi1#cars+cdrs lists)
1015          (if (pair? cars)
1016              (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs))))
1017                    (else (recur cdrs))) ; Tail call in this arm.
1018              '())))
1019           
1020      ;; Fast path.
1021      (let recur ((lis lis1))
1022        (if (null-list? lis) lis
1023            (let ((tail (recur (cdr lis))))
1024              (cond ((f (car lis)) => (lambda (x) (cons x tail)))
1025                    (else tail)))))))
1026
1027
1028;;; Map F across lists, guaranteeing to go left-to-right.
1029;;; NOTE: Some implementations of R5RS MAP are compliant with this spec;
1030;;; in which case this procedure may simply be defined as a synonym for MAP.
1031
1032(define (map-in-order f lis1 . lists)
1033;  (check-arg procedure? f map-in-order)
1034  (if (pair? lists)
1035      (let recur ((lists (cons lis1 lists)))
1036        (receive (cars cdrs) (##srfi1#cars+cdrs lists)
1037          (if (pair? cars)
1038              (let ((x (apply f cars)))         ; Do head first,
1039                (cons x (recur cdrs)))          ; then tail.
1040              '())))
1041           
1042      ;; Fast path.
1043      (let recur ((lis lis1))
1044        (if (null-list? lis) lis
1045            (let ((tail (cdr lis))
1046                  (x (f (car lis))))            ; Do head first,
1047              (cons x (recur tail)))))))        ; then tail.
1048
1049
1050;;; We extend MAP to handle arguments of unequal length.
1051(define map map-in-order)       
1052
1053
1054;;; filter, remove, partition
1055;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1056;;; FILTER, REMOVE, PARTITION and their destructive counterparts do not
1057;;; disorder the elements of their argument.
1058
1059;; This FILTER shares the longest tail of L that has no deleted elements.
1060;; If Scheme had multi-continuation calls, they could be made more efficient.
1061
1062(define (filter pred lis)                       ; Sleazing with EQ? makes this
1063;  (check-arg procedure? pred filter)           ; one faster.
1064  (let recur ((lis lis))               
1065    (if (null-list? lis) lis                    ; Use NOT-PAIR? to handle dotted lists.
1066        (let ((head (car lis))
1067              (tail (cdr lis)))
1068          (if (pred head)
1069              (let ((new-tail (recur tail)))    ; Replicate the RECUR call so
1070                (if (eq? tail new-tail) lis
1071                    (cons head new-tail)))
1072              (recur tail))))))                 ; this one can be a tail call.
1073
1074
1075;;; Another version that shares longest tail.
1076;(define (filter pred lis)
1077;  (receive (ans no-del?)
1078;      ;; (recur l) returns L with (pred x) values filtered.
1079;      ;; It also returns a flag NO-DEL? if the returned value
1080;      ;; is EQ? to L, i.e. if it didn't have to delete anything.
1081;      (let recur ((l l))
1082;       (if (null-list? l) (values l #t)
1083;           (let ((x  (car l))
1084;                 (tl (cdr l)))
1085;             (if (pred x)
1086;                 (receive (ans no-del?) (recur tl)
1087;                   (if no-del?
1088;                       (values l #t)
1089;                       (values (cons x ans) #f)))
1090;                 (receive (ans no-del?) (recur tl) ; Delete X.
1091;                   (values ans #f))))))
1092;    ans))
1093
1094
1095
1096;(define (filter! pred lis)                     ; Things are much simpler
1097;  (let recur ((lis lis))                       ; if you are willing to
1098;    (if (pair? lis)                            ; push N stack frames & do N
1099;        (cond ((pred (car lis))                ; SET-CDR! writes, where N is
1100;               (set-cdr! lis (recur (cdr lis))); the length of the answer.
1101;               lis)                           
1102;              (else (recur (cdr lis))))
1103;        lis)))
1104
1105
1106;;; This implementation of FILTER!
1107;;; - doesn't cons, and uses no stack;
1108;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are
1109;;;   usually expensive on modern machines, and can be extremely expensive on
1110;;;   modern Schemes (e.g., ones that have generational GC's).
1111;;; It just zips down contiguous runs of in and out elts in LIS doing the
1112;;; minimal number of SET-CDR!s to splice the tail of one run of ins to the
1113;;; beginning of the next.
1114
1115(define (filter! pred lis)
1116;  (check-arg procedure? pred filter!)
1117  (let lp ((ans lis))
1118    (cond ((null-list? ans)       ans)                  ; Scan looking for
1119          ((not (pred (car ans))) (lp (cdr ans)))       ; first cons of result.
1120
1121          ;; ANS is the eventual answer.
1122          ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED.
1123          ;;          Scan over a contiguous segment of the list that
1124          ;;          satisfies PRED.
1125          ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous
1126          ;;           segment of the list that *doesn't* satisfy PRED.
1127          ;;           When the segment ends, patch in a link from PREV
1128          ;;           to the start of the next good segment, and jump to
1129          ;;           SCAN-IN.
1130          (else (letrec ((scan-in (lambda (prev lis)
1131                                    (if (pair? lis)
1132                                        (if (pred (car lis))
1133                                            (scan-in lis (cdr lis))
1134                                            (scan-out prev (cdr lis))))))
1135                         (scan-out (lambda (prev lis)
1136                                     (let lp ((lis lis))
1137                                       (if (pair? lis)
1138                                           (if (pred (car lis))
1139                                               (begin (set-cdr! prev lis)
1140                                                      (scan-in lis (cdr lis)))
1141                                               (lp (cdr lis)))
1142                                           (set-cdr! prev lis))))))
1143                  (scan-in ans (cdr ans))
1144                  ans)))))
1145
1146
1147
1148;;; Answers share common tail with LIS where possible;
1149;;; the technique is slightly subtle.
1150
1151(define (partition pred lis)
1152;  (check-arg procedure? pred partition)
1153  (let recur ((lis lis))
1154    (if (null-list? lis) (values lis lis)       ; Use NOT-PAIR? to handle dotted lists.
1155        (let ((elt (car lis))
1156              (tail (cdr lis)))
1157          (receive (in out) (recur tail)
1158            (if (pred elt)
1159                (values (if (pair? out) (cons elt in) lis) out)
1160                (values in (if (pair? in) (cons elt out) lis))))))))
1161
1162
1163
1164;(define (partition! pred lis)                  ; Things are much simpler
1165;  (let recur ((lis lis))                       ; if you are willing to
1166;    (if (null-list? lis) (values lis lis)      ; push N stack frames & do N
1167;        (let ((elt (car lis)))                 ; SET-CDR! writes, where N is
1168;          (receive (in out) (recur (cdr lis))  ; the length of LIS.
1169;            (cond ((pred elt)
1170;                   (set-cdr! lis in)
1171;                   (values lis out))
1172;                  (else (set-cdr! lis out)
1173;                        (values in lis))))))))
1174
1175
1176;;; This implementation of PARTITION!
1177;;; - doesn't cons, and uses no stack;
1178;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are
1179;;;   usually expensive on modern machines, and can be extremely expensive on
1180;;;   modern Schemes (e.g., ones that have generational GC's).
1181;;; It just zips down contiguous runs of in and out elts in LIS doing the
1182;;; minimal number of SET-CDR!s to splice these runs together into the result
1183;;; lists.
1184
1185(define (partition! pred lis)
1186;  (check-arg procedure? pred partition!)
1187  (if (null-list? lis) (values lis lis)
1188
1189      ;; This pair of loops zips down contiguous in & out runs of the
1190      ;; list, splicing the runs together. The invariants are
1191      ;;   SCAN-IN:  (cdr in-prev)  = LIS.
1192      ;;   SCAN-OUT: (cdr out-prev) = LIS.
1193      (letrec ((scan-in (lambda (in-prev out-prev lis)
1194                          (let lp ((in-prev in-prev) (lis lis))
1195                            (if (pair? lis)
1196                                (if (pred (car lis))
1197                                    (lp lis (cdr lis))
1198                                    (begin (set-cdr! out-prev lis)
1199                                           (scan-out in-prev lis (cdr lis))))
1200                                (set-cdr! out-prev lis))))) ; Done.
1201
1202               (scan-out (lambda (in-prev out-prev lis)
1203                           (let lp ((out-prev out-prev) (lis lis))
1204                             (if (pair? lis)
1205                                 (if (pred (car lis))
1206                                     (begin (set-cdr! in-prev lis)
1207                                            (scan-in lis out-prev (cdr lis)))
1208                                     (lp lis (cdr lis)))
1209                                 (set-cdr! in-prev lis)))))) ; Done.
1210
1211        ;; Crank up the scan&splice loops.
1212        (if (pred (car lis))
1213            ;; LIS begins in-list. Search for out-list's first pair.
1214            (let lp ((prev-l lis) (l (cdr lis)))
1215              (cond ((not (pair? l)) (values lis l))
1216                    ((pred (car l)) (lp l (cdr l)))
1217                    (else (scan-out prev-l l (cdr l))
1218                          (values lis l))))     ; Done.
1219
1220            ;; LIS begins out-list. Search for in-list's first pair.
1221            (let lp ((prev-l lis) (l (cdr lis)))
1222              (cond ((not (pair? l)) (values l lis))
1223                    ((pred (car l))
1224                     (scan-in l prev-l (cdr l))
1225                     (values l lis))            ; Done.
1226                    (else (lp l (cdr l)))))))))
1227
1228
1229;;; Inline us, please.
1230(define (remove  pred l) (filter  (lambda (x) (not (pred x))) l))
1231(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l))
1232
1233
1234
1235;;; Here's the taxonomy for the DELETE/ASSOC/MEMBER functions.
1236;;; (I don't actually think these are the world's most important
1237;;; functions -- the procedural FILTER/REMOVE/FIND/FIND-TAIL variants
1238;;; are far more general.)
1239;;;
1240;;; Function                    Action
1241;;; ---------------------------------------------------------------------------
1242;;; remove pred lis             Delete by general predicate
1243;;; delete x lis [=]            Delete by element comparison
1244;;;                                         
1245;;; find pred lis               Search by general predicate
1246;;; find-tail pred lis          Search by general predicate
1247;;; member x lis [=]            Search by element comparison
1248;;;
1249;;; assoc key lis [=]           Search alist by key comparison
1250;;; alist-delete key alist [=]  Alist-delete by key comparison
1251
1252(define (delete x lis . maybe-=) 
1253  (let ((= (optional maybe-= equal?)))
1254    (filter (lambda (y) (not (= x y))) lis)))
1255
1256(define (delete! x lis . maybe-=)
1257  (let ((= (optional maybe-= equal?)))
1258    (filter! (lambda (y) (not (= x y))) lis)))
1259
1260;;; Extended from R4RS to take an optional comparison argument.
1261(define (member x lis . maybe-=)
1262  (let ((= (optional maybe-= equal?)))
1263    (find-tail (lambda (y) (= x y)) lis)))
1264
1265;;; R4RS, hence we don't bother to define.
1266;;; The MEMBER and then FIND-TAIL call should definitely
1267;;; be inlined for MEMQ & MEMV.
1268;(define (memq    x lis) (member x lis eq?))
1269;(define (memv    x lis) (member x lis eqv?))
1270
1271
1272;;; right-duplicate deletion
1273;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1274;;; delete-duplicates delete-duplicates!
1275;;;
1276;;; Beware -- these are N^2 algorithms. To efficiently remove duplicates
1277;;; in long lists, sort the list to bring duplicates together, then use a
1278;;; linear-time algorithm to kill the dups. Or use an algorithm based on
1279;;; element-marking. The former gives you O(n lg n), the latter is linear.
1280
1281(define (delete-duplicates lis . maybe-=)
1282  (let ((elt= (optional maybe-= equal?)))
1283;    (check-arg procedure? elt= delete-duplicates)
1284    (let recur ((lis lis))
1285      (if (null-list? lis) lis
1286          (let* ((x (car lis))
1287                 (tail (cdr lis))
1288                 (new-tail (recur (delete x tail elt=))))
1289            (if (eq? tail new-tail) lis (cons x new-tail)))))))
1290
1291(define (delete-duplicates! lis . maybe-=)
1292  (let ((elt= (optional maybe-= equal?)))
1293;    (check-arg procedure? elt= delete-duplicates!)
1294    (let recur ((lis lis))
1295      (if (null-list? lis) lis
1296          (let* ((x (car lis))
1297                 (tail (cdr lis))
1298                 (new-tail (recur (delete! x tail elt=))))
1299            (if (eq? tail new-tail) lis (cons x new-tail)))))))
1300
1301
1302;;; alist stuff
1303;;;;;;;;;;;;;;;
1304
1305;;; Extended from R4RS to take an optional comparison argument.
1306(define (assoc x lis . maybe-=)
1307  (let ((= (optional maybe-= equal?)))
1308    (find (lambda (entry) (= x (car entry))) lis)))
1309
1310(define (alist-cons key datum alist) (cons (cons key datum) alist))
1311
1312(define (alist-copy alist)
1313  (##sys#map (lambda (elt) (cons (car elt) (cdr elt)))
1314       alist))
1315
1316(define (alist-delete key alist . maybe-=)
1317  (let ((= (optional maybe-= equal?)))
1318    (filter (lambda (elt) (not (= key (car elt)))) alist)))
1319
1320(define (alist-delete! key alist . maybe-=)
1321  (let ((= (optional maybe-= equal?)))
1322    (filter! (lambda (elt) (not (= key (car elt)))) alist)))
1323
1324
1325;;; find find-tail take-while drop-while span break any every list-index
1326;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1327
1328(define (find pred list)
1329  (cond ((find-tail pred list) => car)
1330        (else #f)))
1331
1332(define (find-tail pred list)
1333;  (check-arg procedure? pred find-tail)
1334  (let lp ((list list))
1335    (and (not (null-list? list))
1336         (if (pred (car list)) list
1337             (lp (cdr list))))))
1338
1339(define (take-while pred lis)
1340;  (check-arg procedure? pred take-while)
1341  (let recur ((lis lis))
1342    (if (null-list? lis) '()
1343        (let ((x (car lis)))
1344          (if (pred x)
1345              (cons x (recur (cdr lis)))
1346              '())))))
1347
1348(define (drop-while pred lis)
1349;  (check-arg procedure? pred drop-while)
1350  (let lp ((lis lis))
1351    (if (null-list? lis) '()
1352        (if (pred (car lis))
1353            (lp (cdr lis))
1354            lis))))
1355
1356(define (take-while! pred lis)
1357;  (check-arg procedure? pred take-while!)
1358  (if (or (null-list? lis) (not (pred (car lis)))) '()
1359      (begin (let lp ((prev lis) (rest (cdr lis)))
1360               (if (pair? rest)
1361                   (let ((x (car rest)))
1362                     (if (pred x) (lp rest (cdr rest))
1363                         (set-cdr! prev '())))))
1364             lis)))
1365
1366(define (span pred lis)
1367;  (check-arg procedure? pred span)
1368  (let recur ((lis lis))
1369    (if (null-list? lis) (values '() '())
1370        (let ((x (car lis)))
1371          (if (pred x)
1372              (receive (prefix suffix) (recur (cdr lis))
1373                (values (cons x prefix) suffix))
1374              (values '() lis))))))
1375
1376(define (span! pred lis)
1377;  (check-arg procedure? pred span!)
1378  (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis)
1379      (let ((suffix (let lp ((prev lis) (rest (cdr lis)))
1380                      (if (null-list? rest) rest
1381                          (let ((x (car rest)))
1382                            (if (pred x) (lp rest (cdr rest))
1383                                (begin (set-cdr! prev '())
1384                                       rest)))))))
1385        (values lis suffix))))
1386 
1387
1388(define (break  pred lis) (span  (lambda (x) (not (pred x))) lis))
1389(define (break! pred lis) (span! (lambda (x) (not (pred x))) lis))
1390
1391(define (any pred lis1 . lists)
1392;  (check-arg procedure? pred any)
1393  (if (pair? lists)
1394
1395      ;; N-ary case
1396      (receive (heads tails) (##srfi1#cars+cdrs (cons lis1 lists))
1397        (and (pair? heads)
1398             (let lp ((heads heads) (tails tails))
1399               (receive (next-heads next-tails) (##srfi1#cars+cdrs tails)
1400                 (if (pair? next-heads)
1401                     (or (apply pred heads) (lp next-heads next-tails))
1402                     (apply pred heads)))))) ; Last PRED app is tail call.
1403
1404      ;; Fast path
1405      (and (not (null-list? lis1))
1406           (let lp ((head (car lis1)) (tail (cdr lis1)))
1407             (if (null-list? tail)
1408                 (pred head)            ; Last PRED app is tail call.
1409                 (or (pred head) (lp (car tail) (cdr tail))))))))
1410
1411
1412;(define (every pred list)              ; Simple definition.
1413;  (let lp ((list list))                ; Doesn't return the last PRED value.
1414;    (or (not (pair? list))
1415;        (and (pred (car list))
1416;             (lp (cdr list))))))
1417
1418(define (every pred lis1 . lists)
1419;  (check-arg procedure? pred every)
1420  (if (pair? lists)
1421
1422      ;; N-ary case
1423      (receive (heads tails) (##srfi1#cars+cdrs (cons lis1 lists))
1424        (or (not (pair? heads))
1425            (let lp ((heads heads) (tails tails))
1426              (receive (next-heads next-tails) (##srfi1#cars+cdrs tails)
1427                (if (pair? next-heads)
1428                    (and (apply pred heads) (lp next-heads next-tails))
1429                    (apply pred heads)))))) ; Last PRED app is tail call.
1430
1431      ;; Fast path
1432      (or (null-list? lis1)
1433          (let lp ((head (car lis1))  (tail (cdr lis1)))
1434            (if (null-list? tail)
1435                (pred head)     ; Last PRED app is tail call.
1436                (and (pred head) (lp (car tail) (cdr tail))))))))
1437
1438(define (list-index pred lis1 . lists)
1439;  (check-arg procedure? pred list-index)
1440  (if (pair? lists)
1441
1442      ;; N-ary case
1443      (let lp ((lists (cons lis1 lists)) (n 0))
1444        (receive (heads tails) (##srfi1#cars+cdrs lists)
1445          (and (pair? heads)
1446               (if (apply pred heads) n
1447                   (lp tails (fx+ n 1))))))
1448
1449      ;; Fast path
1450      (let lp ((lis lis1) (n 0))
1451        (and (not (null-list? lis))
1452             (if (pred (car lis)) n (lp (cdr lis) (fx+ n 1)))))))
1453
1454;;; Reverse
1455;;;;;;;;;;;
1456
1457;R4RS, so not defined here.
1458;(define (reverse lis) (fold cons '() lis))
1459                                     
1460;(define (reverse! lis)
1461;  (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) '() lis))
1462
1463(define (reverse! lis)
1464  (let lp ((lis lis) (ans '()))
1465    (if (null-list? lis) ans
1466        (let ((tail (cdr lis)))
1467          (set-cdr! lis ans)
1468          (lp tail lis)))))
1469
1470;;; Lists-as-sets
1471;;;;;;;;;;;;;;;;;
1472
1473;;; This is carefully tuned code; do not modify casually.
1474;;; - It is careful to share storage when possible;
1475;;; - Side-effecting code tries not to perform redundant writes.
1476;;; - It tries to avoid linear-time scans in special cases where constant-time
1477;;;   computations can be performed.
1478;;; - It relies on similar properties from the other list-lib procs it calls.
1479;;;   For example, it uses the fact that the implementations of MEMBER and
1480;;;   FILTER in this source code share longest common tails between args
1481;;;   and results to get structure sharing in the lset procedures.
1482
1483(define (##srfi1#lset2<= = lis1 lis2) (every (lambda (x) (member x lis2 =)) lis1))
1484
1485(define (lset<= = . lists)
1486;  (check-arg procedure? = lset<=)
1487  (or (not (pair? lists)) ; 0-ary case
1488      (let lp ((s1 (car lists)) (rest (cdr lists)))
1489        (or (not (pair? rest))
1490            (let ((s2 (car rest))  (rest (cdr rest)))
1491              (and (or (eq? s2 s1)      ; Fast path
1492                       (##srfi1#lset2<= = s1 s2)) ; Real test
1493                   (lp s2 rest)))))))
1494
1495(define (lset= = . lists)
1496;  (check-arg procedure? = lset=)
1497  (or (not (pair? lists)) ; 0-ary case
1498      (let lp ((s1 (car lists)) (rest (cdr lists)))
1499        (or (not (pair? rest))
1500            (let ((s2   (car rest))
1501                  (rest (cdr rest)))
1502              (and (or (eq? s1 s2)      ; Fast path
1503                       (and (##srfi1#lset2<= = s1 s2) (##srfi1#lset2<= = s2 s1))) ; Real test
1504                   (lp s2 rest)))))))
1505
1506
1507(define (lset-adjoin = lis . elts)
1508;  (check-arg procedure? = lset-adjoin)
1509  (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans)))
1510        lis elts))
1511
1512
1513(define (lset-union = . lists)
1514;  (check-arg procedure? = lset-union)
1515  (reduce (lambda (lis ans)             ; Compute ANS + LIS.
1516            (cond ((null? lis) ans)     ; Don't copy any lists
1517                  ((null? ans) lis)     ; if we don't have to.
1518                  ((eq? lis ans) ans)
1519                  (else
1520                   (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans)
1521                                               ans
1522                                               (cons elt ans)))
1523                         ans lis))))
1524          '() lists))
1525
1526(define (lset-union! = . lists)
1527;  (check-arg procedure? = lset-union!)
1528  (reduce (lambda (lis ans)             ; Splice new elts of LIS onto the front of ANS.
1529            (cond ((null? lis) ans)     ; Don't copy any lists
1530                  ((null? ans) lis)     ; if we don't have to.
1531                  ((eq? lis ans) ans)
1532                  (else
1533                   (pair-fold (lambda (pair ans)
1534                                (let ((elt (car pair)))
1535                                  (if (any (lambda (x) (= x elt)) ans)
1536                                      ans
1537                                      (begin (set-cdr! pair ans) pair))))
1538                              ans lis))))
1539          '() lists))
1540
1541
1542(define (lset-intersection = lis1 . lists)
1543;  (check-arg procedure? = lset-intersection)
1544  (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
1545    (cond ((any null-list? lists) '())          ; Short cut
1546          ((null? lists)          lis1)         ; Short cut
1547          (else (filter (lambda (x)
1548                          (every (lambda (lis) (member x lis =)) lists))
1549                        lis1)))))
1550
1551(define (lset-intersection! = lis1 . lists)
1552;  (check-arg procedure? = lset-intersection!)
1553  (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
1554    (cond ((any null-list? lists) '())          ; Short cut
1555          ((null? lists)          lis1)         ; Short cut
1556          (else (filter! (lambda (x)
1557                           (every (lambda (lis) (member x lis =)) lists))
1558                         lis1)))))
1559
1560
1561(define (lset-difference = lis1 . lists)
1562;  (check-arg procedure? = lset-difference)
1563  (let ((lists (filter pair? lists)))   ; Throw out empty lists.
1564    (cond ((null? lists)     lis1)      ; Short cut
1565          ((memq lis1 lists) '())       ; Short cut
1566          (else (filter (lambda (x)
1567                          (every (lambda (lis) (not (member x lis =)))
1568                                 lists))
1569                        lis1)))))
1570
1571(define (lset-difference! = lis1 . lists)
1572;  (check-arg procedure? = lset-difference!)
1573  (let ((lists (filter pair? lists)))   ; Throw out empty lists.
1574    (cond ((null? lists)     lis1)      ; Short cut
1575          ((memq lis1 lists) '())       ; Short cut
1576          (else (filter! (lambda (x)
1577                           (every (lambda (lis) (not (member x lis =)))
1578                                  lists))
1579                         lis1)))))
1580
1581
1582(define (lset-xor = . lists)
1583;  (check-arg procedure? = lset-xor)
1584  (reduce (lambda (b a)                 ; Compute A xor B:
1585            ;; Note that this code relies on the constant-time
1586            ;; short-cuts provided by LSET-DIFF+INTERSECTION,
1587            ;; LSET-DIFFERENCE & APPEND to provide constant-time short
1588            ;; cuts for the cases A = (), B = (), and A eq? B. It takes
1589            ;; a careful case analysis to see it, but it's carefully
1590            ;; built in.
1591
1592            ;; Compute a-b and a^b, then compute b-(a^b) and
1593            ;; cons it onto the front of a-b.
1594            (receive (a-b a-int-b)   (lset-diff+intersection = a b)
1595              (cond ((null? a-b)     (lset-difference = b a))
1596                    ((null? a-int-b) (append b a))
1597                    (else (fold (lambda (xb ans)
1598                                  (if (member xb a-int-b =) ans (cons xb ans)))
1599                                a-b
1600                                b)))))
1601          '() lists))
1602
1603
1604(define (lset-xor! = . lists)
1605;  (check-arg procedure? = lset-xor!)
1606  (reduce (lambda (b a)                 ; Compute A xor B:
1607            ;; Note that this code relies on the constant-time
1608            ;; short-cuts provided by LSET-DIFF+INTERSECTION,
1609            ;; LSET-DIFFERENCE & APPEND to provide constant-time short
1610            ;; cuts for the cases A = (), B = (), and A eq? B. It takes
1611            ;; a careful case analysis to see it, but it's carefully
1612            ;; built in.
1613
1614            ;; Compute a-b and a^b, then compute b-(a^b) and
1615            ;; cons it onto the front of a-b.
1616            (receive (a-b a-int-b)   (lset-diff+intersection! = a b)
1617              (cond ((null? a-b)     (lset-difference! = b a))
1618                    ((null? a-int-b) (append! b a))
1619                    (else (pair-fold (lambda (b-pair ans)
1620                                       (if (member (car b-pair) a-int-b =) ans
1621                                           (begin (set-cdr! b-pair ans) b-pair)))
1622                                     a-b
1623                                     b)))))
1624          '() lists))
1625
1626
1627(define (lset-diff+intersection = lis1 . lists)
1628;  (check-arg procedure? = lset-diff+intersection)
1629  (cond ((every null-list? lists) (values lis1 '()))    ; Short cut
1630        ((memq lis1 lists)        (values '() lis1))    ; Short cut
1631        (else (partition (lambda (elt)
1632                           (not (any (lambda (lis) (member elt lis =))
1633                                     lists)))
1634                         lis1))))
1635
1636(define (lset-diff+intersection! = lis1 . lists)
1637;  (check-arg procedure? = lset-diff+intersection!)
1638  (cond ((every null-list? lists) (values lis1 '()))    ; Short cut
1639        ((memq lis1 lists)        (values '() lis1))    ; Short cut
1640        (else (partition! (lambda (elt)
1641                            (not (any (lambda (lis) (member elt lis =))
1642                                      lists)))
1643                          lis1))))
Note: See TracBrowser for help on using the repository browser.