;;; -*- Mode:LISP; Package:ZWEI; Base:10; Readtable:CL -*-


;(DEFUN NEED-TO-REVERT-BUFFER (PATHNAME)
;  (LET ((PROBE-STREAM (PROBEF (SEND PATHNAME :NEW-VERSION :NEWEST))))
;    (IF (NOT PROBE-STREAM)
;	(BARF "Cannot find any existing versions of ~A.  Perhaps all versions have been deleted."
;	      PATHNAME)
;      (let ((desired-version (SEND PROBE-STREAM :VERSION)))
;	(IF (GREATERP desired-version
;		      (SEND PATHNAME :VERSION))
;	    (COND ((EQUAL (COMPLETING-READ-FROM-MINI-BUFFER 
;			    "A newer version of this file exists now.  Revert this DIRED buffer? (default is no)" 
;			    '(("yes") ("no")))
;			  '("yes"))
;		   (values (REVERT-BUFFER *INTERVAL*) nil))
;		  ((EQUAL (COMPLETING-READ-FROM-MINI-BUFFER
;			    "Do you want to see the newest version? (default is no)"
;			    '(("yes") ("no")))
;			  '("yes"))
;		   (VALUES (SEND PATHNAME :NEW-VERSION :NEWEST) desired-version))
;		  (T (VALUES PATHNAME NIL)))
;	  (VALUES (SEND PATHNAME :NEW-VERSION :NEWEST) DESIRED-VERSION))))))

;(DEFCOM COM-DIRED-EDIT-FILE "Edit the current file; or DIRED it if it's a directory." ()
;  (OR (TYPEP *WINDOW* 'ZMACS-WINDOW) (BARF "Files can only be edited in ZMACS windows."))
;  (WHEN (GETF (LINE-PLIST (BP-LINE (POINT))) ':DELETED)
;    (BARF "The file ~A has been marked as DELETED.  To compare contents, first undelete this file."
;	  (DIRED-LINE-PATHNAME (bp-line (point)))))
;  (LET* ((LINE (BP-LINE (POINT)))
;	 (DIR-P (GETF (LINE-PLIST LINE) ':DIRECTORY))
;	 (PATHNAME (DIRED-LINE-PATHNAME-OR-BARF LINE))
;	 version-we-want) ;if version of pathname is :NEWEST, otherwise NIL.  This avoids bug
;		;where there exists a > buffer, but some other machine has written a new version
;		;in the meantime.
;    (AND (NOT DIR-P) ; Reversion doesn't make sense for recursive Dired
;	 (GETF (LINE-PLIST LINE) ':NEWEST)
;	 (IF (NULL (MULTIPLE-VALUE-SETQ (PATHNAME version-we-want)
;		     (NEED-TO-REVERT-BUFFER PATHNAME)))
;	     (BARF "Please retype the command.")))
;    (IF DIR-P
;	(DIRECTORY-EDIT (SEND (SEND PATHNAME :PATHNAME-AS-DIRECTORY) :NEW-PATHNAME
;			      					      :NAME :WILD
;								      :TYPE :WILD
;								      :VERSION :WILD))
;      (select-buffer-pathname pathname version-we-want)
;      (LET ((RETURN-KEY (KEY-FOR-COMMAND 'COM-SELECT-PREVIOUS-BUFFER
;				    *COMTAB* NIL NIL #/C-M-L)))
;	(AND (NULL RETURN-KEY) (SETQ RETURN-KEY (KEY-FOR-COMMAND 'COM-SELECT-BUFFER))
;	     (SETQ RETURN-KEY (STRING-APPEND RETURN-KEY " Return")))
;	(AND RETURN-KEY
;	     (FORMAT *QUERY-IO* "~&Type ~A to return to DIRED~%" RETURN-KEY))
;	DIS-TEXT))))

;(defun select-buffer-pathname (pathname &optional version-we-want)
;  "Select buffer associated with PATHNAME, if any.  If version-we-want non-NIL,
;make sure buffer is associated with this version (particularily important for #> buffers."
;  (LET ((BUFFER (FIND-FILE-BUFFER PATHNAME)))
;    (cond ((null buffer) (FIND-FILE PATHNAME))
;	  ((or (null version-we-want)
;	       (symbolp (buffer-file-id buffer))
;	       (eq version-we-want (buffer-file-version-if-known buffer)))
;	   (MAKE-BUFFER-CURRENT BUFFER))
;	  ((if (buffer-modified-p buffer)
;	       (equal (completing-read-from-mini-buffer
;			"Since #> buffer was created, a newer version exists.  THIS BUFFER HAS BEEN MODIFIED.  Revert? (default is no)"
;			'(("yes") ("no")))
;		      '("yes"))
;	     (not (equal (completing-read-from-mini-buffer
;			   "Since #> buffer was created, a newer version exists.  Revert? (default is yes)"
;			   '(("yes") ("no")))
;			 '("no"))))
;	   (revert-buffer buffer)
;	   (make-buffer-current buffer))
;	  (t (make-buffer-current buffer)))))


;(DEFUN WRITE-BUFFER (BUFFER)
;  "Write BUFFER to a file, reading filename in mini buffer."
;  (LET ((PATHNAME (READ-DEFAULTED-PATHNAME (FORMAT NIL "Write buffer ~A to File:"
;						   (BUFFER-NAME BUFFER))
;					   (PATHNAME-DEFAULTS *PATHNAME-DEFAULTS* BUFFER)
;					   NIL NIL :WRITE)))
;    (WRITE-FILE-INTERNAL PATHNAME BUFFER))
;  DIS-NONE)

;(DEFCOM COM-WRITE-FILE "Write out the buffer to the specified file." ()
;  (WRITE-BUFFER *INTERVAL*)
;  (MAYBE-DISPLAY-DIRECTORY :WRITE)
;  DIS-NONE)

;;; Copied from LAD: RELEASE-3.ZWEI; ZMACS.LISP#558 on 2-Oct-86 02:29:19
;(DEFUN WRITE-FILE-INTERNAL (PATHNAME &OPTIONAL (BUFFER *INTERVAL*))
;  "Save BUFFER in file PATHNAME and mark it as visiting that file.
;If the file holds the current ODM node, handle it appropriately."
;  (if (and (boundp '*current-gateway-buffer*)
;	   (eq buffer *current-gateway-buffer*)
;	   (fboundp 'write-file-internal-odm))
;        (write-file-internal-odm pathname buffer)
;  (SEND BUFFER :WRITE-FILE-INTERNAL PATHNAME)))  ;in METH.LISP

;(DEFUN SET-BUFFER-PATHNAME (PATHNAME &OPTIONAL (BUFFER *INTERVAL*) &AUX STRING)
;  "Set the pathname BUFFER is visiting to PATHNAME."
;  (SETF (BUFFER-PATHNAME BUFFER) (SEND PATHNAME :TRANSLATED-PATHNAME))
;  (SETF (BUFFER-GENERIC-PATHNAME BUFFER) (SEND PATHNAME :GENERIC-PATHNAME))
;  (SETQ STRING (SEND PATHNAME :STRING-FOR-EDITOR))
;  (COND ((EQUALP (BUFFER-NAME BUFFER) STRING)
;	 NIL)
;	((CL:ASSOC STRING *ZMACS-BUFFER-NAME-ALIST* :TEST #'EQUALP)
;	 (FORMAT *QUERY-IO* "~&Not renaming the buffer!  There is already a buffer named ~A"
;		 STRING))
;	(T
;	 (SIMILAR-BUFFER-FILES-WARNING BUFFER)
;	 (SEND BUFFER :RENAME STRING)
;;Should no longer be necessary.
;;	 ;; Transfer the attribute list info to the new pathname.
;;	 (LET ((PKG (BUFFER-PACKAGE BUFFER)))
;;	   (REPARSE-BUFFER-attribute-list BUFFER)
;;	   (SETF (BUFFER-PACKAGE BUFFER) PKG))
;	 )))

;(DEFUN SIMILAR-BUFFER-FILES-WARNING (BUFFER &AUX SAME-NAME SAME-TYPE SAME-EVERYTHING)
;  "Warn if any buffer other than BUFFER is visiting the same or a similar file."
;  (DOLIST (ELT *ZMACS-BUFFER-NAME-ALIST*)
;    (AND (NEQ (CDR ELT) BUFFER)
;	 (BUFFER-PATHNAME (CDR ELT))
;	 (BUFFER-FILE-ID (CDR ELT))
;	 (NOT (NODE-SPECIAL-TYPE (CDR ELT)))
;	 (IF (EQUALP (SEND (BUFFER-PATHNAME BUFFER) :STRING-FOR-EDITOR)
;		     (SEND (BUFFER-PATHNAME (CDR ELT)) :STRING-FOR-EDITOR))
;	     (RETURN (SETQ SAME-EVERYTHING (CDR ELT)))
;	   (IF (EQUALP (SEND (BUFFER-PATHNAME BUFFER) :NAME)
;		       (SEND (BUFFER-PATHNAME (CDR ELT)) :NAME))
;	       (COND ((EQUALP (SEND (BUFFER-PATHNAME BUFFER) :TYPE)
;			      (SEND (BUFFER-PATHNAME (CDR ELT)) :TYPE))
;		      (SETQ SAME-TYPE (CDR ELT)))
;		     (T (SETQ SAME-NAME (CDR ELT))))))))
;  (IF SAME-EVERYTHING
;      (FORMAT *QUERY-IO* "~&Warning: Buffer ~A~&  is also visiting file ~A."
;	      (BUFFER-NAME SAME-EVERYTHING) (BUFFER-PATHNAME SAME-EVERYTHING))
;    (LET ((LOSER (OR SAME-TYPE SAME-NAME)))
;      (IF LOSER
;	  (FORMAT *QUERY-IO* "~&Note: Another buffer ~A~&  is visiting file ~A."
;		  (BUFFER-NAME LOSER) (BUFFER-PATHNAME LOSER))))))

;(DEFUN SET-BUFFER-FILE-ID (BUFFER INFO)
;  "Set the BUFFER-FILE-ID of BUFFER to INFO.
;Records the file BUFFER was last read or saved in."
;  (SETF (BUFFER-FILE-ID BUFFER) INFO)
;  (LET ((VERSION-STRING (AND (TYPEP (CAR-SAFE INFO) 'FS:PATHNAME)
;			     (BUFFER-PATHNAME BUFFER)
;			     (NOT (NUMBERP (SEND (BUFFER-PATHNAME BUFFER) :VERSION)))
;			     (LET ((VERSION (SEND (CAR INFO) :VERSION)))
;			       (AND (NUMBERP VERSION) (FORMAT NIL " (~D)" VERSION))))))
;    (SETF (BUFFER-VERSION-STRING BUFFER) VERSION-STRING)
;    (AND (EQ BUFFER *INTERVAL*) (SETQ *ZMACS-BUFFER-VERSION-STRING* VERSION-STRING)))
;  INFO)

;(defun buffer-file-version-if-known (buffer)
; "NIL or the version of the truename associated with this buffer"
; ;--unfortunately, the truename is not stored directly, it should be. --rg.
;  (let ((info (buffer-file-id buffer)))
;    (if (and (memq (type-of (car-safe info)) '(fs:pathname fs:lm-pathname))
;	     (buffer-pathname buffer))
;	(let ((v (send (buffer-pathname buffer) :version)))
;	  (if (numberp v)
;	      v
;	      (send (car info) :version))))))

;
;(DEFCOM COM-REVERT-BUFFER "Forgets changes to a specified buffer.
;Reads the name of the buffer from the mini-buffer and reads back in the file
;or function." ()
;  (LET ((BUFFER (READ-BUFFER-NAME "Buffer to revert:" *INTERVAL*)))
;    (if (not *numeric-arg*)
;	(progn (REVERT-BUFFER BUFFER)
;	       (MUST-REDISPLAY-BUFFER BUFFER DIS-TEXT)
;	       DIS-NONE)
;      (let* ((assoc-file (condition-case () (send buffer :pathname)
;			   (fs:file-not-found (warn "The buffer ~A has no associated pathname."))))
;	     (truename (send assoc-file :truename))
;	     (most-recent-file

;(DEFUN REVERT-BUFFER (BUFFER &OPTIONAL (PATHNAME (BUFFER-PATHNAME BUFFER))
;				       (CONNECT-FLAG (BUFFER-FILE-ID BUFFER))
;				       SELECT-FLAG
;				       QUIETLY-FLAG)
;  "Read file PATHNAME, or BUFFER's visited file into BUFFER.
;CONNECT-FLAG non-NIL means mark BUFFER as visiting the file.
; This may change the buffer's name.
; It defaults non-NIL if BUFFER is visiting a file now.
;If CONNECT-FLAG is NOSECTIONIZE, mark buffer as visiting but don't sectionize it.
;SELECT-FLAG non-NIL means select BUFFER.
;QUIETLY-FLAG means do not print a message about reading a file."
;  (SEND BUFFER :REVERT PATHNAME CONNECT-FLAG SELECT-FLAG QUIETLY-FLAG))

;;; Only the :REVERT method for FILE-BUFFER calls this.
;(DEFUN REVERT-FILE-BUFFER (BUFFER PATHNAME CONNECT-FLAG SELECT-FLAG QUIETLY-FLAG
;			   &AUX GENERIC-PATHNAME PATHNAME-STRING TRUENAME NEW-MODE)
;  (WHEN (AND (NULL (BUFFER-FILE-ID BUFFER)) (NULL PATHNAME))
;    (BARF "The buffer ~A is not associated with a file." (BUFFER-NAME BUFFER)))
;  (MULTIPLE-VALUE-SETQ (PATHNAME PATHNAME-STRING)
;    (EDITOR-FILE-NAME PATHNAME))
;  (WHEN CONNECT-FLAG
;    (SETF (BUFFER-NAME BUFFER) PATHNAME-STRING)
;    (SETF (BUFFER-PATHNAME BUFFER) PATHNAME))
;  (SETQ GENERIC-PATHNAME (SEND PATHNAME :GENERIC-PATHNAME))
;  (SETF (BUFFER-GENERIC-PATHNAME BUFFER) GENERIC-PATHNAME)
;  (WITH-OPEN-FILE-CASE (STREAM PATHNAME :CHARACTERS T)
;    (:NO-ERROR
;     (SETQ TRUENAME (SEND STREAM :TRUENAME))
;     (WHEN (MEMQ (SEND PATHNAME :TYPE) '(NIL :UNSPECIFIC))
;       (MULTIPLE-VALUE-SETQ (PATHNAME PATHNAME-STRING)
;	 (EDITOR-FILE-NAME
;	   (IF (EQUALP (SEND TRUENAME :NAME) (SEND PATHNAME :NAME))
;	       ;; This is in case user reads FOO > from an ITS, and it is reall FOO BAR.
;	       (SEND PATHNAME :NEW-TYPE (SEND TRUENAME :TYPE))
;	     ;; This case if user read FOO BAR from an LMFILE, and truename is FOO|BAR.
;	     ;; Or if user reads FOO BAR from an ITS and it is a link to UGH QUUX.
;	     PATHNAME))))
;     (WHEN CONNECT-FLAG
;       (SETF (BUFFER-NAME BUFFER) PATHNAME-STRING)
;       (SETF (BUFFER-PATHNAME BUFFER) PATHNAME)
;       (SIMILAR-BUFFER-FILES-WARNING BUFFER))
;     (WHEN (NOT QUIETLY-FLAG)
;       (FORMAT *QUERY-IO* "~&Reading ~A" TRUENAME)
;       (LET ((THIS-VERSION (SEND TRUENAME :VERSION))
;	     (INSTALLED-TRUENAME (FILE-LOADED-TRUENAME TRUENAME))
;	     INSTALLED-VERSION)
;	 (AND INSTALLED-TRUENAME
;	      (NUMBERP THIS-VERSION)
;	      (NUMBERP (SETQ INSTALLED-VERSION (SEND INSTALLED-TRUENAME :VERSION)))
;	      ( INSTALLED-VERSION THIS-VERSION)
;	      (FORMAT *QUERY-IO* " (installed version is ~D)" INSTALLED-VERSION))))
;     (FS:READ-ATTRIBUTE-LIST BUFFER STREAM)
;     ;; Forget (and thereby override) and previouse Set Package in this buffer.
;     (SETF (BUFFER-PACKAGE BUFFER) NIL)
;     ;; And recompute from latest attribute list.
;     (INITIALIZE-BUFFER-PACKAGE BUFFER)
;     (UNLESS (SEND BUFFER :GET-ATTRIBUTE ':MODE)
;       (SEND BUFFER :SET-ATTRIBUTE ':MODE
;				   (OR (CDR (SI:ASSOC-EQUAL (SEND PATHNAME :CANONICAL-TYPE)
;							    FS:*FILE-TYPE-MODE-ALIST*))
;				       *DEFAULT-MAJOR-MODE*)))
;     (SETQ NEW-MODE (OR (GET-FILE-MAJOR-MODE (SEND BUFFER :GET-ATTRIBUTE ':MODE))
;			'FUNDAMENTAL-MODE))
;     (LET-IF QUIETLY-FLAG ((*INTERVAL* NIL))
;       (IF (EQ BUFFER *INTERVAL*)
;	   (COMPUTE-BUFFER-PACKAGE BUFFER))
;       (AND NEW-MODE (SEND BUFFER :SET-MAJOR-MODE NEW-MODE)))
;     (PRESERVE-BUFFER-POINT (BUFFER)
;       (WITH-READ-ONLY-SUPPRESSED (BUFFER)
;	 (LET ((*BATCH-UNDO-SAVE* T))		;Don't save all this for undo!
;	   (DISCARD-UNDO-INFORMATION BUFFER)
;	   (DELETE-INTERVAL BUFFER)
;	   (SETF (BUFFER-TICK BUFFER) (TICK))	;For SECTIONIZE-BUFFER
;	   (SETF (BUFFER-FILE-READ-TICK BUFFER) *TICK*)
;	   (LET ((FONTS (SET-BUFFER-FONTS BUFFER))
;		 FONTS-P)
;	     (SETQ FONTS-P (OR (CDR FONTS) (SEND BUFFER :GET-ATTRIBUTE ':DIAGRAM)))
;	     (WHEN SELECT-FLAG
;	       (SEND BUFFER :ACTIVATE)
;	       (MAKE-BUFFER-CURRENT BUFFER)
;	       ;; If it is requested, read in the first screenful and then redisplay.
;	       (DOTIMES (I (+ 5 (WINDOW-N-PLINES *WINDOW*)))
;		 (MULTIPLE-VALUE-BIND (LINE EOFFLG)
;		     (SEND STREAM :LINE-IN LINE-LEADER-SIZE)
;		   (WHEN LINE
;		     (INSERT-LINE-WITH-LEADER LINE
;					      (BP-LINE (INTERVAL-LAST-BP BUFFER))))
;		   (IF EOFFLG (RETURN))))
;	       (REDISPLAY *WINDOW* :START (INTERVAL-FIRST-BP BUFFER) NIL))
;	     (IF (NOT CONNECT-FLAG)
;		 (STREAM-INTO-BP STREAM (INTERVAL-FIRST-BP BUFFER) FONTS-P)
;	       (IF (EQ CONNECT-FLAG 'NOSECTIONIZE)
;		   (STREAM-INTO-BP STREAM (INTERVAL-FIRST-BP BUFFER) FONTS-P)
;		 (SECTIONIZE-FILE-BUFFER BUFFER *ZMACS-COMPLETION-AARRAY* 'ZMACS-BUFFERS
;					 NIL NIL
;					 STREAM FONTS-P))
;	       (SET-BUFFER-FILE-ID BUFFER (SEND STREAM :INFO))
;	       (DOLIST (WINDOW (SEND BUFFER :WINDOWS))
;		 (AND FONTS
;		      (REDEFINE-FONTS WINDOW
;				      FONTS (SEND BUFFER :GET-ATTRIBUTE ':VSP)))
;		 (REDEFINE-WINDOW-OVERPRINTING-FLAG WINDOW
;						    (SEND BUFFER :GET-ATTRIBUTE ':BACKSPACE))
;		 (REDEFINE-WINDOW-TAB-NCHARS WINDOW
;					     (SEND BUFFER :GET-ATTRIBUTE ':TAB-WIDTH))))
;	     (SETF (BUFFER-FILE-READ-TICK BUFFER) *TICK*)
;	     (NOT-MODIFIED BUFFER)))))
;     (UNLESS SELECT-FLAG			;else already done above
;       (SEND BUFFER :ACTIVATE))
;     (UNLESS QUIETLY-FLAG
;       (LET ((NCHARS (SEND-IF-HANDLES STREAM :READ-POINTER)))
;	 (COND ((NULL NCHARS)
;		(FORMAT *QUERY-IO* " -- done."))
;	       ((< NCHARS 5000.)
;		(FORMAT *QUERY-IO* " -- ~D characters." NCHARS))
;	       (T (FORMAT *QUERY-IO* " -- ~DK characters." (ROUND NCHARS 1024.)))))))
;    (FS:FILE-NOT-FOUND
;     (WHEN *FIND-FILE-NOT-FOUND-IS-AN-ERROR* (BARF STREAM))
;     (OR QUIETLY-FLAG (FORMAT *QUERY-IO* "(New File)"))
;     (LET ((*BATCH-UNDO-SAVE* T))
;       (DISCARD-UNDO-INFORMATION BUFFER)
;       (DELETE-INTERVAL BUFFER))
;     (AND CONNECT-FLAG (SET-BUFFER-FILE-ID BUFFER T))
;     (SEND BUFFER :SET-ATTRIBUTE ':MODE
;				 (OR (CDR (SI:ASSOC-EQUAL (SEND PATHNAME :CANONICAL-TYPE)
;							  FS:*FILE-TYPE-MODE-ALIST*))
;				     *DEFAULT-MAJOR-MODE*))
;     (SETF (BUFFER-PACKAGE BUFFER) (PKG-FIND-PACKAGE (OR *DEFAULT-PACKAGE* *PACKAGE*)))
;     (LET ((MODE (GET-FILE-MAJOR-MODE (SEND BUFFER :GET-ATTRIBUTE :MODE))))
;       (LET-IF QUIETLY-FLAG ((*INTERVAL* NIL))
;	 (IF (EQ BUFFER *INTERVAL*) (COMPUTE-BUFFER-PACKAGE BUFFER))
;	 (AND MODE (SEND BUFFER :SET-MAJOR-MODE MODE)))))
;    (FS:FILE-ERROR (BARF STREAM)))
;  (SETF (BUFFER-TICK BUFFER) (TICK)))		;Buffer is same as file
  
;(DEFUN FILE-LOADED-TRUENAME (PATHNAME)
;  "Return the truename of the source of the version of PATHNAME which was LOADed."
;  (OR (LET* ((GENERIC-PATHNAME (SEND PATHNAME :GENERIC-PATHNAME))
;	     (SOURCE-PATHNAME (SEND GENERIC-PATHNAME :GET ':QFASL-SOURCE-FILE-UNIQUE-ID)))
;	(COND ((STRINGP SOURCE-PATHNAME)		;Old versions of the compiler
;	       (SETQ SOURCE-PATHNAME (FS:MERGE-PATHNAME-DEFAULTS SOURCE-PATHNAME PATHNAME)))
;	      ((CONSP SOURCE-PATHNAME)
;	       (SETQ SOURCE-PATHNAME (FS:PATHNAME-FROM-COLD-LOAD-PATHLIST SOURCE-PATHNAME))))
;	(AND (NOT (NULL SOURCE-PATHNAME))
;	     (LET ((TYPE-1 (SEND SOURCE-PATHNAME :TYPE))
;		   (TYPE-2 (SEND PATHNAME :TYPE)))
;	       (OR (EQUAL TYPE-1 TYPE-2)
;		   (AND (OR (EQ TYPE-1 :UNSPECIFIC)
;			    (CL:MEMBER TYPE-1 FS:*ITS-UNINTERESTING-TYPES* :TEST #'STRING=))
;			(OR (EQ TYPE-2 :UNSPECIFIC)
;			    (CL:MEMBER TYPE-2 FS:*ITS-UNINTERESTING-TYPES* :TEST #'STRING=)))))
;	     SOURCE-PATHNAME))
;      (LET* ((NEWEST-PATHNAME (SEND PATHNAME :NEW-VERSION :NEWEST))
;	     (ID (SI:GET-FILE-LOADED-ID NEWEST-PATHNAME PACKAGE)))
;	(AND ID (CAR ID)))))


(defmacro WITH-VERSION-AND-MODIFICATION (buffer body)
  (declare (zwei:indentation 1 1))
  `(let* ((buffer-pathname (zwei:buffer-pathname ,buffer))
	  (buffer-version (or (buffer-file-version-if-known ,buffer)
			      ;;this is a universal-time, given to all files, whether they have
			      ;;version numbers or not.  Here it becomes a quasi-version number.
			      (get (cadr (send buffer-pathname :directory-list nil)) :creation-date)))
	  (file-truename (and buffer-pathname (send buffer-pathname :truename)))
  	  (file-version (pathname-version buffer-pathname))
	  (file-number (if (numberp file-version)
			   file-version
			 (send file-truename :version)))
	  ;;anything is newer than a non-existent buffer version, and
	  ;;file version numbers are assumed to be positive integers
	  (newer-version-exists (and file-number (< (or buffer-version -1) file-number)))
	  ;;(this-version-is-newest (= buffer-version file-number))
	  (buffer-modified (buffer-modified-p ,buffer)))
     ,body))

(defun read-in-newest (pathname)
  (LET ((PROBE-STREAM (PROBEF (SEND PATHNAME :NEW-VERSION :NEWEST))))
    (IF (NOT PROBE-STREAM)
	(BARF "Cannot find any existing versions of ~A.  Perhaps all versions have been deleted."
	      PATHNAME)
      (let ((desired-version (SEND PROBE-STREAM :VERSION)))
	(IF (GREATERP desired-version
		      (SEND PATHNAME :VERSION))
	    (COND ((EQUAL (COMPLETING-READ-FROM-MINI-BUFFER 
			    "A newer version of this file exists now.  Revert this DIRED buffer? (default is no)" 
			    '(("yes") ("no")))	
			  '("yes"))
		   (values (REVERT-BUFFER *INTERVAL*) nil))
		  ((EQUAL (COMPLETING-READ-FROM-MINI-BUFFER
			    "Do you want to see the newest version? (default is no)"
			    '(("yes") ("no")))
			  '("yes"))
		   (VALUES (SEND PATHNAME :NEW-VERSION :NEWEST) desired-version))
		  (T (VALUES PATHNAME NIL)))
	  (VALUES (SEND PATHNAME :NEW-VERSION :NEWEST) DESIRED-VERSION))))))

(defun fquery-unless-arg (return-keywords echo-strings activators user-string &rest string-args)
  ;; This defines an internal function which returns a special symbol if *numeric-arg* has been
  ;; provided; if not, it takes creates a dispatching template using FQUERY.  This template
  ;; will, when invoked at various points in refind-file-1, be used to determine branching
  ;; scenarios at those points.
  (if *numeric-arg-p*
      :GO-AHEAD
    (loop for each-key in return-keywords
	  and for each-string in echo-strings
	  and for each-char in activators
	  with choice-list initially nil
	  do
	  (let* ((this-choice (list (list each-key each-string) each-char)))
	    (setq choice-list (append choice-list (list this-choice))))
	  finally
	  (return
	    (apply
	      #'fquery
	      (list
		(list :type :tyi :choices choice-list)
		user-string
		string-args))))))

(defun REFIND-FILE (&optional (buffer (read-buffer-name "File to refind: "
						        *interval*)))
  ;;  This will give users choices unless they specify (by using com-refind-file with
  ;; an explicit numeric arg) that they want REFIND-FILE to act independently of user
  ;; input.
  (with-version-and-modification-info buffer
    (cond (buffer-modified
	   (cond ((numberp file-version)
		  (selectq (fquery-unless-arg
			    '(:FIND-LATEST :REVERT :NO-ACTION)
			    '("Reading in #> version..." "Reverting buffer..." "Aborting")
			    '(#\F #\R #\N) 
			    "The buffer associated with file ~A, read in with explicit numeric version, has been modified.~
		     	   ~%Find and read in #> version of file, Revert buffer, or Do nothing? "
			    buffer-pathname)
		    ((:GO-AHEAD :FIND-LATEST)
		     (find-file (merge-pathnames buffer-pathname)))
		    (:REVERT (progn (REVERT-BUFFER BUFFER)
				    (MUST-REDISPLAY-BUFFER BUFFER DIS-TEXT)
				    DIS-NONE))
		    (:NO-ACTION nil)))
		 (newer-version-exists
		  (selectq (fquery-unless-arg
			    '(: : :)
			    "The buffer associated with the file ~A has been modified.~
			   ~%Read in the most recent version of ~A, do a Source Compare Merge, or nothing."
			    buffer-pathname))
		 (t (fquery-unless-arg
		      "The current buffer contains a modified version of the latest version of ~A.~
 		       ~%Do you want to Revert Buffer,~
 		       ~%Source Compare Merge with buffer's original contents,~
 		       ~%or do nothing?" buffer-pathname))))
	  (t (cond ((numberp file-version)
		    (fquery-unless-arg
		      "The current buffer contains an unmodified numeric file version, ~A.~
 		     ~%Do you want to Refind version ~A,~
		     ~%Replace buffer contents with those of the newest version of ~A,
 		     ~%Source Compare Merge with buffer's original contents,~
	   	     ~%or do nothing?" buffer-pathname file-number (file-namestring buffer-pathname)))
		   (newer-version-exists (find-file buffer-pathname))
		   (t (format *query-io* "No action taken.")))))))


;(with-version-and-modification-info
;  *interval*
;  (format t "~A~% ~A~% ~A~% ~A~% ~A~% ~A~% ~A~% "
;	  buffer-pathname
;	  buffer-version
;	  file-spec
;	  file-truename
;	  file-version
;	  file-number
;	  newer-version-exists
;	  buffer-modified))




;(let* ((all-choices nil))
;  (loop for each-key in '(:one :two :three)
;	and for each-string in '("one" "two" "three")
;	and for each-char in '(#\1 #\2 #\3) do
;	(format t "~%~A~% ~A~% ~A~%" each-key each-string each-char)
;	(let* ((this-choice (list (list each-key each-string) each-char)))
;	  (print all-choices)
;	  (push this-choice all-choices)))
;  (apply #'fquery (list (list :type :tyi :choices all-choices) "Well? ~A~% " 'do-something)))



;(loop for each-key in '(1 2)
;      and for each-string in '("1" "2")
;      and for each-char in  '(#\1 #\2)
;      with choice-list initially nil
;      do
;      (let* ((this-choice (list (list each-key each-string) each-char)))
;	(setq choice-list (append choice-list (list this-choice))))
;      finally (apply #'fquery (list (list :type :tyi :choices choice-list) "Well? ~A~% " 'do-something)))