source: project/chicken/branches/release/srfi-1.scm @ 13178

Last change on this file since 13178 was 1186, checked in by felix winkelmann, 14 years ago

mailbox got own queue implementation

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