source: branches/working-0711/ccl/lib/sequences.lisp @ 9620

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

Warn about declarations referring to unknown variables; then fix a whole bunch of them in ccl, a surprisingly large number of which actually mattered

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