/[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.106 by heller, Wed Aug 6 19:51:29 2008 UTC revision 1.128 by heller, Sat Jan 10 12:25:16 2009 UTC
# Line 32  Line 32 
32  (defun swank-mop:eql-specializer-object (eql-spec)  (defun swank-mop:eql-specializer-object (eql-spec)
33    (second eql-spec))    (second eql-spec))
34    
35  (when (fboundp 'dspec::define-dspec-alias)  (eval-when (:compile-toplevel :execute :load-toplevel)
36    (dspec::define-dspec-alias defimplementation (name args &rest body)    (defvar *original-defimplementation* (macro-function 'defimplementation))
37      `(defmethod ,name ,args ,@body)))    (defmacro defimplementation (&whole whole name args &body body
38                                   &environment env)
39        (declare (ignore args body))
40        `(progn
41           (dspec:record-definition '(defun ,name) (dspec:location)
42                                    :check-redefinition-p nil)
43           ,(funcall *original-defimplementation* whole env))))
44    
45  ;;; TCP server  ;;; TCP server
46    
# Line 67  Line 73 
73    
74  (defimplementation accept-connection (socket  (defimplementation accept-connection (socket
75                                        &key external-format buffering timeout)                                        &key external-format buffering timeout)
76    (declare (ignore buffering timeout external-format))    (declare (ignore buffering))
77    (let* ((fd (comm::get-fd-from-socket socket)))    (let* ((fd (comm::get-fd-from-socket socket)))
78      (assert (/= fd -1))      (assert (/= fd -1))
79      (make-instance 'comm:socket-stream :socket fd :direction :io      (assert (valid-external-format-p external-format))
80                     :element-type 'base-char)))      (cond ((member (first external-format) '(:latin-1 :ascii))
81               (make-instance 'comm:socket-stream
82  (defun set-sigint-handler ()                            :socket fd
83    ;; Set SIGINT handler on Swank request handler thread.                            :direction :io
84    #-win32                            :read-timeout timeout
85    (sys::set-signal-handler +sigint+                            :element-type 'base-char))
86                             (make-sigint-handler mp:*current-process*)))            (t
87               (make-flexi-stream
88                (make-instance 'comm:socket-stream
89                               :socket fd
90                               :direction :io
91                               :read-timeout timeout
92                               :element-type '(unsigned-byte 8))
93                external-format)))))
94    
95    (defun make-flexi-stream (stream external-format)
96      (unless (member :flexi-streams *features*)
97        (error "Cannot use external format ~A without having installed flexi-streams in the inferior-lisp."
98               external-format))
99      (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM")
100               stream
101               :external-format
102               (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")
103                      external-format)))
104    
105  ;;; Coding Systems  ;;; Coding Systems
106    
107    (defun valid-external-format-p (external-format)
108      (member external-format *external-format-to-coding-system*
109              :test #'equal :key #'car))
110    
111  (defvar *external-format-to-coding-system*  (defvar *external-format-to-coding-system*
112    '(((:latin-1 :eol-style :lf)    '(((:latin-1 :eol-style :lf)
113       "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")       "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
# Line 108  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 148  Return NIL if the symbol is unbound." Line 189  Return NIL if the symbol is unbound."
189                 (let ((pos (position #\newline string)))                 (let ((pos (position #\newline string)))
190                   (if (null pos) string (subseq string 0 pos))))                   (if (null pos) string (subseq string 0 pos))))
191               (doc (kind &optional (sym symbol))               (doc (kind &optional (sym symbol))
192                 (let ((string (documentation sym kind)))                 (let ((string (or (documentation sym kind))))
193                   (if string                   (if string
194                       (first-line string)                       (first-line string)
195                       :not-documented)))                       :not-documented)))
# Line 184  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 212  Return NIL if the symbol is unbound." Line 252  Return NIL if the symbol is unbound."
252                   :io-bindings io-bindings                   :io-bindings io-bindings
253                   :debugger-hoook hook))                   :debugger-hoook hook))
254    
255  (defmethod env-internals:environment-display-notifier  (defmethod env-internals:environment-display-notifier
256      ((env slime-env) &key restarts condition)      ((env slime-env) &key restarts condition)
257    (declare (ignore restarts))    (declare (ignore restarts condition))
258    (funcall (slot-value env 'debugger-hook) condition *debugger-hook*))    (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*)
259      ;;  nil
260      )
261    
262  (defmethod env-internals:environment-display-debugger ((env slime-env))  (defmethod env-internals:environment-display-debugger ((env slime-env))
263    *debug-io*)    *debug-io*)
264    
265    (defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
266      (apply (swank-sym :y-or-n-p-in-emacs) msg args))
267    
268  (defimplementation call-with-debugger-hook (hook fun)  (defimplementation call-with-debugger-hook (hook fun)
269    (let ((*debugger-hook* hook))    (let ((*debugger-hook* hook))
270      (env:with-environment ((slime-env hook '()))      (env:with-environment ((slime-env hook '()))
# Line 318  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 346  Return NIL if the symbol is unbound." Line 387  Return NIL if the symbol is unbound."
387    (let ((frame (nth-frame frame-number)))    (let ((frame (nth-frame frame-number)))
388      (dbg::restart-frame frame :same-args t)))      (dbg::restart-frame frame :same-args t)))
389    
390    (defimplementation disassemble-frame (frame-number)
391      (let* ((frame (nth-frame frame-number)))
392        (when (dbg::call-frame-p frame)
393          (let ((function (dbg::get-call-frame-function frame)))
394            (disassemble function)))))
395    
396  ;;; Definition finding  ;;; Definition finding
397    
398  (defun frame-location (dspec callee-name)  (defun frame-location (dspec callee-name)
# Line 373  Return NIL if the symbol is unbound." Line 420  Return NIL if the symbol is unbound."
420    (lw:rebinding (location)    (lw:rebinding (location)
421      `(let ((compiler::*error-database* '()))      `(let ((compiler::*error-database* '()))
422         (with-compilation-unit ,options         (with-compilation-unit ,options
423           ,@body           (multiple-value-prog1 (progn ,@body)
424           (signal-error-data-base compiler::*error-database* ,location)             (signal-error-data-base compiler::*error-database*
425           (signal-undefined-functions compiler::*unknown-functions* ,location)))))                                     ,location)
426               (signal-undefined-functions compiler::*unknown-functions*
427  (defimplementation swank-compile-file (filename load-p external-format)                                         ,location))))))
428    (with-swank-compilation-unit (filename)  
429      (compile-file filename :load load-p :external-format external-format)))  (defimplementation swank-compile-file (input-file output-file
430                                           load-p external-format)
431      (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)))
436    
437  (defvar *within-call-with-compilation-hooks* nil  (defvar *within-call-with-compilation-hooks* nil
438    "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")    "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")
# Line 429  Return NIL if the symbol is unbound." Line 482  Return NIL if the symbol is unbound."
482                    :location location                    :location location
483                    :original-condition condition)))                    :original-condition condition)))
484    
485    (defvar *temp-file-format* '(:utf-8 :eol-style :lf))
486    
487  (defun compile-from-temp-file (string filename)  (defun compile-from-temp-file (string filename)
488    (unwind-protect    (unwind-protect
489         (progn         (progn
490           (with-open-file (s filename :direction :output :if-exists :supersede)           (with-open-file (s filename :direction :output
491                                         :if-exists :supersede
492                                         :external-format *temp-file-format*)
493    
494             (write-string string s)             (write-string string s)
495             (finish-output s))             (finish-output s))
496           (let ((binary-filename (compile-file filename :load t)))           (multiple-value-bind (binary-filename warnings? failure?)
497                 (compile-file filename :load t
498                               :external-format *temp-file-format*)
499               (declare (ignore warnings?))
500             (when binary-filename             (when binary-filename
501               (delete-file binary-filename))))               (delete-file binary-filename))
502               (not failure?)))
503      (delete-file filename)))      (delete-file filename)))
504    
505  (defun dspec-buffer-position (dspec offset)  (defun dspec-function-name-position (dspec fallback)
506    (etypecase dspec    (etypecase dspec
507      (cons (let ((name (dspec:dspec-primary-name dspec)))      (cons (let ((name (dspec:dspec-primary-name dspec)))
508              (typecase name              (typecase name
509                ((or symbol string)                ((or symbol string)
510                 (list :function-name (string name)))                 (list :function-name (string name)))
511                (t (list :position offset)))))                (t fallback))))
512      (null (list :position offset))      (null fallback)
513      (symbol (list :function-name (string dspec)))))      (symbol (list :function-name (string dspec)))))
514    
515  (defmacro with-fairly-standard-io-syntax (&body body)  (defmacro with-fairly-standard-io-syntax (&body body)
# Line 461  Return NIL if the symbol is unbound." Line 523  Return NIL if the symbol is unbound."
523                (*readtable* ,readtable))                (*readtable* ,readtable))
524            ,@body)))))            ,@body)))))
525    
526    (defun skip-comments (stream)
527      (let ((pos0 (file-position stream)))
528        (cond ((equal (ignore-errors (list (read-delimited-list #\( stream)))
529                      '(()))
530               (file-position stream (1- (file-position stream))))
531              (t (file-position stream pos0)))))
532    
533  #-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3  #-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
534  (defun dspec-stream-position (stream dspec)  (defun dspec-stream-position (stream dspec)
535    (with-fairly-standard-io-syntax    (with-fairly-standard-io-syntax
536      (loop (let* ((pos (file-position stream))      (loop (let* ((pos (progn (skip-comments stream) (file-position stream)))
537                   (form (read stream nil '#1=#:eof)))                   (form (read stream nil '#1=#:eof)))
538              (when (eq form '#1#)              (when (eq form '#1#)
539                (return nil))                (return nil))
# Line 498  Return NIL if the symbol is unbound." Line 567  Return NIL if the symbol is unbound."
567               #-(or lispworks4.1 lispworks4.2)               #-(or lispworks4.1 lispworks4.2)
568               (dspec-stream-position stream dspec)))               (dspec-stream-position stream dspec)))
569          (if pos          (if pos
570              (list :position (1+ pos) t)              (list :position (1+ pos))
571              (dspec-buffer-position dspec 1))))))              (dspec-function-name-position dspec `(:position 1)))))))
572    
573  (defun emacs-buffer-location-p (location)  (defun emacs-buffer-location-p (location)
574    (and (consp location)    (and (consp location)
# Line 521  Return NIL if the symbol is unbound." Line 590  Return NIL if the symbol is unbound."
590       (destructuring-bind (_ buffer offset string) location       (destructuring-bind (_ buffer offset string) location
591         (declare (ignore _ string))         (declare (ignore _ string))
592         (make-location `(:buffer ,buffer)         (make-location `(:buffer ,buffer)
593                        (dspec-buffer-position dspec offset)                        (dspec-function-name-position dspec `(:offset ,offset 0))
594                        hints)))))                        hints)))))
595    
596  (defun make-dspec-progenitor-location (dspec location)  (defun make-dspec-progenitor-location (dspec location)
# Line 562  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 687  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 747  function names like \(SETF GET)." Line 812  function names like \(SETF GET)."
812          (setf (getf (mp:process-plist thread) 'mailbox)          (setf (getf (mp:process-plist thread) 'mailbox)
813                (make-mailbox)))))                (make-mailbox)))))
814    
815  (defimplementation receive ()  (defimplementation receive-if (test &optional timeout)
   (let* ((mbox (mailbox mp:*current-process*))  
          (lock (mailbox.mutex mbox)))  
     (loop  
      (check-slime-interrupts)  
      (mp:with-lock (lock "receive/try")  
        (when (mailbox.queue mbox)  
          (return (pop (mailbox.queue mbox)))))  
      (mp:process-wait-with-timeout "receive" 0.2 #'mailbox.queue mbox))))  
   
 (defimplementation receive-if (test)  
816    (let* ((mbox (mailbox mp:*current-process*))    (let* ((mbox (mailbox mp:*current-process*))
817           (lock (mailbox.mutex mbox)))           (lock (mailbox.mutex mbox)))
818        (assert (or (not timeout) (eq timeout t)))
819      (loop      (loop
820       (check-slime-interrupts)       (check-slime-interrupts)
821       (mp:with-lock (lock "receive-if/try")       (mp:with-lock (lock "receive-if/try")
# Line 768  function names like \(SETF GET)." Line 824  function names like \(SETF GET)."
824           (when tail           (when tail
825             (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))             (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
826             (return (car tail)))))             (return (car tail)))))
827         (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 777  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))  
   ;; pop up the slime debugger by default  
   (let ((lw:*handle-warn-on-redefinition* :warn))  
     (defmethod env-internals:environment-display-notifier  
         (env &key restarts condition)  
       (declare (ignore restarts))  
       (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*))  
     (defmethod env-internals:environment-display-debugger (env)  
       *debug-io*)))  
   
 (defvar *auto-flush-interval* 0.15)  
 (defvar *auto-flush-lock* (mp:make-lock :name "auto-flush-lock"))  
 (defvar *auto-flush-thread* nil)  
 (defvar *auto-flush-streams* '())  
   
 (defimplementation make-stream-interactive (stream)  
   (mp:with-lock (*auto-flush-lock*)  
     (pushnew stream *auto-flush-streams*)  
     (unless *auto-flush-thread*  
       (setq *auto-flush-thread*  
             (mp:process-run-function "auto-flush-thread [SWANK]" ()  
                                      #'flush-streams)))))  
   
 (defun flush-streams ()  
   (loop  
    (mp:with-lock (*auto-flush-lock*)  
      (setq *auto-flush-streams*  
            (remove-if (lambda (x)  
                         (not (and (open-stream-p x)  
                                   (output-stream-p x))))  
                       *auto-flush-streams*))  
      (mapc #'finish-output *auto-flush-streams*))  
    (sleep *auto-flush-interval*)))  
   
 (defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)  
   (apply (swank-sym :y-or-n-p-in-emacs) msg args))  
845    
846    
847  ;;;; Weak hashtables  ;;;; Weak hashtables

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

  ViewVC Help
Powered by ViewVC 1.1.5