source: project/chicken/branches/beyond-hope/srfi-1.scm @ 10439

Last change on this file since 10439 was 10439, checked in by felix winkelmann, 13 years ago

painfully slowly debugging compiler

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