;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 123.268
;;; Reason:
;;;  Tag Table enhancements:
;;;    - Each Tag Table maintains its own set of Tags Search variables;
;;;      you can now switch back and forth with Select Tag Table and
;;;      resume a previous Tags Search
;;;    - Tag Tables are uniquely identified by their name
;;;    - Select Some Buffers and Select All Buffers prompt you for a
;;;      tag table name
;;;    - When specifying a list of buffers as a tag table, hitting End
;;;      does NOT include this buffer
;;; Written 10-May-88 11:01:23 by pld at site Gigamos Cambridge
;;; while running on Azathoth from band 3
;;; with Experimental System 123.264, Experimental Local-File 73.5, Experimental FILE-Server 22.4, Experimental Unix-Interface 11.0, Experimental KERMIT 34.3, Experimental ZMail 71.2, Experimental Lambda-Diag 15.0, Experimental Tape 22.4, microcode 1756, SDU Boot Tape 3.14, SDU ROM 8, the old ones.



; From modified file DJ: L.ZWEI; SECTIO.LISP#291 at 10-May-88 11:23: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)
	  (setf (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*))))))

))

; From modified file DJ: L.ZWEI; SECTIO.LISP#291 at 10-May-88 11:24:14
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; SECTIO  "


(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*
    (when *zmacs-current-tag-table*
      (send *zmacs-current-tag-table* :putprop nil 'current-pathname)
      (send *zmacs-current-tag-table* :putprop nil 'current-point))
    (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))))))
    (when *zmacs-current-tag-table*
      (send *zmacs-current-tag-table* :putprop (bp-top-level-node bp) 'current-pathname)
      (send *zmacs-current-tag-table* :putprop bp 'current-point))
    bp))

))

; From modified file DJ: L.ZWEI; SECTIO.LISP#291 at 10-May-88 11:24:18
#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)
	   (when *zmacs-current-tag-table*
	     (send *zmacs-current-tag-table* :putprop (bp-top-level-node bp) 'current-pathname)
	     (send *zmacs-current-tag-table* :putprop bp 'current-point))
	   (RETURN DIS-TEXT))
	  (T
	   (SETQ PT (NEXT-FILE-BP NIL))
	   (MUST-REDISPLAY *WINDOW* DIS-TEXT)))))

))

; From modified file DJ: L.ZWEI; SECTIO.LISP#291 at 10-May-88 11:24:58
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; SECTIO  "

(DEFCOM COM-SELECT-TAG-TABLE "Make a tag table current for commands like tags search" ()
  (make-tag-table-current (select-tag-table nil))
  DIS-NONE)

))

; From modified file DJ: L.ZWEI; SECTIO.LISP#291 at 10-May-88 11:25:07
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; SECTIO  "

(DEFUN SELECT-FILE-LIST-AS-TAG-TABLE (FILE-LIST NAME)
  "Select a tag table named NAME consisting of the files in FILE-LIST.
This can be used to control commands such as Tags Search."
  (let ((elt (cdr (ass #'string-equal name *zmacs-tag-table-alist*))))
    (unless elt
      (setq elt (MAKE-INSTANCE 'TAG-TABLE-DUMMY-FILE :NAME NAME) )
      (PUSH (CONS NAME elt) *ZMACS-TAG-TABLE-ALIST*))
    (SEND elt :PUTPROP (MAPCAR (LAMBDA (X) (FS:MERGE-PATHNAMES X *PATHNAME-DEFAULTS*)) FILE-LIST)
		       'ZMACS-TAG-TABLE-FILE-SYMBOLS)
    (make-tag-table-current elt)))

))

; From modified file DJ: L.ZWEI; SECTIO.LISP#291 at 10-May-88 11:25:44
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; SECTIO  "

(DEFCOM COM-SELECT-ALL-BUFFERS-AS-TAG-TABLE
  "Select all files currently read in as a tag table.
Numeric arg means read a string and consider only buffers whose names contain it.
This causes commands such as Tags Search, Tags Query Replace, and
Tags Compile Changed Sections to look through all files now visited." ()
  (SELECT-FILE-LIST-AS-TAG-TABLE
    (mapcar #'buffer-pathname
	    (specify-list-of-buffers
	      :only-non-special-buffers t
	      :only-file-buffers t
	      :substring (if *numeric-arg-p*
			     (typein-line-readline "Substring to check for buffers containing: "))))
     (TYPEIN-LINE-READLINE-WITH-DEFAULT "All buffers visiting files" "Name for this tag table"))
  DIS-NONE)

))

; From modified file DJ: L.ZWEI; SECTIO.LISP#291 at 10-May-88 11:25:49
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; SECTIO  "

(DEFCOM COM-SELECT-SOME-BUFFERS-AS-TAG-TABLE
  "Select some of the files currently read in as a tag table.
For each file-visiting buffer, you are asked to say whether to include it.
Numeric arg means read a string and consider only buffers whose names contain it.
This causes commands such as Tags Search, Tags Query Replace, and
Tags Compile Changed Sections to look through all files you specify." ()
  (SELECT-FILE-LIST-AS-TAG-TABLE
     (mapcar #'buffer-pathname
	    (specify-list-of-buffers
	      :only-non-special-buffers t
	      :only-file-buffers t
	      :substring (if *numeric-arg-p*
			     (typein-line-readline "Substring to check for buffers containing: "))
	      :query-string "Include file ~*~A in the tag table? "))
     (TYPEIN-LINE-READLINE-WITH-DEFAULT "Some buffers visiting files" "Name for this tag table"))
  DIS-NONE)

))

; From modified file DJ: L.ZWEI; ZMACS.LISP#564 at 10-May-88 11:45:19
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; ZMACS  "

(defun specify-list-of-buffers (&key (buffer-list *zmacs-buffer-list*)
			             (predicate #'identity)
				     only-file-buffers
				     only-non-special-buffers
				     substring
				     query-string)
  "Return a subset of BUFFER-LIST subject to certain conditions.
Each of the conditions is checked in the order listed below:
- ONLY-NON-SPECIAL-BUFFERS means not to consider buffers with a null NODE-SPECIAL-TYPE.
- ONLY-FILE-BUFFERS means to consider only buffers visiting files.
- SUBSTRING, if non-NIL, means to consider only buffers whose names contain that string.
- PREDICATE means consider only buffers satisfying that function.
- If QUERY-STRING is non-NIL, it is a format string used to ask the user whether
 to include a buffer satisfying all the above conditions.
 The /"arguments/" to this format string are the buffer's name
 and the file it is visiting (if it is a file buffer -- NIL otherwise)."
  (loop for buffer in buffer-list
	with *query-io* = (if query-string *terminal-io* *query-io*)
	with stop = nil
     when (and (not stop)
	       (typep buffer 'zmacs-buffer)
	       (or (not only-non-special-buffers)
		   (not (node-special-type buffer)))
	       (or (not only-file-buffers)
		   (buffer-file-id buffer))
	       (or (not substring)
		   (string-search substring (buffer-name buffer)))
	       (funcall predicate buffer)
	       (or (not query-string)
		   (case (fquery `(:choices (,@format:y-or-n-p-choices
					     ((stop "Finished, no more files") #/ #/F)))
				 query-string
				 (buffer-name buffer)
				 (and (typep buffer 'file-buffer) (buffer-pathname buffer)))
		     ((nil) nil)
		     ((t) t)
		     (stop
		      ;; Say no to this file, and say don't ask for any others.
		      (setq stop t)
		      nil))))
       collect buffer))

))