source: branches/qres/ccl/lib/sequences.lisp @ 14308

Last change on this file since 14308 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

  • 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        #+(or ppc32-target x8632-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
489;This one doesn't choke on circular lists, doesn't cons as much, and is
490;about 1/8K smaller to boot.
491(defun map (type function sequence &rest more-sequences)
492  (declare (dynamic-extent more-sequences))
493  (let* ((sequences (cons sequence more-sequences))
494         (arglist (make-list (length sequences)))
495         (index 0)
496         args seq p (ans ()))
497    (declare (dynamic-extent sequences arglist))
498    (unless (or (null type)
499                (eq type 'list)
500                (memq (if (consp type) (%car type) type)
501                      '(simple-vector simple-string vector string array
502                        simple-array bit-vector simple-bit-vector))
503                (subtypep type 'sequence))
504      (report-bad-arg type 'sequence))
505    (loop
506      (setq p sequences args arglist)
507      (while p
508        (cond ((null (setq seq (%car p))) (return))
509              ((consp seq)
510               (%rplaca p (%cdr seq))
511               (%rplaca args (%car seq)))
512              ((eq index (length seq)) (return))
513              (t (%rplaca args (elt seq index))))
514        (setq args (%cdr args) p (%cdr p)))
515      (setq p (apply function arglist))
516      (if type (push p ans))
517      (setq index (%i+ index 1)))
518    (when type
519      (setq ans (nreverse ans))
520      (if (eq type 'list) ans (coerce ans type)))))
521
522;;;;;;;;;;;;;;;;;
523;;
524;; some, every, notevery, notany
525;;
526;; these all call SOME-XX-MULTI or SOME-XX-ONE
527;; SOME-XX-MULTI should probably be coded in lap
528;;
529;; these should be transformed at compile time
530;;
531;; we may want to consider open-coding when
532;; the predicate is a lambda
533;;
534
535(eval-when (:execute :compile-toplevel)
536  (defmacro negating-quantifier-p (quantifier-constant)
537    `(%i> ,quantifier-constant $notany))
538  )
539
540; Vector is guaranteed to be simple; new-size is guaranteed <= (length vector).
541; Return vector with its size adjusted and extra doublewords zeroed out.
542; Should only be called on freshly consed vectors...
543
544   
545   
546(defun some (predicate one-seq &rest sequences)
547  "Apply PREDICATE to the 0-indexed elements of the sequences, then
548   possibly to those with index 1, and so on. Return the first
549   non-NIL value encountered, or NIL if the end of any sequence is reached."
550  (declare (dynamic-extent sequences))
551  (if sequences
552      (some-xx-multi $some nil predicate one-seq sequences)
553      (some-xx-one $some nil predicate one-seq)))
554
555(defun notany (predicate one-seq &rest sequences)
556  "Apply PREDICATE to the 0-indexed elements of the sequences, then
557   possibly to those with index 1, and so on. Return NIL as soon
558   as any invocation of PREDICATE returns a non-NIL value, or T if the end
559   of any sequence is reached."
560  (declare (dynamic-extent sequences))
561  (if sequences
562      (some-xx-multi $notany t predicate one-seq sequences)
563      (some-xx-one $notany t predicate one-seq)))
564
565(defun every (predicate one-seq &rest sequences)
566  "Apply PREDICATE to the 0-indexed elements of the sequences, then
567   possibly to those with index 1, and so on. Return NIL as soon
568   as any invocation of PREDICATE returns NIL, or T if every invocation
569   is non-NIL."
570  (declare (dynamic-extent sequences))
571  (if sequences
572      (some-xx-multi $every t predicate one-seq sequences)
573      (some-xx-one $every t predicate one-seq)))
574
575(defun notevery (predicate one-seq &rest sequences)
576  "Apply PREDICATE to 0-indexed elements of the sequences, then
577   possibly to those with index 1, and so on. Return T as soon
578   as any invocation of PREDICATE returns NIL, or NIL if every invocation
579   is non-NIL."
580  (declare (dynamic-extent sequences))
581  (if sequences
582      (some-xx-multi $notevery nil predicate one-seq sequences)
583      (some-xx-one $notevery nil predicate one-seq)))
584
585(defun some-xx-multi (caller at-end predicate first-seq sequences)
586  (let* ((sequences (cons first-seq sequences))
587         (min-vector-length target::target-most-positive-fixnum)
588         (arg-slice (make-list (list-length sequences)))
589         (cur-slice arg-slice)
590         (not-result (negating-quantifier-p caller))
591         result)
592  (declare (fixnum min-vector-length)
593           (list sequences arg-slice cur-slice)
594           (dynamic-extent sequences arg-slice))
595  (dolist (seq sequences)
596    (seq-dispatch seq
597                  nil
598                  (setq min-vector-length (min min-vector-length
599                                               (length seq)))))
600  (dotimes (index min-vector-length)
601    (dolist (one-seq sequences)
602      (%rplaca cur-slice
603               (if (vectorp one-seq)
604                   (aref one-seq index)
605                   (if one-seq
606                       (progn
607                         (%rplaca (memq one-seq sequences) (cdr one-seq))
608                         (%car one-seq))
609                       (return-from some-xx-multi at-end))))
610      (setq cur-slice (%cdr cur-slice)))
611    (setq result (apply predicate arg-slice)
612          cur-slice arg-slice)
613    (if not-result
614        (when (not result)
615          (return-from some-xx-multi
616                       (if (eq caller $every) nil t)))
617        (when result
618          (return-from some-xx-multi
619                       (if (eq caller $some) result nil)))))
620  at-end))
621
622
623(defun some-xx-one (caller at-end predicate seq
624                           &aux (not-result (negating-quantifier-p caller))
625                           result)
626  (if (vectorp seq)
627      (if (simple-vector-p seq)
628        (locally (declare (type simple-vector seq))
629          (dovector (element seq)
630            (setq result (funcall predicate element))
631            (if not-result
632              (when (not result)
633                (return-from some-xx-one
634                  (if (eq caller $every) nil t)))
635              (when result
636                (return-from some-xx-one
637                  (if (eq caller $some ) result nil))))))
638        (dovector (element seq)
639          (setq result (funcall predicate element))
640          (if not-result
641            (when (not result)
642              (return-from some-xx-one
643                (if (eq caller $every) nil t)))
644            (when result
645              (return-from some-xx-one
646                (if (eq caller $some ) result nil))))))
647      (dolist (element seq)
648        (setq result (funcall predicate element))
649        (if not-result
650            (when (not result)
651              (return-from some-xx-one
652                           (if (eq caller $every) nil t)))
653            (when result
654              (return-from some-xx-one
655                           (if (eq caller $some ) result nil))))))
656      at-end)
657
658;;; simple positional versions of find, position
659
660(defun find-positional-test-key (item sequence test key)
661  (if sequence
662    (seq-dispatch
663     sequence
664     (let ((cons (member item sequence :test test :key key)))
665       (and cons (%car cons)))
666     (let ((pos (vector-position-1 item sequence nil test nil 0 nil key)))
667       (and pos (aref sequence pos))))))
668
669(defun find-positional-test-not-key (item sequence test-not key)
670  (if sequence
671    (seq-dispatch
672     sequence
673     (let ((cons (member item sequence :test-not test-not :key key)))
674       (and cons (%car cons)))
675     (let ((pos (vector-position-1 item sequence nil nil test-not 0 nil key)))
676       (and pos (aref sequence pos))))))
677
678(defun position-positional-test-key (item sequence test key)
679  (if sequence
680    (seq-dispatch
681     sequence
682     (progn
683       (setq key (adjust-key key))
684       (setq test
685             (adjust-test-args item test nil))
686       (if (or test key)
687         (list-position/find-complex nil item sequence 0 nil test nil key)
688         (list-position/find-simple nil item sequence 0 nil)))
689     (vector-position-1 item sequence nil test nil 0 nil key))))
690
691(defun position-positional-test-not-key (item sequence test-not key)
692  (if sequence
693    (seq-dispatch
694     sequence
695     (progn
696       (setq key (adjust-key key))
697       (multiple-value-bind (test test-not)
698                            (adjust-test-args item nil test-not)
699         (list-position/find-complex nil item sequence 0 nil test test-not key)))
700     (vector-position-1 item sequence nil nil test-not 0 nil key))))
701
702
703;;; Reduce:
704
705(eval-when (:execute :compile-toplevel)
706 
707  (defmacro list-reduce (function sequence start end initial-value ivp key)
708    (let ((what `(if ,key (funcall ,key (car sequence)) (car sequence))))
709      `(let ((sequence (nthcdr ,start ,sequence)))
710         (do ((count (if ,ivp ,start (1+ ,start)) (1+ count))
711              (sequence (if ,ivp sequence (cdr sequence))
712                        (cdr sequence))
713              (value (if ,ivp ,initial-value ,what)
714                     (funcall ,function value ,what)))
715             ((= count ,end) value)))))
716 
717  (defmacro list-reduce-from-end (function sequence start end 
718                                           initial-value ivp key)
719    (let ((what `(if ,key (funcall ,key (car sequence)) (car sequence))))
720      `(let ((sequence (nthcdr (- (length ,sequence) ,end) (reverse ,sequence))))
721         (do ((count (if ,ivp ,start (1+ ,start)) (1+ count))
722              (sequence (if ,ivp sequence (cdr sequence))
723                        (cdr sequence))
724              (value (if ,ivp ,initial-value ,what)
725                     (funcall ,function ,what value)))
726             ((= count ,end) value)))))
727 
728  ) ;; end eval-when
729
730(defun reduce (function sequence &key from-end (start 0)
731                        end (initial-value nil ivp) key)
732  "The specified Sequence is ``reduced'' using the given Function.
733  See manual for details."
734  (unless end (setq end (length sequence)))
735  (if (= end start)
736    (if ivp initial-value (funcall function))
737    (seq-dispatch
738     sequence
739     (if from-end
740       (list-reduce-from-end  function sequence start end initial-value ivp key)
741       (list-reduce function sequence start end initial-value ivp key))
742     (let* ((disp (if from-end -1 1))
743            (index (if from-end (1- end) start))
744            (terminus (if from-end (1- start) end))
745            (value (if ivp initial-value
746                       (let ((elt (aref sequence index)))
747                         (setq index (+ index disp))
748                         (if key (funcall key elt) elt))))
749            (element nil))
750       (do* ()
751            ((= index terminus) value)
752         (setq element (aref sequence index)
753               index (+ index disp)
754               element (if key (funcall key element) element)
755               value (funcall function (if from-end element value) (if from-end value element))))))))
756
757(defun map-into (result-sequence function &rest sequences)
758  (declare (dynamic-extent sequences))
759  (let* ((nargs (list-length sequences))
760         (temp (make-list (length sequences)))
761         (maxcnt (seq-dispatch result-sequence (length result-sequence) (array-total-size result-sequence)))
762         (rseq result-sequence))
763    (declare (fixnum nargs maxcnt))
764    (declare (dynamic-extent temp))
765    ; this declaration is maybe bogus
766    (dolist (seq sequences)
767      (let ((len (length seq)))
768        (declare (fixnum len))
769        (if (< len maxcnt)(setq maxcnt len))))
770    (dotimes (cnt maxcnt)
771      (let ((args temp)(seqs sequences))
772        (dotimes (i nargs)
773          (let ((seq (%car seqs)))
774            (cond ((listp seq)
775                   (%rplaca seqs (%cdr seq))
776                   (%rplaca args (%car seq)))
777                  (t (%rplaca args (aref seq cnt)))))
778          (setq args (%cdr args))
779          (setq seqs (%cdr seqs))))
780      (let ((res (apply function temp)))
781        (cond ((consp rseq)
782               (%rplaca rseq res)
783               (setq rseq (%cdr rseq)))
784              (t (setf (aref result-sequence cnt) res)))))
785    (when (and (not (listp result-sequence))
786               (array-has-fill-pointer-p result-sequence))
787      (setf (fill-pointer result-sequence) maxcnt))
788    result-sequence))
789         
790   
791;;; Coerce:
792
793#|
794; don't know if this is always right
795; It's almost never right: the "type-spec" could be something
796; defined with DEFTYPE, whose last element (if it has one) has
797; nothing to do with the "length" of the specified type.
798(defun specifier-length (type-spec)
799  (if (consp type-spec)
800    (let ((len? (car (last type-spec))))
801      (if (fixnump len?) len?))))
802|#
803
804
805(defun array-ctype-length (ctype)
806  (if (typep ctype 'array-ctype)
807    (let* ((dims (array-ctype-dimensions ctype)))
808      (if (listp dims)
809        (if (null (cdr dims))
810          (let* ((dim0 (car dims)))
811            (unless (eq dim0 '*) dim0)))))))
812
813
814
815
816; from optimizer - just return object if type is OK
817
818
819;If you change this, remember to change the transform.
820(defun coerce (object output-type-spec)
821  "Coerce the Object to an object of type Output-Type-Spec."
822  (let* ((type (specifier-type output-type-spec)))
823    (if (%typep object type)
824      object
825      (cond
826        ((csubtypep type (specifier-type 'character))
827         (character object))
828        ((eq output-type-spec 'standard-char)
829         (let ((char (character object)))
830           (unless (standard-char-p char) (%err-disp $xcoerce object 'standard-char))
831           char))
832        ((eq output-type-spec 'compiled-function)
833         (coerce-to-compiled-function object))
834        ((csubtypep type (specifier-type 'function))
835         (coerce-to-function-1 object))
836        ((csubtypep type (specifier-type 'cons))
837         (if object
838           (coerce-to-list object)
839           (report-bad-arg object 'cons)))
840        ((csubtypep type (specifier-type 'list))
841         (coerce-to-list object))
842        ((csubtypep type (specifier-type 'string))
843         (let ((length (array-ctype-length type)))
844           (if (and length (neq length (length object)))
845             (report-bad-arg (make-string length) `(string ,(length object)))))
846         (coerce-to-uarray object #.(type-keyword-code :simple-string)
847                           t))
848        ((csubtypep type (specifier-type 'vector))
849         (let ((length (array-ctype-length type)))
850           (if (and length (neq length (length object)))
851             (error 'invalid-subtype-error
852                    :datum output-type-spec
853                    :expected-type `(vector * ,(length object)))))
854         (let* ((atype (simplify-vector-ctype type)))
855           (unless (typep atype 'array-ctype)
856             (error "Can't determine vector type of ~s" output-type-spec))
857           (let* ((element-type (type-specifier (array-ctype-element-type atype))))
858             (let ((length (array-ctype-length atype)))
859               (if (and length (neq length (length object)))
860                 (report-bad-arg (make-array length :element-type element-type)
861                                 `(vector ,element-type ,(length object))))
862               (coerce-to-uarray object (element-type-subtype element-type) t)))))
863        ((csubtypep type (specifier-type 'array))
864         (let* ((dims (array-ctype-dimensions type)))
865           (when (consp dims)
866             (when (not (null (cdr dims)))(error "~s is not a sequence type." output-type-spec))))
867         (let ((length (array-ctype-length type)))
868           (if (and length (neq length (length object)))
869             (error "Length of ~s is not ~s." object length)))
870         (coerce-to-uarray object (element-type-subtype (type-specifier 
871                                                         (array-ctype-element-type type))) t))
872        ((numberp object)
873         (let ((res
874                (cond
875                  ((csubtypep type (specifier-type 'double-float))
876                   (float object 1.0d0))
877                  ((csubtypep type (specifier-type 'float))
878                   (float object 1.0s0))                               
879                  ((csubtypep type (specifier-type 'complex))
880                   (coerce-to-complex object  output-type-spec)))))
881           (unless res                  ;(and res (%typep res type))
882             (error "~S can't be coerced to type ~S." object output-type-spec))
883           res))
884        (t (error "~S can't be coerced to type ~S." object output-type-spec))))))
885
886(defun %coerce-to-string (seq)
887   (let* ((len (length seq))
888          (string (make-string len)))
889     (declare (fixnum len) (simple-base-string string))
890     (if (typep seq 'list)
891       (do* ((l seq (cdr l))
892             (i 0 (1+ i)))
893            ((null l) string)
894         (declare (list l) ; we know that it's a proper list because LENGTH won
895                  (fixnum i))
896         (setf (schar string i) (car l)))
897       (dotimes (i len string)
898         (setf (schar string i) (aref seq i))))))
899
900(defun %coerce-to-vector (seq subtype)
901   (let* ((len (length seq))
902          (vector (%alloc-misc len subtype)))
903     (declare (fixnum len) (type (simple-array * (*)) vector))
904     (if (typep seq 'list)
905       (do* ((l seq (cdr l))
906             (i 0 (1+ i)))
907            ((null l) vector)
908         (declare (list l) ; we know that it's a proper list because LENGTH won
909                  (fixnum i))
910         (setf (uvref vector i) (car l)))
911       (dotimes (i len vector)
912         (setf (uvref vector i) (aref seq i))))))
913
914(defun %coerce-to-list (seq)
915  (if (typep seq 'list)
916    seq
917    (collect ((result))
918      (dotimes (i (length seq) (result))
919        (result (aref seq i))))))
920
921
922
923
924(defun coerce-to-complex (object  output-type-spec)
925  (if (consp output-type-spec)
926      (let ((type2 (cadr output-type-spec)))     
927        (if (complexp object)
928            (complex (coerce (realpart object) type2)(coerce (imagpart object) type2))
929            (complex (coerce object type2) 0)))
930      (complex object)))
931       
932
933(defun coerce-to-function-1 (thing)
934  (if (functionp thing)
935    thing
936    (if (symbolp thing)
937      (%function thing)
938      (if (lambda-expression-p thing)
939        (%make-function nil thing nil)
940        (%err-disp $xcoerce thing 'function)))))
941
942;;; Internal Frobs:
943;(coerce object '<array-type>)
944(defun coerce-to-uarray (object subtype simple-p)
945  (if (typep object 'array)
946    (if (and (or (not simple-p) (typep object 'simple-array))
947             (or (null subtype) (eq (array-element-subtype object) subtype)))
948      object
949      ;Make an array of the same shape as object but different subtype..
950      (%copy-array subtype object))
951    (if (typep object 'list)
952      (%list-to-uvector subtype object)
953      (%err-disp $xcoerce object 'array))))
954
955;(coerce object 'list)
956(defun coerce-to-list (object)
957  (seq-dispatch 
958   object
959   object
960   (let* ((n (length object)))
961     (declare (fixnum n))
962     (multiple-value-bind (data offset) (array-data-and-offset object)
963       (let* ((head (cons nil nil))
964              (tail head))
965         (declare (dynamic-extent head)
966                  (cons head tail))
967         (do* ((i 0 (1+ i))
968               (j offset (1+ j)))
969              ((= i n) (cdr head))
970           (declare (fixnum i j))
971           (setq tail (cdr (rplacd tail (cons (uvref data j) nil))))))))))
972 
973
974(defun %copy-array (new-subtype array)
975  ;To be rewritten once make-array disentangled (so have a subtype-based entry
976  ;point)
977  (make-array (if (eql 1 (array-rank array))
978                (length array)
979                (array-dimensions array))
980              :element-type (element-subtype-type new-subtype)
981              :initial-contents array ;***** WRONG *****
982              ))
983
984(defun check-count (c)
985  (if c
986    (min (max (require-type c 'integer) 0) target::target-most-positive-fixnum)
987    target::target-most-positive-fixnum))
988
989;;; Delete:
990
991(defun list-delete-1 (item list from-end test test-not start end count key 
992                           &aux (temp list)  revp)
993  (unless end (setq end target::target-most-positive-fixnum))
994  (when (and from-end count)
995    (let ((len (length temp)))
996      (if (not (%i< start len))
997        (return-from list-delete-1 temp))
998      (setq temp (nreverse temp) revp t)
999      (psetq end (%i- len start)
1000             start (%i- len (%imin len end)))))
1001  (setq key (adjust-key key))
1002  (multiple-value-setq (test test-not)
1003                       (adjust-test-args item test test-not))
1004  (setq temp
1005        (if (or test key test-not)
1006          (list-delete-moderately-complex item temp start end count test test-not key)
1007          (list-delete-very-simple item temp start end count)))
1008   (if revp
1009    (nreverse temp)
1010    temp))
1011
1012
1013(defun list-delete-very-simple (item list start end count)
1014  (unless start (setq start 0))
1015  (unless end (setq end target::target-most-positive-fixnum))
1016  (setq count (check-count count))
1017  (do* ((handle (cons nil list))
1018        (splice handle)
1019        (numdeleted 0)
1020        (i 0 (1+ i)))
1021       ((or (eq i end) (null (%cdr splice)) (eq numdeleted count))
1022        (%cdr handle))
1023    (declare (fixnum i start end count numdeleted)  ; declare-type-free !!
1024             (dynamic-extent handle) 
1025             (list splice handle))
1026    (if (and (%i>= i start) (eq item (car (%cdr splice))))
1027      (progn
1028        (%rplacd splice (%cddr splice))
1029        (setq numdeleted (%i+ numdeleted 1)))
1030      (setq splice (%cdr splice)))))
1031
1032(defun list-delete-moderately-complex (item list start end count test test-not key)
1033  (unless start (setq start 0))
1034  (unless end (setq end target::target-most-positive-fixnum))
1035  (setq count (check-count count))
1036  (do* ((handle (cons nil list))
1037        (splice handle)
1038        (numdeleted 0)
1039        (i 0 (1+ i)))
1040       ((or (= i end) (null (cdr splice)) (= numdeleted count))
1041        (cdr handle))
1042    (declare (fixnum i start end count numdeleted)
1043             (dynamic-extent handle)
1044             (list splice))
1045    (if (and (>= i start) (matchp2 item (cadr splice) test test-not key))
1046      (progn
1047        (rplacd splice (cddr splice))
1048        (setq numdeleted (1+ numdeleted)))
1049      (setq splice (cdr splice)))))
1050
1051(defun list-delete (item list &key from-end test test-not (start 0)
1052                         end count key 
1053                         &aux (temp list)  revp)
1054  (unless end (setq end target::target-most-positive-fixnum))
1055  (when (and from-end count)
1056    (let ((len (length temp)))
1057      (if (not (%i< start len))
1058        (return-from list-delete temp))
1059      (setq temp (nreverse temp) revp t)
1060      (psetq end (%i- len start)
1061             start (%i- len (%imin len end)))))
1062  (setq key (adjust-key key))
1063  (multiple-value-setq (test test-not)
1064                       (adjust-test-args item test test-not))
1065  (setq temp
1066        (if (or test key test-not)
1067          (list-delete-moderately-complex item temp start end count test test-not key)
1068          (list-delete-very-simple item temp start end count)))
1069   (if revp
1070    (nreverse temp)
1071    temp))
1072
1073; The vector will be freshly consed & nothing is displaced to it,
1074; so it's legit to destructively truncate it.
1075; Likewise, it's ok to access its components with UVREF.
1076
1077(defun simple-vector-delete (item vector test test-not key start end inc count
1078                                  &aux (length (length vector)) 
1079                                  subtype pos fill)
1080  (setq key (adjust-key key))
1081  (multiple-value-setq (test test-not) (adjust-test-args item test test-not))
1082  (setq end (check-sequence-bounds vector start end))
1083  (setq fill start)
1084  (if (%i< inc 0) (psetq start (%i- end 1) end (%i- start 1)))
1085  (let* ((bv (make-array (the fixnum (length vector)) :element-type 'bit :Initial-element 0))
1086         offset)   
1087    (declare (dynamic-extent bv)
1088             (type (simple-array bit (*)) bv))
1089    (multiple-value-setq (vector offset)(array-data-and-offset vector))
1090    (setq subtype (typecode vector))
1091    (setq pos start)
1092    (loop
1093      (when (or (eq count 0) (eq pos end))
1094        (unless (eq pos end)
1095          (incf fill (abs (- pos end))))
1096        (return))
1097      (if (matchp2 item (uvref  vector (%i+ pos offset))
1098                   test test-not key)
1099        (progn (setf (aref bv pos) 1)
1100               (setq count (%i- count 1)))
1101        (setq fill (%i+ fill 1)))
1102      (setq pos (%i+ pos inc)))
1103    (when (%i< inc 0)
1104      (psetq start (%i+ end 1) end (%i+ start 1)))
1105    (let* ((tail (- length end))
1106           (size (+ fill tail))
1107           (new-vect (%alloc-misc size subtype))
1108           (fill-end fill))
1109      (declare (fixnum tail size))
1110      (when (neq 0 start)
1111        (dotimes (i start)
1112          (setf (uvref new-vect i) (uvref  vector (%i+ offset i)))
1113          ))
1114      (setq fill start)
1115      (setq pos start)
1116      (loop
1117        (if (eq fill fill-end) (return))
1118        (if (neq 1 (aref bv pos))
1119          (progn
1120            (setf (uvref new-vect fill) (uvref vector (%i+ offset pos)))
1121            (setq fill (%i+ fill 1))))
1122        (setq pos (%i+ pos 1)))
1123      (setq pos end)
1124      (loop
1125        (when (eq fill size) (return))
1126          (setf (uvref  new-vect fill) (uvref  vector (%i+ offset pos)))
1127          (setq fill (%i+ fill 1)
1128                pos (%i+ pos 1)))
1129      new-vect)))
1130
1131
1132; When a vector has a fill pointer & it can be "destructively modified" by adjusting
1133; that fill pointer.
1134(defun vector-delete (item vector test test-not key start end inc count
1135                           &aux (length (length vector)) pos fill val)
1136  (setq key (adjust-key key))
1137  (multiple-value-setq (test test-not) (adjust-test-args item test test-not))
1138  (setq end (check-sequence-bounds vector start end))
1139  (if (%i< inc 0) (psetq start (%i- end 1) end (%i- start 1)))
1140  (setq fill (setq pos start))
1141  (loop
1142    (if (or (eq count 0) (eq pos end)) (return))
1143    (if (matchp2 item (setq val (aref vector pos)) test test-not key)
1144      (setq count (%i- count 1))
1145      (progn
1146        (if (neq fill pos) (setf (aref vector fill) val))
1147        (setq fill (%i+ fill inc))))
1148    (setq pos (%i+ pos inc)))
1149  (if (%i> fill pos) (psetq fill (%i+ pos 1) pos (%i+ fill 1)))
1150  (loop
1151    (if (eq pos length) (return))
1152    (setf (aref vector fill) (aref vector pos))
1153    (setq fill (%i+ fill 1) pos (%i+ pos 1)))
1154  (when (eq t (array-element-type vector))
1155    (let ((old-fill (fill-pointer vector))
1156          (i fill))
1157      (declare (fixnum i old-fill))
1158      (loop
1159        (when (>= i old-fill) (return))
1160        (setf (aref vector i) nil)
1161        (incf i))))
1162  (setf (fill-pointer vector) fill)
1163  vector)
1164
1165(defun delete (item sequence &key from-end test test-not (start 0)
1166                    end count key)
1167  "Return a sequence formed by destructively removing the specified ITEM from
1168  the given SEQUENCE."
1169  (setq count (check-count count))
1170  (if sequence
1171    (seq-dispatch
1172     sequence
1173     (list-delete-1 item 
1174                  sequence 
1175                  from-end
1176                  test 
1177                  test-not
1178                  start 
1179                  end 
1180                  count
1181                  key)
1182     (if (array-has-fill-pointer-p sequence)
1183       (vector-delete item sequence test test-not key start end (if from-end -1 1) count)
1184       (simple-vector-delete item
1185                            sequence
1186                             test test-not key start end (if from-end -1 1) count)))))
1187
1188(defun delete-if (test sequence &key from-end (start 0)                       
1189                       end count key)
1190  "Return a sequence formed by destructively removing the elements satisfying
1191  the specified PREDICATE from the given SEQUENCE."
1192  (delete test sequence
1193          :test #'funcall
1194          :from-end from-end 
1195          :start start 
1196          :end end 
1197          :count count 
1198          :key key))
1199
1200(defun delete-if-not (test sequence &key from-end (start 0) end count key)
1201  "Return a sequence formed by destructively removing the elements not
1202  satisfying the specified PREDICATE from the given SEQUENCE."
1203  (delete test sequence 
1204          :test-not #'funcall 
1205          :from-end from-end 
1206          :start start 
1207          :end end 
1208          :count count 
1209          :key key))
1210
1211
1212
1213;;; Remove:
1214
1215
1216
1217(defun remove (item sequence &key from-end test test-not (start 0)
1218                    end count key)
1219  "Return a copy of SEQUENCE with elements satisfying the test (default is
1220   EQL) with ITEM removed."
1221  (setq count (check-count count))
1222  (seq-dispatch
1223   sequence
1224   (list-delete-1 item 
1225                (copy-list sequence)
1226                from-end
1227                test 
1228                test-not
1229                start 
1230                end 
1231                count
1232                key)
1233   (simple-vector-delete item
1234                         sequence
1235                         test
1236                         test-not
1237                         key
1238                         start
1239                         end
1240                         (if from-end -1 1)
1241                         count)))
1242
1243
1244
1245
1246(defun remove-if (test sequence &key from-end (start 0)
1247                         end count key)
1248  "Return a copy of sequence with elements such that predicate(element)
1249   is non-null removed"
1250  (setq count (check-count count))
1251  (remove test sequence
1252          :test #'funcall
1253          :from-end from-end
1254          :start start
1255          :end end
1256          :count count
1257          :key key))
1258
1259(defun remove-if-not (test sequence &key from-end (start 0)
1260                         end count key)
1261  "Return a copy of sequence with elements such that predicate(element)
1262   is null removed"
1263  (setq count (check-count count))
1264  (remove test sequence
1265          :test-not #'funcall
1266          :from-end from-end
1267          :start start
1268          :end end
1269          :count count
1270          :key key))
1271
1272;;; Remove-Duplicates:
1273
1274;;; Remove duplicates from a list. If from-end, remove the later duplicates,
1275;;; not the earlier ones. Thus if we check from-end we don't copy an item
1276;;; if we look into the already copied structure (from after :start) and see
1277;;; the item. If we check from beginning we check into the rest of the
1278;;; original list up to the :end marker (this we have to do by running a
1279;;; do loop down the list that far and using our test.
1280; test-not is typically NIL, but member doesn't like getting passed NIL
1281; for its test-not fn, so I special cased the call to member. --- cfry
1282
1283(defun remove-duplicates (sequence &key (test #'eql) test-not (start 0) 
1284      from-end end key)
1285  "The elements of SEQUENCE are compared pairwise, and if any two match,
1286   the one occurring earlier is discarded, unless FROM-END is true, in
1287   which case the one later in the sequence is discarded. The resulting
1288   sequence is returned.
1289
1290   The :TEST-NOT argument is deprecated."
1291  (setq end (check-sequence-bounds sequence start end))
1292  (delete-duplicates (copy-seq sequence) :from-end from-end :test test
1293                     :test-not test-not :start start :end end :key key))
1294
1295;;; Delete-Duplicates:
1296
1297(defparameter *delete-duplicates-hash-threshold*  200)
1298
1299(defun list-delete-duplicates* (list test test-not key from-end start end)
1300  ;;(%print "test:" test "test-not:" test-not "key:" key)
1301  (let* ((len (- end start))
1302         (handle (cons nil list))
1303         (previous (nthcdr start handle)))
1304    (declare (dynamic-extent handle))
1305    (if (and (> len *delete-duplicates-hash-threshold*)
1306             (or (eq test 'eq) (eq test 'eql) (eq test 'equal) (eq test 'equalp)
1307                 (eq test #'eq) (eq test #'eql) (eq test #'equal) (eq test #'equalp)))
1308      (let ((hash (make-hash-table :size len :test test :shared nil)))
1309        (loop for i from start below end as obj in (cdr previous)
1310          do (incf (gethash (funcall key obj) hash 0)))
1311        (loop for i from start below end while (cdr previous)
1312          do (let* ((current (cdr previous))
1313                    (obj (car current))
1314                    (obj-key (funcall key obj)))
1315               (if (if from-end
1316                     ;; Keep first ref
1317                     (prog1 (gethash obj-key hash) (setf (gethash obj-key hash) nil))
1318                     ;; Keep last ref
1319                     (eql (decf (gethash obj-key hash)) 0))
1320                 (setq previous current)
1321                 (rplacd previous (cdr current))))))
1322      (do ((current (cdr previous) (cdr current))
1323           (index start (1+ index)))
1324          ((or (= index end) (null current)))
1325        ;;(%print "outer loop top current:" current "previous:" previous)
1326        (if (do ((x (if from-end 
1327                      (nthcdr (1+ start) handle)
1328                      (cdr current))
1329                    (cdr x))
1330                 (i (1+ index) (1+ i)))
1331                ((or (null x) 
1332                     (and (not from-end) (= i end)) 
1333                     (eq x current)) 
1334                 nil)
1335              ;;(%print "inner loop top x:" x "i:" i)
1336              (if (list-delete-duplicates*-aux current x test test-not key)
1337                (return t)))
1338          (rplacd previous (cdr current))
1339          (setq previous (cdr previous)))))
1340    (cdr handle)))
1341
1342(defun list-delete-duplicates*-aux (current x test test-not key)
1343  (if test-not
1344    (not (funcall test-not 
1345                  (funcall key (car current))
1346                  (funcall key (car x))))
1347    (funcall test 
1348             (funcall key (car current)) 
1349             (funcall key (car x)))))
1350
1351
1352(defun vector-delete-duplicates* (vector test test-not key from-end start end 
1353                                         &optional (length (length vector)))
1354  (declare (vector vector))
1355  (let* ((len (- end start))
1356         (index start)
1357         (jndex start))
1358    (if (and (not test-not)
1359             (> len *delete-duplicates-hash-threshold*)
1360             (or (eq test 'eq) (eq test 'eql) (eq test 'equal) (eq test 'equalp)
1361                 (eq test #'eq) (eq test #'eql) (eq test #'equal) (eq test #'equalp)))
1362        (let ((hash (make-hash-table :size len :test test :shared nil)))
1363          (loop for i from start below end as obj = (aref vector i)
1364             do (incf (gethash (funcall key obj) hash 0)))
1365          (loop while (< index end) as obj = (aref vector index) as obj-key = (funcall key obj)
1366             do (incf index)
1367             do (when (if from-end
1368                          (prog1 (gethash obj-key hash) (setf (gethash obj-key hash) nil))
1369                          (eql (decf (gethash obj-key hash)) 0))
1370                  (aset vector jndex obj)
1371                  (incf jndex))))
1372        (loop while (< index end) as obj = (aref vector index)
1373           do (incf index)
1374           do (unless (position (funcall key obj) vector :key key
1375                                :start (if from-end start index) :test test
1376                                :end (if from-end jndex end) :test-not test-not)
1377                (aset vector jndex obj)
1378                (incf jndex))))
1379    (do ((index index (1+ index))       ; copy the rest of the vector
1380         (jndex jndex (1+ jndex)))
1381        ((= index length)
1382         (setq vector (shrink-vector vector jndex)))
1383      (aset vector jndex (aref vector index)))))
1384
1385
1386(defun delete-duplicates (sequence &key (test #'eql) test-not (start 0) from-end end key)
1387  "The elements of SEQUENCE are examined, and if any two match, one is
1388   discarded.  The resulting sequence, which may be formed by destroying the
1389   given sequence, is returned.
1390   Sequences of type STR have a NEW str returned."
1391  (setq end (check-sequence-bounds sequence start end))
1392  (unless key (setq key #'identity))
1393  (seq-dispatch sequence
1394    (if sequence
1395      (list-delete-duplicates* sequence test test-not key from-end start end))
1396    (vector-delete-duplicates* sequence test test-not key from-end start end)))
1397
1398(defun list-substitute* (pred new list start end count key 
1399                              test test-not old)
1400  ;(print-db pred new list start end count key test test-not old)
1401  (let* ((result (list nil))
1402         elt
1403         (splice result)
1404         (list list))           ; Get a local list for a stepper.
1405    (do ((index 0 (1+ index)))
1406        ((= index start))
1407      (setq splice (cdr (rplacd splice (list (car list)))))
1408      (setq list (cdr list)))
1409    (do ((index start (1+ index)))
1410        ((or (and end (= index end)) (null list) (= count 0)))
1411      (setq elt (car list))
1412      (setq splice
1413            (cdr (rplacd splice
1414                         (list
1415                          (cond ((case pred
1416                                   (normal
1417                                    (if test-not
1418                                      (not (funcall test-not  old
1419                                                    ;fry mod to slisp, which had arg order of OLD and ELT reversed.
1420                                                    (funcall key elt)))
1421                                      (funcall test old
1422                                               (funcall key elt))))
1423                                   (if (funcall test (funcall key elt)))
1424                                   (if-not (not (funcall test 
1425                                                         (funcall key elt)))))
1426                                 (setq count (1- count))
1427                                 new)
1428                                (t elt))))))
1429      (setq list (cdr list)))
1430    (do ()
1431        ((null list))
1432      (setq splice (cdr (rplacd splice (list (car list)))))
1433      (setq list (cdr list)))
1434    (cdr result)))
1435
1436;;; Replace old with new in sequence moving from left to right by incrementer
1437;;; on each pass through the loop. Called by all three substitute functions.
1438(defun vector-substitute* (pred new sequence incrementer left right length
1439                                start end count key test test-not old)
1440  (let ((result (make-sequence-like sequence length))
1441        (index left))
1442    (do ()
1443        ((= index start))
1444      (aset result index (aref sequence index))
1445      (setq index (+ index incrementer)))
1446    (do ((elt))
1447        ((or (= index end) (= count 0)))
1448      (setq elt (aref sequence index))
1449      (aset result index 
1450            (cond ((case pred
1451                     (normal
1452                      (if test-not
1453                        (not (funcall test-not old (funcall key elt))) ;cfry mod
1454                        (funcall test old (funcall key elt)))) ;cfry mod
1455                     (if (funcall test (funcall key elt)))
1456                     (if-not (not (funcall test (funcall key elt)))))
1457                   (setq count (1- count))
1458                   new)
1459                  (t elt)))
1460      (setq index (+ index incrementer)))
1461    (do ()
1462        ((= index right))
1463      (aset result index (aref sequence index))
1464      (setq index (+ index incrementer)))
1465    result))
1466
1467;;; Substitute:
1468
1469(defun substitute (new old sequence &key from-end (test #'eql) test-not
1470                       (start 0) count
1471                       end (key #'identity))
1472  "Return a sequence of the same kind as SEQUENCE with the same elements,
1473  except that all elements equal to OLD are replaced with NEW. See manual
1474  for details."
1475  (setq count (check-count count))
1476  (let ((length (length sequence))        )
1477    (setq end (check-sequence-bounds sequence start end))
1478    (seq-dispatch 
1479     sequence
1480     (if from-end
1481       (nreverse (list-substitute* 'normal new (reverse sequence) (- length end)
1482                                   (- length start) count key test test-not old))
1483       (list-substitute* 'normal new sequence start end count key test test-not
1484                         old))
1485     (if from-end
1486       (vector-substitute* 'normal new sequence -1 (1- length) -1 length 
1487                           (1- end) (1- start) count key test test-not old)
1488       (vector-substitute* 'normal new sequence 1 0 length length
1489                           start end count key test test-not old)))))
1490
1491
1492(defun substitute-if (new test sequence &key from-end (start 0)
1493                          (end (length sequence))
1494                          count (key #'identity))
1495  "Return a sequence of the same kind as SEQUENCE with the same elements
1496  except that all elements satisfying the PRED are replaced with NEW. See
1497  manual for details."
1498  (substitute new test sequence
1499              :from-end from-end
1500              :test #'funcall
1501              :start start
1502              :end end
1503              :from-end from-end
1504              :count count
1505              :key key))
1506
1507(defun substitute-if-not (new test sequence &key from-end (start 0)
1508                              (end (length sequence))
1509                              count (key #'identity))
1510  "Return a sequence of the same kind as SEQUENCE with the same elements
1511  except that all elements not satisfying the PRED are replaced with NEW.
1512  See manual for details."
1513  (substitute new test sequence
1514              :from-end from-end
1515              :test-not #'funcall
1516              :start start
1517              :end end
1518              :from-end from-end
1519              :count count
1520              :key key))
1521
1522;;; NSubstitute:
1523
1524(defun nsubstitute (new old sequence &key from-end (test #'eql) test-not 
1525                        end 
1526                        (count target::target-most-positive-fixnum) (key #'identity) (start 0))
1527  "Return a sequence of the same kind as SEQUENCE with the same elements
1528  except that all elements equal to OLD are replaced with NEW. The SEQUENCE
1529  may be destructively modified. See manual for details."
1530  (setq count (check-count count))
1531  (let ((incrementer 1)
1532        (length (length sequence)))
1533    (setq end (check-sequence-bounds sequence start end))
1534    (seq-dispatch
1535     sequence
1536      (if from-end
1537        (nreverse (nlist-substitute*
1538                   new old (nreverse (the list sequence))
1539                   test test-not 
1540                   (- length end) 
1541                   (- length start)
1542                   count key))
1543        (nlist-substitute* new old sequence
1544                           test test-not start end count key))
1545      (progn 
1546        (if from-end
1547          (psetq start (1- end)
1548                 end (1- start)
1549                 incrementer -1))
1550        (nvector-substitute* new old sequence incrementer
1551                             test test-not start end count key)))))
1552
1553(defun nlist-substitute* (new old sequence test test-not start end count key)
1554  (do ((list (nthcdr start sequence) (cdr list))
1555       (index start (1+ index)))
1556      ((or (and end (= index end)) (null list) (= count 0)) sequence)
1557    (when (if test-not
1558            (not (funcall test-not  old (funcall key (car list)))) ;cfry mod
1559            (funcall test  old (funcall key (car list)))) ;cfry mod
1560      (rplaca list new)
1561      (setq count (1- count)))))
1562
1563(defun nvector-substitute* (new old sequence incrementer
1564                                test test-not start end count key)
1565  (do ((index start (+ index incrementer)))
1566      ((or (= index end) (= count 0)) sequence)
1567    (when (if test-not
1568            (not (funcall test-not  old (funcall key (aref sequence index))))
1569            ;above cfry mod. both order of argss to test-not and paren error
1570            ; between the funcall key and the funcall test-not
1571            (funcall test old (funcall key (aref sequence index)))) ;cfry mod
1572      (aset sequence index new)
1573      (setq count (1- count)))))
1574
1575;;; NSubstitute-If:
1576
1577(defun nsubstitute-if (new test sequence &key from-end (start 0)
1578                           end 
1579                           (count target::target-most-positive-fixnum) (key #'identity))
1580  "Return a sequence of the same kind as SEQUENCE with the same elements
1581   except that all elements satisfying the PRED are replaced with NEW.
1582   SEQUENCE may be destructively modified. See manual for details."
1583  (nsubstitute new test sequence
1584               :from-end from-end
1585               :test #'funcall
1586               :start start
1587               :end end
1588               :count count
1589               :key key))
1590
1591
1592;;; NSubstitute-If-Not:
1593
1594(defun nsubstitute-if-not (new test sequence &key from-end (start 0)
1595                               end (count target::target-most-positive-fixnum) (key #'identity))
1596  "Return a sequence of the same kind as SEQUENCE with the same elements
1597   except that all elements not satisfying the TEST are replaced with NEW.
1598   SEQUENCE may be destructively modified. See manual for details."
1599  (nsubstitute new test sequence
1600                 :from-end from-end
1601                 :test-not #'funcall
1602                 :start start
1603                 :end end
1604                 :count count
1605                 :key key))
1606
1607
1608;;; Position:
1609
1610(defun list-position/find-1 (eltp item list from-end test test-not start end key &aux hard)
1611  ;;if eltp is true, return element, otherwise return position
1612  (setq key (adjust-key key))
1613  (multiple-value-setq (test test-not)
1614                       (adjust-test-args item test test-not))
1615  (setq end (check-sequence-bounds list start end)
1616        hard (or test key test-not))
1617  (if from-end
1618    (if hard
1619      (list-position/find-from-end-complex eltp item list start end test test-not key)
1620      (list-position/find-from-end-simple eltp item list start end))
1621    (if hard
1622      (list-position/find-complex eltp item list start end test test-not key)
1623      (list-position/find-simple eltp item list start end))))
1624
1625(defun position (item sequence &key from-end test test-not (start 0) end key)
1626  (if sequence
1627    (seq-dispatch 
1628     sequence
1629     (list-position/find-1 nil item sequence from-end test test-not start end key)
1630     (vector-position-1 item sequence from-end test test-not start end key))))
1631
1632;Is it really necessary for these internal functions to take keyword args?
1633(defun list-position/find (eltp item list &key from-end test test-not (start 0) end key &aux hard)
1634  ;;if eltp is true, return element, otherwise return position
1635  (setq key (adjust-key key))
1636  (multiple-value-setq (test test-not)
1637                       (adjust-test-args item test test-not))
1638  (setq end (check-sequence-bounds list start end)
1639        hard (or test key test-not))
1640  (if from-end
1641    (if hard
1642      (list-position/find-from-end-complex eltp item list start end test test-not key)
1643      (list-position/find-from-end-simple eltp item list start end))
1644    (if hard
1645      (list-position/find-complex eltp item list start end test test-not key)
1646      (list-position/find-simple eltp item list start end))))
1647
1648;;; make these things positional
1649
1650
1651
1652;;; add a simple-vector case
1653
1654(defun vector-position-1 (item vector from-end test test-not start end key
1655                        &aux (inc (if from-end -1 1)) pos)
1656  (setq end (check-sequence-bounds vector start end))
1657  (setq key (adjust-key key))
1658  (multiple-value-setq (test test-not) (adjust-test-args item test test-not))
1659  (if from-end (psetq start (%i- end 1) end (%i- start 1)))
1660  (setq pos start)
1661  (if (simple-vector-p vector)
1662    (locally (declare (type simple-vector vector)
1663                      (optimize (speed 3) (safety 0)))
1664      (loop
1665        (if (eq pos end) (return))
1666        (if (matchp2 item (aref vector pos) test test-not key) (return pos))
1667        (setq pos (%i+ pos inc))))
1668    (loop
1669      (if (eq pos end) (return))
1670      (if (matchp2 item (aref vector pos) test test-not key) (return pos))
1671      (setq pos (%i+ pos inc)))))
1672
1673(defun list-position/find-simple (eltp item list start end &aux (pos 0))
1674  (loop
1675    (if (or (eq pos start) (null list))
1676      (return)
1677      (setq list (cdr list) pos (%i+ pos 1))))
1678  (loop
1679    (if (and list (neq end pos))
1680      (if (eq item (car list))
1681        (return (if eltp item pos))
1682        (setq list (%cdr list) pos (%i+ pos 1)))
1683      (return))))
1684
1685(defun list-position/find-complex (eltp item list start end test test-not key &aux (pos 0))
1686  (loop
1687    (if (or (eq pos start) (null list))
1688      (return)
1689      (setq list (cdr list) pos (%i+ pos 1))))
1690  (loop
1691    (if (and list (neq end pos))
1692      (progn
1693        (if (matchp2 item (car list) test test-not key)
1694          (return (if eltp (%car list) pos))
1695          (setq list (%cdr list) pos (%i+ pos 1))))
1696      (return))))
1697
1698(defun list-position/find-from-end-simple (eltp item list start end &aux (pos 0) ret)
1699  (loop
1700    (if (or (eq pos start) (null list))
1701      (return)
1702      (setq list (cdr list) pos (%i+ pos 1))))
1703  (loop
1704    (if (and list (neq end pos))
1705      (progn
1706        (if (eq item (car list)) (setq ret pos))
1707        (setq list (%cdr list) pos (%i+ pos 1)))
1708      (return (if eltp (if ret item) ret)))))
1709
1710(defun list-position/find-from-end-complex (eltp item list start end test test-not key 
1711                                            &aux (pos 0) ret val)
1712  (loop
1713    (if (or (eq pos start) (null list))
1714      (return)
1715      (setq list (cdr list) pos (%i+ pos 1))))
1716  (loop
1717    (if (and list (neq end pos))
1718      (progn
1719        (if (matchp2 item (setq val (car list)) test test-not key)
1720          (setq ret (if eltp val pos)))
1721        (setq list (%cdr list) pos (%i+ pos 1)))
1722      (return ret))))
1723
1724(defun vector-position (item vector &key from-end test test-not (start 0) end key
1725                        &aux (inc (if from-end -1 1)) pos)
1726  (setq end (check-sequence-bounds vector start end))
1727  (setq key (adjust-key key))
1728  (multiple-value-setq (test test-not) (adjust-test-args item test test-not))
1729  (if from-end (psetq start (%i- end 1) end (%i- start 1)))
1730  (setq pos start)
1731  (loop
1732    (if (eq pos end) (return))
1733    (if (matchp2 item (aref vector pos) test test-not key) (return pos))
1734    (setq pos (%i+ pos inc))))
1735
1736;;; Position-if:
1737
1738(defun position-if (test sequence &key from-end (start 0) end key)
1739  (position test sequence
1740            :test #'funcall
1741            :from-end from-end
1742            :start start
1743            :end end
1744            :key key))
1745
1746
1747;;; Position-if-not:
1748
1749(defun position-if-not (test sequence &key from-end (start 0) end key)
1750  (position test sequence
1751            :test-not #'funcall
1752            :from-end from-end
1753            :start start
1754            :end end
1755            :key key))
1756
1757;;; Count:
1758
1759(defun vector-count-from-start (test item sequence start end key)
1760  (declare (fixnum start end))
1761  (do* ((index start (1+ index))
1762        (count 0))
1763       ((= index end) count)
1764    (declare (fixnum index count))
1765    (when (funcall test item  (funcall key (aref sequence index)))
1766      (incf count))))
1767
1768(defun vector-count-from-end (test item sequence start end key)
1769  (declare (fixnum start end))
1770  (do* ((index (1- end) (1- index))
1771        (count 0)
1772        (limit (1- start)))
1773       ((= index limit) count)
1774    (declare (fixnum index count limit))
1775    (when (funcall test item (funcall key (aref sequence index)))
1776      (incf count))))
1777
1778(defun vector-count-not-p-from-start (test-not item sequence start end key)
1779  (declare (fixnum start end))
1780  (do* ((index start (1+ index))
1781        (count 0))
1782       ((= index end) count)
1783    (declare (fixnum index count))
1784    (unless (funcall test-not item (funcall key (aref sequence index)))
1785      (incf count))))
1786
1787(defun vector-count-not-p-from-end (test-not item sequence start end key)
1788  (declare (fixnum start end))
1789  (do* ((index (1- end) (1- index))
1790        (count 0)
1791        (limit (1- start)))
1792       ((= index limit) count)
1793    (declare (fixnum index count limit))
1794    (unless (funcall test-not item (funcall key (aref sequence index)))
1795      (incf count))))
1796
1797(defun list-count-from-start (test item sequence start end key)
1798  (declare (fixnum start end) (list sequence))
1799  (do* ((seq (nthcdr start sequence) (cdr seq))
1800        (element (car seq) (car seq))
1801        (index start (1+ index))
1802        (count 0))
1803       ((or (= index end) (null seq)) count)
1804    (declare (fixnum index count) (list seq))
1805    (when (funcall test item (funcall key element))
1806      (incf count))))
1807
1808(defun list-count-from-end (test item sequence start end key)
1809  (declare (fixnum start end))
1810  (let* ((len (length sequence)))
1811    (declare (fixnum len))
1812    (list-count-from-start test item (reverse sequence) (- len end) (- len start) key)))
1813
1814(defun list-count-not-p-from-start (test-not item sequence start end key)
1815  (declare (fixnum start end) (list sequence))
1816  (do* ((seq (nthcdr start sequence) (cdr seq))
1817        (element (car seq) (car seq))
1818        (index start (1+ index))
1819        (count 0))
1820       ((or (= index end) (null seq)) count)
1821    (declare (fixnum index count) (list seq))
1822    (unless (funcall test-not item  (funcall key element))
1823      (incf count))))
1824
1825(defun list-count-not-p-from-end (test-not item sequence start end key)
1826  (declare (fixnum start end))
1827  (let* ((len (length sequence)))
1828    (declare (fixnum len))
1829    (list-count-not-p-from-start test-not item (reverse sequence) (- len end) (- len start) key)))
1830
1831(defun count (item sequence &key from-end (test #'eql testp)
1832                   (test-not nil notp) (start 0) end key)
1833  "Return the number of elements in SEQUENCE satisfying a test with ITEM,
1834   which defaults to EQL."
1835  (if (and testp notp)
1836    (test-not-error test test-not))
1837  (unless key
1838    (setq key #'identity))
1839  (setq end (check-sequence-bounds sequence start end))
1840  (if sequence
1841    (seq-dispatch
1842     sequence
1843     (if notp
1844       (if from-end
1845         (list-count-not-p-from-end test-not item  sequence start end key)
1846         (list-count-not-p-from-start test-not item sequence start end key))
1847       (if from-end
1848         (list-count-from-end test item sequence start end key)
1849         (list-count-from-start test item sequence start end key)))
1850     (if notp
1851       (if from-end
1852         (vector-count-not-p-from-end test-not item sequence start end key)
1853         (vector-count-not-p-from-start test-not item sequence start end key))
1854       (if from-end
1855         (vector-count-from-end test item sequence start end key)
1856         (vector-count-from-start test item sequence start end key))))
1857    0))
1858
1859
1860;;; Count-if:
1861
1862(defun count-if (test sequence &key from-end (start 0) end key)
1863  "Return the number of elements in SEQUENCE satisfying PRED(el)."
1864  (count test sequence
1865         :test #'funcall
1866         :from-end from-end
1867         :start start
1868         :end end
1869         :key key))
1870
1871;;; Count-if-not:
1872
1873(defun count-if-not (test sequence &key from-end (start 0) end key)
1874  "Return the number of elements in SEQUENCE not satisfying TEST(el)."
1875  (count test sequence
1876         :test-not #'funcall
1877         :from-end from-end
1878         :start start
1879         :end end
1880         :key key))
1881
1882
1883;;; Find:
1884
1885(defun find (item sequence &key from-end test test-not (start 0) end key &aux temp)
1886  (if sequence
1887    (seq-dispatch
1888     sequence
1889     (list-position/find-1 t item sequence from-end test test-not start end key)
1890     (if (setq temp (vector-position-1 item sequence from-end test test-not start end key))
1891       (aref sequence temp)))))
1892
1893(defun find-if (test sequence &key from-end (start 0) end key)
1894  (find test sequence
1895        :test #'funcall
1896        :from-end from-end
1897        :start start
1898        :end end
1899        :key key))
1900
1901(defun find-if-not (test sequence &key from-end (start 0) end key)
1902  (find test sequence
1903        :test-not #'funcall
1904        :from-end from-end
1905        :start start
1906        :end end
1907        :key key))
1908
1909
1910;;; Mismatch:
1911
1912(defun mismatch (seq1 seq2 &key (from-end nil)
1913                                  (test #'eql)
1914                                  (test-not nil)
1915                                  (key #'identity)
1916                                  (start1 0)
1917                                  (start2 0)
1918                                  (end1 nil)
1919                                  (end2 nil)
1920                             &aux (length1 (length seq1))
1921                                  (length2 (length seq2))
1922                                  (vectorp1 (vectorp seq1))
1923                                  (vectorp2 (vectorp seq2)))
1924  "The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared
1925   element-wise. If they are of equal length and match in every element, the
1926   result is NIL. Otherwise, the result is a non-negative integer, the index
1927   within SEQUENCE1 of the leftmost position at which they fail to match; or,
1928   if one is shorter than and a matching prefix of the other, the index within
1929   SEQUENCE1 beyond the last position tested is returned. If a non-NIL
1930   :FROM-END argument is given, then one plus the index of the rightmost
1931   position in which the sequences differ is returned."
1932  ;seq type-checking is done by length
1933  ;start/end type-cheking is done by <= (below)
1934  ;test/key type-checking is done by funcall
1935  ;no check for both test and test-not
1936  (or end1 (setq end1 length1))
1937  (or end2 (setq end2 length2))
1938  (unless (and (<= start1 end1 length1)
1939               (<= start2 end2 length2))
1940    (error "Sequence arg out of range"))
1941  (unless vectorp1
1942    (setq seq1 (nthcdr start1 seq1))
1943    (if from-end
1944      (do* ((s1 ())
1945            (i start1 (1+ i)))
1946           ((= i end1) (setq seq1 s1))
1947        (push (pop seq1) s1))))
1948  (unless vectorp2
1949    (setq seq2 (nthcdr start2 seq2))
1950    (if from-end
1951      (do* ((s2 ())
1952            (i start2 (1+ i)))
1953           ((= i end2) (setq seq2 s2))
1954        (push (pop seq2) s2))))
1955  (when test-not (setq test test-not))
1956  (if from-end
1957      ;from-end
1958      (let* ((count1 end1)
1959             (count2 end2)
1960             (elt1)
1961             (elt2))
1962        (loop
1963          (if (or (eq count1 start1)
1964                  (eq count2 start2))
1965              (return-from mismatch
1966                           (if (and (eq count1 start1)
1967                                    (eq count2 start2))
1968                               nil
1969                               count1)))
1970         
1971          (setq count1 (%i- count1 1)
1972                count2 (%i- count2 1))
1973
1974          (setq elt1 (funcall key (if vectorp1
1975                                      (aref seq1 count1)
1976                                      (prog1
1977                                        (%car seq1)
1978                                        (setq seq1 (%cdr seq1)))))
1979                elt2 (funcall key (if vectorp2
1980                                      (aref seq2 count2)
1981                                      (prog1
1982                                        (%car seq2)
1983                                        (setq seq2 (%cdr seq2))))))
1984
1985          (when (if test-not
1986                    (funcall test elt1 elt2)
1987                    (not (funcall test elt1 elt2)))
1988            (return-from mismatch (%i+ count1 1)))))
1989      ;from-start
1990      (let* ((count1 start1)
1991             (count2 start2)
1992             (elt1)
1993             (elt2))
1994        (loop
1995          (if (or (eq count1 end1)
1996                  (eq count2 end2))
1997              (return-from mismatch
1998                           (if (and (eq count1 end1)
1999                                    (eq count2 end2))
2000                               nil
2001                               count1)))
2002          (setq elt1 (funcall key (if vectorp1
2003                                      (aref seq1 count1)
2004                                      (prog1
2005                                        (%car seq1)
2006                                        (setq seq1 (%cdr seq1)))))
2007                elt2 (funcall key (if vectorp2
2008                                      (aref seq2 count2)
2009                                      (prog1
2010                                        (%car seq2)
2011                                        (setq seq2 (%cdr seq2))))))
2012         
2013          (when (if test-not
2014                    (funcall test elt1 elt2)
2015                    (not (funcall test elt1 elt2)))
2016            (return-from mismatch count1)) 
2017          (setq count1 (%i+ count1 1)
2018                count2 (%i+ count2 1))
2019         
2020          ))))
2021
2022
2023;;; Search comparison functions:
2024
2025(eval-when (:execute :compile-toplevel)
2026 
2027  ;;; Compare two elements
2028 
2029  (defmacro xcompare-elements (elt1 elt2)
2030    `(if (not key)
2031       (if test-not
2032         (not (funcall test-not ,elt1 ,elt2))
2033         (funcall test ,elt1 ,elt2))
2034       (let* ((e1 (funcall key ,elt1))
2035              (e2 (funcall key ,elt2)))
2036         (if test-not
2037           (not (funcall test-not  e1 e2))
2038           (funcall test e1 e2))))) 
2039 
2040  (defmacro vector-vector-search (sub main)
2041    `(let ((first-elt (aref ,sub start1))
2042           (last-one nil))
2043       (do* ((index2 start2 (1+ index2))
2044             (terminus (%i- end2 (%i- end1 start1))))
2045            ((> index2 terminus))
2046         (declare (fixnum index2 terminus))
2047         (if (xcompare-elements first-elt (aref ,main index2))
2048           (if (do* ((subi1 (1+ start1)(1+ subi1))
2049                     (subi2 (1+ index2) (1+ subi2)))
2050                    ((eq subi1 end1) t)
2051                 (declare (fixnum subi1 subi2))
2052                 (if (not (xcompare-elements (aref ,sub subi1) (aref ,main subi2)))
2053                   (return nil)))
2054             (if from-end
2055               (setq last-one index2)
2056               (return-from search index2)))))
2057       last-one))
2058
2059  (defmacro list-list-search (sub main)
2060    `(let* ((sub-sub (nthcdr start1 ,sub))
2061            (first-elt (%car sub-sub))
2062            (last-one nil))
2063       (do* ((index2 start2 (1+ index2))
2064             (sub-main (nthcdr start2 ,main) (%cdr sub-main))
2065             (terminus (%i- end2 (%i- end1 start1))))
2066            ((> index2 terminus))
2067         (declare (fixnum index2 terminus))
2068         (if (xcompare-elements first-elt (car sub-main))
2069           (if (do* ((ss (%cdr sub-sub) (%cdr ss))
2070                     (pos (1+ start1) (1+ pos))
2071                     (sm (%cdr sub-main) (cdr sm)))
2072                    ((or (null ss) (= pos end1))  t)
2073                 (declare (fixnum pos))
2074                 (if (not (xcompare-elements (%car ss) (%car sm)))
2075                     (return nil)))
2076              (if from-end
2077               (setq last-one index2)
2078               (return-from search index2)))))
2079       last-one))
2080 
2081  (defmacro list-vector-search (sub main)
2082    `(let* ((sub-sub (nthcdr start1 ,sub))
2083              (first-elt (%car sub-sub))
2084              (last-one nil))
2085         (do* ((index2 start2 (1+ index2))
2086               (terminus (%i- end2 (%i- end1 start1))))
2087              ((> index2 terminus))
2088           (declare (fixnum index2 terminus))
2089           (if (xcompare-elements first-elt (aref ,main index2))
2090             (if (do* ((ss (%cdr sub-sub) (%cdr ss))
2091                       (pos (1+ start1) (1+ pos))
2092                       (subi2 (1+ index2) (1+ subi2)))
2093                      ((or (null ss) (= pos end1))  t)
2094                   (declare (fixnum subi2 pos))
2095                   (if (not (xcompare-elements (%car ss) (aref ,main subi2)))
2096                     (return nil)))
2097               (if from-end
2098                 (setq last-one index2)
2099                 (return-from search index2)))))
2100         last-one))
2101
2102  (defmacro vector-list-search (sub main)
2103    `(let ((first-elt (aref ,sub start1))
2104           (last-one nil))
2105       (do* ((index2 start2 (1+ index2))
2106             (sub-main (nthcdr start2 ,main) (%cdr sub-main))
2107             (terminus (%i- end2 (%i- end1 start1))))
2108            ((> index2 terminus))
2109         (declare (fixnum index2 terminus))
2110         (if (xcompare-elements first-elt (car sub-main))
2111           (if (do* ((subi1 (1+ start1)(1+ subi1))
2112                     (sm (%cdr sub-main) (cdr sm)))
2113                    ((eq subi1 end1) t)
2114                 (declare (fixnum subi1))
2115                 (if (not (xcompare-elements (aref ,sub subi1) (car sm)))
2116                   (return nil)))
2117             (if from-end
2118               (setq last-one index2)
2119               (return-from search index2)))))
2120       last-one))
2121                 
2122   
2123  )
2124
2125
2126
2127(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not 
2128                          (start1 0) end1 (start2 0) end2 (key #'identity))
2129  (setq end1 (check-sequence-bounds sequence1 start1 end1))
2130  (setq end2 (check-sequence-bounds sequence2 start2 end2))
2131  (setq key (adjust-key key))
2132  (locally (declare (fixnum start1 end1 start2 end2))
2133    (if (eq 0 (%i- end1 start1))(if from-end end2 start2)
2134    (seq-dispatch sequence1
2135                  (seq-dispatch sequence2
2136                                (list-list-search sequence1 sequence2)
2137                                (list-vector-search sequence1 sequence2))
2138                  (seq-dispatch sequence2
2139                                (vector-list-search sequence1 sequence2)
2140                                (vector-vector-search sequence1 sequence2))))))
2141
2142(defun make-string (size &key (initial-element () initial-element-p) (element-type 'character element-type-p))
2143  "Given a character count and an optional fill character, makes and returns
2144   a new string COUNT long filled with the fill character."
2145  (declare (optimize (speed 1) (safety 1)))
2146  (when (and initial-element-p (not (typep initial-element 'character)))
2147    (report-bad-arg initial-element 'character))
2148  (when (and element-type-p
2149             (not (or (member element-type '(character base-char standard-char))
2150                      (subtypep element-type 'character))))
2151    (error ":element-type ~S is not a subtype of CHARACTER" element-type))
2152  (if initial-element-p
2153      (make-string size :element-type 'base-char :initial-element initial-element)
2154      (make-string size :element-type 'base-char)))
Note: See TracBrowser for help on using the repository browser.