;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 123.185
;;; Reason:
;;;  Problem with rubout handler C-M-t -- Exchange Sexps: can try to
;;;  reference beyond active length of rubout handler buffer.
;;; Written 19-Jan-88 14:59:47 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.184, Experimental Local-File 73.3, Experimental FILE-Server 22.1, Experimental Unix-Interface 11.0, Experimental Tape 18.0, Experimental KERMIT 34.3, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, microcode 1754, SDU Boot Tape 3.12, SDU ROM 8.



; From modified file DJ: L.WINDOW; RH.LISP#189 at 19-Jan-88 15:03:19
#8R TV#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TV")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: WINDOW; RH  "


(defun-rh rh-search-forward-sexp (pos)
  (declare (values new-pos success))
  (let* ((buffer rubout-handler-buffer)
	 (end (length buffer))
	 (new-pos (1- pos))
	 (c))
    (if (>= pos (1- end))
	(values pos nil)
      (labels ((new-c ()
		 (unless (= new-pos end)
		   (incf new-pos)
		   (setq c (elt buffer new-pos))))
	       (skip-atom ()
		 (loop
		   (when (= new-pos end)
		     (return))
		   (cond ((memq c '(#// #/\))
			  (new-c)
			  (new-c))
			 ((eq c #/|)
			  (skip-string #/|)
			  (new-c))
			 ((memq (zwei:char-syntax c zwei:*list-syntax-table*) `(,zwei:list-alphabetic ,zwei:list-colon))
			  (new-c))
			 (t
			  (decf new-pos)
			  (return)))))
	       (skip-string (delim)
		 (loop
		   (when (= new-pos end)
		     (return))
		   (new-c)
		   (when (eq c delim)
		     (return))))
	       (skip-list ()
		 (loop
		   (when (= new-pos end)
		     (return))
		   (new-c)
		   (when (= c #/()
		     (skip-list)
		     (new-c))
		   (when (= c #/))
		     (return))))
	       )
	(loop					;Skip initial whitespace
	  (when (= new-pos end)
	    (return-from rh-search-forward-sexp (values pos nil)))
	  (new-c)
	  (unless (or (member c '(#/space #/tab #/return))
		      (eq (zwei:char-syntax c zwei:*list-syntax-table*) zwei:list-single-quote))
	    (return)))
	(cond ((eq c #/")
	       (skip-string #/"))
	      ((eq c #/()
	       (skip-list))
	      ((eq c #/)))
	      (t
	       (skip-atom)))
	(values (min (1+ new-pos) end) t)))))

))

; From modified file DJ: L.WINDOW; RH.LISP#189 at 19-Jan-88 15:03:20
#8R TV#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TV")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: WINDOW; RH  "


(defun-rh rh-search-backward-sexp (pos &optional (skip-leading-whitespace t))
  (declare (values new-pos success))
  (if (zerop pos)
      (values pos nil)
    (let* ((buffer rubout-handler-buffer)
	   (new-pos pos)
	   (c))
      (labels ((new-c ()
		 (unless (zerop new-pos)
		   (decf new-pos))
		      (setq c (elt buffer new-pos)))
	       (skip-atom ()
		 (loop
		   (cond ((eq c #/|)
			  (skip-string #/|)
			  (if (zerop new-pos)
			      (return)
			    (new-c)))
			 ((memq (zwei:char-syntax c zwei:*list-syntax-table*)
				`(,zwei:list-alphabetic ,zwei:list-colon ,zwei:list-slash))
			  (if (zerop new-pos)
			      (return)
			    (new-c)))
			 (t
			  (unless (zerop new-pos)
			    (new-c)
			    (unless (memq c '(#// #/\))
			      (incf new-pos)))
			  (incf new-pos)
			  (return)))))
	       (skip-string (delim)
		 (loop
		   (when (zerop new-pos)
		     (return))
		   (new-c)
		   (when (eq c delim)
		     (return))))
	       (skip-list ()
		 (loop
		   (when (zerop new-pos)
		     (return))
		   (new-c)
		   (when (= c #/))
		     (skip-list)
		     (new-c))
		   (when (= c #/()
		     (return))))
	       )
	(loop					;Skip trailing whitespace
	  (when (zerop new-pos)
	    (return))
	  (new-c)
	  (unless (member c '(#/space #/tab #/return))
	    (return)))
	(cond ((eq c #/")
	       (skip-string #/"))
	      ((eq c #/))
	       (skip-list))
	      ((eq c #/())
	      (t
	       (skip-atom)))
	(loop
	  (when (zerop new-pos)
	    (return))
	  (new-c)
	  (when (or (member c '(#/space #/tab #/return))
		    (neq (zwei:char-syntax c zwei:*list-syntax-table*) zwei:list-single-quote))
	    (incf new-pos)
	    (return)))
	(when skip-leading-whitespace
	  (loop					;Skip leading whitespace
	    (when (zerop new-pos)
	      (return))
	    (new-c)
	    (unless (member c '(#/space #/tab #/return))
	      (incf new-pos)
	      (return))))
	(values (max new-pos 0) t)))))

))