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

Last change on this file since 14423 was 14373, checked in by gb, 9 years ago

Braino in CONCAT-TO-STRING.

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