define-namespace and SRFI-1

4 files changed, 1554 insertions, 0 deletions

diff --git a/README.rst b/README.rst
new file mode 100644
index 0000000..77ce6bc
--- /dev/null
+++ b/README.rst
@@ -0,0 +1,51 @@
+================
+define-namespace
+================
+
+DEFINE-NAMESPACE is an R5RS macro that implements a subset of R7RS's
+DEFINE-LIBRARY.
+
+-----
+Usage
+-----
+
+Syntax::
+
+    (define-namespace namespace-name [DECL list])
+
+    DECL ::= (define defbody ...)
+           | (export [identifier list])
+           | (import [IMPORTSPEC list])
+
+    IMPORTSPEC ::= (only ns [identifier list])
+               ::= (rename ns [(identifier identifier) list]
+
+    (import-from-namespace [IMPORTSPEC list])
+
+Example::
+
+    (define-namespace ns
+      (define param 5)
+      (define (f x) (* 5 x))
+      (export f))
+
+    (define-namespace ns2
+      (import (rename ns (f g)))
+      (define (f x) (* 5 (g x)))
+      (export f))
+
+    (import-from-namespace (only ns2 f))
+
+    (f 17)
+
+---------------------
+Differences from R7RS
+---------------------
+
+* There are only EXPORT, IMPORT, and BEGIN statements.
+* DEFINE-SYNTAX does not work.
+* EXPORT statements must occur after DEFINEs.
+* IMPORT only allows for ONLY and RENAME clauses.
+* Namespace names are identifers, not lists.
+* Namespaces are Scheme objects.
+* To import outside of namespaces, use IMPORT-FROM-NAMSPACE, not IMPORT.
diff --git a/define-namespace-5.scm b/define-namespace-5.scm
new file mode 100644
index 0000000..0a9211c
--- /dev/null
+++ b/define-namespace-5.scm
@@ -0,0 +1,91 @@
+;;; Copyright (c) 2024, Peter McGoron
+;;; 
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 
+;;; 1) Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2) Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 
+;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
+;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;; 
+
+;;; Compatability functions.
+;;; These functions abstract the namespace container. It is implemented
+;;; as assocation lists, but by changing these functions it could be a
+;;; hash table, binary tree, etc.
+
+(define (%namespace-new) (cons '() '()))
+(define (%namespace-set! ns id val)
+  (let ((alist (car ns)))
+    (set-car! ns (cons (cons id val) alist)))) 
+(define (%namespace-get ns id)
+  (let ((alist (car ns)))
+    (cdr (assv id alist))))
+
+;;; Internal definitions.
+
+(define-syntax %import-from-namespace
+  (syntax-rules (rename only)
+    ((%import-from-namespace continue (only ns identifier rest-only ...) rest ...)
+     (begin
+       (define identifier (%namespace-get ns (quote identifier)))
+       (%import-from-namespace continue (only ns rest-only ...) rest ...)))
+    ((%import-from-namespace continue (only ns) rest ...)
+     (%import-from-namespace continue rest ...))
+    ((%import-from-namespace continue (rename ns (inside to) rename-rest ...) rest ...)
+     (begin
+       (define to (%namespace-get ns (quote inside)))
+       (%import-from-namespace continue (rename ns rename-rest ...) rest ...)))
+    ((%import-from-namespace continue (rename ns) rest ...)
+     (%import-from-namespace continue rest ...))
+    ((%import-from-namespace continue) continue)))
+
+(define-syntax %define-namespace
+  (syntax-rules (export import begin)
+    ((%define-namespace name (begin decls ...) rest ...)
+     (begin
+       (begin decls ...)
+       (%define-namespace name rest ...)))
+    ((%define-namespace name (export identifier exportspec ...) rest ...)
+     (begin
+       (%namespace-set! name (quote identifier) identifier)
+       (%define-namespace name (export exportspec ...) rest ...)))
+    ((%define-namespace name (export) rest ...)
+     (%define-namespace name rest ...))
+    ((%define-namespace name (import body ...) rest ...)
+     (%import-from-namespace (%define-namespace name rest ...)
+                             body ...))
+    ((%define-namespace name) '())))
+
+;;; External definitions.
+
+(define-syntax define-namespace
+  (syntax-rules ()
+    ((define-namespace name body ...)
+     (begin
+       (define name (%namespace-new))
+       (let ((dummy-variable '()))
+         (%define-namespace name body ...))))))
+
+(define-syntax import-from-namespace
+  (syntax-rules ()
+    ((import-from-namespace body ...)
+     (%import-from-namespace '() body ...))))
+
+(import-from-namespace (only srfi-1 fold))
+(fold (lambda (elem acc) (+ elem acc)) 0'(1 2 3 4 5))
+
diff --git a/define-namespace-7.scm b/define-namespace-7.scm
new file mode 100644
index 0000000..6c93183
--- /dev/null
+++ b/define-namespace-7.scm
@@ -0,0 +1,21 @@
+;;; Compatability layer to translate DEFINE-NAMESPACE to R7RS's
+;;; DEFINE-LIBRARY.
+
+(define-syntax import-from-namespace
+  (syntax-rules ()
+    ((import-from-namespace body ...) (import body ...))))
+
+(define-syntax define-namespace
+  (syntax-rules ()
+    ((define-namespace ns body ...)
+     (define-library (namespace ns) body ...))))
+
+(display "hello world\n")
+
+(define-namespace blah
+  (begin
+    (define x 5)))
+
+(define-library (namespace blah)
+  (begin
+    (define (x) 5)))
diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm
new file mode 100644
index 0000000..3194c86
--- /dev/null
+++ b/srfi/srfi-1.scm
@@ -0,0 +1,1391 @@
+;;; SRFI-1 in DEFINE-NAMESPACE.
+(define-namespace srfi-1
+  (begin ;;; SRFI-1 list-processing library   -*- Scheme -*-
+         ;;; Reference implementation
+         ;;;
+         ;;; SPDX-License-Identifier: MIT
+         ;;;
+         ;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+         ;;; this code as long as you do not remove this copyright notice or
+         ;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+         ;;;     -Olin
+         ;;; This is a library of list- and pair-processing functions. I wrote it after
+         ;;; carefully considering the functions provided by the libraries found in
+         ;;; R4RS/R5RS Scheme, MIT Scheme, Gambit, RScheme, MzScheme, slib, Common
+         ;;; Lisp, Bigloo, guile, T, APL and the SML standard basis. It is a pretty
+         ;;; rich toolkit, providing a superset of the functionality found in any of
+         ;;; the various Schemes I considered.
+         ;;; This implementation is intended as a portable reference implementation
+         ;;; for SRFI-1. See the porting notes below for more information.
+         ;;; Exported:
+         ;;; xcons tree-copy make-list list-tabulate cons* list-copy
+         ;;; proper-list? circular-list? dotted-list? not-pair? null-list? list=
+         ;;; circular-list length+
+         ;;; iota
+         ;;; first second third fourth fifth sixth seventh eighth ninth tenth
+         ;;; car+cdr
+         ;;; take       drop
+         ;;; take-right drop-right
+         ;;; take!      drop-right!
+         ;;; split-at   split-at!
+         ;;; last last-pair
+         ;;; zip unzip1 unzip2 unzip3 unzip4 unzip5
+         ;;; count
+         ;;; append! append-reverse append-reverse! concatenate concatenate!
+         ;;; unfold       fold       pair-fold       reduce
+         ;;; unfold-right fold-right pair-fold-right reduce-right
+         ;;; append-map append-map! map! pair-for-each filter-map map-in-order
+         ;;; filter  partition  remove
+         ;;; filter! partition! remove!
+         ;;; find find-tail any every list-index
+         ;;; take-while drop-while take-while!
+         ;;; span break span! break!
+         ;;; delete delete!
+         ;;; alist-cons alist-copy
+         ;;; delete-duplicates delete-duplicates!
+         ;;; alist-delete alist-delete!
+         ;;; reverse!
+         ;;; lset<= lset= lset-adjoin
+         ;;; lset-union  lset-intersection  lset-difference  lset-xor  lset-diff+intersection
+         ;;; lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection!
+         ;;;
+         ;;; In principle, the following R4RS list- and pair-processing procedures
+         ;;; are also part of this package's exports, although they are not defined
+         ;;; in this file:
+         ;;;   Primitives: cons pair? null? car cdr set-car! set-cdr!
+         ;;;   Non-primitives: list length append reverse cadr ... cddddr list-ref
+         ;;;                   memq memv assq assv
+         ;;;   (The non-primitives are defined in this file, but commented out.)
+         ;;;
+         ;;; These R4RS procedures have extended definitions in SRFI-1 and are defined
+         ;;; in this file:
+         ;;;   map for-each member assoc
+         ;;;
+         ;;; The remaining two R4RS list-processing procedures are not included:
+         ;;;   list-tail (use drop)
+         ;;;   list? (use proper-list?)
+         ;;; A note on recursion and iteration/reversal:
+         ;;; Many iterative list-processing algorithms naturally compute the elements
+         ;;; of the answer list in the wrong order (left-to-right or head-to-tail) from
+         ;;; the order needed to cons them into the proper answer (right-to-left, or
+         ;;; tail-then-head). One style or idiom of programming these algorithms, then,
+         ;;; loops, consing up the elements in reverse order, then destructively
+         ;;; reverses the list at the end of the loop. I do not do this. The natural
+         ;;; and efficient way to code these algorithms is recursively. This trades off
+         ;;; intermediate temporary list structure for intermediate temporary stack
+         ;;; structure. In a stack-based system, this improves cache locality and
+         ;;; lightens the load on the GC system. Don't stand on your head to iterate!
+         ;;; Recurse, where natural. Multiple-value returns make this even more
+         ;;; convenient, when the recursion/iteration has multiple state values.
+         ;;; Porting:
+         ;;; This is carefully tuned code; do not modify casually.
+         ;;;   - It is careful to share storage when possible;
+         ;;;   - Side-effecting code tries not to perform redundant writes.
+         ;;;
+         ;;; That said, a port of this library to a specific Scheme system might wish
+         ;;; to tune this code to exploit particulars of the implementation.
+         ;;; The single most important compiler-specific optimisation you could make
+         ;;; to this library would be to add rewrite rules or transforms to:
+         ;;; - transform applications of n-ary procedures (e.g. LIST=, CONS*, APPEND,
+         ;;;   LSET-UNION) into multiple applications of a primitive two-argument
+         ;;;   variant.
+         ;;; - transform applications of the mapping functions (MAP, FOR-EACH, FOLD,
+         ;;;   ANY, EVERY) into open-coded loops. The killer here is that these
+         ;;;   functions are n-ary. Handling the general case is quite inefficient,
+         ;;;   requiring many intermediate data structures to be allocated and
+         ;;;   discarded.
+         ;;; - transform applications of procedures that take optional arguments
+         ;;;   into calls to variants that do not take optional arguments. This
+         ;;;   eliminates unnecessary consing and parsing of the rest parameter.
+         ;;;
+         ;;; These transforms would provide BIG speedups. In particular, the n-ary
+         ;;; mapping functions are particularly slow and cons-intensive, and are good
+         ;;; candidates for tuning. I have coded fast paths for the single-list cases,
+         ;;; but what you really want to do is exploit the fact that the compiler
+         ;;; usually knows how many arguments are being passed to a particular
+         ;;; application of these functions -- they are usually explicitly called, not
+         ;;; passed around as higher-order values. If you can arrange to have your
+         ;;; compiler produce custom code or custom linkages based on the number of
+         ;;; arguments in the call, you can speed these functions up a *lot*. But this
+         ;;; kind of compiler technology no longer exists in the Scheme world as far as
+         ;;; I can see.
+         ;;;
+         ;;; Note that this code is, of course, dependent upon standard bindings for
+         ;;; the R5RS procedures -- i.e., it assumes that the variable CAR is bound
+         ;;; to the procedure that takes the car of a list. If your Scheme
+         ;;; implementation allows user code to alter the bindings of these procedures
+         ;;; in a manner that would be visible to these definitions, then there might
+         ;;; be trouble. You could consider horrible kludgery along the lines of
+         ;;;    (define fact
+         ;;;      (let ((= =) (- -) (* *))
+         ;;;        (letrec ((real-fact (lambda (n)
+         ;;;                              (if (= n 0) 1 (* n (real-fact (- n 1)))))))
+         ;;;          real-fact)))
+         ;;; Or you could consider shifting to a reasonable Scheme system that, say,
+         ;;; has a module system protecting code from this kind of lossage.
+         ;;;
+         ;;; This code does a fair amount of run-time argument checking. If your
+         ;;; Scheme system has a sophisticated compiler that can eliminate redundant
+         ;;; error checks, this is no problem. However, if not, these checks incur
+         ;;; some performance overhead -- and, in a safe Scheme implementation, they
+         ;;; are in some sense redundant: if we don't check to see that the PROC
+         ;;; parameter is a procedure, we'll find out anyway three lines later when
+         ;;; we try to call the value. It's pretty easy to rip all this argument
+         ;;; checking code out if it's inappropriate for your implementation -- just
+         ;;; nuke every call to CHECK-ARG.
+         ;;;
+         ;;; On the other hand, if you *do* have a sophisticated compiler that will
+         ;;; actually perform soft-typing and eliminate redundant checks (Rice's systems
+         ;;; being the only possible candidate of which I'm aware), leaving these checks
+         ;;; in can *help*, since their presence can be elided in redundant cases,
+         ;;; and in cases where they are needed, performing the checks early, at
+         ;;; procedure entry, can "lift" a check out of a loop.
+         ;;;
+         ;;; Finally, I have only checked the properties that can portably be checked
+         ;;; with R5RS Scheme -- and this is not complete. You may wish to alter
+         ;;; the CHECK-ARG parameter checks to perform extra, implementation-specific
+         ;;; checks, such as procedure arity for higher-order values.
+         ;;;
+         ;;; The code has only these non-R4RS dependencies:
+         ;;;   A few calls to an ERROR procedure;
+         ;;;   Uses of the R5RS multiple-value procedure VALUES and the m-v binding
+         ;;;     RECEIVE macro (which isn't R5RS, but is a trivial macro).
+         ;;;   Many calls to a parameter-checking procedure check-arg:
+         ;;;    (define (check-arg pred val caller)
+         ;;;      (let lp ((val val))
+         ;;;        (if (pred val) val (lp (error "Bad argument" val pred caller)))))
+         ;;;   A few uses of the LET-OPTIONAL and :OPTIONAL macros for parsing
+         ;;;     optional arguments.
+         ;;;
+         ;;; Most of these procedures use the NULL-LIST? test to trigger the
+         ;;; base case in the inner loop or recursion. The NULL-LIST? function
+         ;;; is defined to be a careful one -- it raises an error if passed a
+         ;;; non-nil, non-pair value. The spec allows an implementation to use
+         ;;; a less-careful implementation that simply defines NULL-LIST? to
+         ;;; be NOT-PAIR?. This would speed up the inner loops of these procedures
+         ;;; at the expense of having them silently accept dotted lists.
+         ;;; A note on dotted lists:
+         ;;; I, personally, take the view that the only consistent view of lists
+         ;;; in Scheme is the view that *everything* is a list -- values such as
+         ;;; 3 or "foo" or 'bar are simply empty dotted lists. This is due to the
+         ;;; fact that Scheme actually has no true list type. It has a pair type,
+         ;;; and there is an *interpretation* of the trees built using this type
+         ;;; as lists.
+         ;;;
+         ;;; I lobbied to have these list-processing procedures hew to this
+         ;;; view, and accept any value as a list argument. I was overwhelmingly
+         ;;; overruled during the SRFI discussion phase. So I am inserting this
+         ;;; text in the reference lib and the SRFI spec as a sort of "minority
+         ;;; opinion" dissent.
+         ;;;
+         ;;; Many of the procedures in this library can be trivially redefined
+         ;;; to handle dotted lists, just by changing the NULL-LIST? base-case
+         ;;; check to NOT-PAIR?, meaning that any non-pair value is taken to be
+         ;;; an empty list. For most of these procedures, that's all that is
+         ;;; required.
+         ;;;
+         ;;; However, we have to do a little more work for some procedures that
+         ;;; *produce* lists from other lists.  Were we to extend these procedures to
+         ;;; accept dotted lists, we would have to define how they terminate the lists
+         ;;; produced as results when passed a dotted list. I designed a coherent set
+         ;;; of termination rules for these cases; this was posted to the SRFI-1
+         ;;; discussion list. I additionally wrote an earlier version of this library
+         ;;; that implemented that spec. It has been discarded during later phases of
+         ;;; the definition and implementation of this library.
+         ;;;
+         ;;; The argument *against* defining these procedures to work on dotted
+         ;;; lists is that dotted lists are the rare, odd case, and that by
+         ;;; arranging for the procedures to handle them, we lose error checking
+         ;;; in the cases where a dotted list is passed by accident -- e.g., when
+         ;;; the programmer swaps a two arguments to a list-processing function,
+         ;;; one being a scalar and one being a list. For example,
+         ;;;     (member '(1 3 5 7 9) 7)
+         ;;; This would quietly return #f if we extended MEMBER to accept dotted
+         ;;; lists.
+         ;;;
+         ;;; The SRFI discussion record contains more discussion on this topic.
+         (define (check-arg . rest) '())
+         ;;; Constructors
+         ;;;;;;;;;;;;;;;;
+         ;;; Occasionally useful as a value to be passed to a fold or other
+         ;;; higher-order procedure.
+         (define (xcons d a) (cons a d))
+         ;;;; Recursively copy every cons.
+         (define (tree-copy x)
+           (let recur ((x x))
+             (if (not (pair? x)) x
+          (cons (recur (car x)) (recur (cdr x))))))
+         ;;; Make a list of length LEN.
+         (define (make-list len . maybe-elt)
+           (check-arg (lambda (n) (and (integer? n) (>= n 0))) len make-list)
+           (let ((elt (cond ((null? maybe-elt) #f) ; Default value
+                            ((null? (cdr maybe-elt)) (car maybe-elt))
+                            (else (error "Too many arguments to MAKE-LIST"
+                                         (cons len maybe-elt))))))
+             (do ((i len (- i 1))
+                  (ans '() (cons elt ans)))
+                 ((<= i 0) ans))))
+         ;(define (list . ans) ans) ; R4RS
+         ;;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN.
+         (define (list-tabulate len proc)
+           (check-arg (lambda (n) (and (integer? n) (>= n 0))) len list-tabulate)
+           (check-arg procedure? proc list-tabulate)
+           (do ((i (- len 1) (- i 1))
+                (ans '() (cons (proc i) ans)))
+               ((< i 0) ans)))
+         ;;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an)))
+         ;;; (cons* a1) = a1 (cons* a1 a2 ...) = (cons a1 (cons* a2 ...))
+         ;;;
+         ;;; (cons first (unfold not-pair? car cdr rest values))
+         (define (cons* first . rest)
+           (let recur ((x first) (rest rest))
+             (if (pair? rest)
+                 (cons x (recur (car rest) (cdr rest)))
+                 x)))
+         ;;; (unfold not-pair? car cdr lis values)
+         (define (list-copy lis)
+           (let recur ((lis lis))
+             (if (pair? lis)
+                 (cons (car lis) (recur (cdr lis)))
+                 lis)))
+         ;;; IOTA count [start step] (start start+step ... start+(count-1)*step)
+         (define (iota count . maybe-start+step)
+           (check-arg integer? count iota)
+           (if (< count 0) (error "Negative step count" iota count))
+           (let-optionals maybe-start+step ((start 0) (step 1))
+                          (check-arg number? start iota)
+                          (check-arg number? step iota)
+                          (let loop ((n 0) (r '()))
+                            (if (= n count)
+                                (reverse r)
+                                (loop (+ 1 n)
+                                      (cons (+ start (* n step)) r))))))
+         ;;; I thought these were lovely, but the public at large did not share my
+         ;;; enthusiasm...
+         ;;; :IOTA to  (0 ... to-1)
+         ;;; :IOTA from to (from ... to-1)
+         ;;; :IOTA from to step  (from from+step ...)
+         ;;; IOTA: to  (1 ... to)
+         ;;; IOTA: from to (from+1 ... to)
+         ;;; IOTA: from to step (from+step from+2step ...)
+         ;(define (%parse-iota-args arg1 rest-args proc)
+         ;  (let ((check (lambda (n) (check-arg integer? n proc))))
+         ;    (check arg1)
+         ;    (if (pair? rest-args)
+         ; (let ((arg2 (check (car rest-args)))
+         ;       (rest (cdr rest-args)))
+         ;   (if (pair? rest)
+         ;       (let ((arg3 (check (car rest)))
+         ;      (rest (cdr rest)))
+         ;  (if (pair? rest) (error "Too many parameters" proc arg1 rest-args)
+         ;      (values arg1 arg2 arg3)))
+         ;       (values arg1 arg2 1)))
+         ; (values 0 arg1 1))))
+         ;
+         ;(define (iota: arg1 . rest-args)
+         ;  (receive (from to step) (%parse-iota-args arg1 rest-args iota:)
+         ;    (let* ((numsteps (floor (/ (- to from) step)))
+         ;    (last-val (+ from (* step numsteps))))
+         ;      (if (< numsteps 0) (error "Negative step count" iota: from to step))
+         ;      (do ((steps-left numsteps (- steps-left 1))
+         ;    (val last-val (- val step))
+         ;    (ans '() (cons val ans)))
+         ;   ((<= steps-left 0) ans)))))
+         ;
+         ;
+         ;(define (:iota arg1 . rest-args)
+         ;  (receive (from to step) (%parse-iota-args arg1 rest-args :iota)
+         ;    (let* ((numsteps (ceiling (/ (- to from) step)))
+         ;    (last-val (+ from (* step (- numsteps 1)))))
+         ;      (if (< numsteps 0) (error "Negative step count" :iota from to step))
+         ;      (do ((steps-left numsteps (- steps-left 1))
+         ;    (val last-val (- val step))
+         ;    (ans '() (cons val ans)))
+         ;   ((<= steps-left 0) ans)))))
+         (define (circular-list val1 . vals)
+           (let ((ans (cons val1 vals)))
+             (set-cdr! (last-pair ans) ans)
+             ans))
+         ;;; <proper-list> ::= ()   ; Empty proper list
+         ;;;    |   (cons <x> <proper-list>) ; Proper-list pair
+         ;;; Note that this definition rules out circular lists -- and this
+         ;;; function is required to detect this case and return false.
+         (define (proper-list? x)
+           (let lp ((x x) (lag x))
+             (if (pair? x)
+                 (let ((x (cdr x)))
+                   (if (pair? x)
+                       (let ((x (cdr x))
+                             (lag (cdr lag)))
+                         (and (not (eq? x lag)) (lp x lag)))
+                       (null? x)))
+                 (null? x))))
+         ;;; A dotted list is a finite list (possibly of length 0) terminated
+         ;;; by a non-nil value. Any non-cons, non-nil value (e.g., "foo" or 5)
+         ;;; is a dotted list of length 0.
+         ;;;
+         ;;; <dotted-list> ::= <non-nil,non-pair> ; Empty dotted list
+         ;;;               |   (cons <x> <dotted-list>) ; Proper-list pair
+         (define (dotted-list? x)
+           (let lp ((x x) (lag x))
+             (if (pair? x)
+                 (let ((x (cdr x)))
+                   (if (pair? x)
+                       (let ((x (cdr x))
+                             (lag (cdr lag)))
+                         (and (not (eq? x lag)) (lp x lag)))
+                       (not (null? x))))
+                 (not (null? x)))))
+         (define (circular-list? x)
+           (let lp ((x x) (lag x))
+             (and (pair? x)
+                  (let ((x (cdr x)))
+                    (and (pair? x)
+                         (let ((x (cdr x))
+                               (lag (cdr lag)))
+                           (or (eq? x lag) (lp x lag))))))))
+         (define (not-pair? x) (not (pair? x))) ; Inline me.
+         ;;; This is a legal definition which is fast and sloppy:
+         ;;;     (define null-list? not-pair?)
+         ;;; but we'll provide a more careful one:
+         (define (null-list? l)
+           (cond ((pair? l) #f)
+                 ((null? l) #t)
+                 (else (error "null-list?: argument out of domain" l))))
+         (define (list= = . lists)
+           (or (null? lists) ; special case
+               (let lp1 ((list-a (car lists)) (others (cdr lists)))
+                 (or (null? others)
+                     (let ((list-b (car others))
+                           (others (cdr others)))
+                       (if (eq? list-a list-b) ; EQ? => LIST=
+                           (lp1 list-b others)
+                           (let lp2 ((pair-a list-a) (pair-b list-b))
+                             (if (null-list? pair-a)
+                                 (and (null-list? pair-b)
+                                      (lp1 list-b others))
+                                 (and (not (null-list? pair-b))
+                                      (= (car pair-a) (car pair-b))
+                                      (lp2 (cdr pair-a) (cdr pair-b)))))))))))
+         ;;; R4RS, so commented out.
+         ;(define (length x)   ; LENGTH may diverge or
+         ;  (let lp ((x x) (len 0))  ; raise an error if X is
+         ;    (if (pair? x)   ; a circular list. This version
+         ;        (lp (cdr x) (+ len 1))  ; diverges.
+         ;        len)))
+         (define (length+ x)   ; Returns #f if X is circular.
+           (let lp ((x x) (lag x) (len 0))
+             (if (pair? x)
+                 (let ((x (cdr x))
+                       (len (+ len 1)))
+                   (if (pair? x)
+                       (let ((x (cdr x))
+                             (lag (cdr lag))
+                             (len (+ len 1)))
+                         (and (not (eq? x lag)) (lp x lag len)))
+                       len))
+                 len)))
+         (define (zip list1 . more-lists) (apply map list list1 more-lists))
+         ;;; Selectors
+         ;;;;;;;;;;;;;
+         ;;; R4RS non-primitives:
+         ;(define (caar   x) (car (car x)))
+         ;(define (cadr   x) (car (cdr x)))
+         ;(define (cdar   x) (cdr (car x)))
+         ;(define (cddr   x) (cdr (cdr x)))
+         ;
+         ;(define (caaar  x) (caar (car x)))
+         ;(define (caadr  x) (caar (cdr x)))
+         ;(define (cadar  x) (cadr (car x)))
+         ;(define (caddr  x) (cadr (cdr x)))
+         ;(define (cdaar  x) (cdar (car x)))
+         ;(define (cdadr  x) (cdar (cdr x)))
+         ;(define (cddar  x) (cddr (car x)))
+         ;(define (cdddr  x) (cddr (cdr x)))
+         ;
+         ;(define (caaaar x) (caaar (car x)))
+         ;(define (caaadr x) (caaar (cdr x)))
+         ;(define (caadar x) (caadr (car x)))
+         ;(define (caaddr x) (caadr (cdr x)))
+         ;(define (cadaar x) (cadar (car x)))
+         ;(define (cadadr x) (cadar (cdr x)))
+         ;(define (caddar x) (caddr (car x)))
+         ;(define (cadddr x) (caddr (cdr x)))
+         ;(define (cdaaar x) (cdaar (car x)))
+         ;(define (cdaadr x) (cdaar (cdr x)))
+         ;(define (cdadar x) (cdadr (car x)))
+         ;(define (cdaddr x) (cdadr (cdr x)))
+         ;(define (cddaar x) (cddar (car x)))
+         ;(define (cddadr x) (cddar (cdr x)))
+         ;(define (cdddar x) (cdddr (car x)))
+         ;(define (cddddr x) (cdddr (cdr x)))
+         (define first car)
+         (define second cadr)
+         (define third caddr)
+         (define fourth cadddr)
+         (define (fifth x) (car (cddddr x)))
+         (define (sixth x) (cadr (cddddr x)))
+         (define (seventh x) (caddr (cddddr x)))
+         (define (eighth x) (cadddr (cddddr x)))
+         (define (ninth x) (car (cddddr (cddddr x))))
+         (define (tenth x) (cadr (cddddr (cddddr x))))
+         (define (car+cdr pair) (values (car pair) (cdr pair)))
+         ;;; take & drop
+         (define (take lis k)
+           (check-arg integer? k take)
+           (let recur ((lis lis) (k k))
+             (if (zero? k) '()
+                 (cons (car lis)
+                       (recur (cdr lis) (- k 1))))))
+         (define (drop lis k)
+           (check-arg integer? k drop)
+           (let iter ((lis lis) (k k))
+             (if (zero? k) lis (iter (cdr lis) (- k 1)))))
+         (define (take! lis k)
+           (check-arg integer? k take!)
+           (if (zero? k) '()
+               (begin (set-cdr! (drop lis (- k 1)) '())
+                      lis)))
+         ;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list,
+         ;;; off by K, then chasing down the list until the lead pointer falls off
+         ;;; the end.
+         (define (take-right lis k)
+           (check-arg integer? k take-right)
+           (let lp ((lag lis) (lead (drop lis k)))
+             (if (pair? lead)
+                 (lp (cdr lag) (cdr lead))
+                 lag)))
+         (define (drop-right lis k)
+           (check-arg integer? k drop-right)
+           (let recur ((lag lis) (lead (drop lis k)))
+             (if (pair? lead)
+                 (cons (car lag) (recur (cdr lag) (cdr lead)))
+                 '())))
+         ;;; In this function, LEAD is actually K+1 ahead of LAG. This lets
+         ;;; us stop LAG one step early, in time to smash its cdr to ().
+         (define (drop-right! lis k)
+           (check-arg integer? k drop-right!)
+           (let ((lead (drop lis k)))
+             (if (pair? lead)
+                 (let lp ((lag lis) (lead (cdr lead))) ; Standard case
+                   (if (pair? lead)
+                       (lp (cdr lag) (cdr lead))
+                       (begin (set-cdr! lag '())
+                              lis)))
+                 '()))) ; Special case dropping everything -- no cons to side-effect.
+         ;(define (list-ref lis i) (car (drop lis i))) ; R4RS
+         ;;; These use the APL convention, whereby negative indices mean
+         ;;; "from the right." I liked them, but they didn't win over the
+         ;;; SRFI reviewers.
+         ;;; K >= 0: Take and drop  K elts from the front of the list.
+         ;;; K <= 0: Take and drop -K elts from the end   of the list.
+         ;(define (take lis k)
+         ;  (check-arg integer? k take)
+         ;  (if (negative? k)
+         ;      (list-tail lis (+ k (length lis)))
+         ;      (let recur ((lis lis) (k k))
+         ; (if (zero? k) '()
+         ;     (cons (car lis)
+         ;    (recur (cdr lis) (- k 1)))))))
+         ;
+         ;(define (drop lis k)
+         ;  (check-arg integer? k drop)
+         ;  (if (negative? k)
+         ;      (let recur ((lis lis) (nelts (+ k (length lis))))
+         ; (if (zero? nelts) '()
+         ;     (cons (car lis)
+         ;    (recur (cdr lis) (- nelts 1)))))
+         ;      (list-tail lis k)))
+         ;
+         ;
+         ;(define (take! lis k)
+         ;  (check-arg integer? k take!)
+         ;  (cond ((zero? k) '())
+         ; ((positive? k)
+         ;  (set-cdr! (list-tail lis (- k 1)) '())
+         ;  lis)
+         ; (else (list-tail lis (+ k (length lis))))))
+         ;
+         ;(define (drop! lis k)
+         ;  (check-arg integer? k drop!)
+         ;  (if (negative? k)
+         ;      (let ((nelts (+ k (length lis))))
+         ; (if (zero? nelts) '()
+         ;     (begin (set-cdr! (list-tail lis (- nelts 1)) '())
+         ;     lis)))
+         ;      (list-tail lis k)))
+         (define (split-at x k)
+           (check-arg integer? k split-at)
+           (let recur ((lis x) (k k))
+             (if (zero? k) (values '() lis)
+                 (receive (prefix suffix) (recur (cdr lis) (- k 1))
+                          (values (cons (car lis) prefix) suffix)))))
+         (define (split-at! x k)
+           (check-arg integer? k split-at!)
+           (if (zero? k) (values '() x)
+               (let* ((prev (drop x (- k 1)))
+                      (suffix (cdr prev)))
+                 (set-cdr! prev '())
+                 (values x suffix))))
+         (define (last lis) (car (last-pair lis)))
+         (define (last-pair lis)
+           (check-arg pair? lis last-pair)
+           (let lp ((lis lis))
+             (let ((tail (cdr lis)))
+               (if (pair? tail) (lp tail) lis))))
+         ;;; Unzippers -- 1 through 5
+         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+         (define (unzip1 lis) (map car lis))
+         (define (unzip2 lis)
+           (let recur ((lis lis))
+             (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle
+                 (let ((elt (car lis)))   ; dotted lists.
+                   (receive (a b) (recur (cdr lis))
+                            (values (cons (car elt) a)
+                                    (cons (cadr elt) b)))))))
+         (define (unzip3 lis)
+           (let recur ((lis lis))
+             (if (null-list? lis) (values lis lis lis)
+                 (let ((elt (car lis)))
+                   (receive (a b c) (recur (cdr lis))
+                            (values (cons (car elt) a)
+                                    (cons (cadr elt) b)
+                                    (cons (caddr elt) c)))))))
+         (define (unzip4 lis)
+           (let recur ((lis lis))
+             (if (null-list? lis) (values lis lis lis lis)
+                 (let ((elt (car lis)))
+                   (receive (a b c d) (recur (cdr lis))
+                            (values (cons (car elt) a)
+                                    (cons (cadr elt) b)
+                                    (cons (caddr elt) c)
+                                    (cons (cadddr elt) d)))))))
+         (define (unzip5 lis)
+           (let recur ((lis lis))
+             (if (null-list? lis) (values lis lis lis lis lis)
+                 (let ((elt (car lis)))
+                   (receive (a b c d e) (recur (cdr lis))
+                            (values (cons (car elt) a)
+                                    (cons (cadr elt) b)
+                                    (cons (caddr elt) c)
+                                    (cons (cadddr elt) d)
+                                    (cons (car (cddddr elt)) e)))))))
+         ;;; append! append-reverse append-reverse! concatenate concatenate!
+         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+         (define (append! . lists)
+           ;; First, scan through lists looking for a non-empty one.
+           (let lp ((lists lists) (prev '()))
+             (if (not (pair? lists)) prev
+                 (let ((first (car lists))
+                       (rest (cdr lists)))
+                   (if (not (pair? first)) (lp rest first)
+                       ;; Now, do the splicing.
+                       (let lp2 ((tail-cons (last-pair first))
+                                 (rest rest))
+                         (if (pair? rest)
+                             (let ((next (car rest))
+                                   (rest (cdr rest)))
+                               (set-cdr! tail-cons next)
+                               (lp2 (if (pair? next) (last-pair next) tail-cons)
+                                    rest))
+                             first)))))))
+         ;;; APPEND is R4RS.
+         ;(define (append . lists)
+         ;  (if (pair? lists)
+         ;      (let recur ((list1 (car lists)) (lists (cdr lists)))
+         ;        (if (pair? lists)
+         ;            (let ((tail (recur (car lists) (cdr lists))))
+         ;              (fold-right cons tail list1)) ; Append LIST1 & TAIL.
+         ;            list1))
+         ;      '()))
+         ;(define (append-reverse rev-head tail) (fold cons tail rev-head))
+         ;(define (append-reverse! rev-head tail)
+         ;  (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair)
+         ;             tail
+         ;             rev-head))
+         ;;; Hand-inline the FOLD and PAIR-FOLD ops for speed.
+         (define (append-reverse rev-head tail)
+           (let lp ((rev-head rev-head) (tail tail))
+             (if (null-list? rev-head) tail
+                 (lp (cdr rev-head) (cons (car rev-head) tail)))))
+         (define (append-reverse! rev-head tail)
+           (let lp ((rev-head rev-head) (tail tail))
+             (if (null-list? rev-head) tail
+                 (let ((next-rev (cdr rev-head)))
+                   (set-cdr! rev-head tail)
+                   (lp next-rev rev-head)))))
+         (define (concatenate lists) (reduce-right append '() lists))
+         (define (concatenate! lists) (reduce-right append! '() lists))
+         ;;; Fold/map internal utilities
+         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+         ;;; These little internal utilities are used by the general
+         ;;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined.
+         ;;; One the other hand, the n-ary cases are painfully inefficient as it is.
+         ;;; An aggressive implementation should simply re-write these functions
+         ;;; for raw efficiency; I have written them for as much clarity, portability,
+         ;;; and simplicity as can be achieved.
+         ;;;
+         ;;; I use the dreaded call/cc to do local aborts. A good compiler could
+         ;;; handle this with extreme efficiency. An implementation that provides
+         ;;; a one-shot, non-persistent continuation grabber could help the compiler
+         ;;; out by using that in place of the call/cc's in these routines.
+         ;;;
+         ;;; These functions have funky definitions that are precisely tuned to
+         ;;; the needs of the fold/map procs -- for example, to minimize the number
+         ;;; of times the argument lists need to be examined.
+         ;;; Return (map cdr lists).
+         ;;; However, if any element of LISTS is empty, just abort and return '().
+         (define (%cdrs lists)
+           (call-with-current-continuation
+               (lambda (abort)
+                 (let recur ((lists lists))
+                   (if (pair? lists)
+                       (let ((lis (car lists)))
+                         (if (null-list? lis) (abort '())
+                             (cons (cdr lis) (recur (cdr lists)))))
+                       '())))))
+         (define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt))
+           (let recur ((lists lists))
+             (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt))))
+         ;;; LISTS is a (not very long) non-empty list of lists.
+         ;;; Return two lists: the cars & the cdrs of the lists.
+         ;;; However, if any of the lists is empty, just abort and return [() ()].
+         (define (%cars+cdrs lists)
+           (call-with-current-continuation
+               (lambda (abort)
+                 (let recur ((lists lists))
+                   (if (pair? lists)
+                       (receive (list other-lists) (car+cdr lists)
+                                (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
+                                    (receive (a d) (car+cdr list)
+                                             (receive (cars cdrs) (recur other-lists)
+                                                      (values (cons a cars) (cons d cdrs))))))
+                       (values '() '()))))))
+         ;;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the
+         ;;; cars list. What a hack.
+         (define (%cars+cdrs+ lists cars-final)
+           (call-with-current-continuation
+               (lambda (abort)
+                 (let recur ((lists lists))
+                   (if (pair? lists)
+                       (receive (list other-lists) (car+cdr lists)
+                                (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
+                                    (receive (a d) (car+cdr list)
+                                             (receive (cars cdrs) (recur other-lists)
+                                                      (values (cons a cars) (cons d cdrs))))))
+                       (values (list cars-final) '()))))))
+         ;;; Like %CARS+CDRS, but blow up if any list is empty.
+         (define (%cars+cdrs/no-test lists)
+           (let recur ((lists lists))
+             (if (pair? lists)
+                 (receive (list other-lists) (car+cdr lists)
+                          (receive (a d) (car+cdr list)
+                                   (receive (cars cdrs) (recur other-lists)
+                                            (values (cons a cars) (cons d cdrs)))))
+                 (values '() '()))))
+         ;;; count
+         ;;;;;;;;;
+         (define (count pred list1 . lists)
+           (check-arg procedure? pred count)
+           (if (pair? lists)
+               ;; N-ary case
+               (let lp ((list1 list1) (lists lists) (i 0))
+                 (if (null-list? list1) i
+                     (receive (as ds) (%cars+cdrs lists)
+                              (if (null? as) i
+                                  (lp (cdr list1) ds
+                                      (if (apply pred (car list1) as) (+ i 1) i))))))
+               ;; Fast path
+               (let lp ((lis list1) (i 0))
+                 (if (null-list? lis) i
+                     (lp (cdr lis) (if (pred (car lis)) (+ i 1) i))))))
+         ;;; fold/unfold
+         ;;;;;;;;;;;;;;;
+         (define (unfold-right p f g seed . maybe-tail)
+           (check-arg procedure? p unfold-right)
+           (check-arg procedure? f unfold-right)
+           (check-arg procedure? g unfold-right)
+           (let lp ((seed seed) (ans (:optional maybe-tail '())))
+             (if (p seed) ans
+                 (lp (g seed)
+                     (cons (f seed) ans)))))
+         (define (unfold p f g seed . maybe-tail-gen)
+           (check-arg procedure? p unfold)
+           (check-arg procedure? f unfold)
+           (check-arg procedure? g unfold)
+           (if (pair? maybe-tail-gen)
+               (let ((tail-gen (car maybe-tail-gen)))
+                 (if (pair? (cdr maybe-tail-gen))
+                     (apply error "Too many arguments" unfold p f g seed maybe-tail-gen)
+                     (let recur ((seed seed))
+                       (if (p seed) (tail-gen seed)
+                           (cons (f seed) (recur (g seed)))))))
+               (let recur ((seed seed))
+                 (if (p seed) '()
+                     (cons (f seed) (recur (g seed)))))))
+         (define (fold kons knil lis1 . lists)
+           (check-arg procedure? kons fold)
+           (if (pair? lists)
+               (let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case
+                 (receive (cars+ans cdrs) (%cars+cdrs+ lists ans)
+                          (if (null? cars+ans) ans ; Done.
+                              (lp cdrs (apply kons cars+ans)))))
+               (let lp ((lis lis1) (ans knil))   ; Fast path
+                 (if (null-list? lis) ans
+                     (lp (cdr lis) (kons (car lis) ans))))))
+         (define (fold-right kons knil lis1 . lists)
+           (check-arg procedure? kons fold-right)
+           (if (pair? lists)
+               (let recur ((lists (cons lis1 lists)))  ; N-ary case
+                 (let ((cdrs (%cdrs lists)))
+                   (if (null? cdrs) knil
+                       (apply kons (%cars+ lists (recur cdrs))))))
+               (let recur ((lis lis1))    ; Fast path
+                 (if (null-list? lis) knil
+                     (let ((head (car lis)))
+                       (kons head (recur (cdr lis))))))))
+         (define (pair-fold-right f zero lis1 . lists)
+           (check-arg procedure? f pair-fold-right)
+           (if (pair? lists)
+               (let recur ((lists (cons lis1 lists)))  ; N-ary case
+                 (let ((cdrs (%cdrs lists)))
+                   (if (null? cdrs) zero
+                       (apply f (append! lists (list (recur cdrs)))))))
+               (let recur ((lis lis1))    ; Fast path
+                 (if (null-list? lis) zero (f lis (recur (cdr lis)))))))
+         (define (pair-fold f zero lis1 . lists)
+           (check-arg procedure? f pair-fold)
+           (if (pair? lists)
+               (let lp ((lists (cons lis1 lists)) (ans zero)) ; N-ary case
+                 (let ((tails (%cdrs lists)))
+                   (if (null? tails) ans
+                       (lp tails (apply f (append! lists (list ans)))))))
+               (let lp ((lis lis1) (ans zero))
+                 (if (null-list? lis) ans
+                     (let ((tail (cdr lis)))  ; Grab the cdr now,
+                       (lp tail (f lis ans))))))) ; in case F SET-CDR!s LIS.
+         ;;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case.
+         ;;; These cannot meaningfully be n-ary.
+         (define (reduce f ridentity lis)
+           (check-arg procedure? f reduce)
+           (if (null-list? lis) ridentity
+               (fold f (car lis) (cdr lis))))
+         (define (reduce-right f ridentity lis)
+           (check-arg procedure? f reduce-right)
+           (if (null-list? lis) ridentity
+               (let recur ((head (car lis)) (lis (cdr lis)))
+                 (if (pair? lis)
+                     (f head (recur (car lis) (cdr lis)))
+                     head))))
+         ;;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order
+         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+         (define (append-map f lis1 . lists)
+           (really-append-map append-map append f lis1 lists))
+         (define (append-map! f lis1 . lists)
+           (really-append-map append-map! append! f lis1 lists))
+         (define (really-append-map who appender f lis1 lists)
+           (check-arg procedure? f who)
+           (if (pair? lists)
+               (receive (cars cdrs) (%cars+cdrs (cons lis1 lists))
+                        (if (null? cars) '()
+                            (let recur ((cars cars) (cdrs cdrs))
+                              (let ((vals (apply f cars)))
+                                (receive (cars2 cdrs2) (%cars+cdrs cdrs)
+                                         (if (null? cars2) vals
+                                             (appender vals (recur cars2 cdrs2))))))))
+               ;; Fast path
+               (if (null-list? lis1) '()
+                   (let recur ((elt (car lis1)) (rest (cdr lis1)))
+                     (let ((vals (f elt)))
+                       (if (null-list? rest) vals
+                           (appender vals (recur (car rest) (cdr rest)))))))))
+         (define (pair-for-each proc lis1 . lists)
+           (check-arg procedure? proc pair-for-each)
+           (if (pair? lists)
+               (let lp ((lists (cons lis1 lists)))
+                 (let ((tails (%cdrs lists)))
+                   (if (pair? tails)
+                       (begin (apply proc lists)
+                              (lp tails)))))
+               ;; Fast path.
+               (let lp ((lis lis1))
+                 (if (not (null-list? lis))
+                     (let ((tail (cdr lis))) ; Grab the cdr now,
+                       (proc lis)  ; in case PROC SET-CDR!s LIS.
+                       (lp tail))))))
+         ;;; We stop when LIS1 runs out, not when any list runs out.
+         (define (map! f lis1 . lists)
+           (check-arg procedure? f map!)
+           (if (pair? lists)
+               (let lp ((lis1 lis1) (lists lists))
+                 (if (not (null-list? lis1))
+                     (receive (heads tails) (%cars+cdrs/no-test lists)
+                              (set-car! lis1 (apply f (car lis1) heads))
+                              (lp (cdr lis1) tails))))
+               ;; Fast path.
+               (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1))
+           lis1)
+         ;;; Map F across L, and save up all the non-false results.
+         (define (filter-map f lis1 . lists)
+           (check-arg procedure? f filter-map)
+           (if (pair? lists)
+               (let recur ((lists (cons lis1 lists)))
+                 (receive (cars cdrs) (%cars+cdrs lists)
+                          (if (pair? cars)
+                              (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs))))
+                                    (else (recur cdrs))) ; Tail call in this arm.
+                              '())))
+               ;; Fast path.
+               (let recur ((lis lis1))
+                 (if (null-list? lis) lis
+                     (let ((tail (recur (cdr lis))))
+                       (cond ((f (car lis)) => (lambda (x) (cons x tail)))
+                             (else tail)))))))
+         ;;; Map F across lists, guaranteeing to go left-to-right.
+         ;;; NOTE: Some implementations of R5RS MAP are compliant with this spec;
+         ;;; in which case this procedure may simply be defined as a synonym for MAP.
+         (define (map-in-order f lis1 . lists)
+           (check-arg procedure? f map-in-order)
+           (if (pair? lists)
+               (let recur ((lists (cons lis1 lists)))
+                 (receive (cars cdrs) (%cars+cdrs lists)
+                          (if (pair? cars)
+                              (let ((x (apply f cars)))  ; Do head first,
+                                (cons x (recur cdrs)))  ; then tail.
+                              '())))
+               ;; Fast path.
+               (let recur ((lis lis1))
+                 (if (null-list? lis) lis
+                     (let ((tail (cdr lis))
+                           (x (f (car lis))))  ; Do head first,
+                       (cons x (recur tail))))))) ; then tail.
+         ;;; We extend MAP to handle arguments of unequal length.
+         (define map map-in-order)
+         ;;; filter, remove, partition
+         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+         ;;; FILTER, REMOVE, PARTITION and their destructive counterparts do not
+         ;;; disorder the elements of their argument.
+         ;; This FILTER shares the longest tail of L that has no deleted elements.
+         ;; If Scheme had multi-continuation calls, they could be made more efficient.
+         (define (filter pred lis)   ; Sleazing with EQ? makes this
+           (check-arg procedure? pred filter)  ; one faster.
+           (let recur ((lis lis))
+             (if (null-list? lis) lis   ; Use NOT-PAIR? to handle dotted lists.
+                 (let ((head (car lis))
+                       (tail (cdr lis)))
+                   (if (pred head)
+                       (let ((new-tail (recur tail))) ; Replicate the RECUR call so
+                         (if (eq? tail new-tail) lis
+                             (cons head new-tail)))
+                       (recur tail))))))   ; this one can be a tail call.
+         ;;; Another version that shares longest tail.
+         ;(define (filter pred lis)
+         ;  (receive (ans no-del?)
+         ;      ;; (recur l) returns L with (pred x) values filtered.
+         ;      ;; It also returns a flag NO-DEL? if the returned value
+         ;      ;; is EQ? to L, i.e. if it didn't have to delete anything.
+         ;      (let recur ((l l))
+         ; (if (null-list? l) (values l #t)
+         ;     (let ((x  (car l))
+         ;    (tl (cdr l)))
+         ;       (if (pred x)
+         ;    (receive (ans no-del?) (recur tl)
+         ;      (if no-del?
+         ;   (values l #t)
+         ;   (values (cons x ans) #f)))
+         ;    (receive (ans no-del?) (recur tl) ; Delete X.
+         ;      (values ans #f))))))
+         ;    ans))
+         ;(define (filter! pred lis)   ; Things are much simpler
+         ;  (let recur ((lis lis))   ; if you are willing to
+         ;    (if (pair? lis)    ; push N stack frames & do N
+         ;        (cond ((pred (car lis))  ; SET-CDR! writes, where N is
+         ;               (set-cdr! lis (recur (cdr lis))); the length of the answer.
+         ;               lis)
+         ;              (else (recur (cdr lis))))
+         ;        lis)))
+         ;;; This implementation of FILTER!
+         ;;; - doesn't cons, and uses no stack;
+         ;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are
+         ;;;   usually expensive on modern machines, and can be extremely expensive on
+         ;;;   modern Schemes (e.g., ones that have generational GC's).
+         ;;; It just zips down contiguous runs of in and out elts in LIS doing the
+         ;;; minimal number of SET-CDR!s to splice the tail of one run of ins to the
+         ;;; beginning of the next.
+         (define (filter! pred lis)
+           (check-arg procedure? pred filter!)
+           (let lp ((ans lis))
+             (cond ((null-list? ans) ans)   ; Scan looking for
+                   ((not (pred (car ans))) (lp (cdr ans))) ; first cons of result.
+                   ;; ANS is the eventual answer.
+                   ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED.
+                   ;;          Scan over a contiguous segment of the list that
+                   ;;          satisfies PRED.
+                   ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous
+                   ;;           segment of the list that *doesn't* satisfy PRED.
+                   ;;           When the segment ends, patch in a link from PREV
+                   ;;           to the start of the next good segment, and jump to
+                   ;;           SCAN-IN.
+                   (else (letrec ((scan-in (lambda (prev lis)
+                                             (if (pair? lis)
+                                                 (if (pred (car lis))
+                                                     (scan-in lis (cdr lis))
+                                                     (scan-out prev (cdr lis))))))
+                                  (scan-out (lambda (prev lis)
+                                              (let lp ((lis lis))
+                                                (if (pair? lis)
+                                                    (if (pred (car lis))
+                                                        (begin (set-cdr! prev lis)
+                                                               (scan-in lis (cdr lis)))
+                                                        (lp (cdr lis)))
+                                                    (set-cdr! prev lis))))))
+                           (scan-in ans (cdr ans))
+                           ans)))))
+         ;;; Answers share common tail with LIS where possible;
+         ;;; the technique is slightly subtle.
+         (define (partition pred lis)
+           (check-arg procedure? pred partition)
+           (let recur ((lis lis))
+             (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists.
+                 (let ((elt (car lis))
+                       (tail (cdr lis)))
+                   (receive (in out) (recur tail)
+                            (if (pred elt)
+                                (values (if (pair? out) (cons elt in) lis) out)
+                                (values in (if (pair? in) (cons elt out) lis))))))))
+         ;(define (partition! pred lis)   ; Things are much simpler
+         ;  (let recur ((lis lis))   ; if you are willing to
+         ;    (if (null-list? lis) (values lis lis) ; push N stack frames & do N
+         ;        (let ((elt (car lis)))   ; SET-CDR! writes, where N is
+         ;          (receive (in out) (recur (cdr lis)) ; the length of LIS.
+         ;            (cond ((pred elt)
+         ;                   (set-cdr! lis in)
+         ;                   (values lis out))
+         ;                  (else (set-cdr! lis out)
+         ;                        (values in lis))))))))
+         ;;; This implementation of PARTITION!
+         ;;; - doesn't cons, and uses no stack;
+         ;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are
+         ;;;   usually expensive on modern machines, and can be extremely expensive on
+         ;;;   modern Schemes (e.g., ones that have generational GC's).
+         ;;; It just zips down contiguous runs of in and out elts in LIS doing the
+         ;;; minimal number of SET-CDR!s to splice these runs together into the result
+         ;;; lists.
+         (define (partition! pred lis)
+           (check-arg procedure? pred partition!)
+           (if (null-list? lis) (values lis lis)
+               ;; This pair of loops zips down contiguous in & out runs of the
+               ;; list, splicing the runs together. The invariants are
+               ;;   SCAN-IN:  (cdr in-prev)  = LIS.
+               ;;   SCAN-OUT: (cdr out-prev) = LIS.
+               (letrec ((scan-in (lambda (in-prev out-prev lis)
+                                   (let lp ((in-prev in-prev) (lis lis))
+                                     (if (pair? lis)
+                                         (if (pred (car lis))
+                                             (lp lis (cdr lis))
+                                             (begin (set-cdr! out-prev lis)
+                                                    (scan-out in-prev lis (cdr lis))))
+                                         (set-cdr! out-prev lis))))) ; Done.
+                        (scan-out (lambda (in-prev out-prev lis)
+                                    (let lp ((out-prev out-prev) (lis lis))
+                                      (if (pair? lis)
+                                          (if (pred (car lis))
+                                              (begin (set-cdr! in-prev lis)
+                                                     (scan-in lis out-prev (cdr lis)))
+                                              (lp lis (cdr lis)))
+                                          (set-cdr! in-prev lis)))))) ; Done.
+                 ;; Crank up the scan&splice loops.
+                 (if (pred (car lis))
+                     ;; LIS begins in-list. Search for out-list's first pair.
+                     (let lp ((prev-l lis) (l (cdr lis)))
+                       (cond ((not (pair? l)) (values lis l))
+                             ((pred (car l)) (lp l (cdr l)))
+                             (else (scan-out prev-l l (cdr l))
+                                   (values lis l)))) ; Done.
+                     ;; LIS begins out-list. Search for in-list's first pair.
+                     (let lp ((prev-l lis) (l (cdr lis)))
+                       (cond ((not (pair? l)) (values l lis))
+                             ((pred (car l))
+                              (scan-in l prev-l (cdr l))
+                              (values l lis))  ; Done.
+                             (else (lp l (cdr l)))))))))
+         ;;; Inline us, please.
+         (define (remove pred l) (filter (lambda (x) (not (pred x))) l))
+         (define (remove! pred l) (filter! (lambda (x) (not (pred x))) l))
+         ;;; Here's the taxonomy for the DELETE/ASSOC/MEMBER functions.
+         ;;; (I don't actually think these are the world's most important
+         ;;; functions -- the procedural FILTER/REMOVE/FIND/FIND-TAIL variants
+         ;;; are far more general.)
+         ;;;
+         ;;; Function   Action
+         ;;; ---------------------------------------------------------------------------
+         ;;; remove pred lis  Delete by general predicate
+         ;;; delete x lis [=]  Delete by element comparison
+         ;;;
+         ;;; find pred lis  Search by general predicate
+         ;;; find-tail pred lis  Search by general predicate
+         ;;; member x lis [=]  Search by element comparison
+         ;;;
+         ;;; assoc key lis [=]  Search alist by key comparison
+         ;;; alist-delete key alist [=] Alist-delete by key comparison
+         (define (delete x lis . maybe-=)
+           (let ((= (:optional maybe-= equal?)))
+             (filter (lambda (y) (not (= x y))) lis)))
+         (define (delete! x lis . maybe-=)
+           (let ((= (:optional maybe-= equal?)))
+             (filter! (lambda (y) (not (= x y))) lis)))
+         ;;; Extended from R4RS to take an optional comparison argument.
+         (define (member x lis . maybe-=)
+           (let ((= (:optional maybe-= equal?)))
+             (find-tail (lambda (y) (= x y)) lis)))
+         ;;; R4RS, hence we don't bother to define.
+         ;;; The MEMBER and then FIND-TAIL call should definitely
+         ;;; be inlined for MEMQ & MEMV.
+         ;(define (memq    x lis) (member x lis eq?))
+         ;(define (memv    x lis) (member x lis eqv?))
+         ;;; right-duplicate deletion
+         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+         ;;; delete-duplicates delete-duplicates!
+         ;;;
+         ;;; Beware -- these are N^2 algorithms. To efficiently remove duplicates
+         ;;; in long lists, sort the list to bring duplicates together, then use a
+         ;;; linear-time algorithm to kill the dups. Or use an algorithm based on
+         ;;; element-marking. The former gives you O(n lg n), the latter is linear.
+         (define (delete-duplicates lis . maybe-=)
+           (let ((elt= (:optional maybe-= equal?)))
+             (check-arg procedure? elt= delete-duplicates)
+             (let recur ((lis lis))
+               (if (null-list? lis) lis
+                   (let* ((x (car lis))
+                          (tail (cdr lis))
+                          (new-tail (recur (delete x tail elt=))))
+                     (if (eq? tail new-tail) lis (cons x new-tail)))))))
+         (define (delete-duplicates! lis . maybe-=)
+           (let ((elt= (:optional maybe-= equal?)))
+             (check-arg procedure? elt= delete-duplicates!)
+             (let recur ((lis lis))
+               (if (null-list? lis) lis
+                   (let* ((x (car lis))
+                          (tail (cdr lis))
+                          (new-tail (recur (delete! x tail elt=))))
+                     (if (eq? tail new-tail) lis (cons x new-tail)))))))
+         ;;; alist stuff
+         ;;;;;;;;;;;;;;;
+         ;;; Extended from R4RS to take an optional comparison argument.
+         ;;; (define (assoc x lis . maybe-=)
+         ;;;   (let ((= (:optional maybe-= equal?)))
+         ;;;     (find (lambda (entry) (= x (car entry))) lis)))
+         (define (alist-cons key datum alist) (cons (cons key datum) alist))
+         (define (alist-copy alist)
+           (map (lambda (elt) (cons (car elt) (cdr elt)))
+                alist))
+         (define (alist-delete key alist . maybe-=)
+           (let ((= (:optional maybe-= equal?)))
+             (filter (lambda (elt) (not (= key (car elt)))) alist)))
+         (define (alist-delete! key alist . maybe-=)
+           (let ((= (:optional maybe-= equal?)))
+             (filter! (lambda (elt) (not (= key (car elt)))) alist)))
+         ;;; find find-tail take-while drop-while span break any every list-index
+         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+         (define (find pred list)
+           (cond ((find-tail pred list) => car)
+                 (else #f)))
+         (define (find-tail pred list)
+           (check-arg procedure? pred find-tail)
+           (let lp ((list list))
+             (and (not (null-list? list))
+                  (if (pred (car list)) list
+                      (lp (cdr list))))))
+         (define (take-while pred lis)
+           (check-arg procedure? pred take-while)
+           (let recur ((lis lis))
+             (if (null-list? lis) '()
+                 (let ((x (car lis)))
+                   (if (pred x)
+                       (cons x (recur (cdr lis)))
+                       '())))))
+         (define (drop-while pred lis)
+           (check-arg procedure? pred drop-while)
+           (let lp ((lis lis))
+             (if (null-list? lis) '()
+                 (if (pred (car lis))
+                     (lp (cdr lis))
+                     lis))))
+         (define (take-while! pred lis)
+           (check-arg procedure? pred take-while!)
+           (if (or (null-list? lis) (not (pred (car lis)))) '()
+               (begin (let lp ((prev lis) (rest (cdr lis)))
+                        (if (pair? rest)
+                            (let ((x (car rest)))
+                              (if (pred x) (lp rest (cdr rest))
+                                  (set-cdr! prev '())))))
+                      lis)))
+         (define (span pred lis)
+           (check-arg procedure? pred span)
+           (let recur ((lis lis))
+             (if (null-list? lis) (values '() '())
+                 (let ((x (car lis)))
+                   (if (pred x)
+                       (receive (prefix suffix) (recur (cdr lis))
+                                (values (cons x prefix) suffix))
+                       (values '() lis))))))
+         (define (span! pred lis)
+           (check-arg procedure? pred span!)
+           (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis)
+               (let ((suffix (let lp ((prev lis) (rest (cdr lis)))
+                               (if (null-list? rest) rest
+                                   (let ((x (car rest)))
+                                     (if (pred x) (lp rest (cdr rest))
+                                         (begin (set-cdr! prev '())
+                                                rest)))))))
+                 (values lis suffix))))
+         (define (break pred lis) (span (lambda (x) (not (pred x))) lis))
+         (define (break! pred lis) (span! (lambda (x) (not (pred x))) lis))
+         (define (any pred lis1 . lists)
+           (check-arg procedure? pred any)
+           (if (pair? lists)
+               ;; N-ary case
+               (receive (heads tails) (%cars+cdrs (cons lis1 lists))
+                        (and (pair? heads)
+                             (let lp ((heads heads) (tails tails))
+                               (receive (next-heads next-tails) (%cars+cdrs tails)
+                                        (if (pair? next-heads)
+                                            (or (apply pred heads) (lp next-heads next-tails))
+                                            (apply pred heads)))))) ; Last PRED app is tail call.
+               ;; Fast path
+               (and (not (null-list? lis1))
+                    (let lp ((head (car lis1)) (tail (cdr lis1)))
+                      (if (null-list? tail)
+                          (pred head)  ; Last PRED app is tail call.
+                          (or (pred head) (lp (car tail) (cdr tail))))))))
+         ;(define (every pred list)              ; Simple definition.
+         ;  (let lp ((list list))                ; Doesn't return the last PRED value.
+         ;    (or (not (pair? list))
+         ;        (and (pred (car list))
+         ;             (lp (cdr list))))))
+         (define (every pred lis1 . lists)
+           (check-arg procedure? pred every)
+           (if (pair? lists)
+               ;; N-ary case
+               (receive (heads tails) (%cars+cdrs (cons lis1 lists))
+                        (or (not (pair? heads))
+                            (let lp ((heads heads) (tails tails))
+                              (receive (next-heads next-tails) (%cars+cdrs tails)
+                                       (if (pair? next-heads)
+                                           (and (apply pred heads) (lp next-heads next-tails))
+                                           (apply pred heads)))))) ; Last PRED app is tail call.
+               ;; Fast path
+               (or (null-list? lis1)
+                   (let lp ((head (car lis1)) (tail (cdr lis1)))
+                     (if (null-list? tail)
+                         (pred head) ; Last PRED app is tail call.
+                         (and (pred head) (lp (car tail) (cdr tail))))))))
+         (define (list-index pred lis1 . lists)
+           (check-arg procedure? pred list-index)
+           (if (pair? lists)
+               ;; N-ary case
+               (let lp ((lists (cons lis1 lists)) (n 0))
+                 (receive (heads tails) (%cars+cdrs lists)
+                          (and (pair? heads)
+                               (if (apply pred heads) n
+                                   (lp tails (+ n 1))))))
+               ;; Fast path
+               (let lp ((lis lis1) (n 0))
+                 (and (not (null-list? lis))
+                      (if (pred (car lis)) n (lp (cdr lis) (+ n 1)))))))
+         ;;; Reverse
+         ;;;;;;;;;;;
+         ;R4RS, so not defined here.
+         ;(define (reverse lis) (fold cons '() lis))
+         ;(define (reverse! lis)
+         ;  (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) '() lis))
+         (define (reverse! lis)
+           (let lp ((lis lis) (ans '()))
+             (if (null-list? lis) ans
+                 (let ((tail (cdr lis)))
+                   (set-cdr! lis ans)
+                   (lp tail lis)))))
+         ;;; Lists-as-sets
+         ;;;;;;;;;;;;;;;;;
+         ;;; This is carefully tuned code; do not modify casually.
+         ;;; - It is careful to share storage when possible;
+         ;;; - Side-effecting code tries not to perform redundant writes.
+         ;;; - It tries to avoid linear-time scans in special cases where constant-time
+         ;;;   computations can be performed.
+         ;;; - It relies on similar properties from the other list-lib procs it calls.
+         ;;;   For example, it uses the fact that the implementations of MEMBER and
+         ;;;   FILTER in this source code share longest common tails between args
+         ;;;   and results to get structure sharing in the lset procedures.
+         (define (%lset2<= = lis1 lis2) (every (lambda (x) (member x lis2 =)) lis1))
+         (define (lset<= = . lists)
+           (check-arg procedure? = lset<=)
+           (or (not (pair? lists)) ; 0-ary case
+               (let lp ((s1 (car lists)) (rest (cdr lists)))
+                 (or (not (pair? rest))
+                     (let ((s2 (car rest)) (rest (cdr rest)))
+                       (and (or (eq? s2 s1) ; Fast path
+                                (%lset2<= = s1 s2)) ; Real test
+                            (lp s2 rest)))))))
+         (define (lset= = . lists)
+           (define (flip proc) (lambda (x y) (proc y x)))
+           (check-arg procedure? = lset=)
+           (or (not (pair? lists)) ; 0-ary case
+               (let lp ((s1 (car lists)) (rest (cdr lists)))
+                 (or (not (pair? rest))
+                     (let ((s2 (car rest))
+                           (rest (cdr rest)))
+                       (and (or (eq? s1 s2)            ; Fast path
+                                (and (%lset2<= = s1 s2) ; Real test
+                                     (%lset2<= (flip =) s2 s1)))
+                            (lp s2 rest)))))))
+         (define (lset-adjoin = lis . elts)
+           (check-arg procedure? = lset-adjoin)
+           (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans)))
+                 lis elts))
+         (define (lset-union = . lists)
+           (check-arg procedure? = lset-union)
+           (reduce (lambda (lis ans)  ; Compute ANS + LIS.
+                     (cond ((null? lis) ans) ; Don't copy any lists
+                           ((null? ans) lis) ; if we don't have to.
+                           ((eq? lis ans) ans)
+                           (else
+                            (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans)
+                                                        ans
+                                                        (cons elt ans)))
+                                  ans lis))))
+                   '() lists))
+         (define (lset-union! = . lists)
+           (check-arg procedure? = lset-union!)
+           (reduce (lambda (lis ans)  ; Splice new elts of LIS onto the front of ANS.
+                     (cond ((null? lis) ans) ; Don't copy any lists
+                           ((null? ans) lis) ; if we don't have to.
+                           ((eq? lis ans) ans)
+                           (else
+                            (pair-fold (lambda (pair ans)
+                                         (let ((elt (car pair)))
+                                           (if (any (lambda (x) (= x elt)) ans)
+                                               ans
+                                               (begin (set-cdr! pair ans) pair))))
+                                       ans lis))))
+                   '() lists))
+         (define (lset-intersection = lis1 . lists)
+           (check-arg procedure? = lset-intersection)
+           (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
+             (cond ((any null-list? lists) '())  ; Short cut
+                   ((null? lists) lis1)  ; Short cut
+                   (else (filter (lambda (x)
+                                   (every (lambda (lis) (member x lis =)) lists))
+                                 lis1)))))
+         (define (lset-intersection! = lis1 . lists)
+           (check-arg procedure? = lset-intersection!)
+           (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
+             (cond ((any null-list? lists) '())  ; Short cut
+                   ((null? lists) lis1)  ; Short cut
+                   (else (filter! (lambda (x)
+                                    (every (lambda (lis) (member x lis =)) lists))
+                                  lis1)))))
+         (define (lset-difference = lis1 . lists)
+           (check-arg procedure? = lset-difference)
+           (let ((lists (filter pair? lists))) ; Throw out empty lists.
+             (cond ((null? lists) lis1) ; Short cut
+                   ((memq lis1 lists) '()) ; Short cut
+                   (else (filter (lambda (x)
+                                   (every (lambda (lis) (not (member x lis =)))
+                                          lists))
+                                 lis1)))))
+         (define (lset-difference! = lis1 . lists)
+           (check-arg procedure? = lset-difference!)
+           (let ((lists (filter pair? lists))) ; Throw out empty lists.
+             (cond ((null? lists) lis1) ; Short cut
+                   ((memq lis1 lists) '()) ; Short cut
+                   (else (filter! (lambda (x)
+                                    (every (lambda (lis) (not (member x lis =)))
+                                           lists))
+                                  lis1)))))
+         (define (lset-xor = . lists)
+           (check-arg procedure? = lset-xor)
+           (reduce (lambda (b a)   ; Compute A xor B:
+                     ;; Note that this code relies on the constant-time
+                     ;; short-cuts provided by LSET-DIFF+INTERSECTION,
+                     ;; LSET-DIFFERENCE & APPEND to provide constant-time short
+                     ;; cuts for the cases A = (), B = (), and A eq? B. It takes
+                     ;; a careful case analysis to see it, but it's carefully
+                     ;; built in.
+                     ;; Compute a-b and a^b, then compute b-(a^b) and
+                     ;; cons it onto the front of a-b.
+                     (receive (a-b a-int-b) (lset-diff+intersection = a b)
+                              (cond ((null? a-b) (lset-difference = b a))
+                                    ((null? a-int-b) (append b a))
+                                    (else (fold (lambda (xb ans)
+                                                  (if (member xb a-int-b =) ans (cons xb ans)))
+                                                a-b
+                                                b)))))
+                   '() lists))
+         (define (lset-xor! = . lists)
+           (check-arg procedure? = lset-xor!)
+           (reduce (lambda (b a)   ; Compute A xor B:
+                     ;; Note that this code relies on the constant-time
+                     ;; short-cuts provided by LSET-DIFF+INTERSECTION,
+                     ;; LSET-DIFFERENCE & APPEND to provide constant-time short
+                     ;; cuts for the cases A = (), B = (), and A eq? B. It takes
+                     ;; a careful case analysis to see it, but it's carefully
+                     ;; built in.
+                     ;; Compute a-b and a^b, then compute b-(a^b) and
+                     ;; cons it onto the front of a-b.
+                     (receive (a-b a-int-b) (lset-diff+intersection! = a b)
+                              (cond ((null? a-b) (lset-difference! = b a))
+                                    ((null? a-int-b) (append! b a))
+                                    (else (pair-fold (lambda (b-pair ans)
+                                                       (if (member (car b-pair) a-int-b =) ans
+                                                           (begin (set-cdr! b-pair ans) b-pair)))
+                                                     a-b
+                                                     b)))))
+                   '() lists))
+         (define (lset-diff+intersection = lis1 . lists)
+           (check-arg procedure? = lset-diff+intersection)
+           (cond ((every null-list? lists) (values lis1 '())) ; Short cut
+                 ((memq lis1 lists) (values '() lis1)) ; Short cut
+                 (else (partition (lambda (elt)
+                                    (not (any (lambda (lis) (member elt lis =))
+                                              lists)))
+                                  lis1))))
+         (define (lset-diff+intersection! = lis1 . lists)
+           (check-arg procedure? = lset-diff+intersection!)
+           (cond ((every null-list? lists) (values lis1 '())) ; Short cut
+                 ((memq lis1 lists) (values '() lis1)) ; Short cut
+                 (else (partition! (lambda (elt)
+                                     (not (any (lambda (lis) (member elt lis =))
+                                               lists)))
+                                   lis1)))))
+  (export
+   xcons tree-copy make-list list-tabulate cons* list-copy
+   proper-list? circular-list? dotted-list? not-pair? null-list? list=
+   circular-list length+
+   iota
+   first second third fourth fifth sixth seventh eighth ninth tenth
+   car+cdr
+   take drop
+   take-right drop-right
+   take! drop-right!
+   split-at split-at!
+   last last-pair
+   zip unzip1 unzip2 unzip3 unzip4 unzip5
+   count
+   append! append-reverse append-reverse! concatenate concatenate!
+   unfold fold pair-fold reduce
+   unfold-right fold-right pair-fold-right reduce-right
+   append-map append-map! map! pair-for-each filter-map map-in-order
+   filter partition remove
+   filter! partition! remove!
+   find find-tail any every list-index
+   take-while drop-while take-while!
+   span break span! break!
+   delete delete!
+   alist-cons alist-copy
+   delete-duplicates delete-duplicates!
+   alist-delete alist-delete!
+   reverse!
+   lset<= lset= lset-adjoin
+   lset-union lset-intersection lset-difference lset-xor lset-diff+intersection
+   lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection!
+   map for-each member assoc))