[slime-cvs] CVS slime/contrib

[CVS User heller]

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

Modified Files:
	ChangeLog 
Added Files:
	slime-snapshot.el swank-snapshot.lisp 
Log Message:
Commands to save&restore image files without disconnecting.

* slime-snapshot.el: New file.
* swank-snapshot.lisp: New file.

Some new backend functions used for loading image files.

* swank-backend.lisp (socket-fd, make-fd-stream, dup, exec-image)
(command-line-args): New functions.
* swank-cmucl.lisp: Impemented.
* swank-cmucl.lisp (reset-sigio-handlers): New function.
(save-image): Fix quoting bug.

* swank.lisp (clear-event-history): New functoin.
(interactive-eval, eval-region): Don't use FRESH-LINE.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/21 16:23:02	1.314
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/22 09:31:15	1.315
@@ -1,3 +1,10 @@
+2009-12-22  Helmut Eller  <heller at common-lisp.net>
+
+	Commands to save&restore image files without disconnecting.
+
+	* slime-snapshot.el: New file.
+	* swank-snapshot.lisp: New file.
+
 2009-12-21  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-arglists.lisp (completions-for-keyword): Return nil

--- /project/slime/cvsroot/slime/contrib/slime-snapshot.el	2009/12/22 09:31:15	NONE
+++ /project/slime/cvsroot/slime/contrib/slime-snapshot.el	2009/12/22 09:31:15	1.1
;; slime-snapshot.el --- Save&restore memory images without disconnecting

(slime-require :swank-snapshot)

(defun slime-snapshot (filename)
  "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))))

(defun slime-restore (filename)
  "Restore a memory image stored in file FILENAME."
  (interactive (list (read-file-name "Image file: ")))
  ;; bypass event dispatcher because we don't expect a reply. FIXME.
  (slime-net-send `(:emacs-rex (swank-snapshot:restore-snapshot 
				,(expand-file-name filename))
			       nil t nil)
		  (slime-connection)))
--- /project/slime/cvsroot/slime/contrib/swank-snapshot.lisp	2009/12/22 09:31:15	NONE
+++ /project/slime/cvsroot/slime/contrib/swank-snapshot.lisp	2009/12/22 09:31:15	1.1

(defpackage swank-snapshot
  (:use cl)
  (:export restore-snapshot save-snapshot)
  (:import-from swank defslimefun))
(in-package swank-snapshot)

(defslimefun save-snapshot (image-file)
  (swank-backend:save-image image-file 
			    (let ((c swank::*emacs-connection*))
			      (lambda () (resurrect c))))
  t)

(defslimefun restore-snapshot (image-file)
  (let* ((conn swank::*emacs-connection*)
	 (stream (swank::connection.socket-io conn))
	 (clone (swank-backend:dup (swank-backend:socket-fd stream)))
	 (style (swank::connection.communication-style conn))
	 (args (list "--swank-fd" (format nil "~d" clone)
		     "--swank-style" (format nil "~s" style))))
    (swank::close-connection conn nil nil)
    (swank-backend:exec-image image-file args)))

(in-package :swank)

(defun swank-snapshot::resurrect (old-connection)
  (setq *log-output* nil)
  (init-log-output)
  (clear-event-history)
  (setq *connections* (delete old-connection *connections*))
  (format *error-output* "args: ~s~%" (command-line-args))
  (let* ((fd (read-command-line-arg "--swank-fd"))
	 (style (read-command-line-arg "--swank-style")))
    (format *error-output* "fd=~s style=~s~%" fd style)
    (let ((connection (create-connection (make-fd-stream fd :default) style)))
      (run-hook *new-connection-hook* connection)
      (push connection *connections*)
      (serve-requests connection)
      (simple-repl))))

(defun read-command-line-arg (name)
  (let* ((args (command-line-args))
	 (pos (position name args :test #'equal)))
    (read-from-string (elt args (1+ pos)))))

(in-package :swank-snapshot)