;;; -*- cold-load:t; Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10. -*-

1;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.

;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151

;;; Copyright (C) 1986-1989 Texas Instruments Incorporated. All rights reserved.*



(defsubst internal-make-vector (size lispm-array-type &optional initial-element)
;1; Make a new vector ( without a fill-pointer, leader , etc.) of length <size>,*
;1; type <lispm-array-type> and fill it with <initial-element>*
  (let ((vector (if (simple-vector-size-p size)
		    (internal-make-simple-vector size lispm-array-type)
		    (inhibit-style-warnings
		      (make-array size :type lispm-array-type)))))
    (when initial-element (array-initialize vector initial-element))
    vector))

(defun adjust-vector (vector length)
1;; Reduce the length of <vector> to <length>*
;1; if vector has fill-pointer, change it. Else change the vector itself.*
  (if (array-has-fill-pointer-p vector)
      (setf (fill-pointer vector) length)
      (inhibit-style-warnings   ;; to keep compiler from complaining...
	(zlc:adjust-array-size vector length)))   
  vector)

;;PHD 1/2/87 Added fast check for simple cases.
;;PHD 2/6/87 Fixed, added support for CONS.
(defun make-sequence (type size &key initial-element &aux array-type)
  "Returns a sequence of SIZE elements, of type TYPE.
Each element is set to INITIAL-ELEMENT.
TYPE must be equivalent to either LIST or some sort of ARRAY.
If the value is a list, it is completely cdr-coded."
  (cond((member type '(list cons) :test #'eq)
	(make-list size :initial-element initial-element))
       ((eq type 'string)
	(make-string size :initial-element initial-element))
       ((and (member(car-safe type) '(array vector))
	     (cadr-safe type)
	     (setf array-type (cdr (assoc (cadr-safe type) array-element-type-alist :test #'eq))))
	(internal-make-vector size array-type initial-element))
       (t 
	(let ((real-type (type-canonicalize type)))
	  (etypecase real-type
	    (symbol
	     (ecase real-type
	       (list (make-list size :initial-element initial-element))
	       ((array simple-array)
		(internal-make-vector size 'art-q initial-element))))
	    (cons
	     (let* ((btype (car real-type))
		    (element-type (case (cadr real-type)
				    ((nil *) t)
				    (t (cadr real-type)))))
	       (ecase btype
		 ((list cons )(make-list size :initial-element initial-element))
		 ((array simple-array)   
		  (internal-make-vector size (array-type-from-element-type element-type) initial-element))))))))))



(defvar *seq-temp-vector* nil)

(eval-when (compile)
  
  (defmacro copy-from-list-to-vector (list lstart vector vstart count)
1;; Copy <count> items of <list>, starting at <lstart> to <vector> starting at <vstart>*
    `(do ((loopcnt 0 (1+ loopcnt))
	  (source (nthcdr ,lstart ,list) (cdr source)))
	 ((>= loopcnt ,count))
       (setf (aref ,vector (+ ,vstart loopcnt)) (car source))))
  
  (defmacro copy-from-vector-to-list (vector vstart list lstart count)  
1;; Copy <count> items of <vector>, starting at <vstart>, to <list>, starting at <lstart>*
    `(do ((loopcnt 0 (1+ loopcnt))
	  (sink (nthcdr ,lstart ,list) (cdr sink)))
	 ((>= loopcnt ,count))
       (setf (car sink) (aref ,vector (+ ,vstart loopcnt)))))
  
  (defmacro copy-from-list-to-list (list1 lstart1 list2 lstart2 count)  
1;; Copy <count> items of <list1>, starting at <lstart1>, to <list2>, starting at <lstart2>*
    `(do ((loopcnt 0 (1+ loopcnt))
	  (source (nthcdr ,lstart1 ,list1) (cdr source))
	  (sink (nthcdr ,lstart2 ,list2) (cdr sink)))
	 ((>= loopcnt ,count))
       (setf (car sink) (car source))))
  
  (defmacro get-seq-temp-vector (size)
    `(let ((internal-size ,size))
       (or (do (old)
	       ((%store-conditional (locf *seq-temp-vector*)
				    (setq old *seq-temp-vector*)
				    nil)
		(when (and (vectorp old) (>= (array-total-size old) internal-size) old))))
	   (make-array ,size :fill-pointer internal-size :area background-cons-area))))
  )

(defun replace* (seq1 seq2 &optional start1 end1 start2 end2)
1;; <seq1>- the sink , <seq2> - the source*
  (let* ((len1 (length seq1))(len2 (length seq2))
	 (start1 (if start1 (max 0 start1) 0)) (start2 (if start2 (max 0 start2) 0))
	 (end1 (if end1 (min end1 len1) len1)) (end2 (if end2 (min end2 len2) len2))
	 (copynum (min (- end2 start2)(- end1 start1))))
    (if (and (eq seq1 seq2) 
	     (or  ;; overlap test
	       (and (<= start1 start2) (< start2 end1))
	       (and (<= start2 start1) (< start1 end2))))
	(let ((tvector (get-seq-temp-vector (- end2 start2))))
	  (cond ((arrayp seq2)
		 (copy-array-portion seq2 start2 end2 tvector 0 (- end2 start2))
		 (copy-array-portion tvector 0 copynum seq1 start1 (+ start1 copynum)))
		(t
		 (copy-from-list-to-vector seq2 start2 tvector 0 copynum)
		 (copy-from-vector-to-list tvector 0 seq1 start1 copynum)))
	  (setq *seq-temp-vector* tvector))
	(if (arrayp seq1)
	    (if (arrayp seq2) 
		(copy-array-portion seq2 start2 (+ start2 copynum) seq1 start1 (+ start1 copynum))
		(copy-from-list-to-vector seq2 start2 seq1 start1 copynum))
	    (if (arrayp seq2)
		(copy-from-vector-to-list seq2 start2 seq1 start1 copynum)
		(copy-from-list-to-list seq2 start2 seq1 start1 copynum))))
    seq1))


(defun replace (sink-seq source-seq &key start1 end1 start2 end2)
  1"Copy all or part of <SOURCE-SEQ> into <SINK-SEQ>.
A sequence is either a list or a vector.
START2 and END2 specify the part of <source-seq> to be copied.
 They default to 0 and NIL (which means the end of the sequence).
START1 and END1 specify the part of SINK-SEQ to be copied into.
If the subsequence to be copied into is longer than the one to be copied,
 the extra elements of the to-subsequence are left unchanged.
If the two sequences are the same, the data is first copied to a
 intermediate location and then copied back in.
The value is SINK-SEQ."*
  (replace* sink-seq source-seq start1 end1 start2 end2))


(defun subseq (sequence start &optional end)
  1"Return a subsequence of SEQUENCE; a new sequence containing some 
of SEQUENCE's elements.*  1If SEQUENCE is a list, the value is also a 
list;* 1if it is an array, the value is an array of the same type.* 
1The subsequence begins with the element specified by START and ends 
with the element whose index is 1 less than END. * 1If END is NIL, it 
means the end of SEQUENCE."*
  (let* ((start (max 0 start))
	 (len   (length sequence))
	 (end   (if end (min end len) len))
	 (new-length (max (- end start) 0)))
    (if (arrayp sequence)
	(let ((new-array (internal-make-vector new-length (array-type sequence))))
	  (copy-array-portion sequence start end new-array 0 new-length)
	  new-array)
	(let ((new-list (make-list new-length)))
	  (copy-from-list-to-list sequence start new-list 0 new-length)
	  new-list))))

(defun copy-seq (sequence)
  1"Return a new sequence with the same elements as SEQUENCE, and of the same type.
SEQUENCE may be a list or an array."*
  (if (arrayp sequence)
      (let* ((length (length sequence))
	     (new-array (internal-make-vector length (array-type sequence))))
	(copy-array-portion sequence 0 length new-array 0 length)
	new-array)
      (copy-list sequence)))



(defun concatenate (result-type &rest sequences)
  1"Return a sequence of type RESULT-TYPE concatenating the contents of the SEQUENCES.
Each sequence argument may be a list or an array.
RESULT-TYPE must be a valid sequence type such as LIST or VECTOR."*
  (let* ((total-length 
	   (do ((y sequences (cdr y))
		(len 0 (+ len (length (car y)))))
	       ((null y) len)))
	 (new-sequence (make-sequence result-type total-length)))
    (if (arrayp new-sequence)
	(do ((y sequences (cdr y))
	     (len)
	     (indx 0 (+ indx len)))
	    ((null y) new-sequence)
	  (setq len (length (car y)))
	  (if (arrayp (car y))
	      (copy-array-portion (car y) 0 len new-sequence indx (+ indx len))
	      (copy-from-list-to-vector (car y) 0 new-sequence indx len)))
	(do ((y sequences (cdr y))
	     (len)
	     (indx 0 (+ indx len)))
	    ((null y) new-sequence)
	  (setq len (length (car y)))
	  (if (arrayp (car y))
	      (copy-from-vector-to-list (car y) 0 new-sequence indx len)
	      (copy-from-list-to-list (car y) 0 new-sequence indx len))))))

;;;  REVERSE 

(eval-when (compile)
  (defmacro reverse-list-template (list)
    `(do ((x ,list (cdr x))
	  (z nil (cons (car x) z)))
	 ((atom x) z)))

  (defmacro reverse-vector-template (array)
    `(let* ((len (length ,array))
	    (result (internal-make-vector len (array-type ,array))))
	(dotimes (i len result)
	  (setf (aref result i) (aref ,array (- len i 1))))))
)

(defun reverse (sequence)
  1"Return a sequence whose elements are those of SEQUENCE, in reverse order.
If SEQUENCE is a list, the value is a list.
If it is an array, the value is an array of the same type."*
  (if (arrayp sequence)
      (reverse-vector-template sequence)
      (reverse-list-template sequence)))

(defun reverse-list (list)
  (reverse-list-template list))

(defun reverse-vector (array)
  (reverse-vector-template array))


;;;  NREVERSE
(eval-when (compile)
  
  (defmacro nreverse-list-template (procedure list)
    `(let (tail)  ;; handle the general case
	 (tagbody
	  loop  
	     (when (atom ,list) (return-from ,procedure tail))
	     (setq ,list 
		   (prog1 (cdr ,list) (rplacd ,list tail) (setq tail ,list)))
	     (go loop))))

  (defmacro nreverse-vector-template (array)
    `(let* ((len (length ,array))
	    (halflen (truncate len 2)))
       (dotimes (i halflen ,array)
	 (let ((tem (aref ,array i)))
	   (setf (aref ,array i)
		 (aref ,array (- len i 1)))
	   (setf (aref ,array (- len i 1)) tem)))))
)

(defun nreverse (sequence)
  1"Alter SEQUENCE destructively to contain its elements in reverse order.
If SEQUENCE is a list, this works by changing cdr pointers.
If SEQUENCE is an array, this works by shuffling the elements."*
  (if (arrayp sequence)
      (nreverse-vector-template sequence)
      (nreverse-list-template nreverse sequence)))

(defun nreverse-list (list)
  (nreverse-list-template nreverse-list list))

(defun nreverse-vector (array)
  (nreverse-vector-template array))



;;;6/1/88 CLM - Changed way of calculating actlen to avoid getting
;;;unusual results when :end is less than :start.  This is the same
;;;way that SUBSEQ handles these cases. (spr 7774)
(eval-when (compile eval)
  (defmacro with-reduce-bindings (&rest body)
    `(let* ((start (if start (max 0 start) 0))
	    (len (length sequence))
	    (end (if end (min end len) len))
	    (actlen (max (- end start) 0)))
       . ,body))
  )

(defun reduce-vector (fct sequence &optional initial-value initial-value-p start end from-end)
  (with-reduce-bindings
    (if initial-value-p
       (cond ((zerop actlen) (values initial-value))
	     ((= actlen 1)
	      (values (if from-end
			  (funcall fct (aref sequence (1- end)) initial-value)
			  (funcall fct initial-value (aref sequence start)))))
	     (from-end
	      (do ((accum (funcall fct (aref sequence (1- end)) initial-value) 
			  (funcall fct (aref sequence index) accum))
		   (index (- end 2) (1- index)))
		  ((< index start) (values accum))))
	     (t
	      (do ((accum (funcall fct initial-value (aref sequence start))
			  (funcall fct accum (aref sequence index)))
		   (index (1+ start) (1+ index)))
		  ((>= index end) (values accum)))))
       (cond ((zerop actlen) (values (funcall fct)))
	     ((= actlen 1) (values (aref sequence start)))
	     (from-end
	      (do ((accum (funcall fct (aref sequence (- end 2)) (aref sequence (1- end))) 
			  (funcall fct (aref sequence index) accum))
		   (index (- end 3) (1- index)))
		  ((< index start) (values accum))))
	     (t
	      (do ((accum (funcall fct (aref sequence start) (aref sequence (1+ start)))
			  (funcall fct accum (aref sequence index)))
		   (index (+ start 2) (1+ index)))
		  ((>= index end) (values accum))))))))



(defun reduce-list (fct sequence &optional initial-value initial-value-p start end from-end)
  (with-reduce-bindings
    (if initial-value-p
       (cond ((zerop actlen) (values initial-value))
	     ((= actlen 1)
	      (values (if from-end
			  (funcall fct (nth (1- end) sequence) initial-value)
			  (funcall fct initial-value (nth start sequence)))))
	     (from-end
	      (let ((vector (coerce sequence 'vector)))  ;; convert to vector - shorter and faster than a list
		(do ((accum (funcall fct (aref vector (1- end)) initial-value) 
			    (funcall fct (aref vector index) accum))
		     (index (- end 2) (1- index)))
		    ((< index start) (values accum)))))
	     (t
	      (let ((list (nthcdr start sequence)))
		(do ((accum (funcall fct initial-value (car list))
			    (funcall fct accum (car rest)))
		     (rest (cdr list) (cdr rest))
		     (index 1 (1+ index)))
		    ((>= index actlen) (values accum))))))
       (cond ((zerop actlen) (values (funcall fct)))
	     ((= actlen 1) (values (nth start sequence)))
	     (from-end
	      (let ((vector (coerce sequence 'vector)))
		(do ((accum (funcall fct (aref vector (- end 2)) (aref vector (1- end))) 
			    (funcall fct (aref vector index) accum))
		     (index (- end 3) (1- index)))
		    ((< index start) (values accum)))))
	     (t
	      (let ((list (nthcdr start sequence)))
		(do ((accum (funcall fct (car list) (cadr list))
			    (funcall fct accum (car rest)))
		     (rest (cddr list) (cdr rest))
		     (index  2 (1+ index)))
		    ((>= index actlen) (values accum)))))))))

(defun reduce* (fct sequence &optional initial-value initial-value-p start end from-end)
  (if (arrayp sequence)
      (reduce-vector fct sequence initial-value initial-value-p start end from-end)
      (reduce-list fct sequence initial-value initial-value-p start end from-end)))



(defun reduce (function sequence &key (initial-value nil initial-value-p) start end from-end)
  "Combine the elements of SEQUENCE using FUNCTION, a function of two args.
FUNCTION is applied to the first two elements; then to that result and the third element;
 then to that result and the fourth element; and so on.
START and END restrict the action to a part of SEQUENCE,
 as if the rest of SEQUENCE were not there.  They default to 0 and NIL
 (NIL for END means to the end of SEQUENCE).
If FROM-END is non-NIL, FUNCTION is applied to the last two elements;
 then to the previous element and that result; then to the previous
 element and that result; and so on.
If INITIAL-VALUE is specified, it acts like an extra element of SEQUENCE
 at the end (if FROM-END is non-NIL) or the beginning, in addition to
 the actual elements of the specified part of SEQUENCE.  Then there is
 effectively one more element to be processed.  The INITIAL-VALUE is
 used in the first call to FUNCTION.
If there is only one element to be processed,
 that element is returned and FUNCTION is not called.
If there are no elements (SEQUENCE is of length zero and no INITIAL-VALUE),
 FUNCTION is called with no arguments and its value is returned."
  (reduce* function sequence initial-value initial-value-p start end from-end))


(eval-when (compile eval)
(defmacro with-fill-bindings (&rest body)
  `(let* ((start (if start (max 0 start) 0))
	  (len (length sequence))
	  (end (if end (min end len) len)))
     . ,body))
)
(defun fill-vector (sequence item &optional start end)
  (with-fill-bindings
    (array-initialize sequence item start end)
    sequence))

(defun fill-list (sequence item &optional start end)
  (with-fill-bindings
    (do ((rest (nthcdr start sequence) (cdr rest))
	 (indx start (1+ indx)))
	((>= indx end) sequence)
      (setf (car rest) item))))

(defun fill* (sequence item &optional start end)

  (if (arrayp sequence) 
      (fill-vector sequence item start end)
      (fill-list sequence item start end)))

(defun fill (sequence item &key start end)
  "Set all the elements of SEQUENCE (or some subsequence of it) to ITEM.
START and END specify the subsequence; they default to 0 and the end of
the sequence."

  (if (arrayp sequence) 
      (fill-vector sequence item start end)
      (fill-list sequence item start end)))


;;; Primitives for fetching elements sequentially from either lists or arrays.
;;; You use an index variable which contains an array index if the
;;; sequence is an array, or a tail if the sequence is a list.
(eval-when (compile)
(defmacro seq-inc (indexvar)
  `(if (numberp ,indexvar)
       (incf ,indexvar)
     (setq ,indexvar (cdr ,indexvar)))))

(eval-when (compile)
(defmacro seq-fetch (sequence indexvar)
  `(if (numberp ,indexvar)
       (aref ,sequence ,indexvar)
     (car ,indexvar))))  

(eval-when (compile)
(defmacro seq-fetch-inc (sequence indexvar)
  `(if (numberp ,indexvar)
       (aref ,sequence (prog1 ,indexvar (incf ,indexvar)))
     (pop ,indexvar)))) 

(eval-when (compile)
(defmacro seq-store (sequence indexvar value)
  `(if (numberp ,indexvar)
       (setf (aref ,sequence ,indexvar) ,value)
     (setf (car ,indexvar) ,value)))) 

;;; This returns an index variable value that is ready to fetch the
;;; first element of the sequence.
(eval-when (compile)
(defmacro seq-start (sequence &optional numeric-index)
  (if numeric-index
      `(if (arrayp ,sequence)
	   ,numeric-index
	 (nthcdr ,numeric-index ,sequence))
    `(if (arrayp ,sequence) 0 ,sequence))))

;;; This returns a value for use in an end-test.
;;; Compare the index var against this value with EQ to see if you are at the end.
(eval-when (compile)
(defmacro seq-end (sequence &optional numeric-index)
  `(if (arrayp ,sequence)
       (if ,numeric-index
	   (min ,numeric-index (length ,sequence))
	   (length ,sequence))
     (and ,numeric-index (nthcdr ,numeric-index ,sequence)))))

;;; Storing into either an array or a contiguous cdr-coded list.
(eval-when (compile)
(defmacro seq-contig-store (sequence indexvar value)
  `(if (arrayp ,sequence)
       (setf (aref ,sequence ,indexvar) ,value)
     (%p-store-contents-offset ,value ,sequence ,indexvar)))) 

(defun fill-array-from-sequences (array sequence dimension array-index)
  (if (= 0 (array-rank array))
      (setf (lisp:aref array) sequence)
    (do ((index (seq-start sequence))
	 (i 0 (1+ i))
	 (last-dim-flag (= (1+ dimension) (array-rank array)))
	 (stop-i (array-dimension array dimension)))
	((= i stop-i))
      (if last-dim-flag
	  ;; Cut off one level of recursion - eliminates most of the function calls.
	  (setf (ar-1-force array (+ (* array-index stop-i) i))
		(seq-fetch-inc sequence index))
	(fill-array-from-sequences array (seq-fetch-inc sequence index) (1+ dimension)
				   (+ (* array-index stop-i) i))))))


;;;; VECTOR SEARCHES
;;;
;;;  pattern   x[xs] ... x[xe-1]   xL = xe-xs
;;;  vector    y[ys] ... y[ye-1]
;;;
;;;  In SEARCH-VECTOR, seek the Smallest i such that
;;;        ys <= i <= ye-xL
;;;  and
;;;        x[xs] ... x[xe-1]  matches
;;;        y[i] ...  y[i+xL-1]
;;;  returning i.
;;;
;;;  In SEARCH-VECTOR-FROMEND, seek the Largest i such that
;;;        ye-xL-1 <= i <= ye-1
;;;  and
;;;        x[xs] .........x[xe-1] matches
;;;        y[i-xL-1] .... y[i]
;;;  returning i-xL-1
;;;
;;;  In the de-generate case, where xL=0 , SEARCH-VECTOR returns 0
;;;  and  SEARCH-VECTOR-FROMEND returns ye.

;;;; STRING SEARCHES
;;;
;;;  SEARCH-STRING-CASE and SEARCH-STRING-NOCASE are functionally identical
;;;  to SEARCH-VECTOR except that the inner loop is handled by the microcoded
;;;  function %STRING-EQUAL and the special variable 
;;;     ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON
;;;  is bound. Since %STRING-EQUAL operates only left-to-right, the from-end
;;;  versions SEARCH-STRING-CASE-FROMEND and SEARCH-STRING-NOCASE-FROMEND are
;;;  specified:
;;;      seek the Largest i such that
;;;           ys <= i <= ye-xL
;;;  and
;;;        x[xs] ..... x[xe-1] matches
;;;        y[i]  ..... y[i+xL-1]
;;;  returning i.

(eval-when (compile)
  (defmacro search-vector-body (predicate)
    `(block search-loop
       (do ((i ystart (1+ i)))
	   ((> i (- yend rxlen)) nil)
	 (do ((j xstart (1+ j))
	      (k i      (1+ k)))
	     ((>= j xend) (return-from search-loop i))
	   (unless ,predicate    ;; (funcall test (aref x j) (aref y k))
	     (return))))))

  (defmacro search-list-body (predicate)
    `(block search-loop 
       (let ((index nil)
	     (xtail (nthcdr xstart x)))
	 (do ((ytail (nthcdr ystart y) (cdr ytail))
	      (i ystart (1+ i)))
	     ((> i (- yend rxlen)) index)
	   (do ((xtail xtail (cdr xtail))
	       (ktail ytail (cdr ktail))
	       (j xstart (1+ j)))
	      ((>= j xend) (if from-end (setf index i) (return-from search-loop i)))
	     (unless ,predicate    ;; (funcall test (car xtail) (car ytail))
	       (return)))))))
       
       (defmacro search-vector-fromend-body (predicate)
	 `(block search-loop
	    (do ((i (1- yend) (1- i)))
		((< i  (+ ystart rxlen -1)) nil)
	      (do ((j (1- xend)  (1- j))
		   (k i          (1- k)))
		  ((< j xstart) (return-from search-loop (1+ k)))
		(unless ,predicate
		  (return))))))

       
       (defmacro search-string-body ()
	 `(do* ((ch1 (aref x xstart))
		(i ystart (1+ i)))
	       ((> i (- yend rxlen)) nil)
	    (when (and (char-equal ch1 (aref y i)) (sys:%string-equal x xstart y i rxlen))
	      (return i))))
       
       (defmacro search-string-fromend-body ()
	 `(do ((ch1 (aref x xstart))
	       (i (- yend rxlen) (1- i)))
	      ((< i ystart) nil)
	    (when (and (char-equal ch1 (aref y i)) (sys:%string-equal x xstart y i rxlen))
	      (return i))))
       
       (defmacro with-search-bindings (&rest body)
	 `(let* ((xlen   (length x))
		 (ylen   (length y))
	    (xstart (if start1 (max 0 start1) 0))   (ystart (if start2 (max 0 start2) 0))
	    (xend   (if end1 (min end1 xlen) xlen)) (yend   (if end2 (min end2 ylen) ylen))
	    (rxlen  (- xend xstart))  ;; the "real" length of x
	    )
       (progn . ,body)))
  )

(defun search*-list (x y &optional (test #'eql) start2 end2 start1 end1 from-end key test-not)
  (with-search-bindings
    (if (null key)
	(if (null test-not)
	    (search-list-body
		  (case test
		    ((eql #.#'eql)
		     (eql (car xtail) (car ktail)))
		    ((eq #.#'eq)
		     (eq (car xtail) (car ktail)))
		    (t 
		     (funcall test (car xtail) (car ktail)))))
	    (search-list-body
	      (not (funcall test-not (car xtail) (car ktail)))))
	(if (null test-not)
	    (search-list-body
	      (funcall test
		       (funcall key (car xtail))
		       (funcall key (car ktail))))
	    (search-list-body
	      (not (funcall test-not
			    (funcall key (car xtail))
			    (funcall key (car ktail)))))))))

(defun search*-list-eq-or-eql (x y eq-p &optional start2 end2 start1 end1 from-end)
  (with-search-bindings
    (search-list-body
      (if eq-p
	  (eq  (car xtail) (car ktail))
	  (eql (car xtail) (car ktail))))))

;;search-vector-eq is implemented by search-string-case
(defun search*-vector-eql (x y &optional start2 end2 start1 end1 from-end)
  (with-search-bindings
    (if from-end
	(search-vector-fromend-body
	  (eql (aref x j) (aref y k)))
	(search-vector-body
	  (eql (aref x j) (aref y k))))))

(defun search*-vector (x y &optional (test #'eql) start2 end2 start1 end1 key test-not)
  (with-search-bindings
    (if key
	(if test-not
	    (search-vector-body
	      (not (funcall test-not
			    (funcall key (aref x j))
			    (funcall key (aref y k)))))
	    (search-vector-body
	      (funcall test
		       (funcall key (aref x j))
		       (funcall key (aref y k)))))
	(if test-not
	    (search-vector-body
	      (not (funcall test-not (aref x j) (aref y k))))
	    (search-vector-body
	      (funcall test (aref x j) (aref y k)))))))

(defun search*-vector-fromend (x y &optional (test #'eql) start2 end2 start1 end1 key test-not)
  (with-search-bindings
    (if key
	(if test-not
	    (search-vector-fromend-body
	      (not (funcall test-not
			    (funcall key (aref x j))
			    (funcall key (aref y k)))))
	    (search-vector-fromend-body
	      (funcall test
		       (funcall key (aref x j))
		       (funcall key (aref y k)))))
	(if test-not
	    (search-vector-fromend-body
	      (not (funcall test-not (aref x j) (aref y k))))
	    (search-vector-fromend-body
	      (funcall test (aref x j) (aref y k)))))))


(defun search*-string-case (x y &optional start2 end2 start1 end1)
  (with-search-bindings
    (let ((alphabetic-case-affects-string-comparison t))
      (search-string-body))))

(defun search*-string-case-fromend (x y &optional start2 end2 start1 end1)
  (with-search-bindings
    (let ((alphabetic-case-affects-string-comparison t))
      (search-string-fromend-body))))

(defun search*-string-nocase (x y &optional start2 end2 start1 end1)
  (with-search-bindings
    (let ((alphabetic-case-affects-string-comparison nil))
      (search-string-body))))

(defun search*-string-nocase-fromend (x y &optional start2 end2 start1 end1)
  (with-search-bindings
    (let ((alphabetic-case-affects-string-comparison nil))
      (search-string-fromend-body))))


(defun mismatch* (sequence1 sequence2 &optional test (start2 0) end2 (start1 0) end1
		  from-end key test-not)
  (if from-end
      (funcall (if (and (arrayp sequence1) (arrayp sequence2))
		 'mismatch*-arrays-from-end
		 'mismatch*-lists-from-end)
	     sequence1 sequence2 test start2 end2 start1 end1 from-end key test-not) 
      (do ((index1 (seq-start sequence1 start1))
	   (index2 (seq-start sequence2 start2))
	   (i start1 (1+ i))
	   (stop1 (seq-end sequence1 end1))
	   (stop2 (seq-end sequence2 end2))
	   (test-fun (or test-not test #'eql))
	   (test-val (not (null test-not))))
	  ((or (eq index1 stop1) (eq index2 stop2))
	   (unless (and (eq index1 stop1) (eq index2 stop2))
	     i))
	(unless (eq test-val
		    (not (funcall test-fun
				  (if key
				      (funcall key (seq-fetch sequence1 index1))
				      (seq-fetch sequence1 index1))
				  (if key
				      (funcall key (seq-fetch sequence2 index2))
				      (seq-fetch sequence2 index2)))))
	  (return i))
	(seq-inc index1)
	(seq-inc index2))))

(defun mismatch (sequence1 sequence2 &rest keyargs
		 &key from-end test test-not key
		 (start1 0) end1 (start2 0) end2)
  "Return index in SEQUENCE1 of first mismatch between it and SEQUENCE2.
Elements are compared one by one, starting with elements at indexes START1 and START2
 and stopping when index 1 reaches END1 or index 2 reaches END2.
If sequences match, value is NIL.  If they match until one is exhausted but not both,
 the value is the index in SEQUENCE1 at which one sequence is exhausted.
TEST is a function of two args to use to compare two elements.
 The elements match when the TEST function returns non-NIL.
 Alternatively, specify as TEST-NOT a function to use which returns NIL if there is a match.
KEY, if non-NIL, is a function to be applied to each element to get a key,
 which is passed to TEST or TEST-NOT.  If KEY is NIL, the element itself is used.
FROM-END non-NIL means comparison aligns right ends of the specified
 subsequences and returns one plus the index of the rightmost mismatch."
  (declare (arglist sequence1 sequence2 &key from-end test test-not key
			       (start1 0) end1 (start2 0) end2))
  (mismatch* sequence1 sequence2  test start2 end2 start1 end1 from-end key test-not))

  

(defun mismatch*-arrays-from-end
       (sequence1 sequence2 test start2 end2 start1 end1 
	from-end key test-not)
  from-end
  (do ((index1 (1- (or end1 (length sequence1))) (1- index1))
       (index2 (1- (or end2 (length sequence2))) (1- index2)))
      ((or (< index1 start1) (< index2 start2))
       (unless (and (< index1 start1) (< index2 start2))
	 (1+ index1)))
    (unless (eq (not (null test-not))
		(not (funcall (or test-not test 'eql)
			      (if key
				  (funcall key (aref sequence1 index1))
				(aref sequence1 index1))
			      (if key
				  (funcall key (aref sequence2 index2))
				(aref sequence2 index2)))))
      (return (1+ index1)))))

(defun mismatch*-lists-from-end
       (sequence1 sequence2 test start2 end2 start1 end1  
	from-end key test-not)
  from-end
  (let* ((real-end1 (or end1 (length sequence1)))
	 (real-end2 (or end2 (length sequence2)))
	 (compare-length (min (- real-end1 start1) (- real-end2 start2))))
    (do ((index1 (seq-start sequence1 (- real-end1 compare-length)))
	 (index2 (seq-start sequence2 (- real-end2 compare-length)))
	 (i (- real-end1 compare-length) (1+ i))
	 (last-mismatch-index1
	   (cond ((/=  (- real-end1 start1) (- real-end2 start2))
		  (- real-end1 compare-length)))))
	((= i compare-length)
	 last-mismatch-index1)
      (unless (eq (not (null test-not))
		  (not (funcall (or test-not test 'eql)
				(if key
				    (funcall key (seq-fetch sequence1 index1))
				  (seq-fetch sequence1 index1))
				(if key
				    (funcall key (seq-fetch sequence2 index2))
				  (seq-fetch sequence2 index2)))))
	(setq last-mismatch-index1 (1+ i)))
      (seq-inc index1) (seq-inc index2))))


(defun search* (for-seq-1 in-seq-2 &optional (test #'eql) (start2 0) end2 (start1 0) end1  
		from-end key test-not)
  (cond ((and (vectorp for-seq-1) (vectorp in-seq-2))
	 (return-from search*
	   (if from-end 
	       (search*-vector-fromend for-seq-1 in-seq-2 test start2 end2 start1 end1 key test-not)
               (search*-vector for-seq-1 in-seq-2 test start2 end2 start1 end1 key test-not))))
        ((and (listp for-seq-1) (listp in-seq-2))
	 (search*-list for-seq-1 in-seq-2 test start2 end2 start1 end1 from-end key test-not))
	(t  (let* ((length1 (- (or end1 (length for-seq-1)) start1))
		   (real-end2 (max 0 (- (or end2 (length in-seq-2)) length1 -1)))
		   (test-fun (or test-not test #'eql))
		   (test-val (not (null test-not))))
		   
	      (do ((index (seq-start in-seq-2 start2))
		   (i start2 (1+ i))
		   last-index-if-from-end
		   (stop-index (seq-end in-seq-2 real-end2))
		   (start-key-1
		     (let ((e (seq-fetch for-seq-1 (seq-start for-seq-1 start1))))
		       (if key (funcall key e) e))))
		  ((eq index stop-index)
		   last-index-if-from-end)
		(and (eq test-val
			 (not (funcall test-fun
				       start-key-1
				       (if key
					   (funcall key (seq-fetch in-seq-2 index))
					   (seq-fetch in-seq-2 index)))))
		     (not (mismatch* for-seq-1 in-seq-2 test i (+ i length1) start1 end1
				     from-end key test-not))
		     (if from-end
			 (setq last-index-if-from-end i)
			 (return i)))
		(seq-inc index))))))

(defun search (for-sequence-1 in-sequence-2 &key from-end (test #'eql) test-not key
	       (start1 0) end1 (start2 0) end2)
  "Return index in IN-SEQUENCE-2 of first subsequence that matches FOR-SEQUENCE-1.
If no occurrence is found, the value is NIL.
MISMATCH is used to do the matching, with TEST, TEST-NOT and KEY passed along.
START1 and END1 are indices specifying a subsequence of FOR-SEQUENCE-1 to search for.
 The rest of FOR-SEQUENCE-1 might as well not be there.
START2 and END2 are indices specifying a subsequence of IN-SEQUENCE-2 to search through.
 However, the value returned is an index into the entire IN-SEQUENCE-2.
If FROM-END is non-NIL, the value is the index of the LAST subsequence that
 matches FOR-SEQUENCE-1 or the specified part of it.
In either case, the value returned is the index of the beginning of
 the subsequence (of IN-SEQUENCE-2) that matches."
  (search* for-sequence-1 in-sequence-2 test start2 end2 start1 end1  
	       from-end key test-not))