home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / seq.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  76.1 KB  |  2,297 lines
  1. ;;; -*- Log: code.log; Package: Lisp -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: seq.lisp,v 1.10 91/10/01 16:12:59 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Functions to implement generic sequences for Spice Lisp.
  15. ;;; Written by Skef Wholey.
  16. ;;; Fixed up by Jim Muller on Friday the 13th, January, 1984.
  17. ;;; Gone over again by Bill Chiles.  Next?
  18. ;;;
  19. ;;; Be careful when modifying code.  A lot of the structure of the code is
  20. ;;; affected by the fact that compiler transforms use the lower level support
  21. ;;; functions.  If transforms are written for some sequence operation, note
  22. ;;; how the end argument is handled in other operations with transforms.
  23.  
  24. (in-package 'lisp)
  25. (export '(elt subseq copy-seq coerce
  26.       length reverse nreverse make-sequence concatenate map some every
  27.       notany notevery reduce fill replace remove remove-if remove-if-not
  28.       delete delete-if delete-if-not remove-duplicates delete-duplicates
  29.       substitute substitute-if substitute-if-not nsubstitute nsubstitute-if
  30.       nsubstitute-if-not find find-if find-if-not position position-if
  31.       position-if-not count count-if count-if-not mismatch search
  32.           identity)) ; Yep, thet's whar it is.
  33.  
  34.       
  35. ;;; Spice-Lisp specific stuff and utilities:
  36.       
  37. (eval-when (compile)
  38.  
  39. ;;; Seq-Dispatch does an efficient type-dispatch on the given Sequence.
  40.  
  41. (defmacro seq-dispatch (sequence list-form array-form)
  42.   `(if (listp ,sequence)
  43.        ,list-form
  44.        ,array-form))
  45.  
  46. (defmacro elt-slice (sequences n)
  47.   "Returns a list of the Nth element of each of the sequences.  Used by MAP
  48.    and friends."
  49.   `(mapcar #'(lambda (seq) (elt seq ,n)) ,sequences))
  50.  
  51. (defmacro make-sequence-like (sequence length)
  52.   "Returns a sequence of the same type as SEQUENCE and the given LENGTH."
  53.   `(make-sequence-of-type (type-of ,sequence) ,length))
  54.  
  55. (defmacro type-specifier-atom (type)
  56.   "Returns the broad class of which TYPE is a specific subclass."
  57.   `(if (atom ,type) ,type (car ,type)))
  58.  
  59. ) ; eval-when
  60.  
  61.  
  62.  
  63.  
  64. ;;; RESULT-TYPE-OR-LOSE  --  Internal
  65. ;;;
  66. ;;;    Given an arbitrary type specifier, return a sane sequence type specifier
  67. ;;; that we can directly match.
  68. ;;;
  69. (defun result-type-or-lose (type &optional nil-ok)
  70.   (cond
  71.    ((subtypep type 'nil)
  72.     (if nil-ok
  73.     nil
  74.     (error "NIL output type invalid for this sequence function.")))
  75.    ((dolist (seq-type '(list bit-vector string vector) nil)
  76.       (when (subtypep type seq-type)
  77.     (return seq-type))))
  78.    (t
  79.     (error "~S is a bad type specifier for sequence functions." type))))
  80.  
  81.   
  82. (defun make-sequence-of-type (type length)
  83.   "Returns a sequence of the given TYPE and LENGTH."
  84.   (declare (fixnum length))
  85.   (case (type-specifier-atom type)
  86.     (list (make-list length))
  87.     ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2)))
  88.     ((string simple-string base-string simple-base-string)
  89.      (make-string length))
  90.     (simple-vector (make-array length))
  91.     ((array simple-array vector)
  92.      (if (listp type)
  93.      (make-array length :element-type (cadr type))
  94.      (make-array length)))
  95.     (t
  96.      (make-sequence-of-type (result-type-or-lose type) length))))
  97.   
  98. (defun elt (sequence index)
  99.   "Returns the element of SEQUENCE specified by INDEX."
  100.   (etypecase sequence
  101.     (list
  102.      (do ((count index (1- count)))
  103.      ((= count 0) (car sequence))
  104.        (declare (fixnum count))
  105.        (if (atom sequence)
  106.        (error "~S: index too large." index)
  107.        (setq sequence (cdr sequence)))))
  108.     (vector
  109.      (when (>= index (length sequence))
  110.        (error "~S: index too large." index))
  111.      (aref sequence index))))
  112.  
  113. (defun %setelt (sequence index newval)
  114.   "Store NEWVAL as the component of SEQUENCE specified by INDEX."
  115.   (etypecase sequence
  116.     (list
  117.      (do ((count index (1- count))
  118.       (seq sequence))
  119.      ((= count 0) (rplaca seq newval) sequence)
  120.        (declare (fixnum count))
  121.        (if (atom (cdr seq))
  122.        (error "~S: index too large." index)
  123.        (setq seq (cdr seq)))))
  124.     (vector
  125.      (when (>= index (length sequence))
  126.        (error "~S: index too large." index))
  127.      (setf (aref sequence index) newval))))
  128.  
  129.  
  130. (defun length (sequence)
  131.   "Returns an integer that is the length of SEQUENCE."
  132.   (etypecase sequence
  133.     (vector (length (truly-the vector sequence)))
  134.     (list (length (truly-the list sequence)))))
  135.  
  136. (defun make-sequence (type length &key (initial-element NIL iep))
  137.   "Returns a sequence of the given Type and Length, with elements initialized
  138.   to :Initial-Element."
  139.   (declare (fixnum length))
  140.   (let ((type (kernel::type-expand type)))
  141.     (cond ((subtypep type 'list)
  142.        (make-list length :initial-element initial-element))
  143.       ((subtypep type 'string)
  144.        (if iep
  145.            (make-string length :initial-element initial-element)
  146.            (make-string length)))
  147.       ((subtypep type 'simple-vector)
  148.        (make-array length :initial-element initial-element))
  149.       ((subtypep type 'bit-vector)
  150.        (if iep
  151.            (make-array length :element-type '(mod 2)
  152.                :initial-element initial-element)
  153.            (make-array length :element-type '(mod 2))))
  154.       ((subtypep type 'vector)
  155.        (if (listp type)
  156.            (if iep
  157.            (make-array length :element-type (cadr type)
  158.                    :initial-element initial-element)
  159.            (make-array length :element-type (cadr type)
  160.                    :initial-element
  161.                    (if (subtypep (cadr type) 'number)
  162.                    0
  163.                    NIL)))
  164.            (make-array length :initial-element initial-element)))
  165.       (t (error "~S is a bad type specifier for sequences." type)))))
  166.  
  167.  
  168.  
  169. ;;; Subseq:
  170. ;;;
  171. ;;; The support routines for SUBSEQ are used by compiler transforms, so we
  172. ;;; worry about dealing with end being supplied as or defaulting to nil
  173. ;;; at this level.
  174.  
  175. (defun vector-subseq* (sequence start &optional end)
  176.   (declare (vector sequence) (fixnum start))
  177.   (when (null end) (setf end (length sequence)))
  178.   (do ((old-index start (1+ old-index))
  179.        (new-index 0 (1+ new-index))
  180.        (copy (make-sequence-like sequence (- end start))))
  181.       ((= old-index end) copy)
  182.     (declare (fixnum old-index new-index))
  183.     (setf (aref copy new-index) (aref sequence old-index))))
  184.  
  185. (defun list-subseq* (sequence start &optional end)
  186.   (declare (list sequence) (fixnum start))
  187.   (if (and end (>= start (the fixnum end)))
  188.       ()
  189.       (let* ((groveled (nthcdr start sequence))
  190.          (result (list (car groveled))))
  191.     (if groveled
  192.         (do ((list (cdr groveled) (cdr list))
  193.          (splice result (cdr (rplacd splice (list (car list)))))
  194.          (index (1+ start) (1+ index)))
  195.         ((or (atom list) (and end (= index (the fixnum end))))
  196.          result)
  197.           (declare (fixnum index)))
  198.         ()))))
  199.  
  200. ;;; SUBSEQ cannot default end to the length of sequence since it is not
  201. ;;; an error to supply nil for its value.  We must test for end being nil
  202. ;;; in the body of the function, and this is actually done in the support
  203. ;;; routines for other reasons (see above).
  204. (defun subseq (sequence start &optional end)
  205.   "Returns a copy of a subsequence of SEQUENCE starting with element number 
  206.    START and continuing to the end of SEQUENCE or the optional END."
  207.   (seq-dispatch sequence
  208.         (list-subseq* sequence start end)
  209.         (vector-subseq* sequence start end)))
  210.  
  211.  
  212. ;;; Copy-seq:
  213.  
  214. (eval-when (compile eval)
  215.  
  216. (defmacro vector-copy-seq (sequence type)
  217.   `(let ((length (length (the vector ,sequence))))
  218.      (declare (fixnum length))
  219.      (do ((index 0 (1+ index))
  220.       (copy (make-sequence-of-type ,type length)))
  221.      ((= index length) copy)
  222.        (declare (fixnum index))
  223.        (setf (aref copy index) (aref ,sequence index)))))
  224.  
  225. (defmacro list-copy-seq (list)
  226.   `(if (atom ,list) '()
  227.        (let ((result (cons (car ,list) '()) ))
  228.      (do ((x (cdr ,list) (cdr x))
  229.           (splice result
  230.               (cdr (rplacd splice (cons (car x) '() ))) ))
  231.          ((atom x) (unless (null x)
  232.                    (rplacd splice x))
  233.                result)))))
  234.  
  235. )
  236.  
  237. (defun copy-seq (sequence)
  238.   "Returns a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ."
  239.   (seq-dispatch sequence
  240.         (list-copy-seq* sequence)
  241.         (vector-copy-seq* sequence)))
  242.  
  243. ;;; Internal Frobs:
  244.  
  245. (defun list-copy-seq* (sequence)
  246.   (list-copy-seq sequence))
  247.  
  248. (defun vector-copy-seq* (sequence)
  249.   (vector-copy-seq sequence (type-of sequence)))
  250.  
  251.  
  252. ;;; Fill:
  253.  
  254. (eval-when (compile eval)
  255.  
  256. (defmacro vector-fill (sequence item start end)
  257.   `(do ((index ,start (1+ index)))
  258.        ((= index (the fixnum ,end)) ,sequence)
  259.      (declare (fixnum index))
  260.      (setf (aref ,sequence index) ,item)))
  261.  
  262. (defmacro list-fill (sequence item start end)
  263.   `(do ((current (nthcdr ,start ,sequence) (cdr current))
  264.     (index ,start (1+ index)))
  265.        ((or (atom current) (and end (= index (the fixnum ,end))))
  266.     sequence)
  267.      (declare (fixnum index))
  268.      (rplaca current ,item)))
  269.  
  270. )
  271.  
  272. ;;; The support routines for FILL are used by compiler transforms, so we
  273. ;;; worry about dealing with end being supplied as or defaulting to nil
  274. ;;; at this level.
  275.  
  276. (defun list-fill* (sequence item start end)
  277.   (declare (list sequence))
  278.   (list-fill sequence item start end))
  279.  
  280. (defun vector-fill* (sequence item start end)
  281.   (declare (vector sequence))
  282.   (when (null end) (setq end (length sequence)))
  283.   (vector-fill sequence item start end))
  284.  
  285. ;;; FILL cannot default end to the length of sequence since it is not
  286. ;;; an error to supply nil for its value.  We must test for end being nil
  287. ;;; in the body of the function, and this is actually done in the support
  288. ;;; routines for other reasons (see above).
  289. (defun fill (sequence item &key (start 0) end)
  290.   "Replace the specified elements of SEQUENCE with ITEM."
  291.   (seq-dispatch sequence
  292.         (list-fill* sequence item start end)
  293.         (vector-fill* sequence item start end)))
  294.  
  295.  
  296.  
  297. ;;; Replace:
  298.  
  299. (eval-when (compile eval)
  300.  
  301. ;;; If we are copying around in the same vector, be careful not to copy the
  302. ;;; same elements over repeatedly.  We do this by copying backwards.
  303. (defmacro mumble-replace-from-mumble ()
  304.   `(if (and (eq target-sequence source-sequence) (> target-start source-start))
  305.        (let ((nelts (min (- target-end target-start) (- source-end source-start))))
  306.      (do ((target-index (+ (the fixnum target-start) (the fixnum nelts) -1)
  307.                 (1- target-index))
  308.           (source-index (+ (the fixnum source-start) (the fixnum nelts) -1)
  309.                 (1- source-index)))
  310.          ((= target-index (the fixnum (1- target-start))) target-sequence)
  311.        (declare (fixnum target-index source-index))
  312.        (setf (aref target-sequence target-index)
  313.          (aref source-sequence source-index))))
  314.        (do ((target-index target-start (1+ target-index))
  315.         (source-index source-start (1+ source-index)))
  316.        ((or (= target-index (the fixnum target-end))
  317.         (= source-index (the fixnum source-end)))
  318.         target-sequence)
  319.      (declare (fixnum target-index source-index))
  320.      (setf (aref target-sequence target-index)
  321.            (aref source-sequence source-index)))))
  322.  
  323. (defmacro list-replace-from-list ()
  324.   `(if (and (eq target-sequence source-sequence) (> target-start source-start))
  325.        (let ((new-elts (subseq source-sequence source-start
  326.                    (+ (the fixnum source-start)
  327.                   (the fixnum
  328.                        (min (- (the fixnum target-end)
  329.                            (the fixnum target-start))
  330.                         (- (the fixnum source-end)
  331.                            (the fixnum source-start))))))))
  332.      (do ((n new-elts (cdr n))
  333.           (o (nthcdr target-start target-sequence) (cdr o)))
  334.          ((null n) target-sequence)
  335.        (rplaca o (car n))))
  336.        (do ((target-index target-start (1+ target-index))
  337.         (source-index source-start (1+ source-index))
  338.         (target-sequence-ref (nthcdr target-start target-sequence)
  339.                  (cdr target-sequence-ref))
  340.         (source-sequence-ref (nthcdr source-start source-sequence)
  341.                  (cdr source-sequence-ref)))
  342.        ((or (= target-index (the fixnum target-end))
  343.         (= source-index (the fixnum source-end))
  344.         (null target-sequence-ref) (null source-sequence-ref))
  345.         target-sequence)
  346.      (declare (fixnum target-index source-index))
  347.      (rplaca target-sequence-ref (car source-sequence-ref)))))
  348.  
  349. (defmacro list-replace-from-mumble ()
  350.   `(do ((target-index target-start (1+ target-index))
  351.     (source-index source-start (1+ source-index))
  352.     (target-sequence-ref (nthcdr target-start target-sequence)
  353.                  (cdr target-sequence-ref)))
  354.        ((or (= target-index (the fixnum target-end))
  355.         (= source-index (the fixnum source-end))
  356.         (null target-sequence-ref))
  357.     target-sequence)
  358.      (declare (fixnum source-index target-index))
  359.      (rplaca target-sequence-ref (aref source-sequence source-index))))
  360.  
  361. (defmacro mumble-replace-from-list ()
  362.   `(do ((target-index target-start (1+ target-index))
  363.     (source-index source-start (1+ source-index))
  364.     (source-sequence (nthcdr source-start source-sequence)
  365.              (cdr source-sequence)))
  366.        ((or (= target-index (the fixnum target-end))
  367.         (= source-index (the fixnum source-end))
  368.         (null source-sequence))
  369.     target-sequence)
  370.      (declare (fixnum target-index source-index))
  371.      (setf (aref target-sequence target-index) (car source-sequence))))
  372.  
  373. ) ; eval-when
  374.  
  375. ;;; The support routines for REPLACE are used by compiler transforms, so we
  376. ;;; worry about dealing with end being supplied as or defaulting to nil
  377. ;;; at this level.
  378.  
  379. (defun list-replace-from-list* (target-sequence source-sequence target-start
  380.                 target-end source-start source-end)
  381.   (when (null target-end) (setq target-end (length target-sequence)))
  382.   (when (null source-end) (setq source-end (length source-sequence)))
  383.   (list-replace-from-list))
  384.  
  385. (defun list-replace-from-vector* (target-sequence source-sequence target-start
  386.                   target-end source-start source-end)
  387.   (when (null target-end) (setq target-end (length target-sequence)))
  388.   (when (null source-end) (setq source-end (length source-sequence)))
  389.   (list-replace-from-mumble))
  390.  
  391. (defun vector-replace-from-list* (target-sequence source-sequence target-start
  392.                   target-end source-start source-end)
  393.   (when (null target-end) (setq target-end (length target-sequence)))
  394.   (when (null source-end) (setq source-end (length source-sequence)))
  395.   (mumble-replace-from-list))
  396.  
  397. (defun vector-replace-from-vector* (target-sequence source-sequence
  398.                     target-start target-end source-start
  399.                     source-end)
  400.   (when (null target-end) (setq target-end (length target-sequence)))
  401.   (when (null source-end) (setq source-end (length source-sequence)))
  402.   (mumble-replace-from-mumble))
  403.  
  404. ;;; REPLACE cannot default end arguments to the length of sequence since it
  405. ;;; is not an error to supply nil for their values.  We must test for ends
  406. ;;; being nil in the body of the function.
  407. (defun replace (target-sequence source-sequence &key
  408.             ((:start1 target-start) 0)
  409.         ((:end1 target-end))
  410.         ((:start2 source-start) 0)
  411.         ((:end2 source-end)))
  412.   "The target sequence is destructively modified by copying successive
  413.    elements into it from the source sequence."
  414.   (unless target-end (setq target-end (length target-sequence)))
  415.   (unless source-end (setq source-end (length source-sequence)))
  416.   (seq-dispatch target-sequence
  417.         (seq-dispatch source-sequence
  418.                   (list-replace-from-list)
  419.                   (list-replace-from-mumble))
  420.         (seq-dispatch source-sequence
  421.                   (mumble-replace-from-list)
  422.                   (mumble-replace-from-mumble))))
  423.  
  424.  
  425. ;;; Reverse:
  426.  
  427. (eval-when (compile eval)
  428.  
  429. (defmacro vector-reverse (sequence type)
  430.   `(let ((length (length ,sequence)))
  431.      (declare (fixnum length))
  432.      (do ((forward-index 0 (1+ forward-index))
  433.       (backward-index (1- length) (1- backward-index))
  434.       (new-sequence (make-sequence-of-type ,type length)))
  435.      ((= forward-index length) new-sequence)
  436.        (declare (fixnum forward-index backward-index))
  437.        (setf (aref new-sequence forward-index)
  438.          (aref ,sequence backward-index)))))
  439.  
  440. (defmacro list-reverse-macro (sequence)
  441.   `(do ((new-list ()))
  442.        ((atom ,sequence) new-list)
  443.      (push (pop ,sequence) new-list)))
  444.  
  445. )
  446.  
  447. (defun reverse (sequence)
  448.   "Returns a new sequence containing the same elements but in reverse order."
  449.   (seq-dispatch sequence
  450.         (list-reverse* sequence)
  451.         (vector-reverse* sequence)))
  452.  
  453. ;;; Internal Frobs:
  454.  
  455. (defun list-reverse* (sequence)
  456.   (list-reverse-macro sequence))
  457.  
  458. (defun vector-reverse* (sequence)
  459.   (vector-reverse sequence (type-of sequence)))
  460.  
  461.  
  462. ;;; Nreverse:
  463.  
  464. (eval-when (compile eval)
  465.  
  466. (defmacro vector-nreverse (sequence)
  467.   `(let ((length (length (the vector ,sequence))))
  468.      (declare (fixnum length))
  469.      (do ((left-index 0 (1+ left-index))
  470.       (right-index (1- length) (1- right-index))
  471.       (half-length (truncate length 2)))
  472.      ((= left-index half-length) ,sequence)
  473.        (declare (fixnum left-index right-index half-length))
  474.        (rotatef (aref ,sequence left-index)
  475.         (aref ,sequence right-index)))))
  476.  
  477. (defmacro list-nreverse-macro (list)
  478.   `(do ((1st (cdr ,list) (if (atom 1st) 1st (cdr 1st)))
  479.     (2nd ,list 1st)
  480.     (3rd '() 2nd))
  481.        ((atom 2nd) 3rd)
  482.      (rplacd 2nd 3rd)))
  483.  
  484. )
  485.  
  486.  
  487. (defun list-nreverse* (sequence)
  488.   (list-nreverse-macro sequence))
  489.  
  490. (defun vector-nreverse* (sequence)
  491.   (vector-nreverse sequence))
  492.  
  493. (defun nreverse (sequence)
  494.   "Returns a sequence of the same elements in reverse order; the argument
  495.    is destroyed."
  496.   (seq-dispatch sequence
  497.         (list-nreverse* sequence)
  498.         (vector-nreverse* sequence)))
  499.  
  500.  
  501. ;;; Concatenate:
  502.  
  503. (eval-when (compile eval)
  504.  
  505. (defmacro concatenate-to-list (sequences)
  506.   `(let ((result (list nil)))
  507.      (do ((sequences ,sequences (cdr sequences))
  508.       (splice result))
  509.      ((null sequences) (cdr result))
  510.        (let ((sequence (car sequences)))
  511.      (seq-dispatch sequence
  512.                (do ((sequence sequence (cdr sequence)))
  513.                ((atom sequence))
  514.              (setq splice
  515.                    (cdr (rplacd splice (list (car sequence))))))
  516.                (do ((index 0 (1+ index))
  517.                 (length (length sequence)))
  518.                ((= index length))
  519.              (declare (fixnum index length))
  520.              (setq splice
  521.                    (cdr (rplacd splice
  522.                         (list (aref sequence index)))))))))))
  523.  
  524. (defmacro concatenate-to-mumble (output-type-spec sequences)
  525.   `(do ((seqs ,sequences (cdr seqs))
  526.     (total-length 0)
  527.     (lengths ()))
  528.        ((null seqs)
  529.     (do ((sequences ,sequences (cdr sequences))
  530.          (lengths lengths (cdr lengths))
  531.          (index 0)
  532.          (result (make-sequence-of-type ,output-type-spec total-length)))
  533.         ((= index total-length) result)
  534.       (declare (fixnum index))
  535.       (let ((sequence (car sequences)))
  536.         (seq-dispatch sequence
  537.               (do ((sequence sequence (cdr sequence)))
  538.                   ((atom sequence))
  539.                 (setf (aref result index) (car sequence))
  540.                 (setq index (1+ index)))
  541.               (do ((jndex 0 (1+ jndex))
  542.                    (this-length (car lengths)))
  543.                   ((= jndex this-length))
  544.                 (declare (fixnum jndex this-length))
  545.                 (setf (aref result index)
  546.                   (aref sequence jndex))
  547.                 (setq index (1+ index)))))))
  548.      (let ((length (length (car seqs))))
  549.        (declare (fixnum length))
  550.        (setq lengths (nconc lengths (list length)))
  551.        (setq total-length (+ total-length length)))))
  552.  
  553. )
  554.  
  555. (defun concatenate (output-type-spec &rest sequences)
  556.   "Returns a new sequence of all the argument sequences concatenated together
  557.   which shares no structure with the original argument sequences of the
  558.   specified OUTPUT-TYPE-SPEC."
  559.   (case (type-specifier-atom output-type-spec)
  560.     ((simple-vector simple-string vector string array simple-array
  561.             bit-vector simple-bit-vector base-string
  562.             simple-base-string)
  563.      (apply #'concat-to-simple* output-type-spec sequences))
  564.     (list (apply #'concat-to-list* sequences))
  565.     (t
  566.      (apply #'concatenate (result-type-or-lose output-type-spec) sequences))))
  567.  
  568. ;;; Internal Frobs:
  569.  
  570. (defun concat-to-list* (&rest sequences)
  571.   (concatenate-to-list sequences))
  572.  
  573. (defun concat-to-simple* (type &rest sequences)
  574.   (concatenate-to-mumble type sequences))
  575.  
  576.  
  577. ;;; Map:
  578.  
  579. (eval-when (compile eval)
  580.  
  581. (defmacro map-to-list (function sequences)
  582.   `(do ((seqs more-sequences (cdr seqs))
  583.     (min-length (length first-sequence)))
  584.        ((null seqs)
  585.     (let ((result (list nil)))
  586.       (do ((index 0 (1+ index))
  587.            (splice result))
  588.           ((= index min-length) (cdr result))
  589.         (declare (fixnum index))
  590.         (setq splice
  591.           (cdr (rplacd splice
  592.                    (list (apply ,function (elt-slice ,sequences
  593.                                  index)))))))))
  594.      (declare (fixnum min-length))
  595.      (let ((length (length (car seqs))))
  596.        (declare (fixnum length))
  597.        (if (< length min-length)
  598.        (setq min-length length)))))
  599.  
  600. (defmacro map-to-simple (output-type-spec function sequences)
  601.   `(do ((seqs more-sequences (cdr seqs))
  602.     (min-length (length first-sequence)))
  603.        ((null seqs)
  604.     (do ((index 0 (1+ index))
  605.          (result (make-sequence-of-type ,output-type-spec min-length)))
  606.         ((= index min-length) result)
  607.       (declare (fixnum index))
  608.       (setf (aref result index)
  609.         (apply ,function (elt-slice ,sequences index)))))
  610.      (declare (fixnum min-length))
  611.      (let ((length (length (car seqs))))
  612.        (declare (fixnum length))
  613.        (if (< length min-length)
  614.        (setq min-length length)))))
  615.  
  616. (defmacro map-for-effect (function sequences)
  617.   `(do ((seqs more-sequences (cdr seqs))
  618.     (min-length (length first-sequence)))
  619.        ((null seqs)
  620.     (do ((index 0 (1+ index)))
  621.         ((= index min-length) nil)
  622.       (apply ,function (elt-slice ,sequences index))))
  623.      (declare (fixnum min-length))
  624.      (let ((length (length (car seqs))))
  625.        (declare (fixnum length))
  626.        (if (< length min-length)
  627.        (setq min-length length)))))
  628.  
  629.  
  630. )
  631.  
  632. (defun map (output-type-spec function first-sequence &rest more-sequences)
  633.   "FUNCTION must take as many arguments as there are sequences provided.  The 
  634.    result is a sequence such that element i is the result of applying FUNCTION
  635.    to element i of each of the argument sequences."
  636.   (let ((sequences (cons first-sequence more-sequences)))
  637.     (case (type-specifier-atom output-type-spec)
  638.       ((nil) (map-for-effect function sequences))
  639.       (list (map-to-list function sequences))
  640.       ((simple-vector simple-string vector string array simple-array
  641.             bit-vector simple-bit-vector base-string simple-base-string)
  642.        (map-to-simple output-type-spec function sequences))
  643.       (t
  644.        (apply #'map (result-type-or-lose output-type-spec t)
  645.           function sequences)))))
  646.  
  647.  
  648. ;;; Quantifiers:
  649.  
  650. (eval-when (compile eval)
  651. (defmacro defquantifier (name doc-string every-result abort-sense abort-value)
  652.   `(defun ,name (predicate first-sequence &rest more-sequences)
  653.      ,doc-string
  654.      (do ((seqs more-sequences (cdr seqs))
  655.       (length (length first-sequence))
  656.       (sequences (cons first-sequence more-sequences)))
  657.      ((null seqs)
  658.       (do ((index 0 (1+ index)))
  659.           ((= index length) ,every-result)
  660.         (declare (fixnum index))
  661.         (let ((result (apply predicate (elt-slice sequences index))))
  662.           (if ,(if abort-sense 'result '(not result))
  663.           (return ,abort-value)))))
  664.        (declare (fixnum length))
  665.        (let ((this (length (car seqs))))
  666.      (declare (fixnum this))
  667.      (if (< this length) (setq length this))))))
  668. ) ; eval-when
  669.  
  670. (defquantifier some
  671.   "PREDICATE is applied to the elements with index 0 of the sequences, then 
  672.    possibly to those with index 1, and so on.  SOME returns the first 
  673.    non-() value encountered, or () if the end of a sequence is reached."
  674.   nil t result)
  675.  
  676. (defquantifier every
  677.   "PREDICATE is applied to the elements with index 0 of the sequences, then
  678.    possibly to those with index 1, and so on.  EVERY returns () as soon
  679.    as any invocation of PREDICATE returns (), or T if every invocation
  680.    is non-()."
  681.   t nil nil)
  682.  
  683. (defquantifier notany
  684.   "PREDICATE is applied to the elements with index 0 of the sequences, then 
  685.    possibly to those with index 1, and so on.  NOTANY returns () as soon
  686.    as any invocation of PREDICATE returns a non-() value, or T if the end
  687.    of a sequence is reached."
  688.   t t nil)
  689.  
  690. (defquantifier notevery
  691.   "PREDICATE is applied to the elements with index 0 of the sequences, then
  692.    possibly to those with index 1, and so on.  NOTEVERY returns T as soon
  693.    as any invocation of PREDICATE returns (), or () if every invocation
  694.    is non-()."
  695.   nil nil t)
  696.  
  697.  
  698.  
  699. ;;; Reduce:
  700.  
  701. (eval-when (compile eval)
  702.  
  703. (defmacro mumble-reduce (function sequence key start end initial-value ref)
  704.   `(do ((index ,start (1+ index))
  705.     (value ,initial-value))
  706.        ((= index (the fixnum ,end)) value)
  707.      (declare (fixnum index))
  708.      (setq value (funcall ,function value
  709.               (apply-key ,key (,ref ,sequence index))))))
  710.  
  711. (defmacro mumble-reduce-from-end (function sequence key start end initial-value ref)
  712.   `(do ((index (1- ,end) (1- index))
  713.     (value ,initial-value)
  714.     (terminus (1- ,start)))
  715.        ((= index terminus) value)
  716.      (declare (fixnum index terminus))
  717.      (setq value (funcall ,function
  718.               (apply-key ,key (,ref ,sequence index))
  719.               value))))
  720.  
  721. (defmacro list-reduce (function sequence key start end initial-value ivp)
  722.   `(let ((sequence (nthcdr ,start ,sequence)))
  723.      (do ((count (if ,ivp ,start (1+ (the fixnum ,start)))
  724.          (1+ count))
  725.       (sequence (if ,ivp sequence (cdr sequence))
  726.             (cdr sequence))
  727.       (value (if ,ivp ,initial-value (apply-key ,key (car sequence)))
  728.          (funcall ,function value (apply-key ,key (car sequence)))))
  729.      ((= count (the fixnum ,end)) value)
  730.        (declare (fixnum count)))))
  731.  
  732. (defmacro list-reduce-from-end (function sequence key start end initial-value ivp)
  733.   `(let ((sequence (nthcdr (- (the fixnum (length ,sequence)) (the fixnum ,end))
  734.                (reverse ,sequence))))
  735.      (do ((count (if ,ivp ,start (1+ (the fixnum ,start)))
  736.          (1+ count))
  737.       (sequence (if ,ivp sequence (cdr sequence))
  738.             (cdr sequence))
  739.       (value (if ,ivp ,initial-value (apply-key ,key (car sequence)))
  740.          (funcall ,function (apply-key ,key (car sequence)) value)))
  741.      ((= count (the fixnum ,end)) value)
  742.        (declare (fixnum count)))))
  743.  
  744. )
  745.  
  746. (defun reduce (function sequence &key key from-end (start 0)
  747.             end (initial-value nil ivp))
  748.   "The specified Sequence is ``reduced'' using the given Function.
  749.   See manual for details."
  750.   (declare (fixnum start))
  751.   (when (null end) (setf end (length sequence)))
  752.   (cond ((= (the fixnum end) start)
  753.      (if ivp initial-value (funcall function)))
  754.     ((listp sequence)
  755.      (if from-end
  756.          (list-reduce-from-end function sequence key start end
  757.                    initial-value ivp)
  758.          (list-reduce function sequence key start end initial-value ivp)))
  759.     (from-end
  760.      (when (not ivp)
  761.        (setq end (1- (the fixnum end)))
  762.        (setq initial-value (apply-key key (aref sequence end))))
  763.      (mumble-reduce-from-end function sequence key start end
  764.                  initial-value aref))
  765.     (t
  766.      (when (not ivp)
  767.        (setq initial-value (apply-key key (aref sequence start)))
  768.        (setq start (1+ start)))
  769.      (mumble-reduce function sequence key start end initial-value aref))))
  770.  
  771.  
  772. ;;; Coerce:
  773.  
  774. (defun coerce (object output-type-spec)
  775.   "Coerces the Object to an object of type Output-Type-Spec."
  776.   (cond
  777.    ((typep object output-type-spec)
  778.     object)
  779.    ((eq output-type-spec 'character)
  780.     (character object))
  781.    ((eq output-type-spec 'function)
  782.     (eval `#',object))
  783.    ((numberp object)
  784.     (case output-type-spec
  785.       ((short-float single-float float)
  786.        (%single-float object))
  787.       ((double-float long-float)
  788.        (%double-float object))
  789.       (complex
  790.        (complex object))
  791.       (t
  792.        (error "~S can't be converted to type ~S." object output-type-spec))))
  793.    (t
  794.     (typecase object
  795.       (list
  796.        (case (type-specifier-atom output-type-spec)
  797.      ((simple-string string simple-base-string base-string)
  798.       (list-to-string* object))
  799.      ((simple-bit-vector bit-vector) (list-to-bit-vector* object))
  800.      ((simple-vector vector array simple-array)
  801.       (list-to-vector* object output-type-spec))
  802.      (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
  803.       (simple-string
  804.        (case (type-specifier-atom output-type-spec)
  805.      (list (vector-to-list* object))
  806.      ;; Can't coerce a string to a bit-vector!
  807.      ((simple-vector vector array simple-array)
  808.       (vector-to-vector* object output-type-spec))
  809.      (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
  810.       (simple-bit-vector
  811.        (case (type-specifier-atom output-type-spec)
  812.      (list (vector-to-list* object))
  813.      ;; Can't coerce a bit-vector to a string!
  814.      ((simple-vector vector array simple-array)
  815.       (vector-to-vector* object output-type-spec))
  816.      (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
  817.       (simple-vector
  818.        (case (type-specifier-atom output-type-spec)
  819.      (list (vector-to-list* object))
  820.      ((simple-string string simple-base-string base-string)
  821.       (vector-to-string* object))
  822.      ((simple-bit-vector bit-vector) (vector-to-bit-vector* object))
  823.      ((vector array simple-array) (vector-to-vector* object output-type-spec))
  824.      (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
  825.       (string
  826.        (case (type-specifier-atom output-type-spec)
  827.      (list (vector-to-list* object))
  828.      ((simple-string simple-base-string)
  829.       (string-to-simple-string* object))
  830.      ;; Can't coerce a string to a bit-vector!
  831.      ((simple-vector vector simple-array array)
  832.       (vector-to-vector* object output-type-spec))
  833.      (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
  834.       (bit-vector
  835.        (case (type-specifier-atom output-type-spec)
  836.      (list (vector-to-list* object))
  837.      ;; Can't coerce a bit-vector to a string!
  838.      (simple-bit-vector (bit-vector-to-simple-bit-vector* object))
  839.      ((simple-vector vector array simple-array)
  840.       (vector-to-vector* object output-type-spec))
  841.      (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
  842.       (vector
  843.        (case (type-specifier-atom output-type-spec)
  844.      (list (vector-to-list* object))
  845.      ((simple-string string base-string simple-base-string)
  846.       (vector-to-string* object))
  847.      ((simple-bit-vector bit-vector) (vector-to-bit-vector* object))
  848.      ((simple-vector vector array simple-array)
  849.       (vector-to-vector* object output-type-spec))
  850.      (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
  851.       (t (error "~S is an inappropriate type of object for coerce." object))))))
  852.  
  853.  
  854. ;;; Internal Frobs:
  855.  
  856. (macrolet ((frob (name result access src-type &optional typep)
  857.          `(defun ,name (object ,@(if typep '(type) ()))
  858.             (do* ((index 0 (1+ index))
  859.               (length (length (the ,(case src-type
  860.                           (:list 'list)
  861.                           (:vector 'vector))
  862.                            object)))
  863.               (result ,result))
  864.              ((= index length) result)
  865.               (declare (fixnum length index))
  866.               (setf (,access result index)
  867.                 ,(case src-type
  868.                    (:list '(pop object))
  869.                    (:vector '(aref object index))))))))
  870.  
  871.   (frob list-to-string* (make-string length) schar :list)
  872.  
  873.   (frob list-to-bit-vector* (make-array length :element-type '(mod 2))
  874.     sbit :list)
  875.  
  876.   (frob list-to-vector* (make-sequence-of-type type length)
  877.     aref :list t)
  878.  
  879.   (frob vector-to-vector* (make-sequence-of-type type length)
  880.     aref :vector t)
  881.  
  882.   (frob vector-to-string* (make-string length) schar :vector)
  883.  
  884.   (frob vector-to-bit-vector* (make-array length :element-type '(mod 2))
  885.     sbit :vector))
  886.  
  887. (defun vector-to-list* (object)
  888.   (let ((result (list nil))
  889.     (length (length object)))
  890.     (declare (fixnum length))
  891.     (do ((index 0 (1+ index))
  892.      (splice result (cdr splice)))
  893.     ((= index length) (cdr result))
  894.       (declare (fixnum index))
  895.       (rplacd splice (list (aref object index))))))
  896.  
  897. (defun string-to-simple-string* (object)
  898.   (if (simple-string-p object)
  899.       object
  900.       (with-array-data ((data object)
  901.             (start)
  902.             (end (length object)))
  903.     (declare (simple-string data))
  904.     (subseq data start end))))
  905.  
  906. (defun bit-vector-to-simple-bit-vector* (object)
  907.   (if (simple-bit-vector-p object)
  908.       object
  909.       (with-array-data ((data object)
  910.             (start)
  911.             (end (length object)))
  912.     (declare (simple-bit-vector data))
  913.     (subseq data start end))))
  914.  
  915.  
  916. ;;; Delete:
  917.  
  918. (eval-when (compile eval)
  919.  
  920. (defmacro mumble-delete (pred)
  921.   `(do ((index start (1+ index))
  922.     (jndex start)
  923.     (number-zapped 0))
  924.        ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
  925.     (do ((index index (1+ index))        ; copy the rest of the vector
  926.          (jndex jndex (1+ jndex)))
  927.         ((= index (the fixnum length))
  928.          (shrink-vector sequence jndex))
  929.       (declare (fixnum index jndex))
  930.       (setf (aref sequence jndex) (aref sequence index))))
  931.      (declare (fixnum index jndex number-zapped))
  932.      (setf (aref sequence jndex) (aref sequence index))
  933.      (if ,pred
  934.      (setq number-zapped (1+ number-zapped))
  935.      (setq jndex (1+ jndex)))))
  936.  
  937. (defmacro mumble-delete-from-end (pred)
  938.   `(do ((index (1- (the fixnum end)) (1- index)) ; find the losers
  939.     (number-zapped 0)
  940.     (losers ())
  941.         this-element
  942.     (terminus (1- start)))
  943.        ((or (= index terminus) (= number-zapped (the fixnum count)))
  944.     (do ((losers losers)             ; delete the losers
  945.          (index start (1+ index))
  946.          (jndex start))
  947.         ((or (null losers) (= index (the fixnum end)))
  948.          (do ((index index (1+ index))     ; copy the rest of the vector
  949.           (jndex jndex (1+ jndex)))
  950.          ((= index (the fixnum length))
  951.           (shrink-vector sequence jndex))
  952.            (declare (fixnum index jndex))
  953.            (setf (aref sequence jndex) (aref sequence index))))
  954.       (declare (fixnum index jndex))
  955.       (setf (aref sequence jndex) (aref sequence index))
  956.       (if (= index (the fixnum (car losers)))
  957.           (pop losers)
  958.           (setq jndex (1+ jndex)))))
  959.      (declare (fixnum index number-zapped terminus))
  960.      (setq this-element (aref sequence index))
  961.      (when ,pred
  962.        (setq number-zapped (1+ number-zapped))
  963.        (push index losers))))
  964.  
  965. (defmacro normal-mumble-delete ()
  966.   `(mumble-delete
  967.     (if test-not
  968.     (not (funcall test-not item (apply-key key (aref sequence index))))
  969.     (funcall test item (apply-key key (aref sequence index))))))
  970.  
  971. (defmacro normal-mumble-delete-from-end ()
  972.   `(mumble-delete-from-end
  973.     (if test-not
  974.     (not (funcall test-not item (apply-key key this-element)))
  975.     (funcall test item (apply-key key this-element)))))
  976.  
  977. (defmacro list-delete (pred)
  978.   `(let ((handle (cons nil sequence)))
  979.      (do ((current (nthcdr start sequence) (cdr current))
  980.       (previous (nthcdr start handle))
  981.       (index start (1+ index))
  982.       (number-zapped 0))
  983.      ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
  984.       (cdr handle))
  985.        (declare (fixnum index number-zapped))
  986.        (cond (,pred
  987.           (rplacd previous (cdr current))
  988.           (setq number-zapped (1+ number-zapped)))
  989.          (t
  990.           (setq previous (cdr previous)))))))
  991.  
  992. (defmacro list-delete-from-end (pred)
  993.   `(let* ((reverse (nreverse (the list sequence)))
  994.       (handle (cons nil reverse)))
  995.      (do ((current (nthcdr (- (the fixnum length) (the fixnum end)) reverse)
  996.            (cdr current))
  997.       (previous (nthcdr (- (the fixnum length) (the fixnum end)) handle))
  998.       (index start (1+ index))
  999.       (number-zapped 0))
  1000.      ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
  1001.       (nreverse (cdr handle)))
  1002.        (declare (fixnum index number-zapped))
  1003.        (cond (,pred
  1004.           (rplacd previous (cdr current))
  1005.           (setq number-zapped (1+ number-zapped)))
  1006.          (t
  1007.           (setq previous (cdr previous)))))))
  1008.  
  1009. (defmacro normal-list-delete ()
  1010.   '(list-delete
  1011.     (if test-not
  1012.     (not (funcall test-not item (apply-key key (car current))))
  1013.     (funcall test item (apply-key key (car current))))))
  1014.  
  1015. (defmacro normal-list-delete-from-end ()
  1016.   '(list-delete-from-end
  1017.     (if test-not
  1018.     (not (funcall test-not item (apply-key key (car current))))
  1019.     (funcall test item (apply-key key (car current))))))
  1020. )
  1021.  
  1022. (defun delete (item sequence &key from-end (test #'eql) test-not (start 0)
  1023.         end (count most-positive-fixnum) key)
  1024.   "Returns a sequence formed by destructively removing the specified Item from
  1025.   the given Sequence."
  1026.   (declare (fixnum start count))
  1027.   (when (null end) (setf end (length sequence)))
  1028.   (let ((length (length sequence)))
  1029.     (declare (fixnum length))
  1030.     (seq-dispatch sequence
  1031.           (if from-end
  1032.               (normal-list-delete-from-end)
  1033.               (normal-list-delete))
  1034.           (if from-end
  1035.               (normal-mumble-delete-from-end)
  1036.               (normal-mumble-delete)))))
  1037.  
  1038. (eval-when (compile eval)
  1039.  
  1040. (defmacro if-mumble-delete ()
  1041.   `(mumble-delete
  1042.     (funcall predicate (apply-key key (aref sequence index)))))
  1043.  
  1044. (defmacro if-mumble-delete-from-end ()
  1045.   `(mumble-delete-from-end
  1046.     (funcall predicate (apply-key key this-element))))
  1047.  
  1048. (defmacro if-list-delete ()
  1049.   '(list-delete
  1050.     (funcall predicate (apply-key key (car current)))))
  1051.  
  1052. (defmacro if-list-delete-from-end ()
  1053.   '(list-delete-from-end
  1054.     (funcall predicate (apply-key key (car current)))))
  1055.  
  1056. )
  1057.  
  1058. (defun delete-if (predicate sequence &key from-end (start 0) key
  1059.                 end (count most-positive-fixnum))
  1060.   "Returns a sequence formed by destructively removing the elements satisfying
  1061.   the specified Predicate from the given Sequence."
  1062.   (declare (fixnum start count))
  1063.   (when (null end) (setf end (length sequence)))
  1064.   (let ((length (length sequence)))
  1065.     (declare (fixnum length))
  1066.     (seq-dispatch sequence
  1067.           (if from-end
  1068.               (if-list-delete-from-end)
  1069.               (if-list-delete))
  1070.           (if from-end
  1071.               (if-mumble-delete-from-end)
  1072.               (if-mumble-delete)))))
  1073.  
  1074. (eval-when (compile eval)
  1075.  
  1076. (defmacro if-not-mumble-delete ()
  1077.   `(mumble-delete
  1078.     (not (funcall predicate (apply-key key (aref sequence index))))))
  1079.  
  1080. (defmacro if-not-mumble-delete-from-end ()
  1081.   `(mumble-delete-from-end
  1082.     (not (funcall predicate (apply-key key this-element)))))
  1083.  
  1084. (defmacro if-not-list-delete ()
  1085.   '(list-delete
  1086.     (not (funcall predicate (apply-key key (car current))))))
  1087.  
  1088. (defmacro if-not-list-delete-from-end ()
  1089.   '(list-delete-from-end
  1090.     (not (funcall predicate (apply-key key (car current))))))
  1091.  
  1092. )
  1093.  
  1094. (defun delete-if-not (predicate sequence &key from-end (start 0) 
  1095.             end key (count most-positive-fixnum))
  1096.   "Returns a sequence formed by destructively removing the elements not
  1097.   satisfying the specified Predicate from the given Sequence."
  1098.   (declare (fixnum start count))
  1099.   (when (null end) (setf end (length sequence)))
  1100.   (let ((length (length sequence)))
  1101.     (declare (fixnum length))
  1102.     (seq-dispatch sequence
  1103.           (if from-end
  1104.               (if-not-list-delete-from-end)
  1105.               (if-not-list-delete))
  1106.           (if from-end
  1107.               (if-not-mumble-delete-from-end)
  1108.               (if-not-mumble-delete)))))
  1109.  
  1110.  
  1111. ;;; Remove:
  1112.  
  1113. (eval-when (compile eval)
  1114.  
  1115. ;;; MUMBLE-REMOVE-MACRO does not include (removes) each element that
  1116. ;;; satisfies the predicate.
  1117. (defmacro mumble-remove-macro (bump left begin finish right pred)
  1118.   `(do ((index ,begin (,bump index))
  1119.     (result
  1120.      (do ((index ,left (,bump index))
  1121.           (result (make-sequence-like sequence length)))
  1122.          ((= index (the fixnum ,begin)) result)
  1123.        (declare (fixnum index))
  1124.        (setf (aref result index) (aref sequence index))))
  1125.     (new-index ,begin)
  1126.     (number-zapped 0)
  1127.     (this-element))
  1128.        ((or (= index (the fixnum ,finish)) (= number-zapped (the fixnum count)))
  1129.     (do ((index index (,bump index))
  1130.          (new-index new-index (,bump new-index)))
  1131.         ((= index (the fixnum ,right)) (shrink-vector result new-index))
  1132.       (declare (fixnum index new-index))
  1133.       (setf (aref result new-index) (aref sequence index))))
  1134.      (declare (fixnum index new-index number-zapped))
  1135.      (setq this-element (aref sequence index))
  1136.      (cond (,pred (setq number-zapped (1+ number-zapped)))
  1137.        (t (setf (aref result new-index) this-element)
  1138.           (setq new-index (,bump new-index))))))
  1139.  
  1140. (defmacro mumble-remove (pred)
  1141.   `(mumble-remove-macro 1+ 0 start end length ,pred))
  1142.  
  1143. (defmacro mumble-remove-from-end (pred)
  1144.   `(let ((sequence (copy-seq sequence)))
  1145.      (mumble-delete-from-end ,pred)))
  1146.  
  1147. (defmacro normal-mumble-remove ()
  1148.   `(mumble-remove 
  1149.     (if test-not
  1150.     (not (funcall test-not item (apply-key key this-element)))
  1151.     (funcall test item (apply-key key this-element)))))
  1152.  
  1153. (defmacro normal-mumble-remove-from-end ()
  1154.   `(mumble-remove-from-end 
  1155.     (if test-not
  1156.     (not (funcall test-not item (apply-key key this-element)))
  1157.     (funcall test item (apply-key key this-element)))))
  1158.  
  1159. (defmacro if-mumble-remove ()
  1160.   `(mumble-remove (funcall predicate (apply-key key this-element))))
  1161.  
  1162. (defmacro if-mumble-remove-from-end ()
  1163.   `(mumble-remove-from-end (funcall predicate (apply-key key this-element))))
  1164.  
  1165. (defmacro if-not-mumble-remove ()
  1166.   `(mumble-remove (not (funcall predicate (apply-key key this-element)))))
  1167.  
  1168. (defmacro if-not-mumble-remove-from-end ()
  1169.   `(mumble-remove-from-end
  1170.     (not (funcall predicate (apply-key key this-element)))))
  1171.  
  1172. ;;; LIST-REMOVE-MACRO does not include (removes) each element that satisfies
  1173. ;;; the predicate.
  1174. (defmacro list-remove-macro (pred reverse?)
  1175.   `(let* (,@(if reverse? '((sequence (reverse (the list sequence)))))
  1176.       (splice (list nil))
  1177.       (results (do ((index 0 (1+ index))
  1178.             (before-start splice))
  1179.                ((= index (the fixnum start)) before-start)
  1180.              (declare (fixnum index))
  1181.              (setq splice
  1182.                (cdr (rplacd splice (list (pop sequence))))))))
  1183.      (do ((index start (1+ index))
  1184.       (this-element)
  1185.       (number-zapped 0))
  1186.      ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
  1187.       (do ((index index (1+ index)))
  1188.           ((null sequence)
  1189.            ,(if reverse?
  1190.             '(nreverse (the list (cdr results)))
  1191.             '(cdr results)))
  1192.         (declare (fixnum index))
  1193.         (setq splice (cdr (rplacd splice (list (pop sequence)))))))
  1194.        (declare (fixnum index number-zapped))
  1195.        (setq this-element (pop sequence))
  1196.        (if ,pred
  1197.        (setq number-zapped (1+ number-zapped))
  1198.        (setq splice (cdr (rplacd splice (list this-element))))))))
  1199.  
  1200. (defmacro list-remove (pred)
  1201.   `(list-remove-macro ,pred nil))
  1202.  
  1203. (defmacro list-remove-from-end (pred)
  1204.   `(list-remove-macro ,pred t))
  1205.  
  1206. (defmacro normal-list-remove ()
  1207.   `(list-remove
  1208.     (if test-not
  1209.     (not (funcall test-not item (apply-key key this-element)))
  1210.     (funcall test item (apply-key key this-element)))))
  1211.  
  1212. (defmacro normal-list-remove-from-end ()
  1213.   `(list-remove-from-end
  1214.     (if test-not
  1215.     (not (funcall test-not item (apply-key key this-element)))
  1216.     (funcall test item (apply-key key this-element)))))
  1217.  
  1218. (defmacro if-list-remove ()
  1219.   `(list-remove
  1220.     (funcall predicate (apply-key key this-element))))
  1221.  
  1222. (defmacro if-list-remove-from-end ()
  1223.   `(list-remove-from-end
  1224.     (funcall predicate (apply-key key this-element))))
  1225.  
  1226. (defmacro if-not-list-remove ()
  1227.   `(list-remove
  1228.     (not (funcall predicate (apply-key key this-element)))))
  1229.  
  1230. (defmacro if-not-list-remove-from-end ()
  1231.   `(list-remove-from-end
  1232.     (not (funcall predicate (apply-key key this-element)))))
  1233.  
  1234. )
  1235.  
  1236. (defun remove (item sequence &key from-end (test #'eql) test-not (start 0)
  1237.         end (count most-positive-fixnum) key)
  1238.   "Returns a copy of SEQUENCE with elements satisfying the test (default is
  1239.    EQL) with ITEM removed."
  1240.   (declare (fixnum start count))
  1241.   (when (null end) (setf end (length sequence)))
  1242.   (let ((length (length sequence)))
  1243.     (declare (fixnum length))
  1244.     (seq-dispatch sequence
  1245.           (if from-end
  1246.               (normal-list-remove-from-end)
  1247.               (normal-list-remove))
  1248.           (if from-end
  1249.               (normal-mumble-remove-from-end)
  1250.               (normal-mumble-remove)))))
  1251.  
  1252. (defun remove-if (predicate sequence &key from-end (start 0)
  1253.             end (count most-positive-fixnum) key)
  1254.   "Returns a copy of sequence with elements such that predicate(element)
  1255.    is non-null are removed"
  1256.   (declare (fixnum start count))
  1257.   (when (null end) (setf end (length sequence)))
  1258.   (let ((length (length sequence)))
  1259.     (declare (fixnum length))
  1260.     (seq-dispatch sequence
  1261.           (if from-end
  1262.               (if-list-remove-from-end)
  1263.               (if-list-remove))
  1264.           (if from-end
  1265.               (if-mumble-remove-from-end)
  1266.               (if-mumble-remove)))))
  1267.  
  1268. (defun remove-if-not (predicate sequence &key
  1269.                 from-end (start 0) end
  1270.                 (count most-positive-fixnum) key)
  1271.   "Returns a copy of sequence with elements such that predicate(element)
  1272.    is null are removed"
  1273.   (declare (fixnum start count))
  1274.   (when (null end) (setf end (length sequence)))
  1275.   (let ((length (length sequence)))
  1276.     (declare (fixnum length))
  1277.     (seq-dispatch sequence
  1278.           (if from-end
  1279.               (if-not-list-remove-from-end)
  1280.               (if-not-list-remove))
  1281.           (if from-end
  1282.               (if-not-mumble-remove-from-end)
  1283.               (if-not-mumble-remove)))))
  1284.  
  1285.  
  1286. ;;; Remove-Duplicates:
  1287.      
  1288. ;;; Remove duplicates from a list. If from-end, remove the later duplicates,
  1289. ;;; not the earlier ones. Thus if we check from-end we don't copy an item
  1290. ;;; if we look into the already copied structure (from after :start) and see
  1291. ;;; the item. If we check from beginning we check into the rest of the 
  1292. ;;; original list up to the :end marker (this we have to do by running a
  1293. ;;; do loop down the list that far and using our test.
  1294. (defun list-remove-duplicates* (list test test-not start end key from-end)
  1295.   (declare (fixnum start))
  1296.   (let* ((result (list ())) ; Put a marker on the beginning to splice with.
  1297.      (splice result)
  1298.      (current list))
  1299.     (do ((index 0 (1+ index)))
  1300.     ((= index start))
  1301.       (declare (fixnum index))
  1302.       (setq splice (cdr (rplacd splice (list (car current)))))
  1303.       (setq current (cdr current)))
  1304.     (do ((index 0 (1+ index)))
  1305.     ((or (and end (= index (the fixnum end)))
  1306.          (atom current)))
  1307.       (declare (fixnum index))
  1308.       (if (or (and from-end 
  1309.            (not (member (apply-key key (car current))
  1310.                 (nthcdr (1+ start) result)
  1311.                 :test test
  1312.                 :test-not test-not
  1313.                 :key (if key key #'identity))))
  1314.           (and (not from-end)
  1315.            (not (do ((it (apply-key key (car current)))
  1316.                  (l (cdr current) (cdr l))
  1317.                  (i (1+ index) (1+ i)))
  1318.                 ((or (atom l) (and end (= i (the fixnum end))))
  1319.                  ())
  1320.               (declare (fixnum i))
  1321.               (if (if test-not
  1322.                   (not (funcall test-not (apply-key key (car l)) it))
  1323.                   (funcall test (apply-key key (car l)) it))
  1324.                   (return t))))))
  1325.       (setq splice (cdr (rplacd splice (list (car current))))))
  1326.       (setq current (cdr current)))
  1327.     (do ()
  1328.     ((atom current))
  1329.       (setq splice (cdr (rplacd splice (list (car current)))))
  1330.       (setq current (cdr current)))
  1331.     (cdr result)))
  1332.  
  1333.  
  1334.  
  1335. (defun vector-remove-duplicates* (vector test test-not start end key from-end
  1336.                      &optional (length (length vector)))
  1337.   (declare (vector vector) (fixnum start length))
  1338.   (when (null end) (setf end (length vector)))
  1339.   (let ((result (make-sequence-like vector length))
  1340.     (index 0)
  1341.     (jndex start))
  1342.     (declare (fixnum index jndex))
  1343.     (do ()
  1344.     ((= index start))
  1345.       (setf (aref result index) (aref vector index))
  1346.       (setq index (1+ index)))
  1347.     (do ((elt))
  1348.     ((= index end))
  1349.       (setq elt (aref vector index))
  1350.       (unless (or (and from-end
  1351.                 (position (apply-key key elt) result :start start
  1352.                :end jndex :test test :test-not test-not :key key))
  1353.           (and (not from-end)
  1354.                 (position (apply-key key elt) vector :start (1+ index)
  1355.                :end end :test test :test-not test-not :key key)))
  1356.     (setf (aref result jndex) elt)
  1357.     (setq jndex (1+ jndex)))
  1358.       (setq index (1+ index)))
  1359.     (do ()
  1360.     ((= index length))
  1361.       (setf (aref result jndex) (aref vector index))
  1362.       (setq index (1+ index))
  1363.       (setq jndex (1+ jndex)))
  1364.     (shrink-vector result jndex)))
  1365.  
  1366.  
  1367. (defun remove-duplicates (sequence &key (test #'eql) test-not (start 0) from-end
  1368.                    end key)
  1369.   "The elements of Sequence are examined, and if any two match, one is
  1370.    discarded.  The resulting sequence is returned."
  1371.   (declare (fixnum start))
  1372.   (seq-dispatch sequence
  1373.         (if sequence
  1374.             (list-remove-duplicates* sequence test test-not
  1375.                           start end key from-end))
  1376.         (vector-remove-duplicates* sequence test test-not
  1377.                         start end key from-end)))
  1378.  
  1379.  
  1380.  
  1381. ;;; Delete-Duplicates:
  1382.  
  1383.  
  1384. (defun list-delete-duplicates* (list test test-not key from-end start end)
  1385.   (declare (fixnum start))
  1386.   (let ((handle (cons nil list)))
  1387.     (do ((current (nthcdr start list) (cdr current))
  1388.      (previous (nthcdr start handle))
  1389.      (index start (1+ index)))
  1390.     ((or (and end (= index (the fixnum end))) (null current))
  1391.      (cdr handle))
  1392.       (declare (fixnum index))
  1393.       (if (do ((x (if from-end 
  1394.               (nthcdr (1+ start) handle)
  1395.               (cdr current))
  1396.           (cdr x))
  1397.            (i (1+ index) (1+ i)))
  1398.           ((or (null x)
  1399.            (and (not from-end) end (= i (the fixnum end)))
  1400.            (eq x current))
  1401.            nil)
  1402.         (declare (fixnum i))
  1403.         (if (if test-not
  1404.             (not (funcall test-not 
  1405.                   (apply-key key (car current))
  1406.                   (apply-key key (car x))))
  1407.             (funcall test 
  1408.                  (apply-key key (car current)) 
  1409.                  (apply-key key (car x))))
  1410.         (return t)))
  1411.       (rplacd previous (cdr current))
  1412.       (setq previous (cdr previous))))))
  1413.  
  1414.  
  1415. (defun vector-delete-duplicates* (vector test test-not key from-end start end 
  1416.                      &optional (length (length vector)))
  1417.   (declare (vector vector) (fixnum start length))
  1418.   (when (null end) (setf end (length vector)))
  1419.   (do ((index start (1+ index))
  1420.        (jndex start))
  1421.       ((= index end)
  1422.        (do ((index index (1+ index))        ; copy the rest of the vector
  1423.         (jndex jndex (1+ jndex)))
  1424.        ((= index length)
  1425.         (shrink-vector vector jndex)
  1426.         vector)
  1427.      (setf (aref vector jndex) (aref vector index))))
  1428.     (declare (fixnum index jndex))
  1429.     (setf (aref vector jndex) (aref vector index))
  1430.     (unless (position (apply-key key (aref vector index)) vector :key key
  1431.               :start (if from-end start (1+ index)) :test test
  1432.               :end (if from-end jndex end) :test-not test-not)
  1433.       (setq jndex (1+ jndex)))))
  1434.  
  1435.  
  1436. (defun delete-duplicates (sequence &key (test #'eql) test-not (start 0) from-end
  1437.                 end key)
  1438.   "The elements of Sequence are examined, and if any two match, one is
  1439.    discarded.  The resulting sequence, which may be formed by destroying the
  1440.    given sequence, is returned."
  1441.   (seq-dispatch sequence
  1442.     (if sequence
  1443.     (list-delete-duplicates* sequence test test-not key from-end start end))
  1444.   (vector-delete-duplicates* sequence test test-not key from-end start end)))
  1445.  
  1446. (defun list-substitute* (pred new list start end count key test test-not old)
  1447.   (declare (fixnum start end count))
  1448.   (let* ((result (list nil))
  1449.      elt
  1450.      (splice result)
  1451.      (list list))           ; Get a local list for a stepper.
  1452.     (do ((index 0 (1+ index)))
  1453.     ((= index start))
  1454.       (declare (fixnum index))
  1455.       (setq splice (cdr (rplacd splice (list (car list)))))
  1456.       (setq list (cdr list)))
  1457.     (do ((index start (1+ index)))
  1458.     ((or (= index end) (null list) (= count 0)))
  1459.       (declare (fixnum index))
  1460.       (setq elt (car list))
  1461.       (setq splice
  1462.         (cdr (rplacd splice
  1463.              (list
  1464.               (cond
  1465.                ((case pred
  1466.                    (normal
  1467.                     (if test-not
  1468.                     (not 
  1469.                      (funcall test-not old (apply-key key elt)))
  1470.                     (funcall test old (apply-key key elt))))
  1471.                    (if (funcall test (apply-key key elt)))
  1472.                    (if-not (not (funcall test (apply-key key elt)))))
  1473.                 (setq count (1- count))
  1474.                 new)
  1475.                 (t elt))))))
  1476.       (setq list (cdr list)))
  1477.     (do ()
  1478.     ((null list))
  1479.       (setq splice (cdr (rplacd splice (list (car list)))))
  1480.       (setq list (cdr list)))
  1481.     (cdr result)))
  1482.  
  1483. ;;; Replace old with new in sequence moving from left to right by incrementer
  1484. ;;; on each pass through the loop. Called by all three substitute functions.
  1485. (defun vector-substitute* (pred new sequence incrementer left right length
  1486.                start end count key test test-not old)
  1487.   (declare (fixnum start count end incrementer right))
  1488.   (let ((result (make-sequence-like sequence length))
  1489.     (index left))
  1490.     (declare (fixnum index))
  1491.     (do ()
  1492.     ((= index start))
  1493.       (setf (aref result index) (aref sequence index))
  1494.       (setq index (+ index incrementer)))
  1495.     (do ((elt))
  1496.     ((or (= index end) (= count 0)))
  1497.       (setq elt (aref sequence index))
  1498.       (setf (aref result index) 
  1499.         (cond ((case pred
  1500.               (normal
  1501.                 (if test-not
  1502.                 (not (funcall test-not old (apply-key key elt)))
  1503.                 (funcall test old (apply-key key elt))))
  1504.               (if (funcall test (apply-key key elt)))
  1505.               (if-not (not (funcall test (apply-key key elt)))))
  1506.            (setq count (1- count))
  1507.            new)
  1508.           (t elt)))
  1509.       (setq index (+ index incrementer)))
  1510.     (do ()
  1511.     ((= index right))
  1512.       (setf (aref result index) (aref sequence index))
  1513.       (setq index (+ index incrementer)))
  1514.     result))
  1515.  
  1516. (eval-when (compile eval)
  1517.  
  1518.  
  1519. (defmacro subst-dispatch (pred)
  1520.  `(if (listp sequence)
  1521.       (if from-end
  1522.       (nreverse (list-substitute* ,pred new (reverse sequence)
  1523.                       (- (the fixnum length) (the fixnum end))
  1524.                       (- (the fixnum length) (the fixnum start))
  1525.                       count key test test-not old))
  1526.       (list-substitute* ,pred new sequence start end count key test test-not
  1527.                 old))
  1528.       (if from-end
  1529.       (vector-substitute* ,pred new sequence -1 (1- (the fixnum length))
  1530.                   -1 length (1- (the fixnum end))
  1531.                   (1- (the fixnum start)) count key test test-not old)
  1532.       (vector-substitute* ,pred new sequence 1 0 length length
  1533.        start end count key test test-not old))))
  1534.  
  1535. )
  1536.  
  1537.  
  1538. ;;; Substitute:
  1539.  
  1540. (defun substitute (new old sequence &key from-end (test #'eql) test-not
  1541.            (start 0) (count most-positive-fixnum)
  1542.            end key)
  1543.   "Returns a sequence of the same kind as Sequence with the same elements
  1544.   except that all elements equal to Old are replaced with New.  See manual
  1545.   for details."
  1546.   (declare (fixnum start count))
  1547.   (when (null end) (setf end (length sequence)))
  1548.   (let ((length (length sequence)))
  1549.     (declare (fixnum length))
  1550.     (subst-dispatch 'normal)))
  1551.  
  1552.  
  1553. ;;; Substitute-If:
  1554.  
  1555. (defun substitute-if (new test sequence &key from-end (start 0)
  1556.                end (count most-positive-fixnum) key)
  1557.   "Returns a sequence of the same kind as Sequence with the same elements
  1558.   except that all elements satisfying the Test are replaced with New.  See
  1559.   manual for details."
  1560.   (declare (fixnum start count))
  1561.   (when (null end) (setf end (length sequence)))
  1562.   (let ((length (length sequence))
  1563.     test-not
  1564.     old)
  1565.     (declare (fixnum length))
  1566.     (subst-dispatch 'if)))
  1567.   
  1568.  
  1569. ;;; Substitute-If-Not:
  1570.  
  1571. (defun substitute-if-not (new test sequence &key from-end (start 0)
  1572.                end (count most-positive-fixnum) key)
  1573.   "Returns a sequence of the same kind as Sequence with the same elements
  1574.   except that all elements not satisfying the Test are replaced with New.
  1575.   See manual for details."
  1576.   (declare (fixnum start count))
  1577.   (when (null end) (setf end (length sequence)))
  1578.   (let ((length (length sequence))
  1579.     test-not
  1580.     old)
  1581.     (declare (fixnum length))
  1582.     (subst-dispatch 'if-not)))
  1583.  
  1584.  
  1585.  
  1586. ;;; NSubstitute:
  1587.  
  1588. (defun nsubstitute (new old sequence &key from-end (test #'eql) test-not 
  1589.              end (count most-positive-fixnum) key (start 0))
  1590.   "Returns a sequence of the same kind as Sequence with the same elements
  1591.   except that all elements equal to Old are replaced with New.  The Sequence
  1592.   may be destroyed.  See manual for details."
  1593.   (declare (fixnum count start))
  1594.   (when (null end) (setf end (length sequence)))
  1595.   (if (listp sequence)
  1596.       (if from-end
  1597.       (nreverse (nlist-substitute*
  1598.              new old (nreverse (the list sequence))
  1599.              test test-not start end count key))
  1600.       (nlist-substitute* new old sequence
  1601.                  test test-not start end count key))
  1602.       (if from-end
  1603.       (nvector-substitute* new old sequence -1
  1604.                    test test-not (1- end) (1- start) count key)
  1605.       (nvector-substitute* new old sequence 1
  1606.                    test test-not start end count key))))
  1607.  
  1608. (defun nlist-substitute* (new old sequence test test-not start end count key)
  1609.   (declare (fixnum start count end))
  1610.   (do ((list (nthcdr start sequence) (cdr list))
  1611.        (index start (1+ index)))
  1612.       ((or (= index end) (null list) (= count 0)) sequence)
  1613.     (declare (fixnum index))
  1614.     (when (if test-not
  1615.           (not (funcall test-not old (apply-key key (car list))))
  1616.           (funcall test old (apply-key key (car list))))
  1617.       (rplaca list new)
  1618.       (setq count (1- count)))))
  1619.  
  1620. (defun nvector-substitute* (new old sequence incrementer
  1621.                 test test-not start end count key)
  1622.   (declare (fixnum start incrementer count end))
  1623.   (do ((index start (+ index incrementer)))
  1624.       ((or (= index end) (= count 0)) sequence)
  1625.     (declare (fixnum index))
  1626.     (when (if test-not
  1627.           (not (funcall test-not old (apply-key key (aref sequence index))))
  1628.           (funcall test old (apply-key key (aref sequence index))))
  1629.       (setf (aref sequence index) new)
  1630.       (setq count (1- count)))))
  1631.  
  1632.  
  1633. ;;; NSubstitute-If:
  1634.  
  1635. (defun nsubstitute-if (new test sequence &key from-end (start 0)
  1636.                end (count most-positive-fixnum) key)
  1637.   "Returns a sequence of the same kind as Sequence with the same elements
  1638.    except that all elements satisfying the Test are replaced with New.  The
  1639.    Sequence may be destroyed.  See manual for details."
  1640.   (declare (fixnum start count))
  1641.   (let ((end (or end (length sequence))))
  1642.     (declare (fixnum end))
  1643.     (if (listp sequence)
  1644.     (if from-end
  1645.         (nreverse (nlist-substitute-if*
  1646.                new test (nreverse (the list sequence))
  1647.                start end count key))
  1648.         (nlist-substitute-if* new test sequence
  1649.                   start end count key))
  1650.     (if from-end
  1651.         (nvector-substitute-if* new test sequence -1
  1652.                     (1- end) (1- start) count key)
  1653.         (nvector-substitute-if* new test sequence 1
  1654.                     start end count key)))))
  1655.  
  1656. (defun nlist-substitute-if* (new test sequence start end count key)
  1657.   (declare (fixnum end))
  1658.   (do ((list (nthcdr start sequence) (cdr list))
  1659.        (index start (1+ index)))
  1660.       ((or (= index end) (null list) (= count 0)) sequence)
  1661.     (when (funcall test (apply-key key (car list)))
  1662.       (rplaca list new)
  1663.       (setq count (1- count)))))
  1664.  
  1665. (defun nvector-substitute-if* (new test sequence incrementer
  1666.                    start end count key)
  1667.   (do ((index start (+ index incrementer)))
  1668.       ((or (= index end) (= count 0)) sequence)
  1669.     (when (funcall test (apply-key key (aref sequence index)))
  1670.       (setf (aref sequence index) new)
  1671.       (setq count (1- count)))))
  1672.  
  1673.  
  1674. ;;; NSubstitute-If-Not:
  1675.  
  1676. (defun nsubstitute-if-not (new test sequence &key from-end (start 0)
  1677.                    end (count most-positive-fixnum) key)
  1678.   "Returns a sequence of the same kind as Sequence with the same elements
  1679.    except that all elements not satisfying the Test are replaced with New.
  1680.    The Sequence may be destroyed.  See manual for details."
  1681.   (declare (fixnum start count))
  1682.   (let ((end (or end (length sequence))))
  1683.     (declare (fixnum end))
  1684.     (if (listp sequence)
  1685.     (if from-end
  1686.         (nreverse (nlist-substitute-if-not*
  1687.                new test (nreverse (the list sequence))
  1688.                start end count key))
  1689.         (nlist-substitute-if-not* new test sequence
  1690.                       start end count key))
  1691.     (if from-end
  1692.         (nvector-substitute-if-not* new test sequence -1
  1693.                     (1- end) (1- start) count key)
  1694.         (nvector-substitute-if-not* new test sequence 1
  1695.                     start end count key)))))
  1696.  
  1697. (defun nlist-substitute-if-not* (new test sequence start end count key)
  1698.   (declare (fixnum end))
  1699.   (do ((list (nthcdr start sequence) (cdr list))
  1700.        (index start (1+ index)))
  1701.       ((or (= index end) (null list) (= count 0)) sequence)
  1702.     (when (not (funcall test (apply-key key (car list))))
  1703.       (rplaca list new)
  1704.       (setq count (1- count)))))
  1705.  
  1706. (defun nvector-substitute-if-not* (new test sequence incrementer
  1707.                    start end count key)
  1708.   (do ((index start (+ index incrementer)))
  1709.       ((or (= index end) (= count 0)) sequence)
  1710.     (when (not (funcall test (apply-key key (aref sequence index))))
  1711.       (setf (aref sequence index) new)
  1712.       (setq count (1- count)))))
  1713.  
  1714.  
  1715. ;;; Locater macros used by FIND and POSITION.
  1716.  
  1717. (eval-when (compile eval)
  1718.  
  1719. (defmacro vector-locater-macro (sequence body-form return-type)
  1720.   `(let ((incrementer (if from-end -1 1))
  1721.      (start (if from-end (1- (the fixnum end)) start))
  1722.      (end (if from-end (1- (the fixnum start)) end)))
  1723.      (declare (fixnum start end incrementer))
  1724.      (do ((index start (+ index incrementer))
  1725.       ,@(case return-type (:position nil) (:element '(current))))
  1726.      ((= index end) ())
  1727.        (declare (fixnum index))
  1728.        ,@(case return-type
  1729.        (:position nil)
  1730.        (:element `((setf current (aref ,sequence index)))))
  1731.        ,body-form)))
  1732.  
  1733. (defmacro locater-test-not (item sequence seq-type return-type)
  1734.   (let ((seq-ref (case return-type
  1735.            (:position
  1736.             (case seq-type
  1737.               (:vector `(aref ,sequence index))
  1738.               (:list `(pop ,sequence))))
  1739.            (:element 'current)))
  1740.     (return (case return-type
  1741.           (:position 'index)
  1742.           (:element 'current))))
  1743.     `(if test-not
  1744.      (if (not (funcall test-not ,item (apply-key key ,seq-ref)))
  1745.          (return ,return))
  1746.      (if (funcall test ,item (apply-key key ,seq-ref))
  1747.          (return ,return)))))
  1748.  
  1749. (defmacro vector-locater (item sequence return-type)
  1750.   `(vector-locater-macro ,sequence
  1751.              (locater-test-not ,item ,sequence :vector ,return-type)
  1752.              ,return-type))
  1753.  
  1754. (defmacro locater-if-test (test sequence seq-type return-type sense)
  1755.   (let ((seq-ref (case return-type
  1756.            (:position
  1757.             (case seq-type
  1758.               (:vector `(aref ,sequence index))
  1759.               (:list `(pop ,sequence))))
  1760.            (:element 'current)))
  1761.     (return (case return-type
  1762.           (:position 'index)
  1763.           (:element 'current))))
  1764.     (if sense
  1765.     `(if (funcall ,test (apply-key key ,seq-ref))
  1766.          (return ,return))
  1767.     `(if (not (funcall ,test (apply-key key ,seq-ref)))
  1768.          (return ,return)))))
  1769.  
  1770. (defmacro vector-locater-if-macro (test sequence return-type sense)
  1771.   `(vector-locater-macro ,sequence
  1772.              (locater-if-test ,test ,sequence :vector ,return-type ,sense)
  1773.              ,return-type))
  1774.  
  1775. (defmacro vector-locater-if (test sequence return-type)
  1776.   `(vector-locater-if-macro ,test ,sequence ,return-type t))
  1777.  
  1778. (defmacro vector-locater-if-not (test sequence return-type)
  1779.   `(vector-locater-if-macro ,test ,sequence ,return-type nil))
  1780.  
  1781.  
  1782. (defmacro list-locater-macro (sequence body-form return-type)
  1783.   `(if from-end
  1784.        (do ((sequence (nthcdr (- (the fixnum (length sequence))
  1785.                  (the fixnum end))
  1786.                   (reverse (the list ,sequence))))
  1787.         (index (1- (the fixnum end)) (1- index))
  1788.         (terminus (1- (the fixnum start)))
  1789.         ,@(case return-type (:position nil) (:element '(current))))
  1790.        ((or (= index terminus) (null sequence)) ())
  1791.      (declare (fixnum index terminus))
  1792.      ,@(case return-type
  1793.          (:position nil)
  1794.          (:element `((setf current (pop ,sequence)))))
  1795.      ,body-form)
  1796.        (do ((sequence (nthcdr start ,sequence))
  1797.         (index start (1+ index))
  1798.         ,@(case return-type (:position nil) (:element '(current))))
  1799.        ((or (= index (the fixnum end)) (null sequence)) ())
  1800.      (declare (fixnum index))
  1801.      ,@(case return-type
  1802.          (:position nil)
  1803.          (:element `((setf current (pop ,sequence)))))
  1804.      ,body-form)))
  1805.  
  1806. (defmacro list-locater (item sequence return-type)
  1807.   `(list-locater-macro ,sequence
  1808.                (locater-test-not ,item ,sequence :list ,return-type)
  1809.                ,return-type))
  1810.  
  1811. (defmacro list-locater-if-macro (test sequence return-type sense)
  1812.   `(list-locater-macro ,sequence
  1813.                (locater-if-test ,test ,sequence :list ,return-type ,sense)
  1814.                ,return-type))
  1815.  
  1816. (defmacro list-locater-if (test sequence return-type)
  1817.   `(list-locater-if-macro ,test ,sequence ,return-type t))
  1818.  
  1819. (defmacro list-locater-if-not (test sequence return-type)
  1820.   `(list-locater-if-macro ,test ,sequence ,return-type nil))
  1821.  
  1822. ) ; eval-when
  1823.  
  1824.  
  1825. ;;; Position:
  1826.  
  1827. (eval-when (compile eval)
  1828.  
  1829. (defmacro vector-position (item sequence)
  1830.   `(vector-locater ,item ,sequence :position))
  1831.  
  1832. (defmacro list-position (item sequence)
  1833.   `(list-locater ,item ,sequence :position))
  1834.  
  1835. ) ; eval-when
  1836.  
  1837.  
  1838. ;;; POSITION cannot default end to the length of sequence since it is not
  1839. ;;; an error to supply nil for its value.  We must test for end being nil
  1840. ;;; in the body of the function, and this is actually done in the support
  1841. ;;; routines for other reasons (see below).
  1842. (defun position (item sequence &key from-end (test #'eql) test-not (start 0)
  1843.           end key)
  1844.   "Returns the zero-origin index of the first element in SEQUENCE
  1845.    satisfying the test (default is EQL) with the given ITEM"
  1846.   (seq-dispatch sequence
  1847.     (list-position* item sequence from-end test test-not start end key)
  1848.     (vector-position* item sequence from-end test test-not start end key)))
  1849.  
  1850.  
  1851. ;;; The support routines for SUBSEQ are used by compiler transforms, so we
  1852. ;;; worry about dealing with end being supplied as or defaulting to nil
  1853. ;;; at this level.
  1854.  
  1855. (defun list-position* (item sequence from-end test test-not start end key)
  1856.   (declare (fixnum start))
  1857.   (when (null end) (setf end (length sequence)))
  1858.   (list-position item sequence))
  1859.  
  1860. (defun vector-position* (item sequence from-end test test-not start end key)
  1861.   (declare (fixnum start))
  1862.   (when (null end) (setf end (length sequence)))
  1863.   (vector-position item sequence))
  1864.  
  1865.  
  1866. ;;; Position-if:
  1867.  
  1868. (eval-when (compile eval)
  1869.  
  1870. (defmacro vector-position-if (test sequence)
  1871.   `(vector-locater-if ,test ,sequence :position))
  1872.  
  1873.  
  1874. (defmacro list-position-if (test sequence)
  1875.   `(list-locater-if ,test ,sequence :position))
  1876.  
  1877. )
  1878.  
  1879. (defun position-if (test sequence &key from-end (start 0) key end)
  1880.   "Returns the zero-origin index of the first element satisfying test(el)"
  1881.   (declare (fixnum start))
  1882.   (when (null end) (setf end (length sequence)))
  1883.   (seq-dispatch sequence
  1884.         (list-position-if test sequence)
  1885.         (vector-position-if test sequence)))
  1886.  
  1887.  
  1888. ;;; Position-if-not:
  1889.  
  1890. (eval-when (compile eval)
  1891.  
  1892. (defmacro vector-position-if-not (test sequence)
  1893.   `(vector-locater-if-not ,test ,sequence :position))
  1894.  
  1895. (defmacro list-position-if-not (test sequence)
  1896.   `(list-locater-if-not ,test ,sequence :position))
  1897.  
  1898. )
  1899.  
  1900. (defun position-if-not (test sequence &key from-end (start 0) key end)
  1901.   "Returns the zero-origin index of the first element not satisfying test(el)"
  1902.   (declare (fixnum start))
  1903.   (when (null end) (setf end (length sequence)))
  1904.   (seq-dispatch sequence
  1905.         (list-position-if-not test sequence)
  1906.         (vector-position-if-not test sequence)))
  1907.  
  1908.  
  1909. ;;; Find:
  1910.  
  1911. (eval-when (compile eval)
  1912.  
  1913. (defmacro vector-find (item sequence)
  1914.   `(vector-locater ,item ,sequence :element))
  1915.  
  1916. (defmacro list-find (item sequence)
  1917.   `(list-locater ,item ,sequence :element))
  1918.  
  1919. )
  1920.  
  1921. ;;; FIND cannot default end to the length of sequence since it is not
  1922. ;;; an error to supply nil for its value.  We must test for end being nil
  1923. ;;; in the body of the function, and this is actually done in the support
  1924. ;;; routines for other reasons (see above).
  1925. (defun find (item sequence &key from-end (test #'eql) test-not (start 0)
  1926.            end key)
  1927.   "Returns the first element in SEQUENCE satisfying the test (default
  1928.    is EQL) with the given ITEM"
  1929.   (declare (fixnum start))
  1930.   (seq-dispatch sequence
  1931.     (list-find* item sequence from-end test test-not start end key)
  1932.     (vector-find* item sequence from-end test test-not start end key))))
  1933.  
  1934.  
  1935. ;;; The support routines for FIND are used by compiler transforms, so we
  1936. ;;; worry about dealing with end being supplied as or defaulting to nil
  1937. ;;; at this level.
  1938.  
  1939. (defun list-find* (item sequence from-end test test-not start end key)
  1940.   (when (null end) (setf end (length sequence)))
  1941.   (list-find item sequence))
  1942.  
  1943. (defun vector-find* (item sequence from-end test test-not start end key)
  1944.   (when (null end) (setf end (length sequence)))
  1945.   (vector-find item sequence))
  1946.  
  1947.  
  1948. ;;; Find-if:
  1949.  
  1950. (eval-when (compile eval)
  1951.  
  1952. (defmacro vector-find-if (test sequence)
  1953.   `(vector-locater-if ,test ,sequence :element))
  1954.  
  1955. (defmacro list-find-if (test sequence)
  1956.   `(list-locater-if ,test ,sequence :element))
  1957.  
  1958. )
  1959.  
  1960. (defun find-if (test sequence &key from-end (start 0) end key)
  1961.   "Returns the zero-origin index of the first element satisfying the test."
  1962.   (declare (fixnum start))
  1963.   (when (null end) (setf end (length sequence)))
  1964.   (seq-dispatch sequence
  1965.         (list-find-if test sequence)
  1966.         (vector-find-if test sequence)))
  1967.  
  1968.  
  1969. ;;; Find-if-not:
  1970.  
  1971. (eval-when (compile eval)
  1972.  
  1973. (defmacro vector-find-if-not (test sequence)
  1974.   `(vector-locater-if-not ,test ,sequence :element))
  1975.  
  1976. (defmacro list-find-if-not (test sequence)
  1977.   `(list-locater-if-not ,test ,sequence :element))
  1978.  
  1979. )
  1980.  
  1981. (defun find-if-not (test sequence &key from-end (start 0) end key)
  1982.   "Returns the zero-origin index of the first element not satisfying the test."
  1983.   (declare (fixnum start))
  1984.   (when (null end) (setf end (length sequence)))
  1985.   (seq-dispatch sequence
  1986.         (list-find-if-not test sequence)
  1987.         (vector-find-if-not test sequence)))
  1988.  
  1989.  
  1990. ;;; Count:
  1991.  
  1992. (eval-when (compile eval)
  1993.  
  1994. (defmacro vector-count (item sequence)
  1995.   `(do ((index start (1+ index))
  1996.     (count 0))
  1997.        ((= index (the fixnum end)) count)
  1998.      (declare (fixnum index count))
  1999.      (if test-not
  2000.      (if (funcall test-not ,item (apply-key key (aref ,sequence index)))
  2001.          (setq count (1+ count)))
  2002.      (if (funcall test ,item (apply-key key (aref ,sequence index)))
  2003.          (setq count (1+ count))))))
  2004.  
  2005. (defmacro list-count (item sequence)
  2006.   `(do ((sequence (nthcdr start ,sequence))
  2007.     (index start (1+ index))
  2008.     (count 0))
  2009.        ((or (= index (the fixnum end)) (null sequence)) count)
  2010.      (declare (fixnum index count))
  2011.      (if test-not
  2012.      (if (funcall test-not ,item (apply-key key (pop sequence)))
  2013.          (setq count (1+ count)))
  2014.      (if (funcall test ,item (apply-key key (pop sequence)))
  2015.          (setq count (1+ count))))))
  2016.  
  2017. )
  2018.  
  2019. (defun count (item sequence &key from-end (test #'eql) test-not (start 0)
  2020.         end key)
  2021.   "Returns the number of elements in SEQUENCE satisfying a test with ITEM,
  2022.    which defaults to EQL."
  2023.   (declare (ignore from-end) (fixnum start))
  2024.   (when (null end) (setf end (length sequence)))
  2025.   (seq-dispatch sequence
  2026.         (list-count item sequence)
  2027.         (vector-count item sequence)))
  2028.  
  2029.  
  2030. ;;; Count-if:
  2031.  
  2032. (eval-when (compile eval)
  2033.  
  2034. (defmacro vector-count-if (predicate sequence)
  2035.   `(do ((index start (1+ index))
  2036.     (count 0))
  2037.        ((= index (the fixnum end)) count)
  2038.      (declare (fixnum index count))
  2039.      (if (funcall ,predicate (apply-key key (aref ,sequence index)))
  2040.      (setq count (1+ count)))))
  2041.  
  2042. (defmacro list-count-if (predicate sequence)
  2043.   `(do ((sequence (nthcdr start ,sequence))
  2044.     (index start (1+ index))
  2045.     (count 0))
  2046.        ((or (= index (the fixnum end)) (null sequence)) count)
  2047.      (declare (fixnum index count))
  2048.      (if (funcall ,predicate (apply-key key (pop sequence)))
  2049.      (setq count (1+ count)))))
  2050.  
  2051. )
  2052.  
  2053. (defun count-if (test sequence &key from-end (start 0) end key)
  2054.   "Returns the number of elements in SEQUENCE satisfying TEST(el)."
  2055.   (declare (ignore from-end) (fixnum start))
  2056.   (when (null end) (setf end (length sequence)))
  2057.   (seq-dispatch sequence
  2058.         (list-count-if test sequence)
  2059.         (vector-count-if test sequence)))
  2060.  
  2061.  
  2062. ;;; Count-if-not:
  2063.  
  2064. (eval-when (compile eval)
  2065.  
  2066. (defmacro vector-count-if-not (predicate sequence)
  2067.   `(do ((index start (1+ index))
  2068.     (count 0))
  2069.        ((= index (the fixnum end)) count)
  2070.      (declare (fixnum index count))
  2071.      (if (not (funcall ,predicate (apply-key key (aref ,sequence index))))
  2072.      (setq count (1+ count)))))
  2073.  
  2074. (defmacro list-count-if-not (predicate sequence)
  2075.   `(do ((sequence (nthcdr start ,sequence))
  2076.     (index start (1+ index))
  2077.     (count 0))
  2078.        ((or (= index (the fixnum end)) (null sequence)) count)
  2079.      (declare (fixnum index count))
  2080.      (if (not (funcall ,predicate (apply-key key (pop sequence))))
  2081.      (setq count (1+ count)))))
  2082.  
  2083. )
  2084.  
  2085. (defun count-if-not (test sequence &key from-end (start 0) end key)
  2086.   "Returns the number of elements in SEQUENCE not satisfying TEST(el)."
  2087.   (declare (ignore from-end) (fixnum start))
  2088.   (when (null end) (setf end (length sequence)))
  2089.   (seq-dispatch sequence
  2090.         (list-count-if-not test sequence)
  2091.         (vector-count-if-not test sequence)))
  2092.  
  2093.  
  2094. ;;; Mismatch utilities:
  2095.  
  2096. (eval-when (compile eval)
  2097.  
  2098.  
  2099. (defmacro match-vars (&rest body)
  2100.   `(let ((inc (if from-end -1 1))
  2101.      (start1 (if from-end (1- (the fixnum end1)) start1))
  2102.      (start2 (if from-end (1- (the fixnum end2)) start2))
  2103.      (end1 (if from-end (1- (the fixnum start1)) end1))
  2104.      (end2 (if from-end (1- (the fixnum start2)) end2)))
  2105.      (declare (fixnum inc start1 start2 end1 end2))
  2106.      ,@body))
  2107.  
  2108. (defmacro matchify-list (sequence start length end)
  2109.   `(setq ,sequence
  2110.      (if from-end
  2111.          (nthcdr (- (the fixnum ,length) (the fixnum ,start) 1)
  2112.              (reverse (the list ,sequence)))
  2113.          (nthcdr ,start ,sequence))))
  2114.  
  2115. )
  2116.  
  2117. ;;; Mismatch:
  2118.  
  2119. (eval-when (compile eval)
  2120.  
  2121. (defmacro if-mismatch (elt1 elt2)
  2122.   `(cond ((= (the fixnum index1) (the fixnum end1))
  2123.       (return (if (= (the fixnum index2) (the fixnum end2))
  2124.               nil
  2125.               (if from-end
  2126.               (1+ (the fixnum index1))
  2127.               (the fixnum index1)))))
  2128.      ((= (the fixnum index2) (the fixnum end2))
  2129.       (return (if from-end (1+ (the fixnum index1)) index1)))
  2130.      (test-not
  2131.       (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
  2132.           (return (if from-end (1+ (the fixnum index1)) index1))))
  2133.      (t (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2)))
  2134.         (return (if from-end (1+ (the fixnum index1)) index1))))))
  2135.  
  2136. (defmacro mumble-mumble-mismatch ()
  2137.   `(do ((index1 start1 (+ index1 (the fixnum inc)))
  2138.     (index2 start2 (+ index2 (the fixnum inc))))
  2139.        (())
  2140.      (declare (fixnum index1 index2))
  2141.      (if-mismatch (aref sequence1 index1) (aref sequence2 index2))))
  2142.  
  2143. (defmacro mumble-list-mismatch ()
  2144.   `(do ((index1 start1 (+ index1 (the fixnum inc)))
  2145.     (index2 start2 (+ index2 (the fixnum inc))))
  2146.        (())
  2147.      (declare (fixnum index1 index2))
  2148.      (if-mismatch (aref sequence1 index1) (pop sequence2))))
  2149.  
  2150. (defmacro list-mumble-mismatch ()
  2151.   `(do ((index1 start1 (+ index1 (the fixnum inc)))
  2152.     (index2 start2 (+ index2 (the fixnum inc))))
  2153.        (())
  2154.      (declare (fixnum index1 index2))
  2155.      (if-mismatch (pop sequence1) (aref sequence2 index2))))
  2156.  
  2157. (defmacro list-list-mismatch ()
  2158.   `(do ((index1 start1 (+ index1 (the fixnum inc)))
  2159.     (index2 start2 (+ index2 (the fixnum inc))))
  2160.        (())
  2161.      (declare (fixnum index1 index2))
  2162.      (if-mismatch (pop sequence1) (pop sequence2))))
  2163.  
  2164. )
  2165.  
  2166. (defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not 
  2167.                (start1 0) end1 (start2 0) end2 key)
  2168.   "The specified subsequences of Sequence1 and Sequence2 are compared
  2169.   element-wise.  If they are of equal length and match in every element, the
  2170.   result is Nil.  Otherwise, the result is a non-negative integer, the index
  2171.   within Sequence1 of the leftmost position at which they fail to match; or, if
  2172.   one is shorter than and a matching prefix of the other, the index within
  2173.   Sequence1 beyond the last position tested is returned.  If a non-Nil :From-End
  2174.   keyword argument is given, then one plus the index of the rightmost position in
  2175.   which the sequences differ is returned."
  2176.   (declare (fixnum start1 start2))
  2177.   (when (null end1) (setf end1 (length sequence1)))
  2178.   (when (null end2) (setf end2 (length sequence2)))
  2179.   (let ((length1 (length sequence1))
  2180.     (length2 (length sequence2)))
  2181.     (declare (fixnum length1 length2))
  2182.     (match-vars
  2183.      (seq-dispatch sequence1
  2184.       (progn (matchify-list sequence1 start1 length1 end1)
  2185.          (seq-dispatch sequence2
  2186.                (progn (matchify-list sequence2 start2 length2 end2)
  2187.                   (list-list-mismatch))
  2188.                (list-mumble-mismatch)))
  2189.       (seq-dispatch sequence2
  2190.             (progn (matchify-list sequence2 start2 length2 end2)
  2191.                (mumble-list-mismatch))
  2192.             (mumble-mumble-mismatch))))))
  2193.  
  2194.  
  2195. ;;; Search comparison functions:
  2196.  
  2197. (eval-when (compile eval)
  2198.  
  2199. ;;; Compare two elements and return if they don't match:
  2200.  
  2201. (defmacro compare-elements (elt1 elt2)
  2202.   `(if test-not
  2203.        (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
  2204.        (return nil)
  2205.        t)
  2206.        (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2)))
  2207.        (return nil)
  2208.        t)))
  2209.  
  2210. (defmacro search-compare-list-list (main sub)
  2211.   `(do ((main ,main (cdr main))
  2212.     (jndex start1 (1+ jndex))
  2213.     (sub (nthcdr start1 ,sub) (cdr sub)))
  2214.        ((or (null main) (null sub) (= (the fixnum end1) jndex))
  2215.     t)
  2216.      (declare (fixnum jndex))
  2217.      (compare-elements (car main) (car sub))))
  2218.  
  2219. (defmacro search-compare-list-vector (main sub)
  2220.   `(do ((main ,main (cdr main))
  2221.     (index start1 (1+ index)))
  2222.        ((or (null main) (= index (the fixnum end1))) t)
  2223.      (declare (fixnum index))
  2224.      (compare-elements (car main) (aref ,sub index))))
  2225.  
  2226. (defmacro search-compare-vector-list (main sub index)
  2227.   `(do ((sub (nthcdr start1 ,sub) (cdr sub))
  2228.     (jndex start1 (1+ jndex))
  2229.     (index ,index (1+ index)))
  2230.        ((or (= (the fixnum end1) jndex) (null sub)) t)
  2231.      (declare (fixnum jndex index))
  2232.      (compare-elements (aref ,main index) (car sub))))
  2233.  
  2234. (defmacro search-compare-vector-vector (main sub index)
  2235.   `(do ((index ,index (1+ index))
  2236.     (sub-index start1 (1+ sub-index)))
  2237.        ((= sub-index (the fixnum end1)) t)
  2238.      (declare (fixnum sub-index index))
  2239.      (compare-elements (aref ,main index) (aref ,sub sub-index))))
  2240.  
  2241. (defmacro search-compare (main-type main sub index)
  2242.   (if (eq main-type 'list)
  2243.       `(seq-dispatch ,sub
  2244.              (search-compare-list-list ,main ,sub)
  2245.              (search-compare-list-vector ,main ,sub))
  2246.       `(seq-dispatch ,sub
  2247.              (search-compare-vector-list ,main ,sub ,index)
  2248.              (search-compare-vector-vector ,main ,sub ,index))))
  2249.  
  2250. )
  2251.  
  2252. (eval-when (compile eval)
  2253.  
  2254. (defmacro list-search (main sub)
  2255.   `(do ((main (nthcdr start2 ,main) (cdr main))
  2256.     (index2 start2 (1+ index2))
  2257.     (terminus (- (the fixnum end2)
  2258.              (the fixnum (- (the fixnum end1)
  2259.                     (the fixnum start1)))))
  2260.     (last-match ()))
  2261.        ((> index2 terminus) last-match)
  2262.      (declare (fixnum index2 terminus))
  2263.      (if (search-compare list main ,sub index2)
  2264.      (if from-end
  2265.          (setq last-match index2)
  2266.          (return index2)))))
  2267.  
  2268.  
  2269. (defmacro vector-search (main sub)
  2270.   `(do ((index2 start2 (1+ index2))
  2271.     (terminus (- (the fixnum end2)
  2272.              (the fixnum (- (the fixnum end1)
  2273.                     (the fixnum start1)))))
  2274.     (last-match ()))
  2275.        ((> index2 terminus) last-match)
  2276.      (declare (fixnum index2 terminus))
  2277.      (if (search-compare vector ,main ,sub index2)
  2278.      (if from-end
  2279.          (setq last-match index2)
  2280.          (return index2)))))
  2281.  
  2282. )
  2283.  
  2284.  
  2285. (defun search (sequence1 sequence2 &key from-end (test #'eql) test-not 
  2286.         (start1 0) end1 (start2 0) end2 key)
  2287.   "A search is conducted using EQL for the first subsequence of sequence2 
  2288.    which element-wise matches sequence1.  If there is such a subsequence in 
  2289.    sequence2, the index of the its leftmost element is returned; 
  2290.    otherwise () is returned."
  2291.   (declare (fixnum start1 start2))
  2292.   (when (null end1) (setf end1 (length sequence1)))
  2293.   (when (null end2) (setf end2 (length sequence2)))
  2294.   (seq-dispatch sequence2
  2295.     (list-search sequence2 sequence1)
  2296.     (vector-search sequence2 sequence1)))
  2297.