;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 124.54
;;; Reason:
;;;  ZWEI's Tags Search was incorrectly setting (point) -- you could end up with
;;;  (point) being a temporary BP, which causes much user agony.
;;; Written 13-Jun-88 18:19:27 by pld (Peter L. DeWolf) at site Gigamos Cambridge
;;; while running on Azathoth from band 1
;;; with Experimental System 124.49, Experimental Local-File 74.1, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.0, Experimental Tape 23.6, Experimental Lambda-Diag 16.1, microcode 1758, SDU Boot Tape 3.14, SDU ROM 8.



; From modified file DJ: L.ZWEI; SECTIO.LISP#298 at 13-Jun-88 18:19:38
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; SECTIO  "


(defun set-tag-table-pathname-and-bp (table pathname bp)
  (when table
    (send table :putprop pathname 'current-pathname)
    (let ((old-bp (send table :get 'current-point)))
      (cond ((and old-bp bp)
	     (move-bp old-bp bp))
	    ((and old-bp (null bp))
	     (flush-bp old-bp)
	     (send table :remprop 'current-point))
	    (bp
	     (send table :putprop (copy-bp bp :normal) 'current-point))))))


(DEFUN NEXT-FILE-BP (RESTART &AUX PATHNAME BUFFER)
  "Return BP to start of the next file in the selected tag table.
RESTART non-NIL means start again at first file in tag table."
  (AND RESTART
       (SETQ *ZMACS-LAST-TAGS-FILE-LIST* (SEND (SELECT-TAG-TABLE) :GET
					       'ZMACS-TAG-TABLE-FILE-SYMBOLS)))
  (unless *ZMACS-LAST-TAGS-FILE-LIST*
    (set-tag-table-pathname-and-bp *zmacs-current-tag-table* nil nil)
    (BARF "No more files"))
  (POP *ZMACS-LAST-TAGS-FILE-LIST* PATHNAME)
  (let ((bp (COND ((SETQ BUFFER (FIND-FILE-BUFFER PATHNAME))
		   (FORMAT *QUERY-IO* "~&~A~%" PATHNAME)
		   (INTERVAL-FIRST-BP BUFFER))
		  (T
		   (INTERVAL-FIRST-BP (FIND-FILE PATHNAME NIL))))))
    (set-tag-table-pathname-and-bp *zmacs-current-tag-table* (bp-top-level-node bp) bp)
    bp))

))

; From modified file DJ: L.ZWEI; SECTIO.LISP#298 at 13-Jun-88 18:19:42
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; SECTIO  "


(DEFUN TAGS-SEARCH-NEXT-OCCURRENCE (RESTART)
  (DO ((BP)
       (PT (IF RESTART (NEXT-FILE-BP T) (POINT))))
      (NIL)
    (LET ((*INTERVAL* (BP-TOP-LEVEL-NODE PT)))
      (SETQ BP (FUNCALL *ZMACS-TAGS-SEARCH-FUNCTION* PT *ZMACS-TAGS-SEARCH-KEY*)))
    (COND (BP
	   (POINT-PDL-PUSH (POINT) *WINDOW*)
	   (MAKE-BUFFER-CURRENT (BP-TOP-LEVEL-NODE BP))
	   (MOVE-BP (POINT) BP)
	   (set-tag-table-pathname-and-bp *zmacs-current-tag-table* (bp-top-level-node bp) bp)
	   (RETURN DIS-TEXT))
	  (T
	   (SETQ PT (NEXT-FILE-BP NIL))
	   (MUST-REDISPLAY *WINDOW* DIS-TEXT)))))

))

; From modified file DJ: L.ZWEI; SECTIO.LISP#298 at 13-Jun-88 18:19:57
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; SECTIO  "


(defun make-tag-table-current (name-or-tag-table)
  (let ((elt (typecase name-or-tag-table
	       (tag-table-dummy-file
		name-or-tag-table)
	       (string
		 (cdr (ass #'string-equal name-or-tag-table *zmacs-tag-table-alist*)))
	       (otherwise
		nil))))
    (when elt
      (when *zmacs-current-tag-table*
	;;Save current search values....
	(send *zmacs-current-tag-table* :putprop *zmacs-tags-search-key-string* 'search-key-string)
	(send *zmacs-current-tag-table* :putprop *zmacs-last-tags-file-list* 'tags-file-list)
	(if (boundp '*zmacs-tags-search-function*)
	    (send *zmacs-current-tag-table* :putprop *zmacs-tags-search-function* 'search-function)
	  (send *zmacs-current-tag-table* :remprop 'search-function))
	(if (boundp '*zmacs-tags-search-key*)
	    (send *zmacs-current-tag-table* :putprop *zmacs-tags-search-key* 'search-key)
	  (send *zmacs-current-tag-table* :remprop 'search-key)))
      (setq *zmacs-current-tag-table* elt)
      ;;Restore saved search values
      (setq *zmacs-tags-search-key-string* (send *zmacs-current-tag-table* :get 'search-key-string "FOO"))
      (setq *zmacs-last-tags-file-list* (send *zmacs-current-tag-table* :get 'tags-file-list))
      (let ((buffer (send *zmacs-current-tag-table* :get 'current-pathname)))
	(when buffer
	  (make-buffer-current buffer)
	  (move-bp (point) (send *zmacs-current-tag-table* :get 'current-point))))
      (let ((function (send *zmacs-current-tag-table* :get 'search-function)))
	(if function
	    (setq *zmacs-tags-search-function* function)
	  (makunbound '*zmacs-tags-search-function*)))
      (let ((key (send *zmacs-current-tag-table* :get 'search-key)))
	(if key
	    (setq *zmacs-tags-search-key* key)
	  (makunbound '*zmacs-tags-search-key*))))))

))