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

Diff of /slime/swank-lispworks.lisp

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

revision 1.121 by heller, Fri Oct 17 21:26:53 2008 UTC revision 1.128 by heller, Sat Jan 10 12:25:16 2009 UTC
# Line 102  Line 102 
102             (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")             (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")
103                    external-format)))                    external-format)))
104    
 (defun set-sigint-handler ()  
   ;; Set SIGINT handler on Swank request handler thread.  
   #-win32  
   (sys::set-signal-handler +sigint+  
                            (make-sigint-handler mp:*current-process*)))  
   
105  ;;; Coding Systems  ;;; Coding Systems
106    
107  (defun valid-external-format-p (external-format)  (defun valid-external-format-p (external-format)
# Line 141  Line 135 
135      (declare (ignore args))      (declare (ignore args))
136      (mp:process-interrupt process #'sigint-handler)))      (mp:process-interrupt process #'sigint-handler)))
137    
138    (defun set-sigint-handler ()
139      ;; Set SIGINT handler on Swank request handler thread.
140      #-win32
141      (sys::set-signal-handler +sigint+
142                               (make-sigint-handler mp:*current-process*)))
143    
144    #-win32
145    (defimplementation install-sigint-handler (handler)
146      (sys::set-signal-handler +sigint+
147                               (let ((self mp:*current-process*))
148                                 (lambda (&rest args)
149                                   (declare (ignore args))
150                                   (mp:process-interrupt self handler)))))
151    
152  (defimplementation call-without-interrupts (fn)  (defimplementation call-without-interrupts (fn)
153    (lw:without-interrupts (funcall fn)))    (lw:without-interrupts (funcall fn)))
154    
# Line 217  Return NIL if the symbol is unbound." Line 225  Return NIL if the symbol is unbound."
225    
226  (defun describe-function (symbol)  (defun describe-function (symbol)
227    (cond ((fboundp symbol)    (cond ((fboundp symbol)
228           (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"           (format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%"
229                   (string-downcase symbol)                   symbol
230                   (mapcar #'string-upcase                   (lispworks:function-lambda-list symbol)
                          (lispworks:function-lambda-list symbol))  
231                   (documentation symbol 'function))                   (documentation symbol 'function))
232           (describe (fdefinition symbol)))           (describe (fdefinition symbol)))
233          (t (format t "~S is not fbound" symbol))))          (t (format t "~S is not fbound" symbol))))
# Line 356  Return NIL if the symbol is unbound." Line 363  Return NIL if the symbol is unbound."
363        (declare (ignore _n _s _l))        (declare (ignore _n _s _l))
364        value)))        value)))
365    
 (defimplementation frame-catch-tags (index)  
   (declare (ignore index))  
   nil)  
   
366  (defimplementation frame-source-location-for-emacs (frame)  (defimplementation frame-source-location-for-emacs (frame)
367    (let ((frame (nth-frame frame))    (let ((frame (nth-frame frame))
368          (callee (if (plusp frame) (nth-frame (1- frame)))))          (callee (if (plusp frame) (nth-frame (1- frame)))))
# Line 423  Return NIL if the symbol is unbound." Line 426  Return NIL if the symbol is unbound."
426             (signal-undefined-functions compiler::*unknown-functions*             (signal-undefined-functions compiler::*unknown-functions*
427                                         ,location))))))                                         ,location))))))
428    
429  (defimplementation swank-compile-file (filename load-p external-format)  (defimplementation swank-compile-file (input-file output-file
430    (with-swank-compilation-unit (filename)                                         load-p external-format)
431      (compile-file filename :load load-p    (with-swank-compilation-unit (input-file)
432        (compile-file input-file
433                      :output-file output-file
434                      :load load-p
435                    :external-format external-format)))                    :external-format external-format)))
436    
437  (defvar *within-call-with-compilation-hooks* nil  (defvar *within-call-with-compilation-hooks* nil
# Line 625  function names like \(SETF GET)." Line 631  function names like \(SETF GET)."
631                  nil)))                  nil)))
632             htab))             htab))
633    
634  (defimplementation swank-compile-string (string &key buffer position directory  (defimplementation swank-compile-string (string &key buffer position filename
635                                                  debug)                                           policy)
636    (declare (ignore directory debug))    (declare (ignore filename policy))
637    (assert buffer)    (assert buffer)
638    (assert position)    (assert position)
639    (let* ((location (list :emacs-buffer buffer position string))    (let* ((location (list :emacs-buffer buffer position string))
# Line 750  function names like \(SETF GET)." Line 756  function names like \(SETF GET)."
756          (t (funcall continuation))))          (t (funcall continuation))))
757    
758  (defimplementation spawn (fn &key name)  (defimplementation spawn (fn &key name)
759    (let ((mp:*process-initial-bindings*    (mp:process-run-function name () fn))
          (remove (find-package :cl)  
                  mp:*process-initial-bindings*  
                  :key (lambda (x) (symbol-package (car x))))))  
     (mp:process-run-function name () fn)))  
760    
761  (defvar *id-lock* (mp:make-lock))  (defvar *id-lock* (mp:make-lock))
762  (defvar *thread-id-counter* 0)  (defvar *thread-id-counter* 0)
# Line 824  function names like \(SETF GET)." Line 826  function names like \(SETF GET)."
826             (return (car tail)))))             (return (car tail)))))
827       (when (eq timeout t) (return (values nil t)))       (when (eq timeout t) (return (values nil t)))
828       (mp:process-wait-with-timeout       (mp:process-wait-with-timeout
829        "receive-if" 0.2 (lambda () (some test (mailbox.queue mbox)))))))        "receive-if" 0.3 (lambda () (some test (mailbox.queue mbox)))))))
830    
831  (defimplementation send (thread message)  (defimplementation send (thread message)
832    (let ((mbox (mailbox thread)))    (let ((mbox (mailbox thread)))
# Line 832  function names like \(SETF GET)." Line 834  function names like \(SETF GET)."
834        (setf (mailbox.queue mbox)        (setf (mailbox.queue mbox)
835              (nconc (mailbox.queue mbox) (list message))))))              (nconc (mailbox.queue mbox) (list message))))))
836    
837    (defimplementation set-default-initial-binding (var form)
838      (setq mp:*process-initial-bindings*
839            (acons var `(eval (quote ,form))
840                   mp:*process-initial-bindings* )))
841    
842  ;;; Some intergration with the lispworks environment  ;;; Some intergration with the lispworks environment
843    
844  (defun swank-sym (name) (find-symbol (string name) :swank))  (defun swank-sym (name) (find-symbol (string name) :swank))
   
 (defimplementation emacs-connected ()  
   (when (eq (eval (swank-sym :*communication-style*))  
             nil)  
     (set-sigint-handler)))  
845    
846    
847  ;;;; Weak hashtables  ;;;; Weak hashtables

Legend:
Removed from v.1.121  
changed lines
  Added in v.1.128

  ViewVC Help
Powered by ViewVC 1.1.5