[climacs-cvs] CVS update: climacs/gui.lisp

[Robert Strandh]

Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv28656

Modified Files:
	gui.lisp 
Log Message:
Factored out buffer saving into a separate function.

Improved on com-quit so that it asks the user to save buffers before
quitting. 

Date: Fri Jan 21 21:45:26 2005
Author: rstrandh

Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.92 climacs/gui.lisp:1.93
--- climacs/gui.lisp:1.92	Fri Jan 21 11:39:50 2005
+++ climacs/gui.lisp	Fri Jan 21 21:45:25 2005
@@ -282,9 +282,6 @@
 				`(, at command-name :name t)
 				`(,command-name :name t)) ,args , at body))
 
-(define-named-command (com-quit) ()
-  (frame-exit *application-frame*))
-
 (define-named-command com-toggle-overwrite-mode ()
   (with-slots (overwrite-mode) (current-window)
     (setf overwrite-mode (not overwrite-mode))))
@@ -631,20 +628,34 @@
     ;; resets the low and high marks after redisplay
     (redisplay-frame-panes *application-frame*)))
 
+(defun save-buffer (buffer)
+  (let ((filename (or (filename buffer)
+		      (accept 'completable-pathname
+			      :prompt "Save Buffer to File"))))
+    (with-open-file (stream filename :direction :output :if-exists :supersede)
+      (output-to-stream stream buffer 0 (size buffer)))
+    (setf (filename buffer) filename
+	  (name buffer) (pathname-filename filename))
+    (display-message "Wrote: ~a" (filename buffer))
+    (setf (needs-saving buffer) nil)))
+
 (define-named-command com-save-buffer ()
-  (let* ((buffer (buffer (current-window)))
-	 (filename (or (filename buffer)
-		       (accept 'completable-pathname
-			       :prompt "Save Buffer to File"))))
+  (let ((buffer (buffer (current-window))))
     (if (or (null (filename buffer))
 	    (needs-saving buffer))
-	(progn (with-open-file (stream filename :direction :output :if-exists :supersede)
-		 (output-to-stream stream buffer 0 (size buffer)))
-	       (setf (filename buffer) filename
-		     (name buffer) (pathname-filename filename))
-	       (display-message "Wrote: ~a" (filename buffer)))
-	(display-message "No changes need to be saved from ~a" (name buffer)))
-    (setf (needs-saving buffer) nil)))
+	(save-buffer buffer)
+	(display-message "No changes need to be saved from ~a" (name buffer)))))
+
+(define-named-command (com-quit) ()
+  (loop for buffer in (buffers *application-frame*)
+	when (and (needs-saving buffer)
+		  (accept 'boolean
+			  :prompt (format nil "Save buffer: ~a ?" (name buffer))))
+	  do (save-buffer buffer))
+  (when (or (notany #'needs-saving
+		    (buffers *application-frame*))
+	    (accept 'boolean :prompt "Modified buffers exist.  Quit anyway?"))
+    (frame-exit *application-frame*)))
 
 (define-named-command com-write-buffer ()
   (let ((filename (accept 'completable-pathname