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

(defcom INDENT-SEXP-AND-MOVE "Indent the following SEXP for LISP, and move to its closing paren." ()
  (com-indent-for-lisp)
  (com-indent-sexp)
  (com-forward-sexp)
  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.")