;;; -*- Mode:LISP; Package:ZWEI; Readtable:ZL; Base:8 -*-

(defcom COM-INDENT-SEXP-AND-MOVE "Indent the following SEXP for LISP,
and move to   the point after the closing paren (hopefully on next line
so that repeated invocations will have an effect on subsequent sexps." ()   
  (com-indent-for-lisp)
  (com-indent-sexp)
  (com-forward-sexp)
  (com-forward)
  dis-text)

;;; Modified version of two-windows stuff, takes two windows
;;; (structures, not sheets) and makes them share the area
;;; originally occupied by the first of the two, except that
;;; this version makes two side-by-side vertical windows
;;; rather than one on top of the other.

(DEFUN TWO-WINDOWS (ZWEI-WINDOW-1 ZWEI-WINDOW-2)
  (REDISPLAY ZWEI-WINDOW-1 ':NONE)
  (LET ((W1 (WINDOW-SHEET ZWEI-WINDOW-1))
	(W2 (WINDOW-SHEET ZWEI-WINDOW-2))
	(FRAME (WINDOW-FRAME ZWEI-WINDOW-1)))
    (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM)
	(SEND FRAME ':INSIDE-EDGES-WITHOUT-MODE-LINE-WINDOW)
      (TV:PRESERVE-SUBSTITUTE-STATUS (SEND W1 ':SUPERIOR)
	(TV:DELAYING-SCREEN-MANAGEMENT
	  (SEND W1 ':DEEXPOSE)
	  (SEND W2 ':DEEXPOSE)
	  (LET ((width (TRUNCATE (- right left) 2)))
	    (SEND W1 ':SET-EDGES LEFT TOP (+ width left) bottom)
	    (SEND W2 ':SET-EDGES (+ width left) TOP RIGHT BOTTOM)
	    (SEND W1 ':SET-LABEL NIL)
	    (SEND W2 ':SET-LABEL NIL)
	    (SEND W1 ':EXPOSE NIL ':CLEAN)	;Make sure they are both there
	    (SEND W2 ':EXPOSE NIL ':CLEAN)))))
    (SEND FRAME ':UPDATE-LABELS)))

;;;Handy zmacs extensions and fixes to existing features

(DEFCOM COM-KILL-OR-SAVE-BUFFERS "Put up a choice window various buffer operations." ()
  (LET ((BUFFER-ALIST
	  (DO ((BUFFER-LIST *ZMACS-BUFFER-LIST* (CDR BUFFER-LIST))
	       (RET NIL) (TEM)
	       (BUFFER) (FILE-ID))
	      ((NULL BUFFER-LIST) RET)
	    (SETQ BUFFER (CAR BUFFER-LIST))
	    (SETQ TEM (STRING-APPEND "  " (BUFFER-NAME BUFFER))
		  FILE-ID (BUFFER-FILE-ID BUFFER))
	    (SETF (CHAR TEM 0)
		  (COND ((EQ FILE-ID T)
			 #/+)
			((BUFFER-READ-ONLY-P BUFFER)
			 #/)
			((BUFFER-MODIFIED-P BUFFER)
			 #/*)
			(T
			 #/SP)))
	    (LET ((BASIC-CHOICES (IF (BUFFER-NEEDS-SAVING-P BUFFER)
				     '((:SAVE T) :KILL :NOT-MODIFIED)
				   '(:SAVE :KILL :NOT-MODIFIED))))
	      (PUSH (LIST BUFFER TEM
			  (IF (AND (BUFFER-PATHNAME BUFFER)
				   (call-editing-type-function *major-mode* 'lisp-syntax-p nil)
				   ;(EQ (GET (SEND BUFFER ':MAJOR-MODE) 'EDITING-TYPE) ':LISP)
				   )
			      (APPEND BASIC-CHOICES '(:COMPILE))
			    BASIC-CHOICES))
		    RET))))
	CHOICES EXIT-REASON)
    (SETQ BUFFER-ALIST
	  (SORT BUFFER-ALIST (LAMBDA (X Y &AUX STR1 STR2 CH1 CH2)
			       (IF (CHAR= (SETQ CH1 (CHAR (SETQ STR1 (CADR X)) 0))
					  (SETQ CH2 (CHAR (SETQ STR2 (CADR Y)) 0)))
				   (STRING-LESSP STR1 STR2)
				 (< (CASE CH1
				      (#/* 0)
				      (#/+ 1)
				      (#/SP 2)
				      (#/ 3))
				    (CASE CH2
				      (#/* 0)
				      (#/+ 1)
				      (#/SP 2)
				      (#/ 3)))))))
    (if ;;(= *numeric-arg* 16.)			;Was CONTROL-U CONTROL-U typed?
	(= *numeric-arg* 4.)			;use this line if you'd prefer simply CONTROL-U
	(mapcar #'(lambda (entry)		;If so, brings up the menu with all
		    (setf (third entry)		;buffers marked to be killed.
			  (substitute '(:kill t) ':kill (third entry))))
		buffer-alist))
    (SETF (VALUES CHOICES EXIT-REASON)
	  (TV:MULTIPLE-CHOOSE "  Buffer" BUFFER-ALIST
			      '((:SAVE "Save" NIL (:NOT-MODIFIED) NIL NIL)
				(:KILL "Kill" NIL (:NOT-MODIFIED) NIL NIL)
				(:NOT-MODIFIED "UnMod"
					       NIL (:SAVE :KILL) NIL NIL)
				(:COMPILE "Compile" NIL NIL NIL NIL))
			      `(:point ,(floor (// (tv:sheet-width *window*) 2))
				       ,(floor (// (tv:sheet-height *window*) 2)))
			      (min (length buffer-alist)
				   (floor (// (tv:sheet-height *window*)        	;gotta be a better way to say "number
					      (tv:sheet-line-height *window*))))))	;of lines displayable on *window*"
    (IF EXIT-REASON
	NIL
      ;; Make sure the current buffer gets done last
      (LET ((ELEM (ASSQ *INTERVAL* CHOICES)))
	(AND ELEM (SETQ CHOICES (NCONC (DELQ ELEM CHOICES) (NCONS ELEM)))))
      (DOLIST (CHOICE CHOICES)
	(LET ((BUFFER (CAR CHOICE)))
	  (IF (MEMQ ':SAVE (CDR CHOICE))
	      (SAVE-BUFFER BUFFER))
	  (IF (MEMQ ':COMPILE (CDR CHOICE))
	      (COMPILE-FILE (BUFFER-PATHNAME BUFFER)
			    :SET-DEFAULT-PATHNAME NIL
			    :PACKAGE (BUFFER-PACKAGE BUFFER)))
	  (IF (MEMQ ':NOT-MODIFIED (CDR CHOICE))
	      (SETF (BUFFER-TICK BUFFER) (TICK)))
	  (IF (MEMQ ':KILL (CDR CHOICE))
	      (KILL-BUFFER BUFFER T))))
      (FORMAT *QUERY-IO* "~&Done.")))
  DIS-NONE)


;;;Moved to LISPM.INIT
;;;(defmacro with-fdefine-warnings-inhibited ((&body body))
;;;  `(let ((inhibit-fdefine-warnings t))
;;;     ,body))

(load "dj:smh;isearch.qfasl")

(defmacro install-command-and-advertise (command char comtab announcement)
  ;; Install and notify.
  `(progn
     (zwei:command-store ,command ,char ,comtab)
     (format query-io ,announcement)))

(DEFUN DEFAULT-LIST-ONE-FILE (FILE &OPTIONAL (STREAM *STANDARD-OUTPUT*) &AUX PATHNAME)
  (COND ((NULL (SETQ PATHNAME (CAR FILE)))
	 (COND ((GET FILE :DISK-SPACE-DESCRIPTION)
		(SEND STREAM :LINE-OUT (GET FILE :DISK-SPACE-DESCRIPTION)))
	       ((GET FILE :PHYSICAL-VOLUME-FREE-BLOCKS)
		(DO ((FREE (GET FILE :PHYSICAL-VOLUME-FREE-BLOCKS) (CDR FREE))
		     (FLAG T NIL))
		    ((NULL FREE) (SEND STREAM :TYO #\NEWLINE))
		 (FORMAT STREAM "~A #~A=~D" (IF FLAG "Free:" ",") (CAAR FREE) (CDAR FREE))))
	       (T
		(SEND STREAM :TYO #\NEWLINE))))
	((TYPEP STREAM 'INTERVAL-STREAM)
	 (LET ((STRING (CREATE-LINE 'ART-STRING 128. NIL)))
	   (DEFAULT-LIST-ONE-FILE FILE STRING)
	   (SEND STREAM :LINE-OUT STRING)))
	((OR (NULL STREAM) (STRINGP STREAM))
	 (LET ((STRING
		 (OR STREAM (MAKE-ARRAY 128. :TYPE 'ART-STRING :LEADER-LENGTH 1))))
	   (SETF (FILL-POINTER STRING) 0)
	   (ARRAY-INITIALIZE STRING #\SP 0 (ARRAY-LENGTH STRING))
	   (VECTOR-PUSH (IF (GET FILE :DELETED) #\D #\SP) STRING)
	   (VECTOR-PUSH #\SP STRING)
	   (STRING-NCONC STRING (OR (GET FILE :PHYSICAL-VOLUME) ""))
	   (SETF (FILL-POINTER STRING) (1+ (MAX 5 (FILL-POINTER STRING))))
	   (STRING-NCONC STRING (SEND PATHNAME :STRING-FOR-DIRED))
	   (VECTOR-PUSH #\SP STRING)
	   (LET ((LINK-TO (GET FILE :LINK-TO)))
	     (IF LINK-TO
		 (PROGN (STRING-NCONC STRING "=> " LINK-TO " ")
			(SETF (FILL-POINTER STRING)
			      (MAX 56. (FILL-POINTER STRING))))
	       (progn
	       (LET ((LENGTH (GET FILE :LENGTH-IN-BLOCKS)))
		 (SETF (FILL-POINTER STRING)
		       (MAX 39. (FILL-POINTER STRING)))
		 (COND ((NULL LENGTH)
			(STRING-NCONC STRING "     "))
		       ((> LENGTH 999.)
			(SETF (FILL-POINTER STRING)
			      (NUMBER-INTO-ARRAY STRING LENGTH 10.
						 (FILL-POINTER STRING) 4))
			(VECTOR-PUSH #\SP STRING))
		       (T
			(SETF (FILL-POINTER STRING)
			      (MAX 40. (FILL-POINTER STRING)))
			(SETF (FILL-POINTER STRING)
			      (NUMBER-INTO-ARRAY STRING LENGTH 10.
						 (FILL-POINTER STRING) 3))
			(VECTOR-PUSH #\SP STRING))))
	       (LET ((LENGTH (GET FILE :LENGTH-IN-BYTES)))
		 (IF (GET FILE :DIRECTORY)
		     (STRING-NCONC STRING "DIRECTORY")
		   (WHEN LENGTH
		     (SETF (FILL-POINTER STRING)
			   (NUMBER-INTO-ARRAY STRING LENGTH 10.
					      (FILL-POINTER STRING) 6))
		     (VECTOR-PUSH #\( STRING)
		     (SETF (FILL-POINTER STRING)
			   (NUMBER-INTO-ARRAY STRING (GET FILE :BYTE-SIZE) 10.
					      (FILL-POINTER STRING)))
		     (VECTOR-PUSH #\) STRING))))
	       (SETF (FILL-POINTER STRING)
		     (MAX 55. (FILL-POINTER STRING)))
	       (VECTOR-PUSH (COND ((GET FILE :OFFLINE) #\O)
				  ((GET FILE :NOT-BACKED-UP) #\!)
				  (T #\SP))
			    STRING))))
	   (VECTOR-PUSH (IF (GET FILE :DONT-DELETE) #\@ #\SP) STRING)
	   (VECTOR-PUSH (IF (GET FILE :DONT-SUPERSEDE) #\# #\SP) STRING)
	   (VECTOR-PUSH (IF (GET FILE :DONT-REAP) #\$ #\SP) STRING)
	   (TIME-INTO-ARRAY STRING (GET FILE :CREATION-DATE))
	   (LET* ((DATE-LAST-EXPUNGE (GET FILE :DATE-LAST-EXPUNGE))
		  (REFERENCE-DATE (OR DATE-LAST-EXPUNGE (GET FILE :REFERENCE-DATE))))
	     (WHEN (NOT (MEMQ REFERENCE-DATE '(NIL :NIL)))  ;AVOID LOSSAGE CAUSED BY
			;UNMENTIONABLE THINGS HAPPENING DURING RESTORE-MAGTAPE
	       (STRING-NCONC STRING (IF DATE-LAST-EXPUNGE " X=" " ("))
	       (TIME-INTO-ARRAY STRING REFERENCE-DATE NIL)
	       (OR DATE-LAST-EXPUNGE (STRING-NCONC STRING ")"))))
	   (LET ((AUTHOR (GET FILE :AUTHOR)))
	     (WHEN (AND AUTHOR (NOT (EQUAL AUTHOR (SEND PATHNAME :DIRECTORY))))
	       (SETF (FILL-POINTER STRING)
		     (MAX 88. (FILL-POINTER STRING)))
	       (STRING-NCONC STRING AUTHOR)))
	   (LET ((READER (GET FILE :READER)))
	     (WHEN (AND READER (NOT (EQUAL READER (SEND PATHNAME :DIRECTORY))))
	       (SETF (FILL-POINTER STRING)
		     (MAX 98. (FILL-POINTER STRING)))
	       (STRING-NCONC STRING READER)))
	   STRING))
	(T (FORMAT STREAM "~C ~3A "
		   (IF (GET FILE :DELETED) #\D #\SP)
		   (OR (GET FILE :PHYSICAL-VOLUME) ""))
	   (IF (OPERATION-HANDLED-P STREAM :ITEM)
	       (SEND STREAM :ITEM 'FILE PATHNAME "~A" (SEND PATHNAME :STRING-FOR-DIRED))
	     (SEND STREAM :STRING-OUT (SEND PATHNAME :STRING-FOR-DIRED)))
	   (FORMAT STREAM "~20T")
	   (LET ((LINK-TO (GET FILE :LINK-TO)))
	     (IF LINK-TO
		 (FORMAT STREAM "=> ~A ~40T" LINK-TO)
	       (progn
	       (LET ((LENGTH (GET FILE :LENGTH-IN-BLOCKS)))
		 (LET ((*STANDARD-OUTPUT* STREAM))
		   (FORMAT:TAB 39.))
		 (COND ((NULL LENGTH)
			(LET ((*STANDARD-OUTPUT* STREAM))
			  (FORMAT:TAB 44.)))
		       ((> LENGTH 999.)
			(FORMAT STREAM "~4D " LENGTH))
		       (T
			(LET ((*STANDARD-OUTPUT* STREAM))
			  (FORMAT:TAB 40.))
			(FORMAT STREAM "~3D " LENGTH))))
	       (LET ((LENGTH (GET FILE :LENGTH-IN-BYTES)))
		 (IF (GET FILE :DIRECTORY)
		     (PRINC "  DIRECTORY" STREAM)
		   (AND LENGTH
			(FORMAT STREAM "~6D(~D)" LENGTH (GET FILE :BYTE-SIZE)))))
	       (FORMAT STREAM "~55T")
	       (SEND STREAM :TYO
		     (COND ((GET FILE :OFFLINE) #\O)
			   ((GET FILE :NOT-BACKED-UP) #\!)
			   (T #\SP)))))
	   (SEND STREAM :TYO (IF (GET FILE :DONT-DELETE) #\@ #\SP))
	   (SEND STREAM :TYO (IF (GET FILE :DONT-SUPERSEDE) #\# #\SP))
	   (SEND STREAM :TYO (IF (GET FILE :DONT-REAP) #\$ #\SP))
	   (LET ((CREATION-DATE (GET FILE :CREATION-DATE)))
	     (IF CREATION-DATE
		 (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOURS DAY MONTH YEAR)
		     (TIME:DECODE-UNIVERSAL-TIME CREATION-DATE)
		   (FORMAT STREAM "~2,'0D//~2,'0D//~2,'0D ~2,'0D:~2,'0D:~2,'0D"
			   MONTH DAY (MOD YEAR 100.) HOURS MINUTES SECONDS))
		 (FORMAT STREAM "~17@T")))
	   (LET* ((DATE-LAST-EXPUNGE (GET FILE :DATE-LAST-EXPUNGE))
		  (REFERENCE-DATE (OR DATE-LAST-EXPUNGE (GET FILE :REFERENCE-DATE))))
	     (AND (NOT (MEMQ REFERENCE-DATE '(NIL :NIL)))  ;AVOID LOSSAGE CAUSED BY
			;UNMENTIONABLE THINGS HAPPENING DURING RESTORE-MAGTAPE
		  (MULTIPLE-VALUE-BIND (NIL NIL NIL DAY MONTH YEAR)
		      (TIME:DECODE-UNIVERSAL-TIME REFERENCE-DATE)
		    (PRINC (IF DATE-LAST-EXPUNGE " X=" " (")
			   STREAM)
		    (FORMAT STREAM "~2,'0D//~2,'0D//~2,'0D" MONTH DAY (MOD YEAR 100.))
		    (OR DATE-LAST-EXPUNGE (PRINC ")" STREAM))))) 
	   (LET ((AUTHOR (GET FILE :AUTHOR)))
	     (AND AUTHOR (NOT (EQUAL AUTHOR (SEND PATHNAME :DIRECTORY)))
		  (FORMAT STREAM "~88T~A" AUTHOR)))
	   (LET ((READER (GET FILE :READER)))
	     (AND READER (NOT (EQUAL READER (SEND PATHNAME :DIRECTORY)))
		  (FORMAT STREAM "~98T~A" READER)))
	   (SEND STREAM :TYO #\NEWLINE)))))

(DEFCOM COM-STRING-SEARCH-SELECT-BUFFERS-AS-TAG-TABLE
	"Select the buffers whose names contain a specified string as a tag table.
This causes commands such as Tags Search, Tags Query Replace, and
Tags Compile Changed Sections to look through all buffers you specify." ()
  (let (the-string)
    (SELECT-FILE-LIST-AS-TAG-TABLE
      (mapcar #'buffer-pathname
	      (specify-list-of-buffers
	        :only-non-special-buffers t
	        :only-file-buffers t
	        :substring (setq the-string
		  	         (typein-line-readline "Include buffers whose names contain the string: "))
  	        :query-string nil))
      (TYPEIN-LINE-READLINE-WITH-DEFAULT (string-append "Buffers with " the-string
							" in their names")	;disambiguating string in
						;front to aid in specifying
						;the tag table later on...
					 "Name for this tag table:")))
  DIS-NONE)



;;;;Problem: Fails to clear kill history before pushing marked thing -- previously
;;;;killed text appears at point!
;(DEFCOM COM-MOUSE-MOVE-THING-TO-CURSOR
;  "Takes sexp pointed at by the mouse and zaps a copy of it to current cursor location." ()
;  (COM-SET-POP-MARK)
;  (let ((*mouse-x* system:mouse-x)
;	(*mouse-y* system:mouse-y))
;    (COM-MOUSE-MARK-THING))
;  (com-save-region)
;  (COM-MOVE-TO-PREVIOUS-POINT)
;  (com-yank)  ;;yanks too much!
;  (SETQ *MARK-STAYS* nil)
;  DIS-TEXT)

;(install-command-and-advertise 'COM-MOUSE-MOVE-THING-TO-CURSOR #/ *standard-comtab*	;install it.
;"")



(DEFUN PRINT-SHORT-DOC-FOR-TABLE (CHAR COMTAB INDENTATION)
  "Document what CHAR does in COMTAB, for subcommands of prefix characters.
It prints one or two lines of stuff, with the given INDENTATION."
  (LET ((X (COMMAND-LOOKUP CHAR COMTAB T)))
    (COND ((MEMQ X '(NIL :UNDEFINED)))		;undefined
	  ((CONSP X))				;alias
	  ((MACRO-COMMAND-P X)
	   (FORMAT T "~&~V@T~:C is a user defined macro.~%" INDENTATION CHAR))
	  ((PREFIX-COMMAND-P X)
	   (FORMAT T "~&~V@T~:C reads another character and dispatches.~%"
		   INDENTATION CHAR))
	  ((NOT (SYMBOLP X)))			;??
	  (T
	   (FORMAT T "~&~V@T~:C is ~A:~57T"	;more readably than with ~A:~%~@T"	
		   INDENTATION CHAR (COMMAND-NAME X) (+ 5 INDENTATION))
	   (PRINT-DOC :SHORT X CHAR)))))




(DEFCOM COM-FIND-DIRECTORY-FILES "Reads in all files in specified directory.
You type the name of a directory a la COM-DIRED, and all the files
in that directory are brought into the editor if not already in." ()
  (DOLIST (FILE (FS:DIRECTORY (READ-DIRECTORY-NAME "Read in files for directory:" (DEFAULT-PATHNAME))))
    (UNLESS (member (SEND FILE :TYPE) '("DIRECTORY" "DVI" "QFASL"))
      (LET ((SOURCE-PATHNAME (SEND FILE :SOURCE-PATHNAME)))
	(UNLESS (FIND-FILE-BUFFER SOURCE-PATHNAME)
	  (LET ((BUFFER (MAKE-INSTANCE 'ZMACS-BUFFER)))
	    (REVERT-BUFFER BUFFER SOURCE-PATHNAME 'NOSECTIONIZE NIL)
	    (MAKE-BUFFER-CURRENT BUFFER)
	    (SECTIONIZE-BUFFER BUFFER)
	    (NOT-MODIFIED BUFFER)
	    (SETF (BUFFER-FILE-READ-TICK BUFFER) *TICK*))))))
  DIS-TEXT)


(defcom com-bury-buffer "" ()
  (if (not (typep tv:selected-window 'zwei:zmacs-window-pane))
      (barf "No buffers")
    (WITHOUT-INTERRUPTS
      (DOLIST (W *ALL-ZMACS-WINDOWS*)
	(LET ((HISTORY (SEND W :BUFFER-HISTORY)))
	  (APPEND-REMOVE-ON-HISTORY *interval* HISTORY)))
      (SETQ *ZMACS-BUFFER-LIST* (APPEND (REMQ *interval* *ZMACS-BUFFER-LIST*)
					(LIST *interval*)))
      (MAKE-BUFFER-CURRENT (first *zmacs-buffer-list*))))
  dis-text)


(defcom com-rotate-buffer-stack "Control-H" ()
  (if (not (typep tv:selected-window 'zwei:zmacs-window-pane))
      (barf "No buffers")
    (send (nth (1- (length *zmacs-buffer-list*)) *zmacs-buffer-list*) :select))
  dis-text)

(DEFCOM COM-FILL-TEXT-BUFFER "Fill (or adjust) the entire buffer." ()
  (FILL-INTERVAL (interval-first-bp *interval*)
		 (interval-last-bp *interval*)	
		 T (AND *NUMERIC-ARG-P* (PLUSP *NUMERIC-ARG*)))
  DIS-TEXT)


(DEFCOM COM-FILL-LISP-BUFFER "Fill (or adjust) an entire lisp buffer." ()
  (INDENT-INTERVAL-FOR-LISP *interval*)
  DIS-TEXT)


;;;Feature: Reads in all files currently without zmacs buffers in the 
;;;background after accepting tag table name as unique.  Alerts when
;;;done.
;;;
;;;Feature: Allows specification of identical sets of files for multiple
;;;tag tables (as long as they are given different names).
;;;
;;;Caveat (not specific to this code): Tag table names are not case sensitive!
;;;
;;;Warning: Full defaulting is in effect here, so all versions of a file 
;;;are used if you do not specify otherwise!
;;;

(defvariable *zmacs-prefer-preload-tag-table-files-in-background* T :boolean)

(defcom com-select-files-as-tag-table "Prompts for and selects files to use as a tag table.
  With a numeric argument, reads in all specified files in the background." ()
  (let* ((pathname (READ-defaulted-pathname
		     "File or files to use as tag table:"
		     (make-pathname :defaults (DEFAULT-PATHNAME) :name :wild :type :lisp :version :newest)))
	 (newest-p (typecase (pathname-version pathname)
		     (null t)
		     ((member :newest :unspecific) t)))
	 (file-list (mapcar #'(lambda(path)
				(if newest-p
				    (send path :new-pathname :version :newest)
				  path))
			    (directory pathname))))
    (if (null file-list)
	(barf "No files match ~A" pathname)
      (let ((tag-table-name (typein-line-readline "Name for this tag table:")))
	(SELECT-FILE-LIST-AS-TAG-TABLE
	  file-list
	  (do ((used-name tag-table-name
			  (typein-line-readline 
			    (format nil "/"~a/" is already the name of a tag table. ~
				       Please enter another name for this new one:"
				    used-name))))
	      (nil)
	    (if (not (ass #'string-equal used-name *zmacs-tag-table-alist*))
		(return used-name))))
	;;;Optionally, pre-load all files
	(when (or *zmacs-prefer-preload-tag-table-files-in-background* *numeric-arg-p*)
	  (process-run-function `(:name ,(format nil "Loading of ~A" tag-table-name)
					:priority -1)	;don't subordinate front-line file transactions
				#'(lambda (files window)
				    (dolist (file files) (or (find-file-buffer file)
							     (load-file-into-zmacs file nil)))
				    (tv:careful-notify
				      window t
				      "The files of ~A have been loaded into ZMacs and selected as current tag table."
				      tag-table-name))
				;;Args to background file-finding function:
				file-list *window*)))
      ;;;Done.
      (format *query-io* "Done.")))
  DIS-NONE)

;;; Edit a list of section nodes matching a specified string.
(DEFCOM COM-MATCHING-SECTIONS "List all sections in a specified buffer matching a given substring.
Each DEFUN, DEFVAR, DEFSTRUCT, etc. is one section." ()
  (LET ((BUFFER (READ-BUFFER-NAME "List sections in buffer:" *INTERVAL*))
	(substring (completing-read-from-mini-buffer "Substring against which to match sections:" nil)))
    (RESECTIONIZE-BUFFER BUFFER)
    (FORMAT T "Sections in buffer ~A containing string /"~A/":~2%" BUFFER substring)
    (SEND *STANDARD-OUTPUT* :ITEM-LIST 'SECTION-NAME
	  (subset #'(LAMBDA (SECTION-NAME)
		      (string-search substring (format nil "~S" section-name)))
		  (mapcar 'section-node-name (NODE-INFERIORS BUFFER)))))
  DIS-NONE)

(defcom com-kill-all-buffers-in-system-related-directories
	"Flushes buffers which are part of a specified system's related directories."
	()
  (let* ((system-name (read-system-name "System whose associated buffers need removal:"))
	 (system-source-files-list (si:system-source-files system-name si:*source-file-types* nil t))
	 outlist
	 (dir-list (dolist (each-file system-source-files-list outlist)
		     (pushnew (send each-file :string-for-directory)
			      outlist
			      :test #'string-equal)))
 	 (len (length dir-list))
	 (list-of-buffers-to-be-killed)
	 )
    (do ((i 0 (1+ i)) (dir-name)) ((= i len))
      (setq dir-name (format () "~a" (elt (print dir-list) i))
	    dir-name (print (subseq dir-name 0 (position #/; dir-name))))
      (and (mem #'string-equal dir-name dir-list)
	   (y-or-n-p "Release file buffers in system ~A for files in directory ~a? " system-name dir-name)
	   (setq dir-list (append dir-list (list dir-name)))))
    (dolist (buffer *zmacs-buffer-list*)
      (let ((buffer-name (format () "~a" (cdar (pathname-defaults *pathname-defaults* buffer)))))
	(dolist (dir-name dir-list)
	  (when (string-equal buffer-name dir-name
			      :end1 (position #/; buffer-name)
			      :end2 (position #/; dir-name))
	    (setq list-of-buffers-to-be-killed
		  (append list-of-buffers-to-be-killed
			  (progn
			    (and (send buffer :modified-p)
				 (y-or-n-p "Buffer ~a was modified, save it first? " buffer-name)
				 (save-buffer buffer))
			    (list buffer))))
	    (return)))))
    (and (fquery () "There are ~d buffers associated with system ~a out of ~d Zmacs buffers.
Begin removing associated buffers? "
		 (length list-of-buffers-to-be-killed)
		 system-name
		 (length *zmacs-buffer-list*))
	 (progn
	   (dolist (buffer list-of-buffers-to-be-killed)
	     (setq *zmacs-buffer-list* (remq buffer *zmacs-buffer-list*))
	     (send buffer :kill))
	   (format *query-io* "~d buffers associated with system ~a flushed."
		   (length list-of-buffers-to-be-killed)
		   system-name)))
    (make-buffer-current (car *zmacs-buffer-list*)))
  dis-text)

;;;;;;;;;;
;;;;;;;;;; Now install all newly-defined commands, and announce changes to existing functionalities.
;;;;;;;;;;

(send terminal-io :clear-screen)

(install-command-and-advertise 'com-select-files-as-tag-table #/Meta-Shift-S *zmacs-comtab*	;install it.
			       "~%Meta-Shift-S now selects user-specified files as a tag table.")

(format *query-io* "~%Control-U argument to Meta-X Kill or Save Buffers ~
                     now initially marks all buffers for killing.")

(install-command-and-advertise 'com-fill-lisp-buffer #/Control-Meta-Shift-F *zmacs-comtab*	;install it.
			       "~%Control-Meta-Shift-F now justifies all defuns in a Lisp buffer.")


(install-command-and-advertise 'com-fill-text-buffer #/Meta-Shift-F *zmacs-comtab*	;install it.
			       "~%Meta-Shift-F now fills all paragraphs in a text buffer.")

(install-command-and-advertise 'com-rotate-buffer-stack
			       #/c-H *standard-comtab*	;install it.
			       "~%Control-H now rotates the buffer stack (last one becomes new first one).")

(install-command-and-advertise 'com-bury-buffer #/c-I *standard-comtab*	;install it.
			       "~%Control-I now buries the current buffer in the current buffer list.")

(install-command-and-advertise 'com-find-directory-files #/s-t *standard-comtab*	;install it.
			       "~%Super-T now reads in all files of a directory (which you specify in a minibuffer).")

(install-command-and-advertise 'COM-STRING-SEARCH-SELECT-BUFFERS-AS-TAG-TABLE #/c-m-s *standard-comtab* 
       "~%Control-Meta-s now selects buffers as tag table using a user-specified string search on buffer names.")

(install-command-and-advertise 'COM-INDENT-SEXP-AND-MOVE #/c-m-q *standard-comtab* 
       "~%Control-Meta-q now indents the sexp beginning on the current line for LISP.")