source: release/1.2/source/lib/sequences.lisp @ 9796

Last change on this file since 9796 was 9796, checked in by rme, 11 years ago

Port r9786 here (fix for ticket:310 delete-/remove-duplicates bug).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 77.6 KB
Line 
1;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19;;
20;; utility functions
21;;
22;;  these probably want to be in-line
23
24(defun make-sequence-like (sequence length)
25  (seq-dispatch 
26   sequence
27   (make-list length)
28   (make-array length :element-type (array-element-type sequence))))
29
30(defun adjust-test-args (item test test-not)
31  ;; after running this "test" is the real test, a null test means "eq"
32  ;; and "test-not" is used as a flag
33  (when test-not
34    (if test 
35      (error "Both ~s and ~s keywords supplied" :test :test-not)
36      (setq test test-not)))
37  (if test
38    (if (or (eq test #'eq)
39            (eq test 'eq)
40            (and (or (eq test #'equal) (eq test 'equal))
41                 (or (fixnump item) (symbolp item))))
42      (setq test nil)
43      (if (eq test #'funcall)
44        (setq test 'funcall)))
45    (if (or (macptrp item) (and (not (fixnump item)) (numberp item)))
46      (setq test #'eql)))
47  (values test test-not))
48
49(defun adjust-key (key)
50  (and (neq key 'identity) 
51       (neq key #'identity)
52       key))
53
54(defun matchp2 (item elt test test-not key)
55  (if key
56    (setq elt (funcall key elt)))
57  (let ((res (if test
58               (if (eq test 'funcall)
59                 (funcall item elt)
60                 (funcall test item elt))
61               (eq item elt))))
62    (if test-not
63      (not res)
64      res)))
65
66;;; CTYPE is a recognizable subtype of VECTOR, which means that it's either
67;;; a) an ARRAY-CTYPE
68;;; b) a UNION-CTYPE whose leaves are ARRAY-CTYPE
69;;; c) the NIL type, which is trivially a subtype of VECTOR but isn't really
70;;;    worth considering here
71;;; d) a MEMBER-CTYPE whose members are all vectors and which therefore have
72;;;    corresponding ARRAY-CTYPEs.
73;;; Try to find the interesection of all ARRAY-CTYPEs referenced in CTYPE and
74;;;  return it.
75;;; Note that this intersection may be the null type.
76(defun simplify-vector-ctype (ctype)
77  (typecase ctype
78    (array-ctype
79     (make-array-ctype :complexp nil
80                       :element-type (array-ctype-element-type ctype)
81                       :specialized-element-type (array-ctype-specialized-element-type ctype)
82                       :dimensions '(*)))
83                                     
84    (named-ctype ctype)
85    (member-ctype
86     (apply #'type-intersection (mapcar #'(lambda (x)
87                                            (simplify-vector-ctype
88                                             (ctype-of x)))
89                                        (member-ctype-members ctype))))
90    (union-ctype
91     (apply #'type-intersection (mapcar #'simplify-vector-ctype (union-ctype-types ctype))))))
92   
93(defun make-sequence (type length &key (initial-element nil initial-element-p))
94  "Return a sequence of the given TYPE and LENGTH, with elements initialized
95  to INITIAL-ELEMENT."
96  (setq length (require-type length 'fixnum))
97  (let* ((ctype (specifier-type type)))
98    (declare (fixnum length))
99    (if (< length 0) (report-bad-arg length '(and fixnum unsigned-byte)))
100    (let ((tlength (array-ctype-length ctype)))
101      (if (and tlength (neq tlength length))
102        (error 'invalid-subtype-error
103               :datum type
104               :expected-type `(vector ,(type-specifier (array-ctype-element-type ctype)) ,length))))
105    (cond 
106          ((csubtypep ctype (specifier-type 'base-string))
107           (if initial-element-p
108             (make-string length 
109                          :element-type 'base-char
110                          :initial-element initial-element)
111             (make-string length
112                          :element-type 'base-char)))
113          ((csubtypep ctype (specifier-type 'vector))
114           (let* ((atype (simplify-vector-ctype ctype)))
115             (unless (typep atype 'array-ctype)
116               (error "Can't determine vector element-type of ~s" (type-specifier ctype)))
117             (let* ((element-type (type-specifier (array-ctype-element-type atype))))
118               (if (eq element-type '*) (setq element-type t))
119               (if initial-element-p
120                 (make-array (the fixnum length)
121                             :element-type element-type
122                             :initial-element initial-element)
123                 (make-array (the fixnum length)
124                             :element-type element-type)))))
125          ((csubtypep ctype (specifier-type 'null))
126           (unless (zerop length)
127             (error 'invalid-subtype-error :datum type :expected-type 'cons)))
128          ((csubtypep ctype (specifier-type 'cons))
129           (if (zerop length)
130             (error 'invalid-subtype-error :datum type :expected-type 'null)
131             (make-list length :initial-element initial-element)))
132          ((csubtypep ctype (specifier-type 'list))
133           (make-list length :initial-element initial-element))
134          (t (error 'invalid-subtype-error :datum  type
135                    :expected-type 'sequence)))))
136
137
138
139;;; Subseq:
140
141;;; SRC is a (SIMPLE-ARRAY * (*)), TYPECODE is its ... typecode,
142;;; START and END are fixnums and sanity-checked.
143(defun simple-1d-array-subseq (src typecode start end)
144  (declare (fixnum start end typecode))
145  (let* ((n (- end start))
146         (dest (%alloc-misc n typecode)))
147    (declare (fixnum n))
148    (if (= typecode target::subtag-simple-vector)
149      (%copy-gvector-to-gvector src start dest 0 n)
150      (ecase typecode
151        ((#.target::subtag-s8-vector
152          #.target::subtag-u8-vector)
153         (%copy-ivector-to-ivector src start dest 0 n))
154        ((#.target::subtag-s16-vector
155          #.target::subtag-u16-vector)
156         (%copy-ivector-to-ivector src
157                                   (the fixnum (+ start start))
158                                   dest
159                                   0
160                                   (the fixnum (+ n n))))
161        ((#.target::subtag-s32-vector
162          #.target::subtag-u32-vector
163          #.target::subtag-single-float-vector
164          #+32-bit-target #.target::subtag-fixnum-vector
165          #.target::subtag-simple-base-string)
166         (%copy-ivector-to-ivector src
167                                   (the fixnum (ash start 2))
168                                   dest
169                                   0
170                                   (the fixnum (ash n 2))))
171        ;; DOUBLE-FLOAT vectors have extra alignment padding on ppc32.
172        #+ppc32-target
173        (#.ppc32::subtag-double-float-vector
174         (%copy-ivector-to-ivector src
175                                   (the fixnum (+ (the fixnum (ash start 3))
176                                                  (- ppc32::misc-dfloat-offset
177                                                     ppc32::misc-data-offset)))
178                                   dest
179                                   (- ppc32::misc-dfloat-offset
180                                                     ppc32::misc-data-offset)
181                                   (the fixnum (ash n 3))))
182        #+64-bit-target
183        ((#.target::subtag-double-float-vector
184          #.target::subtag-s64-vector
185          #.target::subtag-u64-vector
186          #.target::subtag-fixnum-vector)
187         (%copy-ivector-to-ivector src
188                                   (the fixnum (ash start 3))
189                                   dest
190                                   0
191                                   (the fixnum (ash n 3))))
192        (#.target::subtag-bit-vector
193         ;; We can probably do a byte at a time if (not (logtest start 7))
194         (if (not (logtest start 7))
195           (%copy-ivector-to-ivector src
196                                     (the fixnum (ash (the fixnum (+ start 7))
197                                                      -3))
198                                     dest
199                                     0
200                                     (the fixnum (ash (the fixnum (+ n 7))
201                                                      -3)))
202           ;; Harder to optimize this case.
203           (locally  (declare (simple-bit-vector src dest)
204                              (optimize (speed 3) (safety 0)))
205             (do* ((i start (1+ i))
206                   (j 0 (1+ j)))
207                  ((= i end) dest)
208               (declare (fixnum i j))
209               (setf (sbit dest j) (sbit src i))))))))))
210
211
212(defun nthcdr-error (index list &aux (copy list))
213 "If index > length, error"
214 (dotimes (i index copy)
215   (declare (fixnum i))
216   (if copy
217     (setq copy (cdr copy))
218     (%err-disp $XACCESSNTH index list))))
219
220; slisp didn't error if end > length, or if start > end.
221(defun list-subseq* (sequence start end)
222  (declare (fixnum start end))
223  (if (= start end)
224    nil
225    (let* ((groveled (nthcdr-error start sequence))
226           (result (list (car groveled))))
227      (when groveled
228        (do ((list (cdr groveled) (cdr list))
229             (splice result (cdr (rplacd splice (list (car list)))))
230             (index (1+ start) (1+ index)))
231             ((= index end) result)
232          (declare (fixnum index))
233           ())))))
234
235; This ensures that start & end will be non-negative FIXNUMS ...
236; This implies that the address space is < 2^31 bytes, i.e., no list
237; can have a length > most-positive fixnum.  Let them report it as a
238; bug ...
239
240(defun subseq (sequence start &optional end)
241  "Return a copy of a subsequence of SEQUENCE starting with element number
242   START and continuing to the end of SEQUENCE or the optional END."
243  (setq end (check-sequence-bounds sequence start end))
244  (locally 
245      (declare (fixnum start end))
246      (seq-dispatch 
247       sequence
248       (list-subseq* sequence start end)
249       (let* ((typecode (typecode sequence)))
250         (declare (fixnum typecode))
251         (when (= typecode target::subtag-vectorH)
252           (multiple-value-bind (data offset)
253               (array-data-and-offset sequence)
254             (declare (fixnum offset))
255             (incf start offset)
256             (incf end offset)
257             (setq sequence data typecode (typecode data))))
258         (simple-1d-array-subseq sequence typecode start end)))))
259         
260
261;;; Copy-seq:
262
263(defun copy-seq (sequence)
264  "Return a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ."
265  (seq-dispatch 
266   sequence
267   (copy-list sequence)
268   (let* ((length (length sequence))
269          (subtype (element-type-subtype (array-element-type sequence)))
270          (result  (%alloc-misc length subtype))
271          )
272     (multiple-value-bind (src offset) (array-data-and-offset sequence)
273       (declare (fixnum offset))                         
274       (dotimes (i length result)
275         (declare (fixnum i))
276         (setf (uvref result i) (uvref src offset))
277         (incf offset))))))
278
279
280
281;;; Fill:
282
283(defun fill (sequence item &key (start 0) end)
284  "Replace the specified elements of SEQUENCE with ITEM.
285   !$ could be sped up by calling iv-fill, sv-fill to avoid aref overhead."
286  (setq end (check-sequence-bounds sequence start end))
287  (seq-dispatch 
288   sequence
289   (do* ((current (nthcdr start sequence) (cdr (the list current)))
290         (index start (1+ index)))
291        ((or (atom current) (= index end)) sequence)
292     (rplaca (the cons current) item))
293   (if (and (typep sequence 'ivector)
294            (eql start 0)
295            (eql end (uvsize sequence)))
296     (%init-misc item sequence)
297     (do ((index start (1+ index)))
298         ((= index end) sequence)
299       (aset sequence index item)))))
300
301;;; Replace:
302
303(defun replace (target-sequence source-sequence &key
304                                ((:start1 target-start) 0)
305                                ((:end1 target-end))
306                                ((:start2 source-start) 0)
307                                ((:end2 source-end)))
308  "The target sequence is destructively modified by copying successive
309   elements into it from the source sequence."
310  (setq target-end (check-sequence-bounds target-sequence target-start
311                                          target-end))
312  (setq source-end (check-sequence-bounds source-sequence source-start
313                                          source-end))
314  (locally (declare (fixnum target-start target-end source-start source-end))
315    (seq-dispatch 
316     target-sequence
317     (seq-dispatch 
318      source-sequence
319      (if (and (eq target-sequence source-sequence) 
320               (> target-start source-start))
321        (let ((new-elts (subseq source-sequence source-start
322                                (+ source-start
323                                   (min (- target-end target-start)
324                                        (- source-end source-start))))))
325          (do ((n new-elts (cdr n))
326               (o (nthcdr target-start target-sequence) (cdr o)))
327              ((null n) target-sequence)
328            (rplaca o (car n))))
329        (do ((target-index target-start (1+ target-index))
330             (source-index source-start (1+ source-index))
331             (target-sequence-ref (nthcdr target-start target-sequence)
332                                  (cdr target-sequence-ref))
333             (source-sequence-ref (nthcdr source-start source-sequence)
334                                  (cdr source-sequence-ref)))
335            ((or (= target-index target-end) (= source-index source-end)
336                 (null target-sequence-ref) (null source-sequence-ref))
337             target-sequence)
338          (declare (fixnum target-index source-index))
339          (rplaca target-sequence-ref (car source-sequence-ref))))
340      (do ((target-index target-start (1+ target-index))
341           (source-index source-start (1+ source-index))
342           (target-sequence-ref (nthcdr target-start target-sequence)
343                                (cdr target-sequence-ref)))
344          ((or (= target-index target-end) (= source-index source-end)
345               (null target-sequence-ref))
346           target-sequence)
347        (declare (fixnum target-index source-index))
348        (rplaca target-sequence-ref (aref source-sequence source-index))))
349     (seq-dispatch 
350      source-sequence
351      (do ((target-index target-start (1+ target-index))
352           (source-index source-start (1+ source-index))
353           (source-sequence (nthcdr source-start source-sequence)
354                            (cdr source-sequence)))
355          ((or (= target-index target-end) (= source-index source-end)
356               (null source-sequence))
357           target-sequence)
358        (declare (fixnum target-index source-index))
359        (aset target-sequence target-index (car source-sequence)))
360      ;; If we are copying around in the same vector, be careful not
361      ;; to copy the same elements over repeatedly.  We do this by
362      ;; copying backwards.
363      (if (and (eq target-sequence source-sequence) 
364               (> target-start source-start))
365        (let ((nelts (min (- target-end target-start) 
366                          (- source-end source-start))))
367          (do ((target-index (+ target-start nelts -1) (1- target-index))
368               (source-index (+ source-start nelts -1) (1- source-index)))
369              ((= target-index (1- target-start)) target-sequence)
370            (aset target-sequence target-index
371                  (aref source-sequence source-index))))
372        (do ((target-index target-start (1+ target-index))
373             (source-index source-start (1+ source-index)))
374            ((or (= target-index target-end) (= source-index source-end))
375             target-sequence)
376          (declare (fixnum target-index source-index))
377          (aset target-sequence target-index
378                (aref source-sequence source-index))))))))
379
380;;; Concatenate:
381
382
383(defun concatenate (output-type-spec &rest sequences)
384  "Return a new sequence of all the argument sequences concatenated together
385  which shares no structure with the original argument sequences of the
386  specified OUTPUT-TYPE-SPEC."
387  (declare (dynamic-extent sequences))
388  (if (memq output-type-spec '(string simple-string))
389    (setq output-type-spec 'base-string)
390    (unless (memq output-type-spec '(string simple-string base-string list vector
391                                     simple-base-string
392                                     bit-vector simple-bit-vector))
393      (setq output-type-spec (type-expand output-type-spec))))
394  (case (if (atom output-type-spec) output-type-spec (car output-type-spec))
395    (list (apply #'concat-to-list* sequences))
396    ((simple-vector simple-string simple-base-string base-string vector string array
397                    bit-vector simple-bit-vector)
398     (apply #'concat-to-simple* output-type-spec sequences))
399    (t
400     (if (subtypep output-type-spec 'vector)
401       (apply #'concat-to-simple* output-type-spec sequences)
402       (if (subtypep output-type-spec 'list)
403         (apply #'concat-to-list* sequences)
404         (error "~S: invalid output type specification." output-type-spec))))))
405
406;;; Internal Frobs:
407
408(defun concat-to-list* (&rest sequences)
409  (declare (dynamic-extent sequences))
410  (let* ((result (list nil))
411         (splice result))
412    (dolist (sequence sequences (%cdr result))
413      (seq-dispatch
414       sequence
415       (dolist (item sequence)
416         (setq splice (%cdr (%rplacd splice (list item)))))
417       (dotimes (i (length sequence))
418         (setq splice (%cdr (%rplacd splice (list (aref sequence i))))))))))
419             
420
421(defun concat-to-simple* (output-type-spec &rest arg-sequences)
422  (declare (dynamic-extent arg-sequences))
423  (do ((seqs arg-sequences (cdr seqs))
424        (total-length 0)
425        ;(lengths ())
426        )
427      ((null seqs)
428       (do ((sequences arg-sequences (cdr sequences))
429            ;(lengths lengths (cdr lengths))
430            (index 0)
431            (result (make-sequence output-type-spec total-length)))
432           ((= index total-length) result)
433         (let ((sequence (car sequences)))
434           (seq-dispatch
435            sequence
436            (do ((sequence sequence (cdr sequence)))
437                ((atom sequence))
438              (aset result index (car sequence))
439              (setq index (1+ index)))
440            (let ((len (length sequence)))
441              (do ((jndex 0 (1+ jndex)))
442                  ((= jndex len))
443                (aset result index (aref sequence jndex))
444                (setq index (1+ index))))))))
445     (let ((length (length (car seqs))))
446       ;(setq lengths (nconc lengths (list length))) ; if itsa list, we dont care about its length, if itsan array, length twice is cheap
447       (setq total-length (+ total-length length)))))
448
449
450;This one doesn't choke on circular lists, doesn't cons as much, and is
451;about 1/8K smaller to boot.
452(defun map (type function sequence &rest more-sequences)
453  (declare (dynamic-extent more-sequences))
454  (let* ((sequences (cons sequence more-sequences))
455         (arglist (make-list (length sequences)))
456         (index 0)
457         args seq p (ans ()))
458    (declare (dynamic-extent sequences arglist))
459    (unless (or (null type)
460                (eq type 'list)
461                (memq (if (consp type) (%car type) type)
462                      '(simple-vector simple-string vector string array
463                        simple-array bit-vector simple-bit-vector))
464                (subtypep type 'sequence))
465      (report-bad-arg type 'sequence))
466    (loop
467      (setq p sequences args arglist)
468      (while p
469        (cond ((null (setq seq (%car p))) (return))
470              ((consp seq)
471               (%rplaca p (%cdr seq))
472               (%rplaca args (%car seq)))
473              ((eq index (length seq)) (return))
474              (t (%rplaca args (elt seq index))))
475        (setq args (%cdr args) p (%cdr p)))
476      (setq p (apply function arglist))
477      (if type (push p ans))
478      (setq index (%i+ index 1)))
479    (when type
480      (setq ans (nreverse ans))
481      (if (eq type 'list) ans (coerce ans type)))))
482
483;;;;;;;;;;;;;;;;;
484;;
485;; some, every, notevery, notany
486;;
487;; these all call SOME-XX-MULTI or SOME-XX-ONE
488;; SOME-XX-MULTI should probably be coded in lap
489;;
490;; these should be transformed at compile time
491;;
492;; we may want to consider open-coding when
493;; the predicate is a lambda
494;;
495
496(eval-when (:execute :compile-toplevel)
497  (defmacro negating-quantifier-p (quantifier-constant)
498    `(%i> ,quantifier-constant $notany))
499  )
500
501; Vector is guaranteed to be simple; new-size is guaranteed <= (length vector).
502; Return vector with its size adjusted and extra doublewords zeroed out.
503; Should only be called on freshly consed vectors...
504
505   
506   
507(defun some (predicate one-seq &rest sequences)
508  "Apply PREDICATE to the 0-indexed elements of the sequences, then
509   possibly to those with index 1, and so on. Return the first
510   non-NIL value encountered, or NIL if the end of any sequence is reached."
511  (declare (dynamic-extent sequences))
512  (if sequences
513      (some-xx-multi $some nil predicate one-seq sequences)
514      (some-xx-one $some nil predicate one-seq)))
515
516(defun notany (predicate one-seq &rest sequences)
517  "Apply PREDICATE to the 0-indexed elements of the sequences, then
518   possibly to those with index 1, and so on. Return NIL as soon
519   as any invocation of PREDICATE returns a non-NIL value, or T if the end
520   of any sequence is reached."
521  (declare (dynamic-extent sequences))
522  (if sequences
523      (some-xx-multi $notany t predicate one-seq sequences)
524      (some-xx-one $notany t predicate one-seq)))
525
526(defun every (predicate one-seq &rest sequences)
527  "Apply PREDICATE to the 0-indexed elements of the sequences, then
528   possibly to those with index 1, and so on. Return NIL as soon
529   as any invocation of PREDICATE returns NIL, or T if every invocation
530   is non-NIL."
531  (declare (dynamic-extent sequences))
532  (if sequences
533      (some-xx-multi $every t predicate one-seq sequences)
534      (some-xx-one $every t predicate one-seq)))
535
536(defun notevery (predicate one-seq &rest sequences)
537  "Apply PREDICATE to 0-indexed elements of the sequences, then
538   possibly to those with index 1, and so on. Return T as soon
539   as any invocation of PREDICATE returns NIL, or NIL if every invocation
540   is non-NIL."
541  (declare (dynamic-extent sequences))
542  (if sequences
543      (some-xx-multi $notevery nil predicate one-seq sequences)
544      (some-xx-one $notevery nil predicate one-seq)))
545
546(defun some-xx-multi (caller at-end predicate first-seq sequences)
547  (let* ((sequences (cons first-seq sequences))
548         (min-vector-length most-positive-fixnum)
549         (arg-slice (make-list (list-length sequences)))
550         (cur-slice arg-slice)
551         (not-result (negating-quantifier-p caller))
552         result)
553  (declare (fixnum min-vector-length)
554           (list sequences arg-slice cur-slice)
555           (dynamic-extent sequences arg-slice))
556  (dolist (seq sequences)
557    (seq-dispatch seq
558                  nil
559                  (setq min-vector-length (min min-vector-length
560                                               (length seq)))))
561  (dotimes (index min-vector-length)
562    (dolist (one-seq sequences)
563      (%rplaca cur-slice
564               (if (vectorp one-seq)
565                   (aref one-seq index)
566                   (if one-seq
567                       (progn
568                         (%rplaca (memq one-seq sequences) (cdr one-seq))
569                         (%car one-seq))
570                       (return-from some-xx-multi at-end))))
571      (setq cur-slice (%cdr cur-slice)))
572    (setq result (apply predicate arg-slice)
573          cur-slice arg-slice)
574    (if not-result
575        (when (not result)
576          (return-from some-xx-multi
577                       (if (eq caller $every) nil t)))
578        (when result
579          (return-from some-xx-multi
580                       (if (eq caller $some) result nil)))))
581  at-end))
582
583
584(defun some-xx-one (caller at-end predicate seq
585                           &aux (not-result (negating-quantifier-p caller))
586                           result)
587  (if (vectorp seq)
588      (if (simple-vector-p seq)
589        (locally (declare (type simple-vector seq))
590          (dovector (element seq)
591            (setq result (funcall predicate element))
592            (if not-result
593              (when (not result)
594                (return-from some-xx-one
595                  (if (eq caller $every) nil t)))
596              (when result
597                (return-from some-xx-one
598                  (if (eq caller $some ) result nil))))))
599        (dovector (element seq)
600          (setq result (funcall predicate element))
601          (if not-result
602            (when (not result)
603              (return-from some-xx-one
604                (if (eq caller $every) nil t)))
605            (when result
606              (return-from some-xx-one
607                (if (eq caller $some ) result nil))))))
608      (dolist (element seq)
609        (setq result (funcall predicate element))
610        (if not-result
611            (when (not result)
612              (return-from some-xx-one
613                           (if (eq caller $every) nil t)))
614            (when result
615              (return-from some-xx-one
616                           (if (eq caller $some ) result nil))))))
617      at-end)
618
619;;; simple positional versions of find, position
620
621(defun find-positional-test-key (item sequence test key)
622  (if sequence
623    (seq-dispatch
624     sequence
625     (let ((cons (member item sequence :test test :key key)))
626       (and cons (%car cons)))
627     (let ((pos (vector-position-1 item sequence nil test nil 0 nil key)))
628       (and pos (aref sequence pos))))))
629
630(defun find-positional-test-not-key (item sequence test-not key)
631  (if sequence
632    (seq-dispatch
633     sequence
634     (let ((cons (member item sequence :test-not test-not :key key)))
635       (and cons (%car cons)))
636     (let ((pos (vector-position-1 item sequence nil nil test-not 0 nil key)))
637       (and pos (aref sequence pos))))))
638
639(defun position-positional-test-key (item sequence test key)
640  (if sequence
641    (seq-dispatch
642     sequence
643     (progn
644       (setq key (adjust-key key))
645       (setq test
646             (adjust-test-args item test nil))
647       (if (or test key)
648         (list-position/find-complex nil item sequence 0 nil test nil key)
649         (list-position/find-simple nil item sequence 0 nil)))
650     (vector-position-1 item sequence nil test nil 0 nil key))))
651
652(defun position-positional-test-not-key (item sequence test-not key)
653  (if sequence
654    (seq-dispatch
655     sequence
656     (progn
657       (setq key (adjust-key key))
658       (multiple-value-bind (test test-not)
659                            (adjust-test-args item nil test-not)
660         (list-position/find-complex nil item sequence 0 nil test test-not key)))
661     (vector-position-1 item sequence nil nil test-not 0 nil key))))
662
663
664;;; Reduce:
665
666(eval-when (:execute :compile-toplevel)
667 
668  (defmacro list-reduce (function sequence start end initial-value ivp key)
669    (let ((what `(if ,key (funcall ,key (car sequence)) (car sequence))))
670      `(let ((sequence (nthcdr ,start ,sequence)))
671         (do ((count (if ,ivp ,start (1+ ,start)) (1+ count))
672              (sequence (if ,ivp sequence (cdr sequence))
673                        (cdr sequence))
674              (value (if ,ivp ,initial-value ,what)
675                     (funcall ,function value ,what)))
676             ((= count ,end) value)))))
677 
678  (defmacro list-reduce-from-end (function sequence start end 
679                                           initial-value ivp key)
680    (let ((what `(if ,key (funcall ,key (car sequence)) (car sequence))))
681      `(let ((sequence (nthcdr (- (length ,sequence) ,end) (reverse ,sequence))))
682         (do ((count (if ,ivp ,start (1+ ,start)) (1+ count))
683              (sequence (if ,ivp sequence (cdr sequence))
684                        (cdr sequence))
685              (value (if ,ivp ,initial-value ,what)
686                     (funcall ,function ,what value)))
687             ((= count ,end) value)))))
688 
689  ) ;; end eval-when
690
691(defun reduce (function sequence &key from-end (start 0)
692                        end (initial-value nil ivp) key)
693  "The specified Sequence is ``reduced'' using the given Function.
694  See manual for details."
695  (unless end (setq end (length sequence)))
696  (if (= end start)
697    (if ivp initial-value (funcall function))
698    (seq-dispatch
699     sequence
700     (if from-end
701       (list-reduce-from-end  function sequence start end initial-value ivp key)
702       (list-reduce function sequence start end initial-value ivp key))
703     (let* ((disp (if from-end -1 1))
704            (index (if from-end (1- end) start))
705            (terminus (if from-end (1- start) end))
706            (value (if ivp initial-value
707                       (let ((elt (aref sequence index)))
708                         (setq index (+ index disp))
709                         (if key (funcall key elt) elt))))
710            (element nil))
711       (do* ()
712            ((= index terminus) value)
713         (setq element (aref sequence index)
714               index (+ index disp)
715               element (if key (funcall key element) element)
716               value (funcall function (if from-end element value) (if from-end value element))))))))
717
718(defun map-into (result-sequence function &rest sequences)
719  (declare (dynamic-extent sequences))
720  (let* ((nargs (list-length sequences))
721         (temp (make-list (length sequences)))
722         (maxcnt (seq-dispatch result-sequence (length result-sequence) (array-total-size result-sequence)))
723         (rseq result-sequence))
724    (declare (fixnum cnt nargs maxcnt))
725    (declare (dynamic-extent temp))
726    ; this declaration is maybe bogus
727    (dolist (seq sequences)
728      (let ((len (length seq)))
729        (declare (fixnum len))
730        (if (< len maxcnt)(setq maxcnt len))))
731    (dotimes (cnt maxcnt)
732      (let ((args temp)(seqs sequences))
733        (dotimes (i nargs)
734          (let ((seq (%car seqs)))
735            (cond ((listp seq)
736                   (%rplaca seqs (%cdr seq))
737                   (%rplaca args (%car seq)))
738                  (t (%rplaca args (aref seq cnt)))))
739          (setq args (%cdr args))
740          (setq seqs (%cdr seqs))))
741      (let ((res (apply function temp)))
742        (cond ((consp rseq)
743               (%rplaca rseq res)
744               (setq rseq (%cdr rseq)))
745              (t (setf (aref result-sequence cnt) res)))))
746    (when (and (not (listp result-sequence))
747               (array-has-fill-pointer-p result-sequence))
748      (setf (fill-pointer result-sequence) maxcnt))
749    result-sequence))
750         
751   
752;;; Coerce:
753
754#|
755; don't know if this is always right
756; It's almost never right: the "type-spec" could be something
757; defined with DEFTYPE, whose last element (if it has one) has
758; nothing to do with the "length" of the specified type.
759(defun specifier-length (type-spec)
760  (if (consp type-spec)
761    (let ((len? (car (last type-spec))))
762      (if (fixnump len?) len?))))
763|#
764
765
766(defun array-ctype-length (ctype)
767  (if (typep ctype 'array-ctype)
768    (let* ((dims (array-ctype-dimensions ctype)))
769      (if (listp dims)
770        (if (null (cdr dims))
771          (let* ((dim0 (car dims)))
772            (unless (eq dim0 '*) dim0)))))))
773
774
775
776
777; from optimizer - just return object if type is OK
778
779
780;If you change this, remember to change the transform.
781(defun coerce (object output-type-spec)
782  "Coerce the Object to an object of type Output-Type-Spec."
783  (let* ((type (specifier-type output-type-spec)))
784    (if (%typep object type)
785      object
786      (cond
787        ((csubtypep type (specifier-type 'character))
788         (character object))
789        ((eq output-type-spec 'standard-char)
790         (let ((char (character object)))
791           (unless (standard-char-p char) (%err-disp $xcoerce object 'standard-char))
792           char))
793        ((eq output-type-spec 'compiled-function)
794         (coerce-to-compiled-function object))
795        ((csubtypep type (specifier-type 'function))
796         (coerce-to-function-1 object))
797        ((csubtypep type (specifier-type 'cons))
798         (if object
799           (coerce-to-list object)
800           (report-bad-arg object 'cons)))
801        ((csubtypep type (specifier-type 'list))
802         (coerce-to-list object))
803        ((csubtypep type (specifier-type 'string))
804         (let ((length (array-ctype-length type)))
805           (if (and length (neq length (length object)))
806             (report-bad-arg (make-string length) `(string ,(length object)))))
807         (coerce-to-uarray object #.(type-keyword-code :simple-string)
808                           t))
809        ((csubtypep type (specifier-type 'vector))
810         (let ((length (array-ctype-length type)))
811           (if (and length (neq length (length object)))
812             (error 'invalid-subtype-error
813                    :datum output-type-spec
814                    :expected-type `(vector * ,(length object)))))
815         (let* ((atype (simplify-vector-ctype type)))
816           (unless (typep atype 'array-ctype)
817             (error "Can't determine vector type of ~s" output-type-spec))
818           (let* ((element-type (type-specifier (array-ctype-element-type atype))))
819             (let ((length (array-ctype-length atype)))
820               (if (and length (neq length (length object)))
821                 (report-bad-arg (make-array length :element-type element-type)
822                                 `(vector ,element-type ,(length object))))
823               (coerce-to-uarray object (element-type-subtype element-type) t)))))
824        ((csubtypep type (specifier-type 'array))
825         (let* ((dims (array-ctype-dimensions type)))
826           (when (consp dims)
827             (when (not (null (cdr dims)))(error "~s is not a sequence type." output-type-spec))))
828         (let ((length (array-ctype-length type)))
829           (if (and length (neq length (length object)))
830             (error "Length of ~s is not ~s." object length)))
831         (coerce-to-uarray object (element-type-subtype (type-specifier 
832                                                         (array-ctype-element-type type))) t))
833        ((numberp object)
834         (let ((res
835                (cond
836                  ((csubtypep type (specifier-type 'double-float))
837                   (float object 1.0d0))
838                  ((csubtypep type (specifier-type 'float))
839                   (float object 1.0s0))                               
840                  ((csubtypep type (specifier-type 'complex))
841                   (coerce-to-complex object  output-type-spec)))))
842           (unless res                  ;(and res (%typep res type))
843             (error "~S can't be coerced to type ~S." object output-type-spec))
844           res))
845        (t (error "~S can't be coerced to type ~S." object output-type-spec))))))
846
847
848(defun coerce-to-complex (object  output-type-spec)
849  (if (consp output-type-spec)
850      (let ((type2 (cadr output-type-spec)))     
851        (if (complexp object)
852            (complex (coerce (realpart object) type2)(coerce (imagpart object) type2))
853            (complex (coerce object type2) 0)))
854      (complex object)))
855       
856
857(defun coerce-to-function-1 (thing)
858  (if (functionp thing)
859    thing
860    (if (symbolp thing)
861      (%function thing)
862      (if (lambda-expression-p thing)
863        (%make-function nil thing nil)
864        (%err-disp $xcoerce thing 'function)))))
865
866;;; Internal Frobs:
867;(coerce object '<array-type>)
868(defun coerce-to-uarray (object subtype simple-p)
869  (if (typep object 'array)
870    (if (and (or (not simple-p) (typep object 'simple-array))
871             (or (null subtype) (eq (array-element-subtype object) subtype)))
872      object
873      ;Make an array of the same shape as object but different subtype..
874      (%copy-array subtype object))
875    (if (typep object 'list)
876      (%list-to-uvector subtype object)
877      (%err-disp $xcoerce object 'array))))
878
879;(coerce object 'list)
880(defun coerce-to-list (object)
881  (seq-dispatch 
882   object
883   object
884   (let* ((n (length object)))
885     (declare (fixnum n))
886     (multiple-value-bind (data offset) (array-data-and-offset object)
887       (let* ((head (cons nil nil))
888              (tail head))
889         (declare (dynamic-extent head)
890                  (cons head tail))
891         (do* ((i 0 (1+ i))
892               (j offset (1+ j)))
893              ((= i n) (cdr head))
894           (declare (fixnum i j))
895           (setq tail (cdr (rplacd tail (cons (uvref data j) nil))))))))))
896 
897
898(defun %copy-array (new-subtype array)
899  ;To be rewritten once make-array disentangled (so have a subtype-based entry
900  ;point)
901  (make-array (if (eql 1 (array-rank array))
902                (length array)
903                (array-dimensions array))
904              :element-type (element-subtype-type new-subtype)
905              :initial-contents array ;***** WRONG *****
906              ))
907
908(defun check-count (c)
909  (if c
910    (min (max (require-type c 'integer) 0) most-positive-fixnum)
911    most-positive-fixnum))
912
913;;; Delete:
914
915(defun list-delete-1 (item list from-end test test-not start end count key 
916                           &aux (temp list)  revp)
917  (unless end (setq end most-positive-fixnum))
918  (when (and from-end count)
919    (let ((len (length temp)))
920      (if (not (%i< start len))
921        (return-from list-delete-1 temp))
922      (setq temp (nreverse temp) revp t)
923      (psetq end (%i- len start)
924             start (%i- len (%imin len end)))))
925  (setq key (adjust-key key))
926  (multiple-value-setq (test test-not)
927                       (adjust-test-args item test test-not))
928  (setq temp
929        (if (or test key test-not)
930          (list-delete-moderately-complex item temp start end count test test-not key)
931          (list-delete-very-simple item temp start end count)))
932   (if revp
933    (nreverse temp)
934    temp))
935
936
937(defun list-delete-very-simple (item list start end count)
938  (unless start (setq start 0))
939  (unless end (setq end most-positive-fixnum))
940  (setq count (check-count count))
941  (do* ((handle (cons nil list))
942        (splice handle)
943        (numdeleted 0)
944        (i 0 (1+ i)))
945       ((or (eq i end) (null (%cdr splice)) (eq numdeleted count))
946        (%cdr handle))
947    (declare (fixnum i start end count numdeleted)  ; declare-type-free !!
948             (dynamic-extent handle) 
949             (list splice handle))
950    (if (and (%i>= i start) (eq item (car (%cdr splice))))
951      (progn
952        (%rplacd splice (%cddr splice))
953        (setq numdeleted (%i+ numdeleted 1)))
954      (setq splice (%cdr splice)))))
955
956(defun list-delete-moderately-complex (item list start end count test test-not key)
957  (unless start (setq start 0))
958  (unless end (setq end most-positive-fixnum))
959  (setq count (check-count count))
960  (do* ((handle (cons nil list))
961        (splice handle)
962        (numdeleted 0)
963        (i 0 (1+ i)))
964       ((or (= i end) (null (cdr splice)) (= numdeleted count))
965        (cdr handle))
966    (declare (fixnum i start end count numdeleted)
967             (dynamic-extent handle)
968             (list splice))
969    (if (and (>= i start) (matchp2 item (cadr splice) test test-not key))
970      (progn
971        (rplacd splice (cddr splice))
972        (setq numdeleted (1+ numdeleted)))
973      (setq splice (cdr splice)))))
974
975(defun list-delete (item list &key from-end test test-not (start 0)
976                         end count key 
977                         &aux (temp list)  revp)
978  (unless end (setq end most-positive-fixnum))
979  (when (and from-end count)
980    (let ((len (length temp)))
981      (if (not (%i< start len))
982        (return-from list-delete temp))
983      (setq temp (nreverse temp) revp t)
984      (psetq end (%i- len start)
985             start (%i- len (%imin len end)))))
986  (setq key (adjust-key key))
987  (multiple-value-setq (test test-not)
988                       (adjust-test-args item test test-not))
989  (setq temp
990        (if (or test key test-not)
991          (list-delete-moderately-complex item temp start end count test test-not key)
992          (list-delete-very-simple item temp start end count)))
993   (if revp
994    (nreverse temp)
995    temp))
996
997;;; Modified to clear the elements between the old and new fill pointers
998;;; so they won't hold on to garbage.
999(defun vector-delete (item vector test test-not key start end inc count
1000                           &aux (length (length vector)) pos fill val)
1001  (setq key (adjust-key key))
1002  (multiple-value-setq (test test-not) (adjust-test-args item test test-not))
1003  (setq end (check-sequence-bounds vector start end))
1004  (if (%i< inc 0) (psetq start (%i- end 1) end (%i- start 1)))
1005  (setq fill (setq pos start))
1006  (loop
1007    (if (or (eq count 0) (eq pos end)) (return))
1008    (if (matchp2 item (setq val (aref vector pos)) test test-not key)
1009      (setq count (%i- count 1))
1010      (progn
1011        (if (neq fill pos) (setf (aref vector fill) val))
1012        (setq fill (%i+ fill inc))))
1013    (setq pos (%i+ pos inc)))
1014  (if (%i> fill pos) (psetq fill (%i+ pos 1) pos (%i+ fill 1)))
1015  (loop
1016    (if (eq pos length) (return))
1017    (setf (aref vector fill) (aref vector pos))
1018    (setq fill (%i+ fill 1) pos (%i+ pos 1)))
1019  (when (gvectorp (array-data-and-offset vector))
1020    (let ((old-fill (fill-pointer vector))
1021          (i fill))
1022      (declare (fixnum i old-fill))
1023      (loop
1024        (when (>= i old-fill) (return))
1025        (setf (aref vector i) nil)
1026        (incf i))))
1027  (setf (fill-pointer vector) fill)
1028  vector)
1029
1030
1031; The vector will be freshly consed & nothing is displaced to it,
1032; so it's legit to destructively truncate it.
1033; Likewise, it's ok to access its components with UVREF.
1034
1035(defun simple-vector-delete (item vector test test-not key start end inc count
1036                                  &aux (length (length vector)) 
1037                                  subtype pos fill)
1038  (setq key (adjust-key key))
1039  (multiple-value-setq (test test-not) (adjust-test-args item test test-not))
1040  (setq end (check-sequence-bounds vector start end))
1041  (setq fill start)
1042  (if (%i< inc 0) (psetq start (%i- end 1) end (%i- start 1)))
1043  (let* ((bv (make-array (the fixnum (length vector)) :element-type 'bit :Initial-element 0))
1044         offset)   
1045    (declare (dynamic-extent bv)
1046             (type (simple-array bit (*)) bv))
1047    (multiple-value-setq (vector offset)(array-data-and-offset vector))
1048    (setq subtype (typecode vector))
1049    (setq pos start)
1050    (loop
1051      (when (or (eq count 0) (eq pos end))
1052        (unless (eq pos end)
1053          (incf fill (abs (- pos end))))
1054        (return))
1055      (if (matchp2 item (uvref  vector (%i+ pos offset))
1056                   test test-not key)
1057        (progn (setf (aref bv pos) 1)
1058               (setq count (%i- count 1)))
1059        (setq fill (%i+ fill 1)))
1060      (setq pos (%i+ pos inc)))
1061    (when (%i< inc 0)
1062      (psetq start (%i+ end 1) end (%i+ start 1)))
1063    (let* ((tail (- length end))
1064           (size (+ fill tail))
1065           (new-vect (%alloc-misc size subtype))
1066           (fill-end fill))
1067      (declare (fixnum tail size))
1068      (when (neq 0 start)
1069        (dotimes (i start)
1070          (setf (uvref new-vect i) (uvref  vector (%i+ offset i)))
1071          ))
1072      (setq fill start)
1073      (setq pos start)
1074      (loop
1075        (if (eq fill fill-end) (return))
1076        (if (neq 1 (aref bv pos))
1077          (progn
1078            (setf (uvref new-vect fill) (uvref vector (%i+ offset pos)))
1079            (setq fill (%i+ fill 1))))
1080        (setq pos (%i+ pos 1)))
1081      (setq pos end)
1082      (loop
1083        (when (eq fill size) (return))
1084          (setf (uvref  new-vect fill) (uvref  vector (%i+ offset pos)))
1085          (setq fill (%i+ fill 1)
1086                pos (%i+ pos 1)))
1087      new-vect)))
1088
1089
1090; When a vector has a fill pointer & it can be "destructively modified" by adjusting
1091; that fill pointer.
1092(defun vector-delete (item vector test test-not key start end inc count
1093                           &aux (length (length vector)) pos fill val)
1094  (setq key (adjust-key key))
1095  (multiple-value-setq (test test-not) (adjust-test-args item test test-not))
1096  (setq end (check-sequence-bounds vector start end))
1097  (if (%i< inc 0) (psetq start (%i- end 1) end (%i- start 1)))
1098  (setq fill (setq pos start))
1099  (loop
1100    (if (or (eq count 0) (eq pos end)) (return))
1101    (if (matchp2 item (setq val (aref vector pos)) test test-not key)
1102      (setq count (%i- count 1))
1103      (progn
1104        (if (neq fill pos) (setf (aref vector fill) val))
1105        (setq fill (%i+ fill inc))))
1106    (setq pos (%i+ pos inc)))
1107  (if (%i> fill pos) (psetq fill (%i+ pos 1) pos (%i+ fill 1)))
1108  (loop
1109    (if (eq pos length) (return))
1110    (setf (aref vector fill) (aref vector pos))
1111    (setq fill (%i+ fill 1) pos (%i+ pos 1)))
1112  (when (eq t (array-element-type vector))
1113    (let ((old-fill (fill-pointer vector))
1114          (i fill))
1115      (declare (fixnum i old-fill))
1116      (loop
1117        (when (>= i old-fill) (return))
1118        (setf (aref vector i) nil)
1119        (incf i))))
1120  (setf (fill-pointer vector) fill)
1121  vector)
1122
1123(defun delete (item sequence &key from-end test test-not (start 0)
1124                    end count key)
1125  "Return a sequence formed by destructively removing the specified ITEM from
1126  the given SEQUENCE."
1127  (setq count (check-count count))
1128  (if sequence
1129    (seq-dispatch
1130     sequence
1131     (list-delete-1 item 
1132                  sequence 
1133                  from-end
1134                  test 
1135                  test-not
1136                  start 
1137                  end 
1138                  count
1139                  key)
1140     (if (array-has-fill-pointer-p sequence)
1141       (vector-delete item sequence test test-not key start end (if from-end -1 1) count)
1142       (simple-vector-delete item
1143                            sequence
1144                             test test-not key start end (if from-end -1 1) count)))))
1145
1146(defun delete-if (test sequence &key from-end (start 0)                       
1147                       end count key)
1148  "Return a sequence formed by destructively removing the elements satisfying
1149  the specified PREDICATE from the given SEQUENCE."
1150  (delete test sequence
1151          :test #'funcall
1152          :from-end from-end 
1153          :start start 
1154          :end end 
1155          :count count 
1156          :key key))
1157
1158(defun delete-if-not (test sequence &key from-end (start 0) end count key)
1159  "Return a sequence formed by destructively removing the elements not
1160  satisfying the specified PREDICATE from the given SEQUENCE."
1161  (delete test sequence 
1162          :test-not #'funcall 
1163          :from-end from-end 
1164          :start start 
1165          :end end 
1166          :count count 
1167          :key key))
1168
1169
1170
1171;;; Remove:
1172
1173
1174
1175(defun remove (item sequence &key from-end test test-not (start 0)
1176                    end count key)
1177  "Return a copy of SEQUENCE with elements satisfying the test (default is
1178   EQL) with ITEM removed."
1179  (setq count (check-count count))
1180  (seq-dispatch
1181   sequence
1182   (list-delete-1 item 
1183                (copy-list sequence)
1184                from-end
1185                test 
1186                test-not
1187                start 
1188                end 
1189                count
1190                key)
1191   (simple-vector-delete item
1192                         sequence
1193                         test
1194                         test-not
1195                         key
1196                         start
1197                         end
1198                         (if from-end -1 1)
1199                         count)))
1200
1201
1202
1203
1204(defun remove-if (test sequence &key from-end (start 0)
1205                         end count key)
1206  "Return a copy of sequence with elements such that predicate(element)
1207   is non-null removed"
1208  (setq count (check-count count))
1209  (remove test sequence
1210          :test #'funcall
1211          :from-end from-end
1212          :start start
1213          :end end
1214          :count count
1215          :key key))
1216
1217(defun remove-if-not (test sequence &key from-end (start 0)
1218                         end count key)
1219  "Return a copy of sequence with elements such that predicate(element)
1220   is null removed"
1221  (setq count (check-count count))
1222  (remove test sequence
1223          :test-not #'funcall
1224          :from-end from-end
1225          :start start
1226          :end end
1227          :count count
1228          :key key))
1229
1230;;; Remove-Duplicates:
1231
1232;;; Remove duplicates from a list. If from-end, remove the later duplicates,
1233;;; not the earlier ones. Thus if we check from-end we don't copy an item
1234;;; if we look into the already copied structure (from after :start) and see
1235;;; the item. If we check from beginning we check into the rest of the
1236;;; original list up to the :end marker (this we have to do by running a
1237;;; do loop down the list that far and using our test.
1238; test-not is typically NIL, but member doesn't like getting passed NIL
1239; for its test-not fn, so I special cased the call to member. --- cfry
1240
1241(defun remove-duplicates (sequence &key (test #'eql) test-not (start 0) 
1242      from-end end key)
1243  "The elements of SEQUENCE are compared pairwise, and if any two match,
1244   the one occurring earlier is discarded, unless FROM-END is true, in
1245   which case the one later in the sequence is discarded. The resulting
1246   sequence is returned.
1247
1248   The :TEST-NOT argument is deprecated."
1249  (setq end (check-sequence-bounds sequence start end))
1250  (delete-duplicates (copy-seq sequence) :from-end from-end :test test
1251                     :test-not test-not :start start :end end :key key))
1252
1253;;; Delete-Duplicates:
1254
1255(defun list-delete-duplicates* (list test test-not key from-end start end)
1256  ;;(%print "test:" test "test-not:" test-not "key:" key)
1257  (let ((handle (cons nil list)))
1258    (do ((current  (nthcdr start list) (cdr current))
1259         (previous (nthcdr start handle))
1260         (index start (1+ index)))
1261        ((or (= index end) (null current)) 
1262         (cdr handle))
1263      ;;(%print "outer loop top current:" current "previous:" previous)
1264      (if (do ((x (if from-end 
1265                    (nthcdr (1+ start) handle)
1266                    (cdr current))
1267                  (cdr x))
1268               (i (1+ index) (1+ i)))
1269              ((or (null x) 
1270                   (and (not from-end) (= i end)) 
1271                   (eq x current)) 
1272               nil)
1273            ;;(%print "inner loop top x:" x "i:" i)
1274            (if (list-delete-duplicates*-aux current x test test-not key)
1275              (return t)))
1276        (rplacd previous (cdr current))
1277        (setq previous (cdr previous))))))
1278
1279(defun list-delete-duplicates*-aux (current x test test-not key)
1280  (if test-not
1281    (not (funcall test-not 
1282                  (funcall key (car current))
1283                  (funcall key (car x))))
1284    (funcall test 
1285             (funcall key (car current)) 
1286             (funcall key (car x)))))
1287
1288
1289(defun vector-delete-duplicates* (vector test test-not key from-end start end 
1290                                         &optional (length (length vector)))
1291  (declare (vector vector))
1292  (do ((index start (1+ index))
1293       (jndex start))
1294      ((= index end)
1295       (do ((index index (1+ index))            ; copy the rest of the vector
1296            (jndex jndex (1+ jndex)))
1297           ((= index length)
1298            (setq vector (shrink-vector vector jndex)))
1299            (aset vector jndex (aref vector index))))
1300      (aset vector jndex (aref vector index))
1301      (unless (position (funcall key (aref vector index)) vector :key key
1302                             :start (if from-end start (1+ index)) :test test
1303                                           :end (if from-end jndex end) :test-not test-not)
1304              (setq jndex (1+ jndex)))))
1305
1306(defun delete-duplicates (sequence &key (test #'eql) test-not (start 0) from-end end key)
1307  "The elements of SEQUENCE are examined, and if any two match, one is
1308   discarded.  The resulting sequence, which may be formed by destroying the
1309   given sequence, is returned.
1310   Sequences of type STR have a NEW str returned."
1311  (setq end (check-sequence-bounds sequence start end))
1312  (unless key (setq key #'identity))
1313  (seq-dispatch sequence
1314    (if sequence
1315      (list-delete-duplicates* sequence test test-not key from-end start end))
1316    (vector-delete-duplicates* sequence test test-not key from-end start end)))
1317
1318(defun list-substitute* (pred new list start end count key 
1319                              test test-not old)
1320  ;(print-db pred new list start end count key test test-not old)
1321  (let* ((result (list nil))
1322         elt
1323         (splice result)
1324         (list list))           ; Get a local list for a stepper.
1325    (do ((index 0 (1+ index)))
1326        ((= index start))
1327      (setq splice (cdr (rplacd splice (list (car list)))))
1328      (setq list (cdr list)))
1329    (do ((index start (1+ index)))
1330        ((or (and end (= index end)) (null list) (= count 0)))
1331      (setq elt (car list))
1332      (setq splice
1333            (cdr (rplacd splice
1334                         (list
1335                          (cond ((case pred
1336                                   (normal
1337                                    (if test-not
1338                                      (not (funcall test-not  old
1339                                                    ;fry mod to slisp, which had arg order of OLD and ELT reversed.
1340                                                    (funcall key elt)))
1341                                      (funcall test old
1342                                               (funcall key elt))))
1343                                   (if (funcall test (funcall key elt)))
1344                                   (if-not (not (funcall test 
1345                                                         (funcall key elt)))))
1346                                 (setq count (1- count))
1347                                 new)
1348                                (t elt))))))
1349      (setq list (cdr list)))
1350    (do ()
1351        ((null list))
1352      (setq splice (cdr (rplacd splice (list (car list)))))
1353      (setq list (cdr list)))
1354    (cdr result)))
1355
1356;;; Replace old with new in sequence moving from left to right by incrementer
1357;;; on each pass through the loop. Called by all three substitute functions.
1358(defun vector-substitute* (pred new sequence incrementer left right length
1359                                start end count key test test-not old)
1360  (let ((result (make-sequence-like sequence length))
1361        (index left))
1362    (do ()
1363        ((= index start))
1364      (aset result index (aref sequence index))
1365      (setq index (+ index incrementer)))
1366    (do ((elt))
1367        ((or (= index end) (= count 0)))
1368      (setq elt (aref sequence index))
1369      (aset result index 
1370            (cond ((case pred
1371                     (normal
1372                      (if test-not
1373                        (not (funcall test-not old (funcall key elt))) ;cfry mod
1374                        (funcall test old (funcall key elt)))) ;cfry mod
1375                     (if (funcall test (funcall key elt)))
1376                     (if-not (not (funcall test (funcall key elt)))))
1377                   (setq count (1- count))
1378                   new)
1379                  (t elt)))
1380      (setq index (+ index incrementer)))
1381    (do ()
1382        ((= index right))
1383      (aset result index (aref sequence index))
1384      (setq index (+ index incrementer)))
1385    result))
1386
1387;;; Substitute:
1388
1389(defun substitute (new old sequence &key from-end (test #'eql) test-not
1390                       (start 0) count
1391                       end (key #'identity))
1392  "Return a sequence of the same kind as SEQUENCE with the same elements,
1393  except that all elements equal to OLD are replaced with NEW. See manual
1394  for details."
1395  (setq count (check-count count))
1396  (let ((length (length sequence))        )
1397    (setq end (check-sequence-bounds sequence start end))
1398    (seq-dispatch 
1399     sequence
1400     (if from-end
1401       (nreverse (list-substitute* 'normal new (reverse sequence) (- length end)
1402                                   (- length start) count key test test-not old))
1403       (list-substitute* 'normal new sequence start end count key test test-not
1404                         old))
1405     (if from-end
1406       (vector-substitute* 'normal new sequence -1 (1- length) -1 length 
1407                           (1- end) (1- start) count key test test-not old)
1408       (vector-substitute* 'normal new sequence 1 0 length length
1409                           start end count key test test-not old)))))
1410
1411
1412(defun substitute-if (new test sequence &key from-end (start 0)
1413                          (end (length sequence))
1414                          count (key #'identity))
1415  "Return a sequence of the same kind as SEQUENCE with the same elements
1416  except that all elements satisfying the PRED are replaced with NEW. See
1417  manual for details."
1418  (substitute new test sequence
1419              :from-end from-end
1420              :test #'funcall
1421              :start start
1422              :end end
1423              :from-end from-end
1424              :count count
1425              :key key))
1426
1427(defun substitute-if-not (new test sequence &key from-end (start 0)
1428                              (end (length sequence))
1429                              count (key #'identity))
1430  "Return a sequence of the same kind as SEQUENCE with the same elements
1431  except that all elements not satisfying the PRED are replaced with NEW.
1432  See manual for details."
1433  (substitute new test sequence
1434              :from-end from-end
1435              :test-not #'funcall
1436              :start start
1437              :end end
1438              :from-end from-end
1439              :count count
1440              :key key))
1441
1442;;; NSubstitute:
1443
1444(defun nsubstitute (new old sequence &key from-end (test #'eql) test-not 
1445                        end 
1446                        (count most-positive-fixnum) (key #'identity) (start 0))
1447  "Return a sequence of the same kind as SEQUENCE with the same elements
1448  except that all elements equal to OLD are replaced with NEW. The SEQUENCE
1449  may be destructively modified. See manual for details."
1450  (setq count (check-count count))
1451  (let ((incrementer 1)
1452        (length (length sequence)))
1453    (setq end (check-sequence-bounds sequence start end))
1454    (seq-dispatch
1455     sequence
1456      (if from-end
1457        (nreverse (nlist-substitute*
1458                   new old (nreverse (the list sequence))
1459                   test test-not 
1460                   (- length end) 
1461                   (- length start)
1462                   count key))
1463        (nlist-substitute* new old sequence
1464                           test test-not start end count key))
1465      (progn 
1466        (if from-end
1467          (psetq start (1- end)
1468                 end (1- start)
1469                 incrementer -1))
1470        (nvector-substitute* new old sequence incrementer
1471                             test test-not start end count key)))))
1472
1473(defun nlist-substitute* (new old sequence test test-not start end count key)
1474  (do ((list (nthcdr start sequence) (cdr list))
1475       (index start (1+ index)))
1476      ((or (and end (= index end)) (null list) (= count 0)) sequence)
1477    (when (if test-not
1478            (not (funcall test-not  old (funcall key (car list)))) ;cfry mod
1479            (funcall test  old (funcall key (car list)))) ;cfry mod
1480      (rplaca list new)
1481      (setq count (1- count)))))
1482
1483(defun nvector-substitute* (new old sequence incrementer
1484                                test test-not start end count key)
1485  (do ((index start (+ index incrementer)))
1486      ((or (= index end) (= count 0)) sequence)
1487    (when (if test-not
1488            (not (funcall test-not  old (funcall key (aref sequence index))))
1489            ;above cfry mod. both order of argss to test-not and paren error
1490            ; between the funcall key and the funcall test-not
1491            (funcall test old (funcall key (aref sequence index)))) ;cfry mod
1492      (aset sequence index new)
1493      (setq count (1- count)))))
1494
1495;;; NSubstitute-If:
1496
1497(defun nsubstitute-if (new test sequence &key from-end (start 0)
1498                           end 
1499                           (count most-positive-fixnum) (key #'identity))
1500  "Return a sequence of the same kind as SEQUENCE with the same elements
1501   except that all elements satisfying the PRED are replaced with NEW.
1502   SEQUENCE may be destructively modified. See manual for details."
1503  (nsubstitute new test sequence
1504               :from-end from-end
1505               :test #'funcall
1506               :start start
1507               :end end
1508               :count count
1509               :key key))
1510
1511
1512;;; NSubstitute-If-Not:
1513
1514(defun nsubstitute-if-not (new test sequence &key from-end (start 0)
1515                               end (count most-positive-fixnum) (key #'identity))
1516  "Return a sequence of the same kind as SEQUENCE with the same elements
1517   except that all elements not satisfying the TEST are replaced with NEW.
1518   SEQUENCE may be destructively modified. See manual for details."
1519  (nsubstitute new test sequence
1520                 :from-end from-end
1521                 :test-not #'funcall
1522                 :start start
1523                 :end end
1524                 :count count
1525                 :key key))
1526
1527
1528;;; Position:
1529
1530(defun list-position/find-1 (eltp item list from-end test test-not start end key &aux hard)
1531  ;;if eltp is true, return element, otherwise return position
1532  (setq key (adjust-key key))
1533  (multiple-value-setq (test test-not)
1534                       (adjust-test-args item test test-not))
1535  (setq end (check-sequence-bounds list start end)
1536        hard (or test key test-not))
1537  (if from-end
1538    (if hard
1539      (list-position/find-from-end-complex eltp item list start end test test-not key)
1540      (list-position/find-from-end-simple eltp item list start end))
1541    (if hard
1542      (list-position/find-complex eltp item list start end test test-not key)
1543      (list-position/find-simple eltp item list start end))))
1544
1545(defun position (item sequence &key from-end test test-not (start 0) end key)
1546  (if sequence
1547    (seq-dispatch 
1548     sequence
1549     (list-position/find-1 nil item sequence from-end test test-not start end key)
1550     (vector-position-1 item sequence from-end test test-not start end key))))
1551
1552;Is it really necessary for these internal functions to take keyword args?
1553(defun list-position/find (eltp item list &key from-end test test-not (start 0) end key &aux hard)
1554  ;;if eltp is true, return element, otherwise return position
1555  (setq key (adjust-key key))
1556  (multiple-value-setq (test test-not)
1557                       (adjust-test-args item test test-not))
1558  (setq end (check-sequence-bounds list start end)
1559        hard (or test key test-not))
1560  (if from-end
1561    (if hard
1562      (list-position/find-from-end-complex eltp item list start end test test-not key)
1563      (list-position/find-from-end-simple eltp item list start end))
1564    (if hard
1565      (list-position/find-complex eltp item list start end test test-not key)
1566      (list-position/find-simple eltp item list start end))))
1567
1568;;; make these things positional
1569
1570
1571
1572;;; add a simple-vector case
1573
1574(defun vector-position-1 (item vector from-end test test-not start end key
1575                        &aux (inc (if from-end -1 1)) pos)
1576  (setq end (check-sequence-bounds vector start end))
1577  (setq key (adjust-key key))
1578  (multiple-value-setq (test test-not) (adjust-test-args item test test-not))
1579  (if from-end (psetq start (%i- end 1) end (%i- start 1)))
1580  (setq pos start)
1581  (if (simple-vector-p vector)
1582    (locally (declare (type simple-vector vector)
1583                      (optimize (speed 3) (safety 0)))
1584      (loop
1585        (if (eq pos end) (return))
1586        (if (matchp2 item (aref vector pos) test test-not key) (return pos))
1587        (setq pos (%i+ pos inc))))
1588    (loop
1589      (if (eq pos end) (return))
1590      (if (matchp2 item (aref vector pos) test test-not key) (return pos))
1591      (setq pos (%i+ pos inc)))))
1592
1593(defun list-position/find-simple (eltp item list start end &aux (pos 0))
1594  (loop
1595    (if (or (eq pos start) (null list))
1596      (return)
1597      (setq list (cdr list) pos (%i+ pos 1))))
1598  (loop
1599    (if (and list (neq end pos))
1600      (if (eq item (car list))
1601        (return (if eltp item pos))
1602        (setq list (%cdr list) pos (%i+ pos 1)))
1603      (return))))
1604
1605(defun list-position/find-complex (eltp item list start end test test-not key &aux (pos 0))
1606  (loop
1607    (if (or (eq pos start) (null list))
1608      (return)
1609      (setq list (cdr list) pos (%i+ pos 1))))
1610  (loop
1611    (if (and list (neq end pos))
1612      (progn
1613        (if (matchp2 item (car list) test test-not key)
1614          (return (if eltp (%car list) pos))
1615          (setq list (%cdr list) pos (%i+ pos 1))))
1616      (return))))
1617
1618(defun list-position/find-from-end-simple (eltp item list start end &aux (pos 0) ret)
1619  (loop
1620    (if (or (eq pos start) (null list))
1621      (return)
1622      (setq list (cdr list) pos (%i+ pos 1))))
1623  (loop
1624    (if (and list (neq end pos))
1625      (progn
1626        (if (eq item (car list)) (setq ret pos))
1627        (setq list (%cdr list) pos (%i+ pos 1)))
1628      (return (if eltp (if ret item) ret)))))
1629
1630(defun list-position/find-from-end-complex (eltp item list start end test test-not key 
1631                                            &aux (pos 0) ret val)
1632  (loop
1633    (if (or (eq pos start) (null list))
1634      (return)
1635      (setq list (cdr list) pos (%i+ pos 1))))
1636  (loop
1637    (if (and list (neq end pos))
1638      (progn
1639        (if (matchp2 item (setq val (car list)) test test-not key)
1640          (setq ret (if eltp val pos)))
1641        (setq list (%cdr list) pos (%i+ pos 1)))
1642      (return ret))))
1643
1644(defun vector-position (item vector &key from-end test test-not (start 0) end key
1645                        &aux (inc (if from-end -1 1)) pos)
1646  (setq end (check-sequence-bounds vector start end))
1647  (setq key (adjust-key key))
1648  (multiple-value-setq (test test-not) (adjust-test-args item test test-not))
1649  (if from-end (psetq start (%i- end 1) end (%i- start 1)))
1650  (setq pos start)
1651  (loop
1652    (if (eq pos end) (return))
1653    (if (matchp2 item (aref vector pos) test test-not key) (return pos))
1654    (setq pos (%i+ pos inc))))
1655
1656;;; Position-if:
1657
1658(defun position-if (test sequence &key from-end (start 0) end key)
1659  (position test sequence
1660            :test #'funcall
1661            :from-end from-end
1662            :start start
1663            :end end
1664            :key key))
1665
1666
1667;;; Position-if-not:
1668
1669(defun position-if-not (test sequence &key from-end (start 0) end key)
1670  (position test sequence
1671            :test-not #'funcall
1672            :from-end from-end
1673            :start start
1674            :end end
1675            :key key))
1676
1677;;; Count:
1678
1679(defun vector-count-from-start (test item sequence start end key)
1680  (declare (fixnum start end))
1681  (do* ((index start (1+ index))
1682        (count 0))
1683       ((= index end) count)
1684    (declare (fixnum index count limit))
1685    (when (funcall test item  (funcall key (aref sequence index)))
1686      (incf count))))
1687
1688(defun vector-count-from-end (test item sequence start end key)
1689  (declare (fixnum start end))
1690  (do* ((index (1- end) (1- index))
1691        (count 0)
1692        (limit (1- start)))
1693       ((= index limit) count)
1694    (declare (fixnum index count limit))
1695    (when (funcall test item (funcall key (aref sequence index)))
1696      (incf count))))
1697
1698(defun vector-count-not-p-from-start (test-not item sequence start end key)
1699  (declare (fixnum start end))
1700  (do* ((index start (1+ index))
1701        (count 0))
1702       ((= index end) count)
1703    (declare (fixnum index count limit))
1704    (unless (funcall test-not item (funcall key (aref sequence index)))
1705      (incf count))))
1706
1707(defun vector-count-not-p-from-end (test-not item sequence start end key)
1708  (declare (fixnum start end))
1709  (do* ((index (1- end) (1- index))
1710        (count 0)
1711        (limit (1- start)))
1712       ((= index limit) count)
1713    (declare (fixnum index count limit))
1714    (unless (funcall test-not item (funcall key (aref sequence index)))
1715      (incf count))))
1716
1717(defun list-count-from-start (test item sequence start end key)
1718  (declare (fixnum start end) (list sequence))
1719  (do* ((seq (nthcdr start sequence) (cdr seq))
1720        (element (car seq) (car seq))
1721        (index start (1+ index))
1722        (count 0))
1723       ((or (= index end) (null seq)) count)
1724    (declare (fixnum index count) (list seq))
1725    (when (funcall test item (funcall key element))
1726      (incf count))))
1727
1728(defun list-count-from-end (test item sequence start end key)
1729  (declare (fixnum start end))
1730  (let* ((len (length sequence)))
1731    (declare (fixnum len))
1732    (list-count-from-start test item (reverse sequence) (- len end) (- len start) key)))
1733
1734(defun list-count-not-p-from-start (test-not item sequence start end key)
1735  (declare (fixnum start end) (list sequence))
1736  (do* ((seq (nthcdr start sequence) (cdr seq))
1737        (element (car seq) (car seq))
1738        (index start (1+ index))
1739        (count 0))
1740       ((or (= index end) (null seq)) count)
1741    (declare (fixnum index count) (list seq))
1742    (unless (funcall test-not item  (funcall key element))
1743      (incf count))))
1744
1745(defun list-count-not-p-from-end (test-not item sequence start end key)
1746  (declare (fixnum start end))
1747  (let* ((len (length sequence)))
1748    (declare (fixnum len))
1749    (list-count-not-p-from-start test-not item (reverse sequence) (- len end) (- len start) key)))
1750
1751(defun count (item sequence &key from-end (test #'eql testp)
1752                   (test-not nil notp) (start 0) end key)
1753  "Return the number of elements in SEQUENCE satisfying a test with ITEM,
1754   which defaults to EQL."
1755  (if (and testp notp)
1756    (test-not-error test test-not))
1757  (unless key
1758    (setq key #'identity))
1759  (setq end (check-sequence-bounds sequence start end))
1760  (if sequence
1761    (seq-dispatch
1762     sequence
1763     (if notp
1764       (if from-end
1765         (list-count-not-p-from-end test-not item  sequence start end key)
1766         (list-count-not-p-from-start test-not item sequence start end key))
1767       (if from-end
1768         (list-count-from-end test item sequence start end key)
1769         (list-count-from-start test item sequence start end key)))
1770     (if notp
1771       (if from-end
1772         (vector-count-not-p-from-end test-not item sequence start end key)
1773         (vector-count-not-p-from-start test-not item sequence start end key))
1774       (if from-end
1775         (vector-count-from-end test item sequence start end key)
1776         (vector-count-from-start test item sequence start end key))))
1777    0))
1778
1779
1780;;; Count-if:
1781
1782(defun count-if (test sequence &key from-end (start 0) end key)
1783  "Return the number of elements in SEQUENCE satisfying PRED(el)."
1784  (count test sequence
1785         :test #'funcall
1786         :from-end from-end
1787         :start start
1788         :end end
1789         :key key))
1790
1791;;; Count-if-not:
1792
1793(defun count-if-not (test sequence &key from-end (start 0) end key)
1794  "Return the number of elements in SEQUENCE not satisfying TEST(el)."
1795  (count test sequence
1796         :test-not #'funcall
1797         :from-end from-end
1798         :start start
1799         :end end
1800         :key key))
1801
1802
1803;;; Find:
1804
1805(defun find (item sequence &key from-end test test-not (start 0) end key &aux temp)
1806  (if sequence
1807    (seq-dispatch
1808     sequence
1809     (list-position/find-1 t item sequence from-end test test-not start end key)
1810     (if (setq temp (vector-position-1 item sequence from-end test test-not start end key))
1811       (aref sequence temp)))))
1812
1813(defun find-if (test sequence &key from-end (start 0) end key)
1814  (find test sequence
1815        :test #'funcall
1816        :from-end from-end
1817        :start start
1818        :end end
1819        :key key))
1820
1821(defun find-if-not (test sequence &key from-end (start 0) end key)
1822  (find test sequence
1823        :test-not #'funcall
1824        :from-end from-end
1825        :start start
1826        :end end
1827        :key key))
1828
1829
1830;;; Mismatch:
1831
1832(defun mismatch (seq1 seq2 &key (from-end nil)
1833                                  (test #'eql)
1834                                  (test-not nil)
1835                                  (key #'identity)
1836                                  (start1 0)
1837                                  (start2 0)
1838                                  (end1 nil)
1839                                  (end2 nil)
1840                             &aux (length1 (length seq1))
1841                                  (length2 (length seq2))
1842                                  (vectorp1 (vectorp seq1))
1843                                  (vectorp2 (vectorp seq2)))
1844  "The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared
1845   element-wise. If they are of equal length and match in every element, the
1846   result is NIL. Otherwise, the result is a non-negative integer, the index
1847   within SEQUENCE1 of the leftmost position at which they fail to match; or,
1848   if one is shorter than and a matching prefix of the other, the index within
1849   SEQUENCE1 beyond the last position tested is returned. If a non-NIL
1850   :FROM-END argument is given, then one plus the index of the rightmost
1851   position in which the sequences differ is returned."
1852  ;seq type-checking is done by length
1853  ;start/end type-cheking is done by <= (below)
1854  ;test/key type-checking is done by funcall
1855  ;no check for both test and test-not
1856  (or end1 (setq end1 length1))
1857  (or end2 (setq end2 length2))
1858  (unless (and (<= start1 end1 length1)
1859               (<= start2 end2 length2))
1860    (error "Sequence arg out of range"))
1861  (unless vectorp1
1862    (setq seq1 (nthcdr start1 seq1))
1863    (if from-end
1864      (do* ((s1 ())
1865            (i start1 (1+ i)))
1866           ((= i end1) (setq seq1 s1))
1867        (push (pop seq1) s1))))
1868  (unless vectorp2
1869    (setq seq2 (nthcdr start2 seq2))
1870    (if from-end
1871      (do* ((s2 ())
1872            (i start2 (1+ i)))
1873           ((= i end2) (setq seq2 s2))
1874        (push (pop seq2) s2))))
1875  (when test-not (setq test test-not))
1876  (if from-end
1877      ;from-end
1878      (let* ((count1 end1)
1879             (count2 end2)
1880             (elt1)
1881             (elt2))
1882        (loop
1883          (if (or (eq count1 start1)
1884                  (eq count2 start2))
1885              (return-from mismatch
1886                           (if (and (eq count1 start1)
1887                                    (eq count2 start2))
1888                               nil
1889                               count1)))
1890         
1891          (setq count1 (%i- count1 1)
1892                count2 (%i- count2 1))
1893
1894          (setq elt1 (funcall key (if vectorp1
1895                                      (aref seq1 count1)
1896                                      (prog1
1897                                        (%car seq1)
1898                                        (setq seq1 (%cdr seq1)))))
1899                elt2 (funcall key (if vectorp2
1900                                      (aref seq2 count2)
1901                                      (prog1
1902                                        (%car seq2)
1903                                        (setq seq2 (%cdr seq2))))))
1904
1905          (when (if test-not
1906                    (funcall test elt1 elt2)
1907                    (not (funcall test elt1 elt2)))
1908            (return-from mismatch (%i+ count1 1)))))
1909      ;from-start
1910      (let* ((count1 start1)
1911             (count2 start2)
1912             (elt1)
1913             (elt2))
1914        (loop
1915          (if (or (eq count1 end1)
1916                  (eq count2 end2))
1917              (return-from mismatch
1918                           (if (and (eq count1 end1)
1919                                    (eq count2 end2))
1920                               nil
1921                               count1)))
1922          (setq elt1 (funcall key (if vectorp1
1923                                      (aref seq1 count1)
1924                                      (prog1
1925                                        (%car seq1)
1926                                        (setq seq1 (%cdr seq1)))))
1927                elt2 (funcall key (if vectorp2
1928                                      (aref seq2 count2)
1929                                      (prog1
1930                                        (%car seq2)
1931                                        (setq seq2 (%cdr seq2))))))
1932         
1933          (when (if test-not
1934                    (funcall test elt1 elt2)
1935                    (not (funcall test elt1 elt2)))
1936            (return-from mismatch count1)) 
1937          (setq count1 (%i+ count1 1)
1938                count2 (%i+ count2 1))
1939         
1940          ))))
1941
1942
1943;;; Search comparison functions:
1944
1945(eval-when (:execute :compile-toplevel)
1946 
1947  ;;; Compare two elements
1948 
1949  (defmacro xcompare-elements (elt1 elt2)
1950    `(if (not key)
1951       (if test-not
1952         (not (funcall test-not ,elt1 ,elt2))
1953         (funcall test ,elt1 ,elt2))
1954       (let* ((e1 (funcall key ,elt1))
1955              (e2 (funcall key ,elt2)))
1956         (if test-not
1957           (not (funcall test-not  e1 e2))
1958           (funcall test e1 e2))))) 
1959 
1960  (defmacro vector-vector-search (sub main)
1961    `(let ((first-elt (aref ,sub start1))
1962           (last-one nil))
1963       (do* ((index2 start2 (1+ index2))
1964             (terminus (%i- end2 (%i- end1 start1))))
1965            ((> index2 terminus))
1966         (declare (fixnum index2 terminus))
1967         (if (xcompare-elements first-elt (aref ,main index2))
1968           (if (do* ((subi1 (1+ start1)(1+ subi1))
1969                     (subi2 (1+ index2) (1+ subi2)))
1970                    ((eq subi1 end1) t)
1971                 (declare (fixnum subi1 subi2))
1972                 (if (not (xcompare-elements (aref ,sub subi1) (aref ,main subi2)))
1973                   (return nil)))
1974             (if from-end
1975               (setq last-one index2)
1976               (return-from search index2)))))
1977       last-one))
1978
1979  (defmacro list-list-search (sub main)
1980    `(let* ((sub-sub (nthcdr start1 ,sub))
1981            (first-elt (%car sub-sub))
1982            (last-one nil))
1983       (do* ((index2 start2 (1+ index2))
1984             (sub-main (nthcdr start2 ,main) (%cdr sub-main))
1985             (terminus (%i- end2 (%i- end1 start1))))
1986            ((> index2 terminus))
1987         (declare (fixnum index2 terminus))
1988         (if (xcompare-elements first-elt (car sub-main))
1989           (if (do* ((ss (%cdr sub-sub) (%cdr ss))
1990                     (pos (1+ start1) (1+ pos))
1991                     (sm (%cdr sub-main) (cdr sm)))
1992                    ((or (null ss) (= pos end1))  t)
1993                 (declare (fixnum pos))
1994                 (if (not (xcompare-elements (%car ss) (%car sm)))
1995                     (return nil)))
1996              (if from-end
1997               (setq last-one index2)
1998               (return-from search index2)))))
1999       last-one))
2000 
2001  (defmacro list-vector-search (sub main)
2002    `(let* ((sub-sub (nthcdr start1 ,sub))
2003              (first-elt (%car sub-sub))
2004              (last-one nil))
2005         (do* ((index2 start2 (1+ index2))
2006               (terminus (%i- end2 (%i- end1 start1))))
2007              ((> index2 terminus))
2008           (declare (fixnum index2 terminus))
2009           (if (xcompare-elements first-elt (aref ,main index2))
2010             (if (do* ((ss (%cdr sub-sub) (%cdr ss))
2011                       (pos (1+ start1) (1+ pos))
2012                       (subi2 (1+ index2) (1+ subi2)))
2013                      ((or (null ss) (= pos end1))  t)
2014                   (declare (fixnum subi2 pos))
2015                   (if (not (xcompare-elements (%car ss) (aref ,main subi2)))
2016                     (return nil)))
2017               (if from-end
2018                 (setq last-one index2)
2019                 (return-from search index2)))))
2020         last-one))
2021
2022  (defmacro vector-list-search (sub main)
2023    `(let ((first-elt (aref ,sub start1))
2024           (last-one nil))
2025       (do* ((index2 start2 (1+ index2))
2026             (sub-main (nthcdr start2 ,main) (%cdr sub-main))
2027             (terminus (%i- end2 (%i- end1 start1))))
2028            ((> index2 terminus))
2029         (declare (fixnum index2 terminus))
2030         (if (xcompare-elements first-elt (car sub-main))
2031           (if (do* ((subi1 (1+ start1)(1+ subi1))
2032                     (sm (%cdr sub-main) (cdr sm)))
2033                    ((eq subi1 end1) t)
2034                 (declare (fixnum subi1))
2035                 (if (not (xcompare-elements (aref ,sub subi1) (car sm)))
2036                   (return nil)))
2037             (if from-end
2038               (setq last-one index2)
2039               (return-from search index2)))))
2040       last-one))
2041                 
2042   
2043  )
2044
2045
2046
2047(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not 
2048                          (start1 0) end1 (start2 0) end2 (key #'identity))
2049  (setq end1 (check-sequence-bounds sequence1 start1 end1))
2050  (setq end2 (check-sequence-bounds sequence2 start2 end2))
2051  (setq key (adjust-key key))
2052  (locally (declare (fixnum start1 end1 start2 end2))
2053    (if (eq 0 (%i- end1 start1))(if from-end end2 start2)
2054    (seq-dispatch sequence1
2055                  (seq-dispatch sequence2
2056                                (list-list-search sequence1 sequence2)
2057                                (list-vector-search sequence1 sequence2))
2058                  (seq-dispatch sequence2
2059                                (vector-list-search sequence1 sequence2)
2060                                (vector-vector-search sequence1 sequence2))))))
2061
Note: See TracBrowser for help on using the repository browser.