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

Last change on this file since 15477 was 15477, checked in by gb, 8 years ago

COPY-LIST: if we find that the list is "fairly long", check to see
if it's "very long" and change algorithm if so.

CHECK-SEQUENCE-BOUNDS: take length as an &optional arg, since some
callers may want to avoid doing LENGTH multiple times.

CONSTANTLY: return #'TRUE or #'FALSE if appropriate.

REMOVE, REMOVE-IF, REMOVE-IF-NOT: build result, don't do destructive
operations on copy. (Fixes ticket:1015 in the trunk, though other
sequence functions may do similar things.)

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