;;;-*- Mode:LISP; Package:ZWEI -*-
;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **

;Directory editor

(DEFVAR *DIRED-PATHNAME-NAME* NIL)
(DEFVAR *DIRED-MOUSE-COMMAND*)
(DEFVAR *DIRED-FUNCTION-TO-APPLY*)

(DEFMACRO DIRED-LINE-PATHNAME (LINE)
  `(GET (LOCF (LINE-PLIST ,LINE)) ':PATHNAME))

(DEFMAJOR COM-DIRED-MODE DIRED-MODE "Dired" "Setup for editting a directory" ()
  (PROGN (OR (BOUNDP '*DIRED-MOUSE-COMMAND*)
	     (SETQ *DIRED-MOUSE-COMMAND*
		   (MAKE-MENU-COMMAND '(DIRED-SORT-BY-INCREASING-REFERENCE-DATE
					DIRED-SORT-BY-DECREASING-REFERENCE-DATE
					DIRED-SORT-BY-INCREASING-CREATION-DATE
					DIRED-SORT-BY-DECREASING-CREATION-DATE
					DIRED-SORT-BY-INCREASING-FILE-NAME
					DIRED-SORT-BY-DECREASING-FILE-NAME
					DIRED-SORT-BY-INCREASING-SIZE
					DIRED-SORT-BY-DECREASING-SIZE
					COM-DIRED-AUTOMATIC
					COM-DIRED-AUTOMATIC-ALL
					COM-DIRED-CHANGE-FILE-PROPERTIES
					))))
	 (AND (TYPEP *INTERVAL* 'FILE-BUFFER)
	      (LET ((PATHNAME (BUFFER-PATHNAME *INTERVAL*)))
		(AND PATHNAME (SETQ *DIRED-PATHNAME-NAME* (STRING PATHNAME))))))
  (SET-COMTAB *MODE-COMTAB* '(#\SP COM-DOWN-REAL-LINE
			      #/! COM-DIRED-NEXT-UNDUMPED
			      #/$ COM-DIRED-COMPLEMENT-NO-REAP-FLAG
			      #/. COM-DIRED-CHANGE-FILE-PROPERTIES
			      #/? COM-DIRED-HELP
			      #\HELP COM-DIRED-HELP
			      #/A COM-DIRED-APPLY-FUNCTION
			      #/a (0 #/A)
			      #/C COM-DIRED-SRCCOM
			      #/c (0 #/C)
			      #/D COM-DIRED-DELETE
			      #/d (0 #/D)
			      #/D COM-DIRED-DELETE
			      #/E COM-DIRED-EDIT-FILE
			      #/e (0 #/E)
			      #/H COM-DIRED-AUTOMATIC
			      #/h (0 #/H)
			      #/K COM-DIRED-DELETE
			      #/k (0 #/K)
			      #/K COM-DIRED-DELETE
			      #/N COM-DIRED-NEXT-HOG
			      #/n (0 #/N)
			      #/P COM-DIRED-PRINT-FILE
			      #/p (0 #/P)
			      #/Q COM-DIRED-EXIT
			      #/q (0 #/Q)
			      #/U COM-DIRED-UNDELETE
			      #/u (0 #/U)
			      #/V COM-DIRED-VIEW-FILE
			      #/v (0 #/V)
			      #/X COM-EXTENDED-COMMAND
			      #/x (0 #/X)
			      #\RUBOUT COM-DIRED-REVERSE-UNDELETE
			      #\ABORT COM-DIRED-ABORT
			      #\END COM-DIRED-EXIT))
  (SET-COMTAB *MODE-COMTAB* (LIST #\MOUSE-3-1 *DIRED-MOUSE-COMMAND*))
  (SETQ *MODE-LINE-LIST* (APPEND *MODE-LINE-LIST* '("  " *DIRED-PATHNAME-NAME*
						    "     (Q to exit)"))))

(DEFCOM COM-DIRED "Edit a directory.
For documentation on the Dired commands, enter Dired and type question-mark." ()
  (DIRECTORY-EDIT (READ-DIRECTORY-NAME "Edit directory" (DEFAULT-PATHNAME))))

(DEFCOM COM-R-DIRED "Edit directory for current file.
With no argument, edits the directory containing the file in the current buffer.
With an argument of 1, shows only files with the same first name as the current file.
With an argument of 4, asks for a directory name.
For documentation on the Dired commands, enter Dired and type question-mark." ()
  (LET ((PATHNAME (FUNCALL (DEFAULT-PATHNAME) ':NEW-PATHNAME ':TYPE ':WILD
							     ':VERSION ':WILD)))
    (COND ((NOT *NUMERIC-ARG-P*)
	   (DIRECTORY-EDIT (FUNCALL PATHNAME ':NEW-NAME ':WILD)))
	  ((= *NUMERIC-ARG* 1)
	   (DIRECTORY-EDIT PATHNAME))
	  (T (COM-DIRED)))))

;;; Here is the actual directory editor
(DEFUN DIRECTORY-EDIT (PATHNAME &AUX DIRECTORY)
  (SETQ *DIRED-PATHNAME-NAME* (FUNCALL PATHNAME ':STRING-FOR-PRINTING))
  (FUNCALL-SELF ':FIND-SPECIAL-BUFFER ':DIRED T "Dired" 3 'DIRED-MODE)
  (SETF (NODE-TICK *INTERVAL*) ':READ-ONLY)
  (WITH-READ-ONLY-SUPPRESSED (*INTERVAL*)
    (AND (TYPEP *INTERVAL* 'FILE-BUFFER)
	 (SETF (BUFFER-PATHNAME *INTERVAL*) PATHNAME))
    (DELETE-INTERVAL *INTERVAL*)
    (COM-DIRED-MODE)
    (SETQ DIRECTORY (FS:DIRECTORY-LIST PATHNAME ':DELETED ':SORTED))
    ;; Mark all files that are the newest
    (DIRED-COMPUTE-GREATER-THANS (CDR DIRECTORY))
    (LET ((STREAM (INTERVAL-STREAM-INTO-BP (INTERVAL-FIRST-BP *INTERVAL*))))
      (FUNCALL STREAM ':STRING-OUT *DIRED-PATHNAME-NAME*)
      (FUNCALL STREAM ':TYO #\CR)
      (DO ((FILES DIRECTORY (CDR FILES))
	   (FILE)
	   (LINE) (FIRST-FILE-LINE))
	  ((NULL FILES)
	   (AND FIRST-FILE-LINE
		(MOVE-BP (POINT) FIRST-FILE-LINE 0)))
	(SETQ FILE (CAR FILES))
	(FUNCALL *DIRECTORY-SINGLE-FILE-LISTER* FILE STREAM)
	(SETQ LINE (LINE-PREVIOUS (BP-LINE (FUNCALL STREAM ':READ-BP))))
	(AND (NULL FIRST-FILE-LINE)
	     (CAR FILE)
	     (SETQ FIRST-FILE-LINE LINE))
	(SETF (LINE-PLIST LINE) (CONS ':PATHNAME FILE)))))
  DIS-TEXT)

(DEFCOM COM-DIRED-HELP "Explain DIRED commands" ()
  (FORMAT T "You are in the directory editor.  The commands are:
	D (or K, c-D, c-K)  Mark the current file for deletion.
	U	Undelete the current file, or else the file just above the cursor.
	Rubout	Undelete file above the cursor.
	Space	Move to the next line.
	  With a numeric argument these repeat, backwards if the argument is negative.	  
	!	Move to the next file that is not backed up.
	N	Move to the next file with more than 2 versions.
	H	Mark excess versions of the current file for deletion.
	P	Print the current file on the standard hardcopy device.
	Q	Exit.  You will be shown the files to be deleted and asked for
		confirmation.  In this display /":/" means a link, /">/" means
		this is the highest version-number of this file, /"!/" means
		not backed-up, and /"$/" means not to be reaped, please.
	$	Complement the /"don't reap/" flag.
	E	Edit the current file.
	V	View the current file (doesn't read it all in).
	X	Execute extended command (same as meta-X).
	C	SRCCOM this file with the > version.
	A	Queue this file for function application.
	Clicking the right-hand button on the mouse will give you a menu
	of useful commands.~%")
  DIS-NONE)

(DEFUN DIRED-MAP-OVER-LINES (N-TIMES FUNCTION)
  (WITH-READ-ONLY-SUPPRESSED (*INTERVAL*)
    (LET ((BP (BEG-LINE (POINT)))
	  (BOTTOM (INTERVAL-LAST-BP *INTERVAL*)))
      (DOTIMES (I (ABS N-TIMES))
	(AND (MINUSP N-TIMES) (SETQ BP (BEG-LINE BP -1 T)))
	(OR (DIRED-LINE-PATHNAME (BP-LINE BP))
	    (BARF "Don't mung the header please"))
	(AND (BP-= BP BOTTOM) (RETURN))
	(FUNCALL FUNCTION (BP-LINE BP))
	(AND (PLUSP N-TIMES) (SETQ BP (BEG-LINE BP +1 T))))
      (MOVE-BP (POINT) BP))
    DIS-TEXT))
  
(DEFCOM COM-DIRED-DELETE "Mark file(s) for deletion" ()
  (DIRED-MAP-OVER-LINES *NUMERIC-ARG* 
			#'(LAMBDA (LINE)
			    (MUNG-LINE LINE)
			    (ASET #/D LINE 0))))

(DEFCOM COM-DIRED-UNDELETE "Un-mark file(s) for deletion" ()
  (DIRED-MAP-OVER-LINES (IF (AND (NOT *NUMERIC-ARG-P*)
				 (NOT (MEMQ (BP-CHAR (POINT)) '(#/D #/P))))
			    -1
			    *NUMERIC-ARG*)
			#'(LAMBDA (LINE)
			    (MUNG-LINE LINE)
			    (ASET #\SP LINE 0))))

(DEFCOM COM-DIRED-REVERSE-UNDELETE "Un-mark file(s) upwards for deletion" ()
  (SETQ *NUMERIC-ARG* (- *NUMERIC-ARG*))
  (COM-DIRED-UNDELETE))

(DEFCOM COM-DIRED-PRINT-FILE "Mark a file to be printed" ()
   (DIRED-MAP-OVER-LINES *NUMERIC-ARG*
			 #'(LAMBDA(LINE)
			     (MUNG-LINE LINE) 
			     (IF (DIRED-PRINTABLE-FILE-P LINE)
				 (ASET #/P LINE 0)
				 (BARF "Can't print random files!")))))

(DEFCOM COM-DIRED-APPLY-FUNCTION "Mark file(s) for having a function applied to them" ()
  (DIRED-MAP-OVER-LINES *NUMERIC-ARG* 
			#'(LAMBDA (LINE)
			    (MUNG-LINE LINE)
			    (ASET #/A LINE 0))))

(DEFUN DIRED-PRINTABLE-FILE-P (LINE &AUX PLIST PATHNAME TYPE BYTE)
  (SETQ PLIST (LOCF (LINE-PLIST LINE))
	PATHNAME (GET PLIST ':PATHNAME)
	TYPE (FUNCALL PATHNAME ':TYPE))
  (AND (NOT (MEMBER TYPE '("QFASL" "BIN" "DRW" "WD" "FASL" "KST" ":EJ" "TAGS"
			   "OUTPUT" "PRESS")))	;others?
       (OR (EQUAL TYPE "PLT")
	   (MEMQ (GET PLIST ':BYTE-SIZE) '(7 8)) ;This is probably a text file, skip open
	   (WITH-OPEN-FILE (STREAM PATHNAME '(:IN :FIXNUM :BYTE-SIZE 9.))
	     (DOTIMES (I 4) (SETQ BYTE (FUNCALL STREAM ':TYI)))
	     (NOT (BIT-TEST BYTE 1))))))

(DEFCOM COM-DIRED-NEXT-UNDUMPED "Find next file that is not backed up" ()
  (DO ((BP (BEG-LINE (POINT) +1 NIL) (BEG-LINE BP +1 NIL)))
      ((NULL BP) (BARF))
    (AND (GET (LOCF (LINE-PLIST (BP-LINE BP))) ':NOT-BACKED-UP)
	 (RETURN (MOVE-BP (POINT) BP))))
  DIS-BPS)

(DEFCOM COM-DIRED-COMPLEMENT-NO-REAP-FLAG "Change the $ flag" ()
  (LET* ((LINE (BP-LINE (POINT)))
	 (PLIST (LOCF (LINE-PLIST LINE)))
	 (PATHNAME (GET PLIST ':PATHNAME)))
    (FS:CHANGE-FILE-PROPERTIES PATHNAME T ':DONT-REAP
			       (PUTPROP PLIST (NOT (GET PLIST ':DONT-REAP)) ':DONT-REAP))
    (SETF (LINE-LENGTH LINE) 0)
    (WITH-OUTPUT-TO-STRING (S LINE)
      (FUNCALL *DIRECTORY-SINGLE-FILE-LISTER* (CONS PATHNAME (CDR PLIST)) S))
    (MUNG-LINE LINE)
    (DECF (LINE-LENGTH LINE)))			;Don't leave carriage return in line
  DIS-TEXT)

(DEFCOM COM-DIRED-NEXT-HOG "Find the next file with superfluous versions.
This is a file with more numbered versions than the value of *FILE-VERSIONS-KEPT*,
or the numeric argument if one is supplied." ()
  (LET* ((HOG (IF *NUMERIC-ARG-P* *NUMERIC-ARG* *FILE-VERSIONS-KEPT*))
	 (LINE (BP-LINE (POINT)))
	 PATHNAME)
    (DO () ((SETQ PATHNAME (DIRED-LINE-PATHNAME LINE)))
      (SETQ LINE (LINE-NEXT LINE)))
    (DO ((LINE LINE (LINE-NEXT LINE))
	 (STOP-LINE (BP-LINE (INTERVAL-LAST-BP *INTERVAL*)))
	 (NAME (FUNCALL PATHNAME ':NAME))
	 (TYPE (FUNCALL PATHNAME ':TYPE))
	 (SKIP-P T)	;Skipping current file
	 (FIRST-LINE)	;Save first line in this group
	 (N-VERSIONS))	;Number of versions of current file so far
	((EQ LINE STOP-LINE) (BARF "No more hogs"))
      (SETQ PATHNAME (DIRED-LINE-PATHNAME LINE))
     CHECK-AGAIN
      (AND PATHNAME
	   (COND ((AND (EQUAL NAME (FUNCALL PATHNAME ':NAME))
		       (EQUAL TYPE (FUNCALL PATHNAME ':TYPE)))
		  (COND ((AND (NOT SKIP-P)
			      (> (SETQ N-VERSIONS (1+ N-VERSIONS)) HOG))
			 (MOVE-BP (POINT) FIRST-LINE 0)
			 (RECENTER-WINDOW *WINDOW* ':START (POINT))
			 (RETURN DIS-BPS))))
		 (T (SETQ SKIP-P NIL
			  NAME (FUNCALL PATHNAME ':NAME)
			  TYPE (FUNCALL PATHNAME ':TYPE)
			  N-VERSIONS 0
			  FIRST-LINE LINE)
		    (GO CHECK-AGAIN)))))))

(DEFCOM COM-DIRED-SRCCOM "Compare the current file against the > version" ()
  (SRCCOM-FILE (DIRED-LINE-PATHNAME (BP-LINE (POINT))))
  DIS-NONE)

(TV:ADD-TYPEOUT-ITEM-TYPE *TYPEOUT-COMMAND-ALIST* FILE "Compare" SRCCOM-FILE NIL
			  "Compare this file with the newest version.")

(DEFUN SRCCOM-FILE (PATHNAME-1 &AUX PATHNAME-2)
  (SETQ PATHNAME-2 (FUNCALL PATHNAME-1 ':NEW-VERSION ':NEWEST))
  (PROMPT-LINE "Source comparing ~A" PATHNAME-1)
  (SRCCOM:SOURCE-COMPARE PATHNAME-1 PATHNAME-2))

(DEFCOM COM-DIRED-VIEW-FILE "View the current file" ()
   (LET ((PATHNAME (DIRED-LINE-PATHNAME (BP-LINE (POINT)))))
     (VIEW-FILE PATHNAME))
   DIS-NONE)

(DEFCOM COM-DIRED-EDIT-FILE "Edit the current file" ()
  (OR (TYPEP *INTERVAL* 'BUFFER) (BARF))
  (LET* ((LINE (BP-LINE (POINT)))
	 (PATHNAME (DIRED-LINE-PATHNAME LINE)))
    (AND (GET (LOCF (LINE-PLIST LINE)) ':NEWEST)
	 (SETQ PATHNAME (FUNCALL PATHNAME ':NEW-VERSION ':NEWEST)))
    (FIND-FILE PATHNAME))
  (LET ((BLURB (KEY-FOR-COMMAND 'COM-SELECT-PREVIOUS-BUFFER)))
    (AND (NULL BLURB) (SETQ BLURB (KEY-FOR-COMMAND 'COM-SELECT-BUFFER))
	 (SETQ BLURB (STRING-APPEND BLURB " Return")))
    (AND BLURB
	 (TYPEIN-LINE "Type ~A to return to DIRED" BLURB)))
  DIS-TEXT)

;;; This goes through a sorted list of files and puts :NEWEST properties on files
(DEFUN DIRED-COMPUTE-GREATER-THANS (DIRECTORY)
  (DO ((FILES DIRECTORY (CDR FILES))
       (FILE NIL NEXT-FILE)
       (NEXT-FILE))
      (NIL)
    (SETQ NEXT-FILE (CAR FILES))
    (AND FILE
	 (OR (NULL NEXT-FILE)
	     (NOT (AND (EQUAL (FUNCALL (CAR FILE) ':NAME) (FUNCALL (CAR NEXT-FILE) ':NAME))
		       (EQUAL (FUNCALL (CAR FILE) ':TYPE) (FUNCALL (CAR NEXT-FILE) ':TYPE)))))
	 (NOT (MEMQ (FUNCALL (CAR FILE) ':VERSION) '(:NEWEST :UNSPECIFIC)))
	 (PUTPROP FILE T ':NEWEST))
    (OR FILES (RETURN NIL))))

(DEFCOM COM-DIRED-ABORT "Abort dired" ()
  (FUNCALL-SELF ':EXIT-SPECIAL-BUFFER))

(DEFCOM COM-DIRED-EXIT "Leave DIRED.
Displays the files to be deleted and/or printed, then asks you to confirm." ()
  (DO-NAMED DIRED-EXIT
      ((LINE (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*)) (LINE-NEXT LINE))
       (DELETE-FILES NIL)			;Each element is a line
       (UNDELETE-FILES NIL)
       (PRINT-FILES NIL)
       (APPLY-FILES NIL)
       (LAST-LINE (BP-LINE (INTERVAL-LAST-BP *INTERVAL*)))
       (DELETED-P))
      ((EQ LINE LAST-LINE)
       (SETQ DELETE-FILES (NREVERSE DELETE-FILES)
	     UNDELETE-FILES (NREVERSE UNDELETE-FILES)
	     PRINT-FILES (NREVERSE PRINT-FILES)
	     APPLY-FILES (NREVERSE APPLY-FILES))
       (*CATCH 'RETURN-TO-DIRED (PROGN	 
	 (COND ((OR DELETE-FILES UNDELETE-FILES PRINT-FILES APPLY-FILES)
		(AND DELETE-FILES (DIRED-PRINT-FILE-LIST DELETE-FILES "deleted"))
		(AND UNDELETE-FILES (DIRED-PRINT-FILE-LIST UNDELETE-FILES "undeleted"))
		(AND PRINT-FILES (DIRED-PRINT-FILE-LIST PRINT-FILES "printed"))
		(AND APPLY-FILES (DIRED-PRINT-FILE-LIST APPLY-FILES "processed by function"))
		(COND ((DIRED-FILE-QUERY (AND DELETE-FILES "Delete")
					 (AND UNDELETE-FILES "Undelete")
					 (AND PRINT-FILES "Print")
					 (AND APPLY-FILES "Apply function"))
		       (AND DELETE-FILES
			    (DIRED-DO-FILE-LIST DELETE-FILES 'DIRED-DELETE-FILE "delete"
						':DELETE-MULTIPLE-FILES))
		       (AND UNDELETE-FILES
			    (DIRED-DO-FILE-LIST UNDELETE-FILES 'DIRED-UNDELETE-FILE
						"undelete"
						':UNDELETE-MULTIPLE-FILES))
		       (AND PRINT-FILES
			    (DIRED-DO-FILE-LIST PRINT-FILES 'DIRED-PRINT-FILE "print"))
		       (COND (APPLY-FILES
			      ;This crock to fake out read-function-name.
			      ;Mouse would not win particularily.
			      (LET* ((*MINI-BUFFER-REPEATED-COMMAND* '())
				     (*DIRED-FUNCTION-TO-APPLY*
				       (READ-FUNCTION-NAME "Function to apply:" 'QC-FILE
							   'AARRAY-OK)))
				(DIRED-DO-FILE-LIST APPLY-FILES
						    'DIRED-APPLY-FUNCTION NIL))))))))
	 (RETURN-FROM DIRED-EXIT (FUNCALL-SELF ':EXIT-SPECIAL-BUFFER T)))))
    (COND ((DIRED-LINE-PATHNAME LINE)
	   (SETQ DELETED-P (GET (LOCF (LINE-PLIST LINE)) ':DELETED))
	   (SELECTQ (AREF LINE 0)
	     (#/D (OR DELETED-P (PUSH LINE DELETE-FILES)))
	     (#\SP (AND DELETED-P (PUSH LINE UNDELETE-FILES)))
	     (#/P (PUSH LINE PRINT-FILES))
	     (#/A (PUSH LINE APPLY-FILES))))))
  DIS-BPS)

(DEFUN DIRED-PRINT-FILE-LIST (FILES NAME)
  (FORMAT *TYPEOUT-WINDOW* "~&Files to be ~A in ~A~2%" NAME *DIRED-PATHNAME-NAME*)
  (FUNCALL *TYPEOUT-WINDOW* ':ITEM-LIST NIL
	   (MAPCAR #'(LAMBDA (LINE)
		       (LET ((PLIST (LOCF (LINE-PLIST LINE))))
			 (STRING-APPEND
			   (IF (GET PLIST ':DONT-REAP) #/$ #\SP)
			   (IF (GET PLIST ':NOT-BACKED-UP) #/! #\SP)
			   (IF (GET PLIST ':LINK-TO) #/: #\SP)
			   (IF (GET PLIST ':NEWEST) #/> #\SP)
			   #\SP
			   (FUNCALL (GET PLIST ':PATHNAME) ':STRING-FOR-DIRED))))
		   FILES)))

(DEFUN DIRED-FILE-QUERY (&REST NAMES &AUX (N 0))
  (FORMAT *TYPEOUT-WINDOW* "~%")
  (DO L NAMES (CDR L) (NULL L)
    (AND (CAR L) (SETQ N (1+ N))))
  (DO ((L NAMES (CDR L))
       (FLAG NIL))
      ((NULL L))
    (COND ((CAR L)
	   (IF FLAG
	       (COND ((> N 2)
		      (FUNCALL *TYPEOUT-WINDOW* ':STRING-OUT ", ")
		      (SETQ N (1- N)))
		     ((= N 2)
		      (FUNCALL *TYPEOUT-WINDOW* ':STRING-OUT " or ")))
	       (SETQ FLAG T))
	   (FUNCALL *TYPEOUT-WINDOW* ':STRING-OUT (CAR L)))))
  (FORMAT *TYPEOUT-WINDOW* "? ")
  (SELECTQ (LET ((QUERY-IO *TYPEOUT-WINDOW*))
	     (FQUERY '(:CHOICES (((:YES "Yes.") #/Y)
				 ((:NO "No.") #/N)
				 ((:ABORT "Abort.") #/Q)
				 ((:ABORT "Abort.") #/X))
		       :FRESH-LINE NIL
		       :HELP-FUNCTION DIRED-FILE-QUERY-HELP)
		     ""))
    (:YES T)
    (:NO (*THROW 'RETURN-TO-DIRED T))
    (:ABORT NIL)))

(DEFUN DIRED-FILE-QUERY-HELP (STREAM IGNORE IGNORE)
  (FORMAT STREAM
	  "~%Type Y to go ahead, N to return to DIRED, or Q or X to abort out of DIRED.~%"))

;; A MULTIPLE-FILE-MESSAGE is assumed to take a first argument of ERROR-P
;; and a second of FILES.  It should return either a string (entire operation failed),
;; NIL (entire operation successful),
;; or a list of values corresponding to individual message values.
(DEFUN DIRED-DO-FILE-LIST (FILES FUNCTION NAME &OPTIONAL MULTIPLE-FILE-MESSAGE
			   &AUX ERR PATHS)
  (COND ((AND MULTIPLE-FILE-MESSAGE
	      (FUNCALL (DIRED-LINE-PATHNAME (CAR FILES))
		       ':OPERATION-HANDLED-P MULTIPLE-FILE-MESSAGE))
	 (SETQ PATHS
	       (LET ((RESULT (MAKE-LIST (LENGTH FILES))))
		 (DO ((R RESULT (CDR R))
		      (F FILES (CDR F)))
		     ((NULL F) RESULT)
		   (SETF (CAR R) (DIRED-LINE-PATHNAME (CAR F))))))
	 (SETQ ERR (FUNCALL (CAR PATHS) MULTIPLE-FILE-MESSAGE
			    NIL			;error-p
			    PATHS))
	 (AND NAME (STRINGP ERR)
	      (DIRED-REPORT-ERROR NAME "files" ERR))
	 (AND NAME ERR
	      (DO ((F PATHS (CDR F))
		   (E ERR (CDR E)))
		  ((NULL E))
		(AND (STRINGP (CAR E))
		     (DIRED-REPORT-ERROR NAME (CAR F) (CAR E))))))
	(T (DOLIST (LINE FILES)
	     (SETQ ERR (FUNCALL FUNCTION LINE))
	     (AND NAME
		  (STRINGP ERR)
		  (DIRED-REPORT-ERROR NAME (DIRED-LINE-PATHNAME LINE) ERR))))))

(DEFUN DIRED-REPORT-ERROR (NAME PATH ERR)
  (FORMAT *TYPEOUT-WINDOW* "~&Cannot ~A ~A because ~A"
	  NAME PATH ERR))

(DEFUN DIRED-DELETE-FILE (LINE)
  (DELETEF (DIRED-LINE-PATHNAME LINE) NIL))

(DEFUN DIRED-UNDELETE-FILE (LINE)
  (UNDELETEF (DIRED-LINE-PATHNAME LINE) NIL))

(DEFUN DIRED-APPLY-FUNCTION (LINE)
  (FUNCALL *DIRED-FUNCTION-TO-APPLY* (DIRED-LINE-PATHNAME LINE)))

;;; Crock for printing files.  Should be improved someday...

(DEFINE-SITE-VARIABLE *DIRED-HARDCOPY-MODE* :DEFAULT-HARDCOPY-MODE)

(DEFUN DIRED-PRINT-FILE (LINE)
  (DIRED-PRINT-FILE-1 (DIRED-LINE-PATHNAME LINE)))

(DEFUN DIRED-PRINT-FILE-1 (PATHNAME &AUX (TYPE (FUNCALL PATHNAME ':TYPE))
			   FUNCTION)
  (COND ((NULL *DIRED-HARDCOPY-MODE*)
	 "I don't know how to print files at your site")
	((NULL (SETQ FUNCTION (GET *DIRED-HARDCOPY-MODE* ':DIRED-PRINT-FUNCTION)))
	 (FORMAT NIL "I don't know how to print files on ~A" *DIRED-HARDCOPY-MODE*))
	(T
	 (FUNCALL FUNCTION PATHNAME (SELECTOR TYPE EQUAL
				      ("PLT" ':SUDS-PLOT)
				      ("XGP" ':XGP)
				      ("PRESS" ':PRESS)
				      (OTHERWISE ':TEXT))))))

(DEFPROP DIRED-SORT-BY-INCREASING-FILE-NAME "Sort by file name (up)" COMMAND-NAME)
(DEFPROP DIRED-SORT-BY-INCREASING-FILE-NAME "Sort buffer by increasing file name"
	 DOCUMENTATION)
(DEFUN DIRED-SORT-BY-INCREASING-FILE-NAME ()
  (DIRED-SORT #'(LAMBDA (L1 L2)
		  (FS:PATHNAME-LESSP (DIRED-LINE-PATHNAME L1)
				     (DIRED-LINE-PATHNAME L2)))))

(DEFPROP DIRED-SORT-BY-DECREASING-FILE-NAME "Sort by file name (down)" COMMAND-NAME)
(DEFPROP DIRED-SORT-BY-DECREASING-FILE-NAME "Sort buffer by decreasing file name"
	 DOCUMENTATION)
(DEFUN DIRED-SORT-BY-DECREASING-FILE-NAME ()
  (DIRED-SORT #'(LAMBDA (L1 L2)
		  (FS:PATHNAME-LESSP (DIRED-LINE-PATHNAME L2)
				     (DIRED-LINE-PATHNAME L1)))))


(DEFPROP DIRED-SORT-BY-INCREASING-REFERENCE-DATE "Sort by reference date (up)" COMMAND-NAME)
(DEFPROP DIRED-SORT-BY-INCREASING-REFERENCE-DATE "Sort buffer by increasing reference date"
	 DOCUMENTATION)
(DEFUN DIRED-SORT-BY-INCREASING-REFERENCE-DATE ()
  (DIRED-SORT #'(LAMBDA (L1 L2)
		  (LET ((P1 (LOCF (LINE-PLIST L1)))
			(P2 (LOCF (LINE-PLIST L2))))
		    (< (OR (GET P1 ':REFERENCE-DATE) -1)
		       (OR (GET P2 ':REFERENCE-DATE) -1))))))

(DEFPROP DIRED-SORT-BY-DECREASING-REFERENCE-DATE "Sort by reference date (down)" COMMAND-NAME)
(DEFPROP DIRED-SORT-BY-DECREASING-REFERENCE-DATE "Sort buffer by decreasing reference date"
	 DOCUMENTATION)
(DEFUN DIRED-SORT-BY-DECREASING-REFERENCE-DATE ()
  (DIRED-SORT #'(LAMBDA (L1 L2)
		  (LET ((P1 (LOCF (LINE-PLIST L1)))
			(P2 (LOCF (LINE-PLIST L2))))
		    (< (OR (GET P2 ':REFERENCE-DATE) -1)
		       (OR (GET P1 ':REFERENCE-DATE) -1))))))

(DEFPROP DIRED-SORT-BY-INCREASING-CREATION-DATE "Sort by creation date (up)" COMMAND-NAME)
(DEFPROP DIRED-SORT-BY-INCREASING-CREATION-DATE "Sort buffer by increasing creation date"
	 DOCUMENTATION)
(DEFUN DIRED-SORT-BY-INCREASING-CREATION-DATE ()
  (DIRED-SORT #'(LAMBDA (L1 L2)
		  (LET ((P1 (LOCF (LINE-PLIST L1)))
			(P2 (LOCF (LINE-PLIST L2))))
		    (< (GET P1 ':CREATION-DATE) (GET P2 ':CREATION-DATE))))))

(DEFPROP DIRED-SORT-BY-DECREASING-CREATION-DATE "Sort by creation date (down)" COMMAND-NAME)
(DEFPROP DIRED-SORT-BY-DECREASING-CREATION-DATE "Sort buffer by decreasing creation date"
	 DOCUMENTATION)
(DEFUN DIRED-SORT-BY-DECREASING-CREATION-DATE ()
  (DIRED-SORT #'(LAMBDA (L1 L2)
		  (LET ((P1 (LOCF (LINE-PLIST L1)))
			(P2 (LOCF (LINE-PLIST L2))))
		    (< (GET P2 ':CREATION-DATE) (GET P1 ':CREATION-DATE))))))

(DEFPROP DIRED-SORT-BY-INCREASING-SIZE "Sort by file size (up)" COMMAND-NAME)
(DEFPROP DIRED-SORT-BY-INCREASING-SIZE "Sort buffer by increasing file size" DOCUMENTATION)
(DEFUN DIRED-SORT-BY-INCREASING-SIZE ()
  (DIRED-SORT #'(LAMBDA (L1 L2)
		  (< (DIRED-LINE-FILE-SIZE L1) (DIRED-LINE-FILE-SIZE L2)))))

(DEFPROP DIRED-SORT-BY-DECREASING-SIZE "Sort by file size (down)" COMMAND-NAME)
(DEFPROP DIRED-SORT-BY-DECREASING-SIZE "Sort buffer by decreasing file size" DOCUMENTATION)
(DEFUN DIRED-SORT-BY-DECREASING-SIZE ()
  (DIRED-SORT #'(LAMBDA (L1 L2)
		  (< (DIRED-LINE-FILE-SIZE L2) (DIRED-LINE-FILE-SIZE L1)))))

;;; Return size in bits
(DEFUN DIRED-LINE-FILE-SIZE (LINE &AUX PLIST BYTE-SIZE)
  (SETQ PLIST (LOCF (LINE-PLIST LINE)))
  (COND ((GET PLIST ':LINK-TO) -1)		;Sort links together in this mode
	((SETQ BYTE-SIZE (GET PLIST ':BYTE-SIZE))
	 (* BYTE-SIZE (GET PLIST ':LENGTH-IN-BYTES)))
	(T
	 (* (GET PLIST ':BLOCK-SIZE)
	    (GET PLIST ':LENGTH-IN-BLOCKS)))))

(DEFUN DIRED-SORT (PREDICATE)
  (WITH-READ-ONLY-SUPPRESSED (*INTERVAL*)
    (SORT-LINES-INTERVAL PREDICATE
			 (BEG-LINE (INTERVAL-FIRST-BP *INTERVAL*) 2) 
			 (INTERVAL-LAST-BP *INTERVAL*)))
  DIS-TEXT)

(DEFCOM COM-DIRED-AUTOMATIC "Mark superfluous versions of current file for deletion
Superfluous files are those with more numbered versions than the value
of *FILE-VERSIONS-KEPT*, and files with type in the list
*TEMP-FILE-TYPE-LIST*, except those marked with a $ are not deleted.
With numeric argument, processes whole directory." ()
  (IF *NUMERIC-ARG-P* (COM-DIRED-AUTOMATIC-ALL)
      ;; Start by making FIRST-LINE and LAST-LINE bracket all of this file,
      ;; and make N-VERSIONS be the number of numeric versions of it
      (LET ((FIRST-LINE (BP-LINE (POINT)))
	    (LAST-LINE)
	    (STOP-LINE (BP-LINE (INTERVAL-LAST-BP *INTERVAL*)))
	    (N-VERSIONS 0))
	(DO ((LINE FIRST-LINE (LINE-NEXT LINE))
	     (NAME (FUNCALL (DIRED-LINE-PATHNAME FIRST-LINE) ':NAME))
	     (TYPE (FUNCALL (DIRED-LINE-PATHNAME FIRST-LINE) ':TYPE))
	     (PATHNAME))
	    ((EQ LINE STOP-LINE) (SETQ LAST-LINE LINE))
	  (SETQ PATHNAME (DIRED-LINE-PATHNAME LINE))
	  (OR (AND (EQUAL (FUNCALL PATHNAME ':NAME) NAME)
		   (OR (EQUAL (FUNCALL PATHNAME ':TYPE) TYPE)
		       (MEMQ (FUNCALL PATHNAME ':VERSION) '(:NEWEST :UNSPECIFIC))))
	      (RETURN (SETQ LAST-LINE LINE)))
	  (AND (NOT (MEMQ (FUNCALL PATHNAME ':VERSION) '(:NEWEST :UNSPECIFIC)))
	       (SETQ N-VERSIONS (1+ N-VERSIONS))))
	;; Now scan through, assuming we are sorted by increasing versions, and
	;; mark the oldest versions for deletion.  Also mark temp types.
	(DO ((LINE FIRST-LINE (LINE-NEXT LINE))
	     (N-TO-DELETE (- N-VERSIONS *FILE-VERSIONS-KEPT*))
	     (PATHNAME) (TYPE))
	    ((EQ LINE LAST-LINE))
	  (SETQ PATHNAME (DIRED-LINE-PATHNAME LINE)
		TYPE (FUNCALL PATHNAME ':TYPE))
	  (COND ((OR (PLUSP N-TO-DELETE)
		     (MEMBER TYPE *TEMP-FILE-TYPE-LIST*))
		 (OR (GET (LOCF (LINE-PLIST LINE)) ':DONT-REAP)
		     (WITH-READ-ONLY-SUPPRESSED (*INTERVAL*)
		        (MUNG-LINE LINE)
			(ASET #/D LINE 0)))
		 (AND (NOT (MEMQ (FUNCALL PATHNAME ':VERSION) '(:NEWEST :UNSPECIFIC)))
		      (SETQ N-TO-DELETE (1- N-TO-DELETE))))))))
  DIS-TEXT)

(DEFCOM COM-DIRED-AUTOMATIC-ALL "Mark all superfluous files for deletion." ()
  (DO ((LINE (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*)) (LINE-NEXT LINE))
       (STOP-LINE (BP-LINE (INTERVAL-LAST-BP *INTERVAL*)))
       (NAME NIL)	;If non-NIL is TYPE being skipped
       (TYPE)
       (*NUMERIC-ARG-P* NIL)
       (PATHNAME)
       (FIRST-FILE-LINE NIL))
      ((EQ LINE STOP-LINE)
       (MOVE-BP (POINT) FIRST-FILE-LINE 0))
    (SETQ PATHNAME (DIRED-LINE-PATHNAME LINE))
   CHECK-THIS
    (COND (PATHNAME
	   (OR FIRST-FILE-LINE (SETQ FIRST-FILE-LINE LINE))
	   (COND ((NULL NAME)
		  (MOVE-BP (POINT) LINE 0)
		  (COM-DIRED-AUTOMATIC)
		  (SETQ NAME (FUNCALL PATHNAME ':NAME)
			TYPE (FUNCALL PATHNAME ':TYPE)))
		 ((AND (EQUAL (FUNCALL PATHNAME ':NAME) NAME)
		       (OR (EQUAL (FUNCALL PATHNAME ':TYPE) TYPE)
			   (MEMQ (FUNCALL PATHNAME ':VERSION) '(:NEWEST :UNSPECIFIC)))))
		 (T (SETQ NAME NIL)
		    (GO CHECK-THIS))))))
 DIS-TEXT)

(DEFCOM COM-DIRED-CHANGE-FILE-PROPERTIES "Change the properties of this file." ()
  (CHANGE-FILE-PROPERTIES (DIRED-LINE-PATHNAME (BP-LINE (POINT))))
  DIS-NONE)

(DEFFLAVOR STANDALONE-MAIL-OR-DIRED-MIXIN () ()
  (:INCLUDED-FLAVORS TOP-LEVEL-EDITOR))

(DEFMETHOD (STANDALONE-MAIL-OR-DIRED-MIXIN :EXIT-SPECIAL-BUFFER) (&OPTIONAL IGNORE)
  (*THROW 'EXIT-TOP-LEVEL T))

(DEFMETHOD (STANDALONE-MAIL-OR-DIRED-MIXIN :FIND-BUFFER-NAMED) (&REST IGNORE))

(DEFMETHOD (STANDALONE-MAIL-OR-DIRED-MIXIN :FIND-SPECIAL-BUFFER) (&REST IGNORE))

(DEFFLAVOR DIRED-TOP-LEVEL-EDITOR
       ((*MAJOR-MODE* 'DIRED-MODE)
	*DIRED-PATHNAME-NAME*)
       (STANDALONE-MAIL-OR-DIRED-MIXIN TOP-LEVEL-EDITOR)
  (:DOCUMENTATION :SPECIAL-PURPOSE "The editor for the (DIRED) function"))

(DEFMETHOD (DIRED-TOP-LEVEL-EDITOR :DIRED) (PATHNAME &AUX FRAME)
  (SETQ PATHNAME (FS:MERGE-PATHNAME-DEFAULTS PATHNAME
					     (FUNCALL FS:LAST-FILE-OPENED ':NEW-PATHNAME
						      ':NAME ':WILD ':TYPE ':WILD
						      ':VERSION ':WILD)
					     ':WILD ':WILD))
  (DIRECTORY-EDIT PATHNAME)
  (MUST-REDISPLAY *WINDOW* DIS-ALL)
  (SETQ FRAME (WINDOW-FRAME *WINDOW*))
  (TV:WINDOW-CALL (FRAME :DEACTIVATE)
    (FUNCALL *TYPEOUT-WINDOW* ':MAKE-COMPLETE)	;Make sure typeout window does not come up
    (FUNCALL-SELF ':EDIT)))

(DEFVAR *DIRED-COMMAND-LOOP*)

(DEFUN INITIALIZE-DIRED-COMMAND-LOOP ()
  (OR (BOUNDP '*DIRED-COMMAND-LOOP*)
      (LET* ((FRAME (TV:MAKE-WINDOW 'ZWEI-FRAME))
	     (WINDOW (FUNCALL FRAME ':CREATE-WINDOW 'ZWEI-WINDOW-PANE ':LABEL "Dired")))
	(SET-WINDOW-INTERVAL WINDOW (CREATE-INTERVAL NIL NIL T))
	(SETQ *DIRED-COMMAND-LOOP* (MAKE-COMMAND-LOOP *STANDARD-COMTAB* WINDOW
						      'DIRED-TOP-LEVEL-EDITOR)))))

(ADD-INITIALIZATION "INITIALIZE-DIRED-COMMAND-LOOP" '(INITIALIZE-DIRED-COMMAND-LOOP)
		    '(:NORMAL) '*EDITOR-INITIALIZATION-LIST*)

(DEFUN DIRED (&OPTIONAL (PATHNAME ""))
  (FUNCALL *DIRED-COMMAND-LOOP* ':DIRED PATHNAME))

(DEFCOM COM-REAP-FILE "Delete multiple versions of the specified file." ()
  (LET ((PATHNAME (READ-DEFAULTED-WILD-PATHNAME "Reap file" (DEFAULT-PATHNAME))))
    (PROMPT-LINE "")
    (REAP-FILE PATHNAME
	       (IF *NUMERIC-ARG-P* *NUMERIC-ARG* *FILE-VERSIONS-KEPT*)
	       *MODE-LINE-WINDOW*))
  (FUNCALL *TYPEOUT-WINDOW* ':MAKE-COMPLETE)
  DIS-NONE)

(DEFUN REAP-FILE (&OPTIONAL (PATHNAME "")
			    (N-TO-KEEP *FILE-VERSIONS-KEPT*)
			    (PROMPT-STREAM STANDARD-OUTPUT))
  (SETQ PATHNAME (FS:MERGE-PATHNAME-DEFAULTS PATHNAME
					     (FUNCALL FS:LAST-FILE-OPENED ':NEW-PATHNAME
						      ':TYPE ':WILD ':VERSION ':WILD)
					     ':WILD ':WILD))
  (FORMAT PROMPT-STREAM "~&Reaping ~A" PATHNAME)
  (REAP-DIRECTORY PATHNAME N-TO-KEEP STANDARD-OUTPUT))

(DEFCOM COM-CLEAN-DIRECTORY "Delete multiple versions in the specified directory." ()
  (LET ((PATHNAME (READ-DIRECTORY-NAME "Clean directory" (DEFAULT-PATHNAME))))
    (PROMPT-LINE "")
    (CLEAN-DIRECTORY PATHNAME
		     (IF *NUMERIC-ARG-P* *NUMERIC-ARG* *FILE-VERSIONS-KEPT*)
		     *MODE-LINE-WINDOW*))
  (FUNCALL *TYPEOUT-WINDOW* ':MAKE-COMPLETE)
  DIS-NONE)

(DEFUN CLEAN-DIRECTORY (&OPTIONAL (PATHNAME FS:LAST-FILE-OPENED)
				  (N-TO-KEEP *FILE-VERSIONS-KEPT*)
				  (PROMPT-STREAM STANDARD-OUTPUT))
  (SETQ PATHNAME (FS:MERGE-PATHNAME-DEFAULTS PATHNAME
					     (FUNCALL FS:LAST-FILE-OPENED ':NEW-PATHNAME
						      ':NAME ':WILD ':TYPE ':WILD
						      ':VERSION ':WILD)
					     ':WILD ':WILD))
  (FORMAT PROMPT-STREAM "~&Cleaning ~A for >~D versions"
	  PATHNAME N-TO-KEEP)
  (REAP-DIRECTORY PATHNAME N-TO-KEEP STANDARD-OUTPUT))

(DEFPROP DIRED-PATHNAME-LESSP COMPILER:OBSOLETE COMPILER:STYLE-CHECKER)
(DEFPROP DIRED-PATHNAME-LESSP "is an obsolete function; use FS:PATHNAME-LESSP"
	 COMPILER:OBSOLETE)
(DEFF DIRED-PATHNAME-LESSP 'FS:PATHNAME-LESSP)

(DEFUN REAP-DIRECTORY (PATHNAME N-TO-KEEP STREAM &AUX DIRECTORY-LIST)
  (SETQ DIRECTORY-LIST (FS:DIRECTORY-LIST PATHNAME ':SORTED))
  (SETQ DIRECTORY-LIST (DELQ (ASSQ NIL DIRECTORY-LIST) DIRECTORY-LIST))
  (DO ((LIST DIRECTORY-LIST (CDR LIST))
       (HEAD NIL)
       (PREV-NAME NIL NAME) (NAME)
       (PREV-TYPE NIL TYPE) (TYPE)
       (PATHNAME))
      (NIL)
    (AND LIST
	 (SETQ PATHNAME (CAAR LIST)
	       NAME (FUNCALL PATHNAME ':NAME)
	       TYPE (FUNCALL PATHNAME ':TYPE)))
    (COND ((OR (NULL LIST)
	       (NOT (EQUAL PREV-NAME NAME))
	       (AND (NOT (EQUAL PREV-TYPE TYPE))
		    (NEQ (FUNCALL PATHNAME ':VERSION) ':UNSPECIFIC)))
	   (AND HEAD (REAP-ONE-FILE HEAD LIST N-TO-KEEP STREAM))
	   (OR (SETQ HEAD LIST) (RETURN NIL))))))

(DEFUN REAP-ONE-FILE (HEAD TAIL N-TO-KEEP STREAM
		      &AUX (N-VERSIONS 0) DELETE-LIST KEEP-LIST)
  (DO LIST HEAD (CDR LIST) (EQ LIST TAIL)
    (AND (NUMBERP (FUNCALL (CAAR LIST) ':VERSION))
	 (SETQ N-VERSIONS (1+ N-VERSIONS))))
  (DO ((LIST HEAD (CDR LIST))
       (N-TO-DELETE (- N-VERSIONS N-TO-KEEP))
       (FILE) (PATHNAME) (VERSION))
      ((EQ LIST TAIL)
       (SETQ DELETE-LIST (NREVERSE DELETE-LIST)
	     KEEP-LIST (NREVERSE KEEP-LIST)))
    (SETQ FILE (CAR LIST)
	  PATHNAME (CAR FILE)
	  VERSION (FUNCALL PATHNAME ':VERSION))
    (IF (AND (OR (AND (NUMBERP VERSION) (PLUSP N-TO-DELETE))
		 (MEMBER (FUNCALL PATHNAME ':TYPE) *TEMP-FILE-TYPE-LIST*))
	     (NOT (GET FILE ':DONT-REAP)))
	(PUSH FILE DELETE-LIST)
	(PUSH FILE KEEP-LIST))
    (AND (NUMBERP VERSION)
	 (SETQ N-TO-DELETE (1- N-TO-DELETE))))
  (COND (DELETE-LIST
	 (COND (KEEP-LIST
		(FORMAT STREAM "~&Keeping the following file~P:~%"
			(LENGTH KEEP-LIST))
		(DOLIST (FILE KEEP-LIST)
		  (FUNCALL *DIRECTORY-SINGLE-FILE-LISTER* FILE))))
	 (FORMAT STREAM "~&Deleting the following file~P:~%"
		 (LENGTH DELETE-LIST))
	 (DOLIST (FILE DELETE-LIST)
	   (FUNCALL *DIRECTORY-SINGLE-FILE-LISTER* FILE))
	 (AND (Y-OR-N-P "Ok? " STREAM)
	      (DO ((L DELETE-LIST (CDR L))
		   (PATHNAME) (ERRMES))
		  ((NULL L))
		(SETQ PATHNAME (CAAR L))
		(SETQ ERRMES (DELETEF PATHNAME NIL))
		(AND (STRINGP ERRMES)
		     (FORMAT STREAM "~&Cannot delete ~A because ~A.~%" PATHNAME ERRMES)))))))

(DEFCOM COM-CHANGE-FILE-PROPERTIES "Change properties on a file" ()
  (LET ((PATHNAME (READ-DEFAULTED-PATHNAME "Change properties for" (PATHNAME-DEFAULTS)
					   NIL NIL ':DELETED)))
    (CHANGE-FILE-PROPERTIES PATHNAME))
  DIS-NONE)

(DEFUN CHANGE-FILE-PROPERTIES (PATHNAME &AUX DIRECTORY INDICATORS VALUES CHOICES CHANGES)
  (MULTIPLE-VALUE (DIRECTORY INDICATORS)
    (FS:FILE-PROPERTIES PATHNAME NIL))
  (AND (STRINGP DIRECTORY) (BARF "Err: ~A" DIRECTORY))
  (OR (SETQ PATHNAME (CAR DIRECTORY))
      (BARF "Err:  File not found"))
  (SETQ VALUES (LOOP FOR IND IN INDICATORS
		     COLLECT (GET DIRECTORY IND)))
  (SETQ CHOICES (LOOP FOR IND IN INDICATORS
		      COLLECT (LIST IND
				    (OR (GET IND 'PRETTY-NAME)
					(PUTPROP IND
						 (PRETTY-COMMAND-NAME (STRING-APPEND IND))
						 'PRETTY-NAME))
				    (DO ((L FS:*KNOWN-DIRECTORY-PROPERTIES* (CDR L)))
					((NULL L) ':SEXP)
				      (AND (MEMQ IND (CDAR L))
					   (RETURN (CADDR (CAAR L))))))))
  (LET ((BASE 10.) (IBASE 10.) (*NOPOINT T))
    (*CATCH 'ABORT
      (PROGV INDICATORS VALUES
	(TV:CHOOSE-VARIABLE-VALUES CHOICES
				   ':LABEL (FORMAT NIL "Change properties for ~A" PATHNAME)
				   ':MARGIN-CHOICES '("Do It"
						      ("Abort" (*THROW 'ABORT T))))
	(SETQ CHANGES (LOOP FOR IND IN INDICATORS
			    FOR VAL IN VALUES
			    AS NEW = (SYMEVAL IND)
			    WHEN (NOT (EQUAL NEW VAL))
			    NCONC (LIST IND NEW))))
      (LEXPR-FUNCALL #'FS:CHANGE-FILE-PROPERTIES PATHNAME T CHANGES))))

;;; Send mail
(DEFMINOR COM-MAIL-MODE MAIL-MODE "Mail" 1 "Setup for mailing" ()
  (SET-CHAR-SYNTAX WORD-ALPHABETIC *MODE-WORD-SYNTAX-TABLE* #/_)
  (SET-CHAR-SYNTAX WORD-ALPHABETIC *MODE-WORD-SYNTAX-TABLE* #/')
  (SET-CHAR-SYNTAX WORD-DELIMITER *MODE-WORD-SYNTAX-TABLE* #/.)
  (SET-COMTAB *MODE-COMTAB* '(#/ COM-EXIT-COM-MAIL
			      #\END COM-EXIT-COM-MAIL
			      #\ABORT COM-QUIT-COM-MAIL
			      #/] COM-QUIT-COM-MAIL
			      #\TAB COM-TAB-TO-TAB-STOP))
  (SETQ *COMMENT-START* NIL)		;Be like Text mode
  ;; This FORMAT is here to dynamically figure out how to type the character
  (SETQ *MODE-LINE-LIST* `(,@*MODE-LINE-LIST* ,(FORMAT NIL "     ~:@C mails, ~:@C aborts"
						       #\END #\ABORT)))
	;;This makes M-Q and M-[ understand the --Text follows this line-- line
  (SETQ *PARAGRAPH-DELIMITER-LIST* (CONS #/- *PARAGRAPH-DELIMITER-LIST*)))

(DEFCOM COM-MAIL "Send mail.
Puts you into the buffer *MAIL*.  With a numeric argument
retains the previous contents of the buffer.  Above the funny
line you can put TO:, CC:, SUBJECT: (or S:), and FROM: lines to
control the mailing process.  Below the funny line you put the
text of the message.  End causes the mail to be transmitted.
Abort quits out." ()
  (COM-MAIL-INTERNAL (NOT *NUMERIC-ARG-P*)))

;;;Create a buffer, put it in text mode, initialize to the right thing, enter
;;;recursive R, when user exits, write mail request file.
(DEFUN COM-MAIL-INTERNAL (RE-INIT-P &OPTIONAL WHO WHAT)
  (FUNCALL-SELF ':FIND-SPECIAL-BUFFER ':MAIL RE-INIT-P "Mail" 2 'TEXT-MODE)
  (COM-TEXT-MODE)
  (TURN-ON-MODE 'MAIL-MODE)
  (COND (RE-INIT-P				;With no numeric arg, re-initialize the buffer
	 (DELETE-INTERVAL *INTERVAL*)
	 (INSERT-MOVING (POINT) "To: ")
	 (AND WHO (INSERT-MOVING (POINT) WHO))
	 (LET ((BP (INSERT (POINT) "
--Text follows this line--
")))
	   (AND WHAT (INSERT-MOVING BP WHAT))
	   (AND WHO (MOVE-BP (POINT) BP)))))
  DIS-TEXT)

(DEFCOM COM-QUIT-COM-MAIL "Abort sending mail, but announce how to continue" ()
  (TYPEIN-LINE "Quitting, you may continue")
  (IF (TYPEP SELF 'MAIL-TOP-LEVEL-EDITOR)
      (TYPEIN-LINE-MORE " with (MAIL T)")
      (LET ((STANDARD-OUTPUT *TYPEIN-WINDOW*))
	   (FIND-COMMAND-ON-KEYS 'COM-MAIL 1 " by giving a numeric arg to ")))
  (FUNCALL-SELF ':EXIT-SPECIAL-BUFFER))

(DEFCOM COM-EXIT-COM-MAIL "Actually transmits the mail." ()
  (LET* ((BP1 (INTERVAL-FIRST-BP *INTERVAL*))
	 (BP2 (OR (SEARCH BP1 "--Text follows this line--")
		  (BARF "You've messed up the buffer"))))
    ;; Call ZMail to do the actual sending in the appropriate manner for this host
    (SEND-MESSAGE BP1 (BEG-LINE BP2) T (BEG-LINE BP2 1 T) (INTERVAL-LAST-BP *INTERVAL*) T))
  (FUNCALL-SELF ':EXIT-SPECIAL-BUFFER T))

(DEFFLAVOR MAIL-TOP-LEVEL-EDITOR
       ((*MAJOR-MODE* 'TEXT-MODE))
       (STANDALONE-MAIL-OR-DIRED-MIXIN TOP-LEVEL-EDITOR)
  (:DOCUMENTATION :SPECIAL-PURPOSE "The editor for the (MAIL) function"))

(DEFMETHOD (MAIL-TOP-LEVEL-EDITOR :MAIL) (WHO WHAT &AUX (RE-INIT-P T) FRAME)
  (AND (EQ WHO T) (SETQ RE-INIT-P NIL WHO NIL))
  (COM-MAIL-INTERNAL RE-INIT-P (AND WHO (STRING WHO)) (AND WHAT (STRING WHAT)))
  (MUST-REDISPLAY *WINDOW* DIS-ALL)
  (SETQ FRAME (WINDOW-FRAME *WINDOW*))
  (TV:WINDOW-CALL (FRAME :DEACTIVATE)
    (FUNCALL-SELF ':EDIT)))

(DEFVAR *MAIL-COMMAND-LOOP*)

(DEFUN INITIALIZE-MAIL-COMMAND-LOOP ()
  (OR (BOUNDP '*MAIL-COMMAND-LOOP*)
      (LET* ((FRAME (TV:MAKE-WINDOW 'ZWEI-FRAME))
	     (WINDOW (FUNCALL FRAME ':CREATE-WINDOW 'ZWEI-WINDOW-PANE ':LABEL "Mail")))
	(SET-WINDOW-INTERVAL WINDOW (CREATE-INTERVAL NIL NIL T))
	(SETQ *MAIL-COMMAND-LOOP* (MAKE-COMMAND-LOOP *STANDARD-COMTAB* WINDOW
						     'MAIL-TOP-LEVEL-EDITOR)))))

(ADD-INITIALIZATION "INITIALIZE-MAIL-COMMAND-LOOP" '(INITIALIZE-MAIL-COMMAND-LOOP)
		    '(:NORMAL) '*EDITOR-INITIALIZATION-LIST*)

;;; Top level functions for mailing
(DEFUN MAIL (&OPTIONAL WHO WHAT)
  (FUNCALL *MAIL-COMMAND-LOOP* ':MAIL WHO WHAT))

(DEFUN BUG (&OPTIONAL (WHO 'LISPM) WHAT)
  (MULTIPLE-VALUE-BIND (WHOM WHAT0)
      (PARSE-BUG-ARG WHO)
    (AND WHAT (SETQ WHAT0 (STRING-APPEND WHAT0 #\CR WHAT)))
    (MAIL WHOM WHAT0)))

(DEFINE-SITE-VARIABLE *HOST-FOR-BUG-REPORTS* :HOST-FOR-BUG-REPORTS)

(DEFUN PARSE-BUG-ARG (WHO)
  (VALUES (STRING-APPEND "BUG-" WHO #/@ *HOST-FOR-BUG-REPORTS*)
	  (FORMAT NIL
		  "In~:[ ~A in~;~*~] ~A, on ~A:~2%"
		  (STRING-EQUAL WHO "LISPM") WHO
		  (SI:SYSTEM-VERSION-INFO)
		  SI:LOCAL-PRETTY-HOST-NAME)))

(DEFCOM COM-BUG "Setup mail buffer for sending a bug report, arg prompts for type" ()
  (LET (WHO WHAT)
    (COND (NIL ;(NOT *NUMERIC-ARG-P*)
	   (SETQ WHO 'LISPM))
	  (T
	   (SETQ WHO (TEMP-KILL-RING "ZWEI" (TYPEIN-LINE-READLINE
					      "Report bug to BUG- (default LISPM)")))
	   (AND (EQUAL WHO "") (SETQ WHO 'LISPM))))
    (MULTIPLE-VALUE (WHO WHAT)
      (PARSE-BUG-ARG WHO))
    (COM-MAIL-INTERNAL T WHO WHAT)))

(DEFFLAVOR SOURCE-COMPARE-MERGE-TOP-LEVEL-EDITOR () (TOP-LEVEL-EDITOR))

(DEFVAR *SOURCE-COMPARE-MERGE-COMMAND-LOOP*)

(DEFUN INITIALIZE-SOURCE-COMPARE-MERGE-COMMAND-LOOP ()
  (OR (BOUNDP '*SOURCE-COMPARE-MERGE-COMMAND-LOOP*)
      (LET* ((FRAME (TV:MAKE-WINDOW 'ZWEI-FRAME))
	     (WINDOW (FUNCALL FRAME ':CREATE-WINDOW 'ZWEI-WINDOW-PANE
			      ':LABEL "Source compare merge")))
	(SET-WINDOW-INTERVAL WINDOW (CREATE-INTERVAL NIL NIL T))
	(SETQ *SOURCE-COMPARE-MERGE-COMMAND-LOOP*
	      (MAKE-COMMAND-LOOP *STANDARD-COMTAB* WINDOW
				 'SOURCE-COMPARE-MERGE-TOP-LEVEL-EDITOR)))))

(DEFUN SOURCE-COMPARE-MERGE (PATHNAME-1 PATHNAME-2 OUTPUT-PATHNAME)
  (INITIALIZE-SOURCE-COMPARE-MERGE-COMMAND-LOOP)
  (FUNCALL *SOURCE-COMPARE-MERGE-COMMAND-LOOP* ':SOURCE-COMPARE-MERGE
	   (FS:MERGE-PATHNAME-DEFAULTS PATHNAME-1)
	   (FS:MERGE-PATHNAME-DEFAULTS PATHNAME-2 PATHNAME-1)
	   (FS:MERGE-PATHNAME-DEFAULTS OUTPUT-PATHNAME PATHNAME-2)))

(DEFMETHOD (SOURCE-COMPARE-MERGE-TOP-LEVEL-EDITOR :SOURCE-COMPARE-MERGE)
	   (PATHNAME-1 PATHNAME-2 OUTPUT-PATHNAME &AUX FRAME FILE-1 FILE-2)
  (DELETE-INTERVAL *INTERVAL*)
  (MUST-REDISPLAY *WINDOW* DIS-ALL)
  (SETQ FRAME (WINDOW-FRAME *WINDOW*))
  (MULTIPLE-VALUE-BIND (TERMINAL-IO STANDARD-INPUT STANDARD-OUTPUT QUERY-IO)
      (FUNCALL-SELF ':TERMINAL-STREAMS)
    (TV:WINDOW-CALL (FRAME :DEACTIVATE)
      (FUNCALL *TYPEOUT-WINDOW* ':MAKE-COMPLETE)
      (SELECT-WINDOW *WINDOW*)
      (TV:PROCESS-TYPEAHEAD TV:IO-BUFFER
			    #'(LAMBDA (CH)
				(COND ((NLISTP CH) CH)
				      ((EQ (CAR CH) 'SELECT-WINDOW)
				       (APPLY #'PROCESS-SPECIAL-COMMAND CH)
				       NIL)
				      ((MEMQ (CAR CH) '(CONFIGURATION-CHANGED REDISPLAY))
				       NIL)
				      (T CH))))
      (UNWIND-PROTECT
	(PROGN
	  (SETQ FILE-1 (SRCCOM:CREATE-FILE PATHNAME-1)
		FILE-2 (SRCCOM:CREATE-FILE PATHNAME-2))
	  (LET ((MARKS (SRCCOM:SOURCE-COMPARE-AUTOMATIC-MERGE-RECORDING
			 FILE-1 FILE-2 (INTERVAL-STREAM *INTERVAL*))))
	    (SOURCE-COMPARE-MERGE-QUERY MARKS))
	  (WITH-OPEN-FILE (STREAM OUTPUT-PATHNAME '(:OUT))
	    (STREAM-OUT-INTERVAL STREAM *INTERVAL*)
	    (CLOSE STREAM)
	    (FUNCALL STREAM ':TRUENAME)))
	(AND FILE-1 (FUNCALL (SRCCOM:FILE-STREAM FILE-1) ':CLOSE))
	(AND FILE-2 (FUNCALL (SRCCOM:FILE-STREAM FILE-2) ':CLOSE))))))