[slime-cvs] CVS slime

[CVS User heller]

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

Modified Files:
	ChangeLog swank-allegro.lisp swank-backend.lisp 
	swank-lispworks.lisp swank-openmcl.lisp swank.lisp 
Log Message:
* swank-backend.lisp (set-default-initial-binding): New function.
* swank.lisp (setup-stream-indirection):  Use it

--- /project/slime/cvsroot/slime/ChangeLog	2009/01/10 10:08:17	1.1659
+++ /project/slime/cvsroot/slime/ChangeLog	2009/01/10 12:17:41	1.1660
@@ -2,6 +2,11 @@
 
 	* swank.lisp (do-symbols*): Wrap body in TAGBODY.
 
+2009-01-10  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-backend.lisp (set-default-initial-binding): New function.
+	* swank.lisp (setup-stream-indirection):  Use it
+
 2009-01-09  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-allegro.lisp (swank-compile-string): Don't use the
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2009/01/09 07:12:56	1.122
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2009/01/10 12:17:41	1.123
@@ -693,6 +693,10 @@
      (mp:process-wait-with-timeout "receive-if" 0.5
                                    #'mp:gate-open-p (mailbox.gate mbox)))))
 
+(defimplementation set-default-initial-binding (var form)
+  (setq excl:*cl-default-special-bindings*
+        (acons var form excl:*cl-default-special-bindings*)))
+
 (defimplementation quit-lisp ()
   (excl:exit 0 :quiet t))
 
--- /project/slime/cvsroot/slime/swank-backend.lisp	2009/01/08 10:33:43	1.167
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2009/01/10 12:17:41	1.168
@@ -1036,6 +1036,14 @@
 (definterface receive-if (predicate &optional timeout)
   "Return the first message satisfiying PREDICATE.")
 
+(definterface set-default-initial-binding (var form)
+  "Initialize special variable VAR by default with FORM.
+
+Some implementations initialize certain variables in each newly
+created thread.  This function sets the form which is used to produce
+the initial value."
+  (set var (eval form)))
+
 ;; List of delayed interrupts.  
 ;; This should only have thread-local bindings, so no init form.
 (defvar *pending-slime-interrupts*)
--- /project/slime/cvsroot/slime/swank-lispworks.lisp	2009/01/08 10:33:44	1.126
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp	2009/01/10 12:17:41	1.127
@@ -753,11 +753,7 @@
         (t (funcall continuation))))
 
 (defimplementation spawn (fn &key name)
-  (let ((mp:*process-initial-bindings* 
-         (remove (find-package :cl) 
-                 mp:*process-initial-bindings*
-                 :key (lambda (x) (symbol-package (car x))))))
-    (mp:process-run-function name () fn)))
+  (mp:process-run-function name () fn))
 
 (defvar *id-lock* (mp:make-lock))
 (defvar *thread-id-counter* 0)
@@ -835,6 +831,11 @@
       (setf (mailbox.queue mbox)
             (nconc (mailbox.queue mbox) (list message))))))
 
+(defimplementation set-default-initial-binding (var form)
+  (setq mp:*process-initial-bindings* 
+        (acons var `(eval (quote ,form))
+               mp:*process-initial-bindings* )))
+
 ;;; Some intergration with the lispworks environment
 
 (defun swank-sym (name) (find-symbol (string name) :swank))
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/01/08 10:33:44	1.153
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/01/10 12:17:41	1.154
@@ -1094,6 +1094,9 @@
      (when (eq timeout t) (return (values nil t)))
      (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))
 
+(defimplementation set-default-initial-binding (var form)
+  (eval `(ccl::def-standard-initial-binding ,var ,form)))
+
 (defimplementation quit-lisp ()
   (ccl::quit))
 
--- /project/slime/cvsroot/slime/swank.lisp	2009/01/10 10:06:59	1.629
+++ /project/slime/cvsroot/slime/swank.lisp	2009/01/10 12:17:41	1.630
@@ -1457,7 +1457,9 @@
     (proclaim `(special ,current-stream-var))
     (set current-stream-var stream)
     ;; Assign the real binding as a synonym for the current one.
-    (set stream-var (make-synonym-stream current-stream-var))))
+    (let ((stream (make-synonym-stream current-stream-var)))
+      (set stream-var stream)
+      (set-default-initial-binding stream-var `(quote ,stream)))))
 
 (defun prefixed-var (prefix variable-symbol)
   "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"