;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 122.5
;;; Reason:
;;;  Conditionalize for arrays with fill-pointers in SUBSTITUTE, DELETE, etc.
;;; Written 13-May-87 16:36:46 by robert (Robert Putnam) at site LMI Cambridge
;;; while running on Fish food from band 3
;;; with Experimental System 122.3, Experimental Local-File 73.0, Experimental FILE-Server 22.0, Experimental Unix-Interface 11.0, Experimental Tape 17.0, Experimental Tiger 26.0, Experimental KERMIT 33.0, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, microcode 1742, SDU Boot Tape 3.14, SDU ROM 102.



; From modified file DJ: L.SYS; GENRIC.LISP#54 at 13-May-87 16:36:55
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; GENRIC  "


(defun remove-from-array (item vector start end count test invertp key from-end one-arg-predicate)
  (or end (setq end (length vector)))
  (or count (setq count (length vector)))
  (let ((temp (get-temp-vector (min count (- end start))))
	elt)
    (setf (fill-pointer temp) 0)
    ;; Find the indices of all the things we want to remove.
    (if from-end
	(do ((i (1- end) (1- i)))
	    ((or (< i start)
		 ( (fill-pointer temp) count))
	     (nreverse temp))
	  (setq elt (if key (funcall key (cl:aref vector i)) (cl:aref vector i)))
	  (if (eq invertp (not (cond (one-arg-predicate
				      (funcall one-arg-predicate elt))
				     (test
				      (funcall test item elt))
				     (t
				      (eql item elt)))))
	    (vector-push i temp)))
      (do ((i start (1+ i)))
	  ((or ( i end) ( (fill-pointer temp) count)))
	(setq elt (if key (funcall key (cl:aref vector i)) (cl:aref vector i)))
	(if (eq invertp (not (cond (one-arg-predicate
				    (funcall one-arg-predicate elt))
				   (test
				    (funcall test item elt))
				   (t
				    (eql item elt)))))
	    (vector-push i temp))))
    ;; Now TEMP contains the indices of the elements to be removed, in ascending order.
    (cond ((zerop (fill-pointer temp))
	   (setq *temp-vector* temp)
	   vector)
	  (t
	   (let ((result (if (array-has-fill-pointer-p vector)
			     (make-array (array-dimension vector 0) :type (array-type vector)
					 :fill-pointer (- (fill-pointer vector) (fill-pointer temp)))
			   (make-array (- (length vector) (fill-pointer temp))
				       :type (array-type vector)))))
	     (copy-array-portion vector 0 (cl:aref temp 0) result 0 (cl:aref temp 0))
	     (do ((i 1 (1+ i))
		  (stop (fill-pointer temp)))
		 (( i stop)
		  (let ((x (1+ (cl:aref temp (1- i)))))
		    (copy-array-portion vector  x (length vector)
					result (- x i) (length result))))
	       (let ((x (1+ (cl:aref temp (1- i))))
		     (y (cl:aref temp i)))
		 (copy-array-portion vector x y result (- x i) (- y i))))
	     (setf (fill-pointer temp) 0)
	     (setq *temp-vector* temp)
	     result)))))

))

; From modified file DJ: L.SYS; GENRIC.LISP#54 at 13-May-87 16:37:10
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; GENRIC  "


(defun remove-duplicates-from-array (sequence start end test invertp key from-end)
  (or end (setq end (length sequence)))
  (let ((temp (get-temp-vector (- end start))))
    (setf (fill-pointer temp) 0)
    ;; Find the indices of all the things we want to remove.
    (if from-end
	(do ((i (1- end) (1- i)))
	    ((< i start)
	     (nreverse temp))
	  (when (nth-value 1 (find-1 (if key (funcall key (cl:aref sequence i))
				       (cl:aref sequence i))
				     sequence start i test invertp key))
	    (vector-push i temp)))
        (do ((i start (1+ i)))
	    (( i end))
	  (when (nth-value 1 (find-1 (if key (funcall key (cl:aref sequence i))
				       (cl:aref sequence i))
				     sequence (1+ i) end test invertp key))
	    (vector-push i temp))))
    ;; Now TEMP contains the indices of the elements to be removed, in ascending order.
    (cond ((zerop (fill-pointer temp))
	   (setq *temp-vector* temp)
	   sequence)
	  (t
	   (let ((result (if (array-has-fill-pointer-p sequence)
			     (make-array (array-dimension sequence 0) :type (array-type sequence)
					 :fill-pointer (- (fill-pointer sequence) (fill-pointer temp)))
			   (make-array (- (length sequence) (fill-pointer temp))
				       :type (array-type sequence)))))
	     (copy-array-portion sequence 0 (cl:aref temp 0) result 0 (cl:aref temp 0))
	     (do ((i 1 (1+ i))
		  (stop (fill-pointer temp)))
		 (( i stop)
		  (let ((x (1+ (cl:aref temp (1- i)))))
		    (copy-array-portion sequence  x (length sequence)
					result (- x i) (length result))))
	       (let ((x (1+ (cl:aref temp (1- i))))
		     (y (cl:aref temp i)))
		 (copy-array-portion sequence x y
				     result (- x i) (- y i))))
	     (setf (fill-pointer temp) 0)
	     (setq *temp-vector* temp)
	     result)))))

))

; From modified file DJ: L.SYS; GENRIC.LISP#54 at 13-May-87 16:37:22
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; GENRIC  "


(defun substitute-in-array (copyflag newitem olditem sequence
			    start end count test invertp key from-end one-arg-predicate
			    &aux result)
  (or count (setq count (length sequence)))
  (or end (setq end (length sequence)))
  (or copyflag (setq result sequence))
  (do ((i (if from-end (1- end) start)
	  (+ i inc))
       (inc (if from-end -1 1))
       (num-replaced 0)
       elt)
      ((or (if from-end (< i start) ( i end))
	   ( num-replaced count)))
    (setq elt (if key (funcall key (cl:aref sequence i)) (cl:aref sequence i)))
    (when (eq invertp (not (cond (one-arg-predicate
				  (funcall one-arg-predicate elt))
				 (test
				  (funcall test olditem elt))
				 (t
				  (eql olditem elt)))))
      (unless result
	(setq result (if (array-has-fill-pointer-p sequence)
			 (make-array (array-dimension sequence 0) :type (array-type sequence)
				 :fill-pointer (fill-pointer sequence))
		       (make-array (array-dimension sequence 0) :type (array-type sequence))))
	(copy-array-contents sequence result))
      (setf (cl:aref result i) newitem)
      (incf num-replaced)))
  (or result sequence))

))