[slime-cvs] CVS update: slime/swank-allegro.lisp

[Luke Gorrie]

Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv29920

Modified Files:
	swank-allegro.lisp 
Log Message:
Removed fwrapper-based code for inheriting "swankiness" to newly
spawned threads. This was fighting the system and not the right thing.

Date: Sun Aug  1 22:23:57 2004
Author: lgorrie

Index: slime/swank-allegro.lisp
diff -u slime/swank-allegro.lisp:1.46 slime/swank-allegro.lisp:1.47
--- slime/swank-allegro.lisp:1.46	Sat Jul 31 23:44:46 2004
+++ slime/swank-allegro.lisp	Sun Aug  1 22:23:57 2004
@@ -45,13 +45,6 @@
 (defimplementation accept-connection (socket)
   (socket:accept-connection socket :wait t))
 
-;; The following defitinions are workarounds for the buggy
-;; no-applicable-method function in Allegro 5.  We have to provide an
-;; implementation.
-(defimplementation emacs-connected (stream)
-  (declare (ignore stream))
-  (install-advice))
-
 (defimplementation format-sldb-condition (c)
   (princ-to-string c))
 
@@ -366,43 +359,11 @@
 
 ;;;; Multithreading
 
-(defvar *swank-thread* nil
-  "Bound to true in any thread with an ancestor created by SPAWN.
-Such threads always use Emacs for debugging and user interaction.")
-
-(defvar *inherited-bindings*
-  '(*debugger-hook*
-    *standard-output* *error-output* *trace-output*
-    *standard-input*
-    *debug-io* *query-io* *terminal-io*)
-  "Variables whose values are inherited by children of Swank threads.")
-
 (defimplementation startup-multiprocessing ()
   (mp:start-scheduler))
 
 (defimplementation spawn (fn &key name)
-  (mp:process-run-function name
-                           (lambda ()
-                             (let ((*swank-thread* t))
-                               (funcall fn)))))
-
-#+(version>= 6)
-(excl:def-fwrapper make-process/inherit (&key &allow-other-keys)
-  "Advice for MP:MAKE-PROCESS.
-New threads that have a Swank thread for an ancestor will inherit
-debugging and I/O bindings from their parent."
-  (let ((process (excl:call-next-fwrapper)))
-    (when *swank-thread*
-      (push (cons '*swank-thread* t)
-            (mp:process-initial-bindings process))
-      (dolist (variable *inherited-bindings*)
-        (push (cons variable (symbol-value variable))
-              (mp:process-initial-bindings process))))
-    process))
-
-(defun install-advice ()
-  #+(version>= 6)
-  (excl:fwrap 'mp:make-process 'make-process/inherit 'make-process/inherit))
+  (mp:process-run-function name fn))
 
 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
 (defvar *thread-id-counter* 0)