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

Last change on this file since 10942 was 10942, checked in by gz, 12 years ago

Propagate r10938:r10941 (duplicate definition warnings) to trunk

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