/[slime]/slime/swank-allegro.lisp
ViewVC logotype

Diff of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.46 by heller, Sun Aug 1 06:44:46 2004 UTC revision 1.47 by lgorrie, Mon Aug 2 05:23:57 2004 UTC
# Line 45  Line 45 
45  (defimplementation accept-connection (socket)  (defimplementation accept-connection (socket)
46    (socket:accept-connection socket :wait t))    (socket:accept-connection socket :wait t))
47    
 ;; 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))  
   
48  (defimplementation format-sldb-condition (c)  (defimplementation format-sldb-condition (c)
49    (princ-to-string c))    (princ-to-string c))
50    
# Line 366  Line 359 
359    
360  ;;;; Multithreading  ;;;; Multithreading
361    
 (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.")  
   
362  (defimplementation startup-multiprocessing ()  (defimplementation startup-multiprocessing ()
363    (mp:start-scheduler))    (mp:start-scheduler))
364    
365  (defimplementation spawn (fn &key name)  (defimplementation spawn (fn &key name)
366    (mp:process-run-function name    (mp:process-run-function name fn))
                            (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))  
367    
368  (defvar *id-lock* (mp:make-process-lock :name "id lock"))  (defvar *id-lock* (mp:make-process-lock :name "id lock"))
369  (defvar *thread-id-counter* 0)  (defvar *thread-id-counter* 0)

Legend:
Removed from v.1.46  
changed lines
  Added in v.1.47

  ViewVC Help
Powered by ViewVC 1.1.5