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

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

In SOME-XX-MULTI, traverse the list of sequences in a way that
doesn't require us to try to find the current sequence via MEMQ;
this could affect the wrong sequence if some sequences shared
structure (and wasn't the smartest thing to do even if they didn't.)
Fixes ticket:859.

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