;;; -*- Mode:LISP; Readtable:CL; Base:10 -*- (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-INFO (buffer body) (declare (zwei:indentation 1 1)) `(let* ((buffer-pathname (zwei:buffer-pathname ,buffer)) (buffer-version (or (buffer-file-version-if-known ,buffer) (get (cadr (send buffer-pathname :directory-list nil)) :creation-date))) (file-truename (and file-spec (send file-spec :truename))) (file-version (pathname-version file-spec)) (file-number (or (numberp 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 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. ;; This FLET wrapper 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. (flet ((fquery-unless-arg (return-keywords echo-strings activators user-string &rest string-args) (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))))))) (refind-file-1 choice-list))) (defun refind-file-1 (choice-list) (with-version-and-modification-info buffer (cond (buffer-modified (cond ((numberp file-version) (fquery-unless-arg "The file ~A, read in with explicit numeric version, has been modified." file-spec)) (newer-version-exists (fquery-unless-arg "Read in most recent version of ~A, do a Source Compare Merge, or nothing." file-spec)) (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?" file-spec)))) (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?" file-spec file-number (file-namestring file-spec))) (newer-version-exists (find-file file-spec)) (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)))