diff --git a/hemlock/rcs.lisp b/hemlock/rcs.lisp
index 0c38baac45b90e142c33564d23fa17b7f6123989..d80a87ef60740552d58625bc886416b64593e8fd 100644
--- a/hemlock/rcs.lisp
+++ b/hemlock/rcs.lisp
@@ -1,12 +1,19 @@
-;;; -*- Package: HEMLOCK -*-
+;;; -*- Package: HEMLOCK; Mode: Lisp -*-
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/rcs.lisp,v 1.5 1990/02/09 21:20:32 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/rcs.lisp,v 1.6 1990/03/02 20:45:44 ch Exp $
 ;;;
 ;;; Various commands for dealing with RCS under hemlock.
 ;;; 
 
 (in-package "HEMLOCK")
 
+
+;;;;
+
+(defhvar "RCS Check Out Keep Original As Backup"
+  "If non-NIL, all comamnds which perform an RCS check out will rename
+  any existing original file to a backup filename."
+  :value nil)
 
 (defun current-buffer-pathname ()
   (let ((pathname (buffer-pathname (current-buffer))))
@@ -71,18 +78,22 @@
   (in-directory pathname
     (let ((file (file-namestring pathname)))
       (do-command "rcs" `("-l" ,file))
-      (multiple-value-bind
-	  (won dev ino mode)
-	  (mach:unix-stat file)
-	(declare (ignore dev ino))
-	(when won
-	  (mach:unix-chmod file (logior mode mach:writeown)))))))
+      (multiple-value-bind (won dev ino mode) (mach:unix-stat file)
+	(declare (ignore ino))
+	(cond (won
+	       (mach:unix-chmod file (logior mode mach:writeown)))
+	      (t
+	       (editor-error "MACH:UNIX-STAT lost in RCS-LOCK-FILE: ~A"
+			     (mach:get-unix-error-msg dev))))))))
 
 (defun rcs-unlock-file (pathname)
   (message "Unlocking ~A ..." (namestring pathname))
   (in-directory pathname
     (do-command "rcs" `("-u" ,(file-namestring pathname)))))
 
+
+;;;; Check In
+
 (defun rcs-check-in-file (pathname keep-lock)
   (let ((old-buffer (current-buffer))
 	(allow-delete nil)
@@ -118,6 +129,58 @@
       (setf allow-delete t)
       (delete-buffer buffer))))
 
+
+;;;; Check Out
+
+(defun maybe-rcs-check-out-file (pathname lock always-overwrite-p)
+  (maybe-rcs-check-out-files (list pathname) lock always-overwrite-p))
+
+(defun maybe-rcs-check-out-files (pathnames lock always-overwrite-p)
+  (let ((check-out-count 0))
+    (macrolet ((frob ()
+		 `(progn
+		    (rcs-check-out-file pathname lock)
+		    (incf check-out-count))))
+      (dolist (pathname pathnames)
+	(cond
+	 ((and (not always-overwrite-p)
+	       (probe-file pathname) (ext:file-writable pathname))
+	  ;; File exists and is writable so check and see if the user really
+	  ;; wants to check it out.
+	  (command-case (:prompt
+			 (format nil "The file ~A is writable.  Overwrite? "
+				 (file-namestring pathname))
+			 :help
+			 "Type one of the following single-character commands:")
+	    ((:yes :confirm)
+	     "Overwrite the file."
+	     (frob))
+	    (:no
+	     "Skip checking out this file.")
+	    ((#\r #\R)
+	     "Rename the file before checking it out."
+	     (let ((new-pathname (prompt-for-file
+				  :prompt "New Filename: "
+				  :default (buffer-default-pathname
+					      (current-buffer))
+				  :must-exist nil)))
+	       (rename-file pathname new-pathname)
+	       (frob)))
+	    (:do-all
+	     "Overwrite this file and all remaining files."
+	     (setf always-overwrite-p t)
+	     (frob))
+	    (:do-once
+	     "Overwrite this file and then exit."
+	     (frob)
+	     (return))
+	    (:exit
+	     "Exit immediately."
+	     (return))))
+	 (t
+	  (frob)))))
+    check-out-count))
+
 (defun rcs-check-out-file (pathname lock)
   (message "Checking out ~A ..." (namestring pathname))
   (in-directory pathname
@@ -125,14 +188,11 @@
 	   (if (probe-file pathname)
 	       (lisp::pick-backup-name (namestring pathname))
 	       nil)))
-      (when backup
-	(rename-file pathname backup))
+      (when backup (rename-file pathname backup))
       (do-command "rcsco" `(,@(if lock '("-l")) ,(file-namestring pathname)))
-      (when backup
+      (unless (value rcs-check-out-keep-original-as-backup)
 	(delete-file backup)))))
 
-
-
 (defun pick-temp-file (defaults)
   (let ((index 0))
     (loop
@@ -142,6 +202,9 @@
 	      (t
 	       (return name)))))))
 
+
+;;;; Checking In / Checking Out and Locking / Unlocking 
+
 (defcommand "RCS Lock Buffer File" (p)
   "Attempt to lock the file in the current buffer."
   "Attempt to lock the file in the current buffer."
@@ -190,10 +253,10 @@
 				    :must-exist nil)))
 
 (defcommand "RCS Check In Buffer File" (p)
-  "Checkin the file in the current buffer.  With an argument, do not release
-  the lock."
-  "Checkin the file in the current buffer.  With an argument, do not release
-  the lock."
+  "Checkin the file in the current buffer.  With an argument, do not
+  release the lock."
+  "Checkin the file in the current buffer.  With an argument, do not
+  release the lock."
   (let ((buffer (current-buffer))
 	(pathname (current-buffer-pathname)))
     (when (buffer-modified buffer)
@@ -202,10 +265,10 @@
     (visit-file-command nil pathname buffer)))
 
 (defcommand "RCS Check In File" (p)
-  "Prompt for a file, and attempt to check it in.  With an argument, do not
-  release the lock."
-  "Prompt for a file, and attempt to check it in.  With an argument, do not
-  release the lock."
+  "Prompt for a file, and attempt to check it in.  With an argument, do
+  not release the lock."
+  "Prompt for a file, and attempt to check it in.  With an argument, do
+  not release the lock."
   (rcs-check-in-file (prompt-for-file :prompt "File to lock: "
 				      :default
 				         (buffer-default-pathname
@@ -214,8 +277,10 @@
 		     p))
 
 (defcommand "RCS Check Out Buffer File" (p)
-  "Checkout the file in the current buffer.  With an argument, lock the file."
-  "Checkout the file in the current buffer.  With an argument, lock the file."
+  "Checkout the file in the current buffer.  With an argument, lock the
+  file."
+  "Checkout the file in the current buffer.  With an argument, lock the
+  file."
   (let* ((buffer (current-buffer))
 	 (pathname (current-buffer-pathname))
 	 (point (current-point))
@@ -223,7 +288,7 @@
     (when (buffer-modified buffer)
       (when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? "))
 	(editor-error "Aborted.")))
-    (rcs-check-out-file pathname p)
+    (maybe-rcs-check-out-file pathname p nil)
     (setf (buffer-modified buffer) nil)
     (when p
       (setf (buffer-writable buffer) t)
@@ -233,17 +298,20 @@
       (buffer-end point))))
 
 (defcommand "RCS Check Out File" (p)
-  "Prompt for a file and attempt to check it out.  With an argument, lock the
-  file."
-  "Prompt for a file and attempt to check it out.  With an argument, lock the
-  file."
+  "Prompt for a file and attempt to check it out.  With an argument,
+  lock the file."
+  "Prompt for a file and attempt to check it out.  With an argument,
+  lock the file."
   (let ((pathname (prompt-for-file :prompt "File to check out: "
 				   :default (buffer-default-pathname
 					     (current-buffer))
 				   :must-exist nil)))
-    (rcs-check-out-file pathname p)
+    (maybe-rcs-check-out-file pathname p nil)
     (find-file-command nil pathname)))
 
+
+;;;; Log File
+
 (defhvar "RCS Log Entry Buffer"
   "Name of the buffer to put RCS log entries into."
   :value "RCS Log")
@@ -290,20 +358,35 @@
     (buffer-start (current-point))
     (setf (buffer-modified buffer) nil)))
 
+
+;;;; Directory Support
 
-(defcommand "RCS Update Directory" (p)
-  "Prompt for a directory and check out all files that are older than the
-  corresponding RCS file.  With an argument, never ask about overwriting
-  writable files."
-  "Prompt for a directory and check out all files that are older than the
-  corresponding RCS file.  With an argument, never ask about overwriting
-  writable files."
-  (let* ((def (buffer-default-pathname (current-buffer)))
-	 (dir (prompt-for-file :prompt "Directory to update: "
+(defun list-out-of-date-files (dir)
+  (let ((rcsdir (make-pathname :host (pathname-host dir)
+			       :device (pathname-device dir)
+			       :directory (concatenate 'simple-vector
+						       (pathname-directory dir)
+						       (vector "RCS"))))
+	(out-of-date-files nil))
+    (unless (directoryp rcsdir)
+      (editor-error "Could not find the RCS directory."))
+    (dolist (rcsfile (directory rcsdir))
+      (let ((rcsname (file-namestring rcsfile)))
+	(when (string= rcsname ",v" :start1 (- (length rcsname) 2))
+	  (let* ((name (subseq rcsname 0 (- (length rcsname) 2)))
+		 (file (merge-pathnames (parse-namestring name) dir)))
+	    (unless (and (probe-file file)
+			 (>= (file-write-date file) (file-write-date rcsfile)))
+	      (push file out-of-date-files))))))
+    out-of-date-files))
+
+(defun rcs-prompt-for-directory (prompt)
+  (let* ((default (buffer-default-pathname (current-buffer)))
+	 (dir (prompt-for-file :prompt prompt
 			       :default (make-pathname
-					 :host (pathname-host def)
-					 :device (pathname-device def)
-					 :directory (pathname-directory def)
+					 :host (pathname-host default)
+					 :device (pathname-device default)
+					 :directory (pathname-directory default)
 					 :defaults nil)
 			       :must-exist nil)))
     (unless (directoryp dir)
@@ -313,50 +396,41 @@
 	(unless (directoryp with-slash)
 	  (editor-error "~S is not a directory" (namestring dir)))
 	(setf dir with-slash)))
-    (let ((rcsdir
-	   (make-pathname :host (pathname-host dir)
-			  :device (pathname-device dir)
-			  :directory (concatenate 'simple-vector
-						  (pathname-directory dir)
-						  (vector "RCS"))))
-	  (count 0))
-      (unless (directoryp rcsdir)
-	(editor-error "Could not find the RCS directory."))
-      (dolist (rcsfile (directory rcsdir))
-	(let ((rcsname (file-namestring rcsfile)))
-	  (when (string= rcsname ",v" :start1 (- (length rcsname) 2))
-	    (let* ((name (subseq rcsname 0 (- (length rcsname) 2)))
-		   (file (merge-pathnames (parse-namestring name)
-					  dir)))
-	      (when (and (probe-file file)
-			 (< (file-write-date file) (file-write-date rcsfile)))
-		(multiple-value-bind
-		    (won dev inode mode)
-		    (mach:unix-stat (namestring file))
-		  (declare (ignore dev inode))
-		  (when (and won (not (zerop (logand mode mach:writeown))))
-		    (cond ((or p
-			       (not (prompt-for-y-or-n
-				     :prompt
-				     (format nil
-					     "~S is writable, overwrite? "
-					     (namestring file))
-				     :default nil
-				     :default-string "n")))
-			   (let ((private
-				  (merge-pathnames (concatenate
-						    'simple-string
-						    (file-namestring file)
-						    ".private")
-						   file)))
-			     (message "Renaming ~S to ~S"
-				      (namestring file)
-				      (namestring private))
-			     (rename-file file private)))
-			  (t
-			   (delete-file file))))
-		  (incf count)
-		  (rcs-check-out-file file nil)))))))
-      (if (zerop count)
-	  (message "No files are out of date.")
-	  (message "Checked out ~D file~:P" count)))))
+    dir))
+
+(defcommand "RCS Update Directory" (p)
+  "Prompt for a directory and check out all files that are older than
+  their corresponding RCS files.  With an argument, never ask about
+  overwriting writable files."
+  "Prompt for a directory and check out all files that are older than
+  the corresponding RCS file.  With an argument, never ask about
+  overwriting writable files."
+  (let* ((directory (rcs-prompt-for-directory "Directory to update: "))
+	 (out-of-date-files (list-out-of-date-files directory))
+	 (n-out-of-date (length out-of-date-files)))
+    (cond ((zerop n-out-of-date)
+	   (message "All RCS files in ~A are up to date."
+		    (namestring directory)))
+	  (t
+	   (let ((n-checked-out
+		  (maybe-rcs-check-out-files out-of-date-files nil p)))
+	     (message "Number of files out of date: ~D; ~
+	     number of files checked out: ~D"
+		      n-out-of-date n-checked-out)))))))
+
+(defcommand "RCS List Out Of Date Files" (p)
+  "Prompt for a directory and list all of the files that are older than
+  their corresponding RCS files."
+  "Prompt for a directory and list all of the files that are older than
+  their corresponding RCS files."
+  (declare (ignore p))
+  (let* ((directory (rcs-prompt-for-directory "Directory: "))
+	 (out-of-date-files (list-out-of-date-files directory)))
+    (cond ((null out-of-date-files)
+	   (message "All RCS files in ~A are up to date."
+		    (namestring directory)))
+	  (t
+	   (with-pop-up-display (s :buffer-name "*RCS Out of Date Files*")
+	     (format s "Directory: ~A~%~%" (namestring directory))
+	     (dolist (file out-of-date-files)
+	       (format s "~A~%" (file-namestring file))))))))