[slime-cvs] CVS slime/contrib

[CVS User heller]

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv14026/contrib

Modified Files:
	ChangeLog slime-snapshot.el swank-snapshot.lisp 
Log Message:
Snapshot restore support for SBCL.

* swank-backend.lisp (background-save-image): New.
* swank-sbcl.lisp (command-line-args, dup, sys-execv, exec-image)
(make-fd-stream, background-save-image): New.

Add support to save snapshots in backround.

* swank-snapshot.lisp (background-save-snapshot): New.
(resurrect): Initialize repl streams.
* slime-snapshot.el (slime-snapshot): With prefix-arg perform
saving in background.  Also ask before overwriting existing files.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/08/13 07:25:15	1.406
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/08/21 06:39:59	1.407
@@ -1,3 +1,12 @@
+2010-08-21  Anton Kovalenko <anton at sw4me.com>
+
+	Add support to save snapshots in backround.
+
+	* swank-snapshot.lisp (background-save-snapshot): New.
+	(resurrect): Initialize repl streams.
+	* slime-snapshot.el (slime-snapshot): With prefix-arg perform
+	saving in background.  Also ask before overwriting existing files.
+
 2010-08-13  Helmut Eller  <heller at common-lisp.net>
 
 	Fix slime-restore.
--- /project/slime/cvsroot/slime/contrib/slime-snapshot.el	2010/05/28 19:13:17	1.5
+++ /project/slime/cvsroot/slime/contrib/slime-snapshot.el	2010/08/21 06:39:59	1.6
@@ -5,11 +5,20 @@
   (:license "Unknown")
   (:swank-dependencies swank-snapshot))
 
-(defun slime-snapshot (filename)
+(defun slime-snapshot (filename &optional background)
   "Save a memory image to the file FILENAME."
-  (interactive (list (read-file-name "Image file: ")))
-  (slime-eval-with-transcript 
-   `(swank-snapshot:save-snapshot ,(expand-file-name filename))))
+  (interactive (list (read-file-name "Image file: ")
+		     current-prefix-arg))
+  (let ((file (expand-file-name filename)))
+    (when (and (file-exists-p file)
+	       (not (yes-or-no-p (format "File exists %s.  Overwrite it? " 
+					 filename))))
+      (signal 'quit nil))
+    (slime-eval-with-transcript
+     `(,(if background
+	    'swank-snapshot:background-save-snapshot
+	  'swank-snapshot:save-snapshot)
+       ,file))))
 
 (defun slime-restore (filename)
   "Restore a memory image stored in file FILENAME."
--- /project/slime/cvsroot/slime/contrib/swank-snapshot.lisp	2010/08/13 07:25:15	1.2
+++ /project/slime/cvsroot/slime/contrib/swank-snapshot.lisp	2010/08/21 06:39:59	1.3
@@ -1,7 +1,7 @@
 
 (defpackage swank-snapshot
   (:use cl)
-  (:export restore-snapshot save-snapshot)
+  (:export restore-snapshot save-snapshot background-save-snapshot)
   (:import-from swank defslimefun))
 (in-package swank-snapshot)
 
@@ -9,7 +9,7 @@
   (swank-backend:save-image image-file 
 			    (let ((c swank::*emacs-connection*))
 			      (lambda () (resurrect c))))
-  t)
+  (format nil "Dumped lisp to ~A" image-file))
 
 (defslimefun restore-snapshot (image-file)
   (let* ((conn swank::*emacs-connection*)
@@ -17,12 +17,28 @@
 	 (clone (swank-backend:dup (swank-backend:socket-fd stream)))
 	 (style (swank::connection.communication-style conn))
 	 (coding (swank::connection.coding-system conn))
+	 (repl (if (swank::connection.user-io conn) t))
 	 (args (list "--swank-fd" (format nil "~d" clone)
 		     "--swank-style" (format nil "~s" style)
-		     "--swank-coding" (format nil "~s" coding))))
+		     "--swank-coding" (format nil "~s" coding)
+		     "--swank-repl" (format nil "~s" repl))))
     (swank::close-connection conn nil nil)
     (swank-backend:exec-image image-file args)))
 
+(defslimefun background-save-snapshot (image-file)
+  (let ((connection swank::*emacs-connection*))
+    (flet ((complete (success)
+	     (let ((swank::*emacs-connection* connection))
+	       (swank::background-message
+		"Dumping lisp image ~A ~:[failed!~;succeeded.~]" 
+		image-file success)))
+	   (awaken ()
+	     (resurrect connection)))
+      (swank-backend:background-save-image image-file
+					   :restart-function #'awaken
+					   :completion-function #'complete)
+      (format nil "Started dumping lisp to ~A..." image-file))))
+
 (in-package :swank)
 
 (defun swank-snapshot::resurrect (old-connection)
@@ -34,9 +50,13 @@
   (let* ((fd (read-command-line-arg "--swank-fd"))
 	 (style (read-command-line-arg "--swank-style"))
 	 (coding (read-command-line-arg "--swank-coding"))
+	 (repl (read-command-line-arg "--swank-repl"))
 	 (* (format *error-output* "fd=~s style=~s cs=~s~%" fd style coding))
 	 (stream (make-fd-stream fd (find-external-format-or-lose coding)))
 	 (connection (make-connection nil stream style  coding)))
+    (let ((*emacs-connection* connection))
+      (when repl (create-repl nil))
+      (background-message "~A" "Lisp image restored"))
     (serve-requests connection)
     (simple-repl)))