;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 124.108
;;; Reason:
;;;  Miscellaneous improvements - interface, logic, etc. - for ZMacs tag tables.
;;;  
;;;  1. List Tag Tables has spaces between table displays, and doesn't use
;;;  typeout window unless there's more than 'Done.'.
;;;  
;;;  2. In some places avoid bad logic if current tag table is not set, but
;;;  there's at least one in the table. This was being done variously; define
;;;  (ZMACS-CURRENT-TAG-TABLE) to straighten this out.  Use it a few places. 
;;;  
;;;  3. When reading system names from mini-buffer, make C-Sh-Y work (insert
;;;  default so user can edit it).  Similar for SELECT-TAG-TABLE.
;;;  
;;;  4. In SELECT-TAG-TABLE, prompt for confirmation if there are no tag
;;;  tables read in.  Apparently either most, or all, hosts don't actively
;;;  support the tag table file format; so make sure this is what user
;;;  wanted, and avoid time-consuming chunking leading to useless messages.
;;;  Also, when prompting for tag table, print default.
;;; Written 26-Jun-88 01:48:00 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 1
;;; with Experimental System 124.107, Experimental Local-File 74.3, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.1, Experimental Tape 23.6, Experimental Lambda-Diag 16.2, Tiger 28.0, microcode 1761, SDU Boot Tape 3.14, SDU ROM 103, Beta 3 for in-house.



; From modified file DJ: L.ZWEI; SECTIO.LISP#303 at 26-Jun-88 01:48:41
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; SECTIO  "


(DEFCOM COM-LIST-TAG-TABLES "List the names of all the tag table files read in" ()
  (let ((output *query-io*))
    (DOLIST (TAG-TABLE *ZMACS-TAG-TABLE-ALIST*)
      (setq output *standard-output*)
      (FORMAT output "~&~4TFiles in tag table ~A~@[ (current tag table)~]:~%"
	      (CAR TAG-TABLE)
	      (eq (cdr tag-table) *zmacs-current-tag-table*))
      (SEND output :ITEM-LIST 'FILE
	    (SEND (CDR TAG-TABLE) :GET 'ZMACS-TAG-TABLE-FILE-SYMBOLS))
      (format output "~%"))
    (FORMAT output "~&Done.~%"))
  DIS-NONE)

))

; From modified file DJ: L.ZWEI; SECTIO.LISP#303 at 26-Jun-88 01:48:44
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; SECTIO  "


(defun zmacs-current-tag-table ()
  (or *zmacs-current-tag-table*
      (cdar *zmacs-tag-table-alist*)))

))

; From modified file DJ: L.ZWEI; SECTIO.LISP#303 at 26-Jun-88 01:48:50
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; SECTIO  "


(defcom com-current-tag-table "Give the name of the current tag table" ()
  (if (setq *zmacs-current-tag-table* (zmacs-current-tag-table))
      (format *query-io* "~A" (send *zmacs-current-tag-table* :name))
    (format *query-io* "No current tag table"))
  dis-none)

))

; From modified file DJ: L.ZWEI; SECTIO.LISP#303 at 26-Jun-88 01:49:00
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; SECTIO  "


(DEFCOM COM-SELECT-SYSTEM-AS-TAG-TABLE "Make the files in a system behave like a tags file"
	()
  (LET ((SYSTEM-NAME (READ-SYSTEM-NAME "System to select as tag table:")))
    (SELECT-FILE-LIST-AS-TAG-TABLE
      (SI:SYSTEM-SOURCE-FILES SYSTEM-NAME SI:*SOURCE-FILE-TYPES* NIL T)  ;include subsystems.
      SYSTEM-NAME))
  DIS-NONE)

))

; From modified file DJ: L.ZWEI; SECTIO.LISP#303 at 26-Jun-88 01:49:03
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; SECTIO  "


(DEFUN READ-SYSTEM-NAME (PROMPT
			 &OPTIONAL (DEFAULT (SYSTEM-OF-PATHNAME
					      (BUFFER-GENERIC-PATHNAME *INTERVAL*) T)))
  "Read a system name in the mini buffer, defaulting to DEFAULT.
Prompts with PROMPT (which should end with a colon and not mention the default).
DEFAULT defaults to a guess based on the current buffer."
  (LET* ((default-name (if default (si:system-name default)))
	 (*mini-buffer-default-string* default-name)
	 (SYSTEM-NAME (COMPLETING-READ-FROM-MINI-BUFFER
			(IF DEFAULT
			    (FORMAT NIL "~A (Default ~A)" PROMPT default-name)
			  PROMPT)
			(SI:ALL-SYSTEMS-NAME-ALIST)
			T)))
    (COND ((CONSP SYSTEM-NAME)
	   (SETQ SYSTEM-NAME (CAR SYSTEM-NAME)))
	  ((STRING-EQUAL SYSTEM-NAME "")
	   (OR (SETQ SYSTEM-NAME (si:system-name DEFAULT)) (BARF)))
	  ((STRINGP SYSTEM-NAME)
	   (CONDITION-CASE (SYSTEM) (SI:FIND-SYSTEM-NAMED SYSTEM-NAME NIL NIL)
	     (ERROR (BARF "~A" SYSTEM))
	     (:NO-ERROR (SETQ SYSTEM-NAME (SI:SYSTEM-NAME SYSTEM))))))
    SYSTEM-NAME))

))

; From modified file DJ: L.ZWEI; SECTIO.LISP#303 at 26-Jun-88 01:49:05
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; SECTIO  "


(DEFUN SELECT-TAG-TABLE (&OPTIONAL (DEFAULT-P T))
  "Read a tag table name and return that tag table.
DEFAULT-P non-NIL (as it is if omitted) means if there is an
obvious default than just return it without asking the user at all."
  (COND ((NULL *ZMACS-TAG-TABLE-ALIST*)
	 (format *query-io* "~&No tag tables have been read in.")
	 (beep nil *query-io*)
	 (if (null (y-or-n-p "~&Do you want to read an external /"tag table file/"?"))
	     (barf)
	   (LET ((PATHNAME (READ-DEFAULTED-PATHNAME "Tag table pathname:"
						    (PATHNAME-DEFAULTS) "TAGS")))
	     (READ-TAG-TABLE PATHNAME)
	     PATHNAME)))
	((AND DEFAULT-P *ZMACS-CURRENT-TAG-TABLE*)
	 *ZMACS-CURRENT-TAG-TABLE*)
	((AND DEFAULT-P (NULL (CDR *ZMACS-TAG-TABLE-ALIST*)))
	 (CDAR *ZMACS-TAG-TABLE-ALIST*))
	(T
	 (setq *zmacs-current-tag-table* (zmacs-current-tag-table))
	 (LET ((TABLE (let ((*mini-buffer-default-string*
			      (and *zmacs-current-tag-table* (send *zmacs-current-tag-table* :name))))
			(COMPLETING-READ-FROM-MINI-BUFFER
			  (format nil "Tag table~@[ (default is ~a)~]:" *mini-buffer-default-string*)
			  *ZMACS-TAG-TABLE-ALIST*))))
	   (COND ((and (stringp table)
		       (EQUAL (string-trim *whitespace-chars* TABLE) ""))
		  (COND (*ZMACS-CURRENT-TAG-TABLE* *ZMACS-CURRENT-TAG-TABLE*)
			(T (BARF))))
		 ((CDR TABLE))
		 (t (barf)))))))


))