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

Last change on this file since 16171 was 16171, checked in by gb, 6 years ago

Canonicalize the type specifier when calling COERCE-TO-COMPLEX.
Fixes ticket:1218 in the trunk.

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