;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 123.177
;;; Reason:
;;;  Improvements to the Rubout Handler:
;;;    Control-Meta-F, Control-Meta-B, Control-Meta-K, and Control-Meta-Rubout
;;;     all know more about Lisp forms: symbols, strings, ' and #'
;;;     and attempt to move over or delete such objects.
;;;    Control-Meta-T now exists to transpose the order of the two such
;;;     objects that surround point.
;;; Written 6-Jan-88 17:32:51 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.175, 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#183 at 6-Jan-88 18:58:48
#8R TV#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TV")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: WINDOW; RH  "

;;;S-expression commands

;;; Try to move over complete LISP forms.  First value is the new position.  Second
;;; return value says if we succeeded or not.

(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 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 (1+ new-pos) t)))))

(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 new-pos t)))))

(define-rh-command rh-com-forward-sexp (#/Control-meta-f) (ignore)
  (rh-set-position (rh-search-forward-sexp (rh-typein-pointer))))

(define-rh-command rh-com-backward-sexp (#/Control-meta-b) (ignore)
  (rh-set-position (rh-search-backward-sexp (rh-typein-pointer))))

(define-rh-command rh-com-delete-sexp (#/Control-meta-k) (ignore)
  (rh-delete-string (rh-typein-pointer) (rh-search-forward-sexp (rh-typein-pointer))))

(define-rh-command rh-com-rubout-sexp (#/Control-meta-rubout) (ignore)
  (rh-delete-string (rh-search-backward-sexp (rh-typein-pointer)) (rh-typein-pointer)))

(define-rh-command rh-com-exchange-sexp (#/control-meta-t) (ignore)
  (let* ((thissexpbeg (rh-search-backward-sexp (rh-typein-pointer) nil))
	 (thissexpend (rh-search-forward-sexp thissexpbeg))
	 (othersexpend (rh-search-forward-sexp (rh-typein-pointer)))
	 (othersexpbeg (rh-search-backward-sexp othersexpend nil))
	 (thissexp (make-string (- thissexpend thissexpbeg)))
	 (othersexp (make-string (- othersexpend othersexpbeg))))
    (replace thissexp rubout-handler-buffer :start2 thissexpbeg :end2 thissexpend)
    (replace othersexp rubout-handler-buffer :start2 othersexpbeg :end2 othersexpend)
    (rh-delete-string othersexpbeg othersexpend nil)
    (setf (rh-typein-pointer) othersexpbeg)
    (rh-insert-string thissexp 0 nil t nil)
    (rh-delete-string thissexpbeg thissexpend nil)
    (setf (rh-typein-pointer) thissexpbeg)
    (rh-insert-string othersexp 0 nil t nil)
    (rh-set-position othersexpend)))

))