source: trunk/source/lib/sequences.lisp @ 8482

Last change on this file since 8482 was 8482, checked in by gb, 12 years ago

Use %INIT-MISC for ivector fill.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 79.2 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 (length sequence)) 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  (delete-duplicates (copy-seq sequence) :from-end from-end :test test
1250                     :test-not test-not :start start :end end :key key))
1251
1252;;; Delete-Duplicates:
1253
1254(defresource *eq-hash-resource* :constructor (make-hash-table :test #'eq)
1255  :destructor #'clrhash)
1256
1257(defresource *eql-hash-resource* :constructor (make-hash-table :test #'eql)
1258  :destructor #'clrhash)
1259
1260(defresource *equal-hash-resource* :constructor (make-hash-table :test #'equal)
1261  :destructor #'clrhash)
1262
1263(defresource *equalp-hash-resource* :constructor (make-hash-table :test #'equalp)
1264  :destructor #'clrhash)
1265
1266(defun list-delete-duplicates* (list test test-not key from-end start end)
1267  ;(%print "test:" test "test-not:" test-not "key:" key)
1268  (let (res)
1269    (cond 
1270     ((and (> (- end start) 10) (not test-not) ;(eq key #'identity)
1271           (cond ((or (eq test 'eq)(eq test #'eq))(setq res *eq-hash-resource*))
1272                 ((or (eq test 'eql)(eq test #'eql))(setq res *eql-hash-resource*))
1273                 ((or (eq test 'equal)(eq test  #'equal))
1274                  (setq res *equal-hash-resource*))
1275                 ((or (eq test 'equalp)(eq test #'equalp))
1276                  (setq res *equalp-hash-resource*))))
1277      (when (not from-end)(setq list (nreverse list))) ; who cares about which end?
1278      (let* (prev)
1279        (using-resource (table res)
1280          (do* ((rest (nthcdr start list) (%cdr rest))
1281                (index start (%i+ 1 index)))
1282               ((or (eq index end)(null rest)))
1283            (declare (fixnum index start end))
1284            (let ((thing (funcall key (%car rest))))
1285              (cond ((gethash thing table)
1286                     (%rplacd prev (%cdr rest)))
1287                    (t (setf (gethash thing table) t)
1288                       (setq prev rest))))))
1289        (if from-end list (nreverse list))))
1290     (T 
1291      (let ((handle (cons nil list)))
1292        (do ((current  (nthcdr start list) (cdr current))
1293             (previous (nthcdr start handle))
1294             (index start (1+ index)))
1295            ((or (= index end) (null current)) 
1296             (cdr handle))
1297          ;(%print "outer loop top current:" current "previous:" previous)
1298          (if (do ((x (if from-end 
1299                        (nthcdr (1+ start) handle)
1300                        (cdr current))
1301                      (cdr x))
1302                   (i (1+ index) (1+ i)))
1303                  ((or (null x) 
1304                       (and (not from-end) (= i end)) 
1305                       (eq x current)) 
1306                   nil)
1307                ;(%print "inner loop top x:" x "i:" i)
1308                (if (list-delete-duplicates*-aux current x test test-not key)                                   
1309                  (return t)))
1310            (rplacd previous (cdr current))
1311            (setq previous (cdr previous)))))))))
1312
1313(defun list-delete-duplicates*-aux (current x test test-not key)
1314     (if test-not
1315       (not (funcall test-not 
1316                     (funcall key (car current))
1317                     (funcall key (car x))))
1318       (funcall test 
1319                (funcall key (car current)) 
1320                (funcall key (car x)))))
1321
1322
1323(defun vector-delete-duplicates* (vector test test-not key from-end start end 
1324                                         &optional (length (length vector)))
1325  (declare (vector vector))
1326  (do ((index start (1+ index))
1327       (jndex start))
1328      ((= index end)
1329       (do ((index index (1+ index))            ; copy the rest of the vector
1330            (jndex jndex (1+ jndex)))
1331           ((= index length)
1332            (setq vector (shrink-vector vector jndex)))
1333            (aset vector jndex (aref vector index))))
1334      (aset vector jndex (aref vector index))
1335      (unless (position (funcall key (aref vector index)) vector :key key
1336                             :start (if from-end start (1+ index)) :test test
1337                                           :end (if from-end jndex end) :test-not test-not)
1338              (setq jndex (1+ jndex)))))
1339
1340(defun delete-duplicates (sequence &key (test #'eql) test-not (start 0) from-end end key)
1341  "The elements of SEQUENCE are examined, and if any two match, one is
1342   discarded.  The resulting sequence, which may be formed by destroying the
1343   given sequence, is returned.
1344   Sequences of type STR have a NEW str returned."
1345  (unless end (setq end (length sequence)))
1346  (unless key (setq key #'identity))
1347  (seq-dispatch sequence
1348    (if sequence
1349              (list-delete-duplicates* sequence test test-not key from-end start end))
1350    (vector-delete-duplicates* sequence test test-not key from-end start end)))
1351
1352(defun list-substitute* (pred new list start end count key 
1353                              test test-not old)
1354  ;(print-db pred new list start end count key test test-not old)
1355  (let* ((result (list nil))
1356         elt
1357         (splice result)
1358         (list list))           ; Get a local list for a stepper.
1359    (do ((index 0 (1+ index)))
1360        ((= index start))
1361      (setq splice (cdr (rplacd splice (list (car list)))))
1362      (setq list (cdr list)))
1363    (do ((index start (1+ index)))
1364        ((or (and end (= index end)) (null list) (= count 0)))
1365      (setq elt (car list))
1366      (setq splice
1367            (cdr (rplacd splice
1368                         (list
1369                          (cond ((case pred
1370                                   (normal
1371                                    (if test-not
1372                                      (not (funcall test-not  old
1373                                                    ;fry mod to slisp, which had arg order of OLD and ELT reversed.
1374                                                    (funcall key elt)))
1375                                      (funcall test old
1376                                               (funcall key elt))))
1377                                   (if (funcall test (funcall key elt)))
1378                                   (if-not (not (funcall test 
1379                                                         (funcall key elt)))))
1380                                 (setq count (1- count))
1381                                 new)
1382                                (t elt))))))
1383      (setq list (cdr list)))
1384    (do ()
1385        ((null list))
1386      (setq splice (cdr (rplacd splice (list (car list)))))
1387      (setq list (cdr list)))
1388    (cdr result)))
1389
1390;;; Replace old with new in sequence moving from left to right by incrementer
1391;;; on each pass through the loop. Called by all three substitute functions.
1392(defun vector-substitute* (pred new sequence incrementer left right length
1393                                start end count key test test-not old)
1394  (let ((result (make-sequence-like sequence length))
1395        (index left))
1396    (do ()
1397        ((= index start))
1398      (aset result index (aref sequence index))
1399      (setq index (+ index incrementer)))
1400    (do ((elt))
1401        ((or (= index end) (= count 0)))
1402      (setq elt (aref sequence index))
1403      (aset result index 
1404            (cond ((case pred
1405                     (normal
1406                      (if test-not
1407                        (not (funcall test-not old (funcall key elt))) ;cfry mod
1408                        (funcall test old (funcall key elt)))) ;cfry mod
1409                     (if (funcall test (funcall key elt)))
1410                     (if-not (not (funcall test (funcall key elt)))))
1411                   (setq count (1- count))
1412                   new)
1413                  (t elt)))
1414      (setq index (+ index incrementer)))
1415    (do ()
1416        ((= index right))
1417      (aset result index (aref sequence index))
1418      (setq index (+ index incrementer)))
1419    result))
1420
1421;;; Substitute:
1422
1423(defun substitute (new old sequence &key from-end (test #'eql) test-not
1424                       (start 0) count
1425                       end (key #'identity))
1426  "Return a sequence of the same kind as SEQUENCE with the same elements,
1427  except that all elements equal to OLD are replaced with NEW. See manual
1428  for details."
1429  (setq count (check-count count))
1430  (let ((length (length sequence))        )
1431    (setq end (check-sequence-bounds sequence start end))
1432    (seq-dispatch 
1433     sequence
1434     (if from-end
1435       (nreverse (list-substitute* 'normal new (reverse sequence) (- length end)
1436                                   (- length start) count key test test-not old))
1437       (list-substitute* 'normal new sequence start end count key test test-not
1438                         old))
1439     (if from-end
1440       (vector-substitute* 'normal new sequence -1 (1- length) -1 length 
1441                           (1- end) (1- start) count key test test-not old)
1442       (vector-substitute* 'normal new sequence 1 0 length length
1443                           start end count key test test-not old)))))
1444
1445
1446(defun substitute-if (new test sequence &key from-end (start 0)
1447                          (end (length sequence))
1448                          count (key #'identity))
1449  "Return a sequence of the same kind as SEQUENCE with the same elements
1450  except that all elements satisfying the PRED are replaced with NEW. See
1451  manual for details."
1452  (substitute new test sequence
1453              :from-end from-end
1454              :test #'funcall
1455              :start start
1456              :end end
1457              :from-end from-end
1458              :count count
1459              :key key))
1460
1461(defun substitute-if-not (new test sequence &key from-end (start 0)
1462                              (end (length sequence))
1463                              count (key #'identity))
1464  "Return a sequence of the same kind as SEQUENCE with the same elements
1465  except that all elements not satisfying the PRED are replaced with NEW.
1466  See manual for details."
1467  (substitute new test sequence
1468              :from-end from-end
1469              :test-not #'funcall
1470              :start start
1471              :end end
1472              :from-end from-end
1473              :count count
1474              :key key))
1475
1476;;; NSubstitute:
1477
1478(defun nsubstitute (new old sequence &key from-end (test #'eql) test-not 
1479                        end 
1480                        (count most-positive-fixnum) (key #'identity) (start 0))
1481  "Return a sequence of the same kind as SEQUENCE with the same elements
1482  except that all elements equal to OLD are replaced with NEW. The SEQUENCE
1483  may be destructively modified. See manual for details."
1484  (setq count (check-count count))
1485  (let ((incrementer 1)
1486        (length (length sequence)))
1487    (setq end (check-sequence-bounds sequence start end))
1488    (seq-dispatch
1489     sequence
1490      (if from-end
1491        (nreverse (nlist-substitute*
1492                   new old (nreverse (the list sequence))
1493                   test test-not 
1494                   (- length end) 
1495                   (- length start)
1496                   count key))
1497        (nlist-substitute* new old sequence
1498                           test test-not start end count key))
1499      (progn 
1500        (if from-end
1501          (psetq start (1- end)
1502                 end (1- start)
1503                 incrementer -1))
1504        (nvector-substitute* new old sequence incrementer
1505                             test test-not start end count key)))))
1506
1507(defun nlist-substitute* (new old sequence test test-not start end count key)
1508  (do ((list (nthcdr start sequence) (cdr list))
1509       (index start (1+ index)))
1510      ((or (and end (= index end)) (null list) (= count 0)) sequence)
1511    (when (if test-not
1512            (not (funcall test-not  old (funcall key (car list)))) ;cfry mod
1513            (funcall test  old (funcall key (car list)))) ;cfry mod
1514      (rplaca list new)
1515      (setq count (1- count)))))
1516
1517(defun nvector-substitute* (new old sequence incrementer
1518                                test test-not start end count key)
1519  (do ((index start (+ index incrementer)))
1520      ((or (= index end) (= count 0)) sequence)
1521    (when (if test-not
1522            (not (funcall test-not  old (funcall key (aref sequence index))))
1523            ;above cfry mod. both order of argss to test-not and paren error
1524            ; between the funcall key and the funcall test-not
1525            (funcall test old (funcall key (aref sequence index)))) ;cfry mod
1526      (aset sequence index new)
1527      (setq count (1- count)))))
1528
1529;;; NSubstitute-If:
1530
1531(defun nsubstitute-if (new test sequence &key from-end (start 0)
1532                           end 
1533                           (count most-positive-fixnum) (key #'identity))
1534  "Return a sequence of the same kind as SEQUENCE with the same elements
1535   except that all elements satisfying the PRED are replaced with NEW.
1536   SEQUENCE may be destructively modified. See manual for details."
1537  (nsubstitute new test sequence
1538               :from-end from-end
1539               :test #'funcall
1540               :start start
1541               :end end
1542               :count count
1543               :key key))
1544
1545
1546;;; NSubstitute-If-Not:
1547
1548(defun nsubstitute-if-not (new test sequence &key from-end (start 0)
1549                               end (count most-positive-fixnum) (key #'identity))
1550  "Return a sequence of the same kind as SEQUENCE with the same elements
1551   except that all elements not satisfying the TEST are replaced with NEW.
1552   SEQUENCE may be destructively modified. See manual for details."
1553  (nsubstitute new test sequence
1554                 :from-end from-end
1555                 :test-not #'funcall
1556                 :start start
1557                 :end end
1558                 :count count
1559                 :key key))
1560
1561
1562;;; Position:
1563
1564(defun list-position/find-1 (eltp item list from-end test test-not start end key &aux hard)
1565  ;;if eltp is true, return element, otherwise return position
1566  (setq key (adjust-key key))
1567  (multiple-value-setq (test test-not)
1568                       (adjust-test-args item test test-not))
1569  (setq end (check-sequence-bounds list start end)
1570        hard (or test key test-not))
1571  (if from-end
1572    (if hard
1573      (list-position/find-from-end-complex eltp item list start end test test-not key)
1574      (list-position/find-from-end-simple eltp item list start end))
1575    (if hard
1576      (list-position/find-complex eltp item list start end test test-not key)
1577      (list-position/find-simple eltp item list start end))))
1578
1579(defun position (item sequence &key from-end test test-not (start 0) end key)
1580  (if sequence
1581    (seq-dispatch 
1582     sequence
1583     (list-position/find-1 nil item sequence from-end test test-not start end key)
1584     (vector-position-1 item sequence from-end test test-not start end key))))
1585
1586;Is it really necessary for these internal functions to take keyword args?
1587(defun list-position/find (eltp item list &key from-end test test-not (start 0) end key &aux hard)
1588  ;;if eltp is true, return element, otherwise return position
1589  (setq key (adjust-key key))
1590  (multiple-value-setq (test test-not)
1591                       (adjust-test-args item test test-not))
1592  (setq end (check-sequence-bounds list start end)
1593        hard (or test key test-not))
1594  (if from-end
1595    (if hard
1596      (list-position/find-from-end-complex eltp item list start end test test-not key)
1597      (list-position/find-from-end-simple eltp item list start end))
1598    (if hard
1599      (list-position/find-complex eltp item list start end test test-not key)
1600      (list-position/find-simple eltp item list start end))))
1601
1602;;; make these things positional
1603
1604
1605
1606;;; add a simple-vector case
1607
1608(defun vector-position-1 (item vector from-end test test-not start end key
1609                        &aux (inc (if from-end -1 1)) pos)
1610  (setq end (check-sequence-bounds vector start end))
1611  (setq key (adjust-key key))
1612  (multiple-value-setq (test test-not) (adjust-test-args item test test-not))
1613  (if from-end (psetq start (%i- end 1) end (%i- start 1)))
1614  (setq pos start)
1615  (if (simple-vector-p vector)
1616    (locally (declare (type simple-vector vector)
1617                      (optimize (speed 3) (safety 0)))
1618      (loop
1619        (if (eq pos end) (return))
1620        (if (matchp2 item (aref vector pos) test test-not key) (return pos))
1621        (setq pos (%i+ pos inc))))
1622    (loop
1623      (if (eq pos end) (return))
1624      (if (matchp2 item (aref vector pos) test test-not key) (return pos))
1625      (setq pos (%i+ pos inc)))))
1626
1627(defun list-position/find-simple (eltp item list start end &aux (pos 0))
1628  (loop
1629    (if (or (eq pos start) (null list))
1630      (return)
1631      (setq list (cdr list) pos (%i+ pos 1))))
1632  (loop
1633    (if (and list (neq end pos))
1634      (if (eq item (car list))
1635        (return (if eltp item pos))
1636        (setq list (%cdr list) pos (%i+ pos 1)))
1637      (return))))
1638
1639(defun list-position/find-complex (eltp item list start end test test-not key &aux (pos 0))
1640  (loop
1641    (if (or (eq pos start) (null list))
1642      (return)
1643      (setq list (cdr list) pos (%i+ pos 1))))
1644  (loop
1645    (if (and list (neq end pos))
1646      (progn
1647        (if (matchp2 item (car list) test test-not key)
1648          (return (if eltp (%car list) pos))
1649          (setq list (%cdr list) pos (%i+ pos 1))))
1650      (return))))
1651
1652(defun list-position/find-from-end-simple (eltp item list start end &aux (pos 0) ret)
1653  (loop
1654    (if (or (eq pos start) (null list))
1655      (return)
1656      (setq list (cdr list) pos (%i+ pos 1))))
1657  (loop
1658    (if (and list (neq end pos))
1659      (progn
1660        (if (eq item (car list)) (setq ret pos))
1661        (setq list (%cdr list) pos (%i+ pos 1)))
1662      (return (if eltp (if ret item) ret)))))
1663
1664(defun list-position/find-from-end-complex (eltp item list start end test test-not key 
1665                                            &aux (pos 0) ret val)
1666  (loop
1667    (if (or (eq pos start) (null list))
1668      (return)
1669      (setq list (cdr list) pos (%i+ pos 1))))
1670  (loop
1671    (if (and list (neq end pos))
1672      (progn
1673        (if (matchp2 item (setq val (car list)) test test-not key)
1674          (setq ret (if eltp val pos)))
1675        (setq list (%cdr list) pos (%i+ pos 1)))
1676      (return ret))))
1677
1678(defun vector-position (item vector &key from-end test test-not (start 0) end key
1679                        &aux (inc (if from-end -1 1)) pos)
1680  (setq end (check-sequence-bounds vector start end))
1681  (setq key (adjust-key key))
1682  (multiple-value-setq (test test-not) (adjust-test-args item test test-not))
1683  (if from-end (psetq start (%i- end 1) end (%i- start 1)))
1684  (setq pos start)
1685  (loop
1686    (if (eq pos end) (return))
1687    (if (matchp2 item (aref vector pos) test test-not key) (return pos))
1688    (setq pos (%i+ pos inc))))
1689
1690;;; Position-if:
1691
1692(defun position-if (test sequence &key from-end (start 0) end key)
1693  (position test sequence
1694            :test #'funcall
1695            :from-end from-end
1696            :start start
1697            :end end
1698            :key key))
1699
1700
1701;;; Position-if-not:
1702
1703(defun position-if-not (test sequence &key from-end (start 0) end key)
1704  (position test sequence
1705            :test-not #'funcall
1706            :from-end from-end
1707            :start start
1708            :end end
1709            :key key))
1710
1711;;; Count:
1712
1713(defun vector-count-from-start (test item sequence start end key)
1714  (declare (fixnum start end))
1715  (do* ((index start (1+ index))
1716        (count 0))
1717       ((= index end) count)
1718    (declare (fixnum index count limit))
1719    (when (funcall test item  (funcall key (aref sequence index)))
1720      (incf count))))
1721
1722(defun vector-count-from-end (test item sequence start end key)
1723  (declare (fixnum start end))
1724  (do* ((index (1- end) (1- index))
1725        (count 0)
1726        (limit (1- start)))
1727       ((= index limit) count)
1728    (declare (fixnum index count limit))
1729    (when (funcall test item (funcall key (aref sequence index)))
1730      (incf count))))
1731
1732(defun vector-count-not-p-from-start (test-not item sequence start end key)
1733  (declare (fixnum start end))
1734  (do* ((index start (1+ index))
1735        (count 0))
1736       ((= index end) count)
1737    (declare (fixnum index count limit))
1738    (unless (funcall test-not item (funcall key (aref sequence index)))
1739      (incf count))))
1740
1741(defun vector-count-not-p-from-end (test-not item sequence start end key)
1742  (declare (fixnum start end))
1743  (do* ((index (1- end) (1- index))
1744        (count 0)
1745        (limit (1- start)))
1746       ((= index limit) count)
1747    (declare (fixnum index count limit))
1748    (unless (funcall test-not item (funcall key (aref sequence index)))
1749      (incf count))))
1750
1751(defun list-count-from-start (test item sequence start end key)
1752  (declare (fixnum start end) (list sequence))
1753  (do* ((seq (nthcdr start sequence) (cdr seq))
1754        (element (car seq) (car seq))
1755        (index start (1+ index))
1756        (count 0))
1757       ((or (= index end) (null seq)) count)
1758    (declare (fixnum index count) (list seq))
1759    (when (funcall test item (funcall key element))
1760      (incf count))))
1761
1762(defun list-count-from-end (test item sequence start end key)
1763  (declare (fixnum start end))
1764  (let* ((len (length sequence)))
1765    (declare (fixnum len))
1766    (list-count-from-start test item (reverse sequence) (- len end) (- len start) key)))
1767
1768(defun list-count-not-p-from-start (test-not item sequence start end key)
1769  (declare (fixnum start end) (list sequence))
1770  (do* ((seq (nthcdr start sequence) (cdr seq))
1771        (element (car seq) (car seq))
1772        (index start (1+ index))
1773        (count 0))
1774       ((or (= index end) (null seq)) count)
1775    (declare (fixnum index count) (list seq))
1776    (unless (funcall test-not item  (funcall key element))
1777      (incf count))))
1778
1779(defun list-count-not-p-from-end (test-not item sequence start end key)
1780  (declare (fixnum start end))
1781  (let* ((len (length sequence)))
1782    (declare (fixnum len))
1783    (list-count-not-p-from-start test-not item (reverse sequence) (- len end) (- len start) key)))
1784
1785(defun count (item sequence &key from-end (test #'eql testp)
1786                   (test-not nil notp) (start 0) end key)
1787  "Return the number of elements in SEQUENCE satisfying a test with ITEM,
1788   which defaults to EQL."
1789  (if (and testp notp)
1790    (test-not-error test test-not))
1791  (unless key
1792    (setq key #'identity))
1793  (setq end (check-sequence-bounds sequence start end))
1794  (if sequence
1795    (seq-dispatch
1796     sequence
1797     (if notp
1798       (if from-end
1799         (list-count-not-p-from-end test-not item  sequence start end key)
1800         (list-count-not-p-from-start test-not item sequence start end key))
1801       (if from-end
1802         (list-count-from-end test item sequence start end key)
1803         (list-count-from-start test item sequence start end key)))
1804     (if notp
1805       (if from-end
1806         (vector-count-not-p-from-end test-not item sequence start end key)
1807         (vector-count-not-p-from-start test-not item sequence start end key))
1808       (if from-end
1809         (vector-count-from-end test item sequence start end key)
1810         (vector-count-from-start test item sequence start end key))))
1811    0))
1812
1813
1814;;; Count-if:
1815
1816(defun count-if (test sequence &key from-end (start 0) end key)
1817  "Return the number of elements in SEQUENCE satisfying PRED(el)."
1818  (count test sequence
1819         :test #'funcall
1820         :from-end from-end
1821         :start start
1822         :end end
1823         :key key))
1824
1825;;; Count-if-not:
1826
1827(defun count-if-not (test sequence &key from-end (start 0) end key)
1828  "Return the number of elements in SEQUENCE not satisfying TEST(el)."
1829  (count test sequence
1830         :test-not #'funcall
1831         :from-end from-end
1832         :start start
1833         :end end
1834         :key key))
1835
1836
1837;;; Find:
1838
1839(defun find (item sequence &key from-end test test-not (start 0) end key &aux temp)
1840  (if sequence
1841    (seq-dispatch
1842     sequence
1843     (list-position/find-1 t item sequence from-end test test-not start end key)
1844     (if (setq temp (vector-position-1 item sequence from-end test test-not start end key))
1845       (aref sequence temp)))))
1846
1847(defun find-if (test sequence &key from-end (start 0) end key)
1848  (find test sequence
1849        :test #'funcall
1850        :from-end from-end
1851        :start start
1852        :end end
1853        :key key))
1854
1855(defun find-if-not (test sequence &key from-end (start 0) end key)
1856  (find test sequence
1857        :test-not #'funcall
1858        :from-end from-end
1859        :start start
1860        :end end
1861        :key key))
1862
1863
1864;;; Mismatch:
1865
1866(defun mismatch (seq1 seq2 &key (from-end nil)
1867                                  (test #'eql)
1868                                  (test-not nil)
1869                                  (key #'identity)
1870                                  (start1 0)
1871                                  (start2 0)
1872                                  (end1 nil)
1873                                  (end2 nil)
1874                             &aux (length1 (length seq1))
1875                                  (length2 (length seq2))
1876                                  (vectorp1 (vectorp seq1))
1877                                  (vectorp2 (vectorp seq2)))
1878  "The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared
1879   element-wise. If they are of equal length and match in every element, the
1880   result is NIL. Otherwise, the result is a non-negative integer, the index
1881   within SEQUENCE1 of the leftmost position at which they fail to match; or,
1882   if one is shorter than and a matching prefix of the other, the index within
1883   SEQUENCE1 beyond the last position tested is returned. If a non-NIL
1884   :FROM-END argument is given, then one plus the index of the rightmost
1885   position in which the sequences differ is returned."
1886  ;seq type-checking is done by length
1887  ;start/end type-cheking is done by <= (below)
1888  ;test/key type-checking is done by funcall
1889  ;no check for both test and test-not
1890  (or end1 (setq end1 length1))
1891  (or end2 (setq end2 length2))
1892  (unless (and (<= start1 end1 length1)
1893               (<= start2 end2 length2))
1894    (error "Sequence arg out of range"))
1895  (unless vectorp1
1896    (setq seq1 (nthcdr start1 seq1))
1897    (if from-end
1898      (do* ((s1 ())
1899            (i start1 (1+ i)))
1900           ((= i end1) (setq seq1 s1))
1901        (push (pop seq1) s1))))
1902  (unless vectorp2
1903    (setq seq2 (nthcdr start2 seq2))
1904    (if from-end
1905      (do* ((s2 ())
1906            (i start2 (1+ i)))
1907           ((= i end2) (setq seq2 s2))
1908        (push (pop seq2) s2))))
1909  (when test-not (setq test test-not))
1910  (if from-end
1911      ;from-end
1912      (let* ((count1 end1)
1913             (count2 end2)
1914             (elt1)
1915             (elt2))
1916        (loop
1917          (if (or (eq count1 start1)
1918                  (eq count2 start2))
1919              (return-from mismatch
1920                           (if (and (eq count1 start1)
1921                                    (eq count2 start2))
1922                               nil
1923                               count1)))
1924         
1925          (setq count1 (%i- count1 1)
1926                count2 (%i- count2 1))
1927
1928          (setq elt1 (funcall key (if vectorp1
1929                                      (aref seq1 count1)
1930                                      (prog1
1931                                        (%car seq1)
1932                                        (setq seq1 (%cdr seq1)))))
1933                elt2 (funcall key (if vectorp2
1934                                      (aref seq2 count2)
1935                                      (prog1
1936                                        (%car seq2)
1937                                        (setq seq2 (%cdr seq2))))))
1938
1939          (when (if test-not
1940                    (funcall test elt1 elt2)
1941                    (not (funcall test elt1 elt2)))
1942            (return-from mismatch (%i+ count1 1)))))
1943      ;from-start
1944      (let* ((count1 start1)
1945             (count2 start2)
1946             (elt1)
1947             (elt2))
1948        (loop
1949          (if (or (eq count1 end1)
1950                  (eq count2 end2))
1951              (return-from mismatch
1952                           (if (and (eq count1 end1)
1953                                    (eq count2 end2))
1954                               nil
1955                               count1)))
1956          (setq elt1 (funcall key (if vectorp1
1957                                      (aref seq1 count1)
1958                                      (prog1
1959                                        (%car seq1)
1960                                        (setq seq1 (%cdr seq1)))))
1961                elt2 (funcall key (if vectorp2
1962                                      (aref seq2 count2)
1963                                      (prog1
1964                                        (%car seq2)
1965                                        (setq seq2 (%cdr seq2))))))
1966         
1967          (when (if test-not
1968                    (funcall test elt1 elt2)
1969                    (not (funcall test elt1 elt2)))
1970            (return-from mismatch count1)) 
1971          (setq count1 (%i+ count1 1)
1972                count2 (%i+ count2 1))
1973         
1974          ))))
1975
1976
1977;;; Search comparison functions:
1978
1979(eval-when (:execute :compile-toplevel)
1980 
1981  ;;; Compare two elements
1982 
1983  (defmacro xcompare-elements (elt1 elt2)
1984    `(if (not key)
1985       (if test-not
1986         (not (funcall test-not ,elt1 ,elt2))
1987         (funcall test ,elt1 ,elt2))
1988       (let* ((e1 (funcall key ,elt1))
1989              (e2 (funcall key ,elt2)))
1990         (if test-not
1991           (not (funcall test-not  e1 e2))
1992           (funcall test e1 e2))))) 
1993 
1994  (defmacro vector-vector-search (sub main)
1995    `(let ((first-elt (aref ,sub start1))
1996           (last-one nil))
1997       (do* ((index2 start2 (1+ index2))
1998             (terminus (%i- end2 (%i- end1 start1))))
1999            ((> index2 terminus))
2000         (declare (fixnum index2 terminus))
2001         (if (xcompare-elements first-elt (aref ,main index2))
2002           (if (do* ((subi1 (1+ start1)(1+ subi1))
2003                     (subi2 (1+ index2) (1+ subi2)))
2004                    ((eq subi1 end1) t)
2005                 (declare (fixnum subi1 subi2))
2006                 (if (not (xcompare-elements (aref ,sub subi1) (aref ,main subi2)))
2007                   (return nil)))
2008             (if from-end
2009               (setq last-one index2)
2010               (return-from search index2)))))
2011       last-one))
2012
2013  (defmacro list-list-search (sub main)
2014    `(let* ((sub-sub (nthcdr start1 ,sub))
2015            (first-elt (%car sub-sub))
2016            (last-one nil))
2017       (do* ((index2 start2 (1+ index2))
2018             (sub-main (nthcdr start2 ,main) (%cdr sub-main))
2019             (terminus (%i- end2 (%i- end1 start1))))
2020            ((> index2 terminus))
2021         (declare (fixnum index2 terminus))
2022         (if (xcompare-elements first-elt (car sub-main))
2023           (if (do* ((ss (%cdr sub-sub) (%cdr ss))
2024                     (pos (1+ start1) (1+ pos))
2025                     (sm (%cdr sub-main) (cdr sm)))
2026                    ((or (null ss) (= pos end1))  t)
2027                 (declare (fixnum pos))
2028                 (if (not (xcompare-elements (%car ss) (%car sm)))
2029                     (return nil)))
2030              (if from-end
2031               (setq last-one index2)
2032               (return-from search index2)))))
2033       last-one))
2034 
2035  (defmacro list-vector-search (sub main)
2036    `(let* ((sub-sub (nthcdr start1 ,sub))
2037              (first-elt (%car sub-sub))
2038              (last-one nil))
2039         (do* ((index2 start2 (1+ index2))
2040               (terminus (%i- end2 (%i- end1 start1))))
2041              ((> index2 terminus))
2042           (declare (fixnum index2 terminus))
2043           (if (xcompare-elements first-elt (aref ,main index2))
2044             (if (do* ((ss (%cdr sub-sub) (%cdr ss))
2045                       (pos (1+ start1) (1+ pos))
2046                       (subi2 (1+ index2) (1+ subi2)))
2047                      ((or (null ss) (= pos end1))  t)
2048                   (declare (fixnum subi2 pos))
2049                   (if (not (xcompare-elements (%car ss) (aref ,main subi2)))
2050                     (return nil)))
2051               (if from-end
2052                 (setq last-one index2)
2053                 (return-from search index2)))))
2054         last-one))
2055
2056  (defmacro vector-list-search (sub main)
2057    `(let ((first-elt (aref ,sub start1))
2058           (last-one nil))
2059       (do* ((index2 start2 (1+ index2))
2060             (sub-main (nthcdr start2 ,main) (%cdr sub-main))
2061             (terminus (%i- end2 (%i- end1 start1))))
2062            ((> index2 terminus))
2063         (declare (fixnum index2 terminus))
2064         (if (xcompare-elements first-elt (car sub-main))
2065           (if (do* ((subi1 (1+ start1)(1+ subi1))
2066                     (sm (%cdr sub-main) (cdr sm)))
2067                    ((eq subi1 end1) t)
2068                 (declare (fixnum subi1))
2069                 (if (not (xcompare-elements (aref ,sub subi1) (car sm)))
2070                   (return nil)))
2071             (if from-end
2072               (setq last-one index2)
2073               (return-from search index2)))))
2074       last-one))
2075                 
2076   
2077  )
2078
2079
2080
2081(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not 
2082                          (start1 0) end1 (start2 0) end2 (key #'identity))
2083  (setq end1 (check-sequence-bounds sequence1 start1 end1))
2084  (setq end2 (check-sequence-bounds sequence2 start2 end2))
2085  (setq key (adjust-key key))
2086  (locally (declare (fixnum start1 end1 start2 end2))
2087    (if (eq 0 (%i- end1 start1))(if from-end end2 start2)
2088    (seq-dispatch sequence1
2089                  (seq-dispatch sequence2
2090                                (list-list-search sequence1 sequence2)
2091                                (list-vector-search sequence1 sequence2))
2092                  (seq-dispatch sequence2
2093                                (vector-list-search sequence1 sequence2)
2094                                (vector-vector-search sequence1 sequence2))))))
2095
Note: See TracBrowser for help on using the repository browser.