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

Diff of /slime/swank-sbcl.lisp

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

revision 1.157 by heller, Mon Jun 26 06:28:06 2006 UTC revision 1.158 by jsnellman, Sat Jul 1 07:11:31 2006 UTC
# Line 4  Line 4 
4  ;;;  ;;;
5  ;;; Created 2003, Daniel Barlow <dan@metacircles.com>  ;;; Created 2003, Daniel Barlow <dan@metacircles.com>
6  ;;;  ;;;
7  ;;; This code has been placed in the Public Domain.  All warranties are  ;;; This code has been placed in the Public Domain.  All warranties are
8  ;;; disclaimed.  ;;; disclaimed.
9    
10  ;;; Requires the SB-INTROSPECT contrib.  ;;; Requires the SB-INTROSPECT contrib.
# Line 27  Line 27 
27  (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))  (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
28    
29  (defun swank-mop:slot-definition-documentation (slot)  (defun swank-mop:slot-definition-documentation (slot)
30    (sb-pcl::documentation slot t))    (sb-pcl::documentation slot t))
31    
32  ;;; TCP Server  ;;; TCP Server
33    
# Line 41  Line 41 
41            (not (sb-alien:extern-alien "linux_no_threads_p" sb-alien:boolean)))            (not (sb-alien:extern-alien "linux_no_threads_p" sb-alien:boolean)))
42        :spawn)        :spawn)
43      (t :fd-handler)))      (t :fd-handler)))
44    
45  (defun resolve-hostname (name)  (defun resolve-hostname (name)
46    (car (sb-bsd-sockets:host-ent-addresses    (car (sb-bsd-sockets:host-ent-addresses
47          (sb-bsd-sockets:get-host-by-name name))))          (sb-bsd-sockets:get-host-by-name name))))
# Line 62  Line 62 
62    (sb-sys:invalidate-descriptor (socket-fd socket))    (sb-sys:invalidate-descriptor (socket-fd socket))
63    (sb-bsd-sockets:socket-close socket))    (sb-bsd-sockets:socket-close socket))
64    
65  (defimplementation accept-connection (socket &key  (defimplementation accept-connection (socket &key
66                                        (external-format :iso-latin-1-unix)                                        (external-format :iso-latin-1-unix)
67                                        (buffering :full) timeout)                                        (buffering :full) timeout)
68    (declare (ignore timeout))    (declare (ignore timeout))
# Line 95  Line 95 
95  (defimplementation remove-sigio-handlers (socket)  (defimplementation remove-sigio-handlers (socket)
96    (let ((fd (socket-fd socket)))    (let ((fd (socket-fd socket)))
97      (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))      (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
98      (sb-sys:invalidate-descriptor fd))      (sb-sys:invalidate-descriptor fd))
99    (close socket))    (close socket))
100    
101  (defimplementation add-fd-handler (socket fn)  (defimplementation add-fd-handler (socket fn)
102    (declare (type function fn))    (declare (type function fn))
103    (let ((fd (socket-fd socket)))    (let ((fd (socket-fd socket)))
104      (format *debug-io* "; Adding fd handler: ~S ~%" fd)      (format *debug-io* "; Adding fd handler: ~S ~%" fd)
105      (sb-sys:add-fd-handler fd :input (lambda (_)      (sb-sys:add-fd-handler fd :input (lambda (_)
106                                         _                                         _
107                                         (funcall fn)))))                                         (funcall fn)))))
108    
# Line 128  Line 128 
128                                         :input t                                         :input t
129                                         :element-type 'character                                         :element-type 'character
130                                         :buffering buffering                                         :buffering buffering
131                                         #+sb-unicode :external-format                                         #+sb-unicode :external-format
132                                         #+sb-unicode ef                                         #+sb-unicode ef
133                                         )))                                         )))
134    
135  (defun accept (socket)  (defun accept (socket)
136    "Like socket-accept, but retry on EAGAIN."    "Like socket-accept, but retry on EAGAIN."
137    (loop (handler-case    (loop (handler-case
138              (return (sb-bsd-sockets:socket-accept socket))              (return (sb-bsd-sockets:socket-accept socket))
139            (sb-bsd-sockets:interrupted-error ()))))            (sb-bsd-sockets:interrupted-error ()))))
140    
# Line 190  Line 190 
190          (read stream t nil t))))          (read stream t nil t))))
191   (values))   (values))
192    
193  (defvar *shebang-readtable*  (defvar *shebang-readtable*
194    (let ((*readtable* (copy-readtable nil)))    (let ((*readtable* (copy-readtable nil)))
195      (set-dispatch-macro-character #\# #\!      (set-dispatch-macro-character #\# #\!
196                                    (lambda (s c n) (shebang-reader s c n))                                    (lambda (s c n) (shebang-reader s c n))
197                                    *readtable*)                                    *readtable*)
198      *readtable*))      *readtable*))
# Line 216  Line 216 
216  (defvar *debootstrap-packages* t)  (defvar *debootstrap-packages* t)
217    
218  (defun call-with-debootstrapping (fun)  (defun call-with-debootstrapping (fun)
219    (handler-bind ((sb-int:bootstrap-package-not-found    (handler-bind ((sb-int:bootstrap-package-not-found
220                    #'sb-int:debootstrap-package))                    #'sb-int:debootstrap-package))
221      (funcall fun)))      (funcall fun)))
222    
# Line 224  Line 224 
224    `(call-with-debootstrapping (lambda () ,@body)))    `(call-with-debootstrapping (lambda () ,@body)))
225    
226  (defimplementation call-with-syntax-hooks (fn)  (defimplementation call-with-syntax-hooks (fn)
227    (cond ((and *debootstrap-packages*    (cond ((and *debootstrap-packages*
228                (sbcl-package-p *package*))                (sbcl-package-p *package*))
229           (with-debootstrapping (funcall fn)))           (with-debootstrapping (funcall fn)))
230          (t          (t
# Line 291  information." Line 291  information."
291        (list :error "No error location available")))        (list :error "No error location available")))
292    
293  (defun locate-compiler-note (file source-path source)  (defun locate-compiler-note (file source-path source)
294    (cond ((and ;;(eq file :lisp)    (cond ((and (not (eq file :lisp)) *buffer-name*)
               *buffer-name*)  
295           ;; Compiling from a buffer           ;; Compiling from a buffer
296           (let ((position (+ *buffer-offset*           (let ((position (+ *buffer-offset*
297                              (source-path-string-position                              (source-path-string-position
298                               (cons 0 (nthcdr 2 source-path))                               source-path *buffer-substring*))))
                              *buffer-substring*))))  
299             (make-location (list :buffer *buffer-name*)             (make-location (list :buffer *buffer-name*)
300                            (list :position position))))                            (list :position position))))
301          ((and (pathnamep file) (null *buffer-name*))          ((and (pathnamep file) (null *buffer-name*))
302           ;; Compiling from a file           ;; Compiling from a file
303           (make-location (list :file (namestring file))           (make-location (list :file (namestring file))
304                          (list :position                          (list :position
305                                (1+ (source-path-file-position                                (1+ (source-path-file-position
306                                     source-path file)))))                                     source-path file)))))
307          ((and (eq file :lisp) (stringp source))          ((and (eq file :lisp) (stringp source))
308           ;; Compiling macro generated code           ;; Compiling macro generated code
# Line 360  compiler state." Line 358  compiler state."
358    
359  (defvar *trap-load-time-warnings* nil)  (defvar *trap-load-time-warnings* nil)
360    
361  (defimplementation swank-compile-file (filename load-p  (defimplementation swank-compile-file (filename load-p
362                                         &optional external-format)                                         &optional external-format)
363    (let ((ef (if external-format    (let ((ef (if external-format
364                  (find-external-format external-format)                  (find-external-format external-format)
365                  :default)))                  :default)))
366      (handler-case      (handler-case
# Line 396  compiler state." Line 394  compiler state."
394          (*buffer-offset* position)          (*buffer-offset* position)
395          (*buffer-substring* string)          (*buffer-substring* string)
396          (filename (temp-file-name)))          (filename (temp-file-name)))
397      (flet ((compile-it (fn)      (flet ((compile-it (fn)
398               (with-compilation-hooks ()               (with-compilation-hooks ()
399                 (with-compilation-unit                 (with-compilation-unit
400                     (:source-plist (list :emacs-buffer buffer                     (:source-plist (list :emacs-buffer buffer
# Line 594  Return a list of the form (NAME LOCATION Line 592  Return a list of the form (NAME LOCATION
592    (declare (type function debugger-loop-fn))    (declare (type function debugger-loop-fn))
593    (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))    (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
594           (sb-debug:*stack-top-hint* nil))           (sb-debug:*stack-top-hint* nil))
595      (handler-bind ((sb-di:debug-condition      (handler-bind ((sb-di:debug-condition
596                      (lambda (condition)                      (lambda (condition)
597                        (signal (make-condition                        (signal (make-condition
598                                 'sldb-condition                                 'sldb-condition
# Line 644  stack." Line 642  stack."
642  ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the  ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
643  ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co  ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
644  ;;; which returns the source location for a _code-location_.  ;;; which returns the source location for a _code-location_.
645  ;;;  ;;;
646  ;;; Maybe these should be named code-location-file-source-location,  ;;; Maybe these should be named code-location-file-source-location,
647  ;;; etc, turned into generic functions, or something. In the very  ;;; etc, turned into generic functions, or something. In the very
648  ;;; least the names should indicate the main entry point vs. helper  ;;; least the names should indicate the main entry point vs. helper
# Line 661  stack." Line 659  stack."
659            (t (error "Cannot find source location for: ~A " code-location)))))            (t (error "Cannot find source location for: ~A " code-location)))))
660    
661  (defun lisp-source-location (code-location)  (defun lisp-source-location (code-location)
662    (let ((source (prin1-to-string    (let ((source (prin1-to-string
663                   (sb-debug::code-location-source-form code-location 100))))                   (sb-debug::code-location-source-form code-location 100))))
664      (make-location `(:source-form ,source) '(:position 0))))      (make-location `(:source-form ,source) '(:position 0))))
665    
# Line 671  stack." Line 669  stack."
669          (let* ((pos (string-source-position code-location emacs-string))          (let* ((pos (string-source-position code-location emacs-string))
670                 (snipped (with-input-from-string (s emacs-string)                 (snipped (with-input-from-string (s emacs-string)
671                            (read-snippet s pos))))                            (read-snippet s pos))))
672            (make-location `(:buffer ,emacs-buffer)            (make-location `(:buffer ,emacs-buffer)
673                           `(:position ,(+ emacs-position pos))                           `(:position ,(+ emacs-position pos))
674                           `(:snippet ,snipped))))                           `(:snippet ,snipped))))
675        (fallback-source-location code-location)))        (fallback-source-location code-location)))
676    
# Line 691  stack." Line 689  stack."
689    (sb-c::debug-source-name (sb-di::code-location-debug-source code-location)))    (sb-c::debug-source-name (sb-di::code-location-debug-source code-location)))
690    
691  (defun code-location-debug-source-created (code-location)  (defun code-location-debug-source-created (code-location)
692    (sb-c::debug-source-created    (sb-c::debug-source-created
693     (sb-di::code-location-debug-source code-location)))     (sb-di::code-location-debug-source code-location)))
694    
695  (defun code-location-debug-fun-fun (code-location)  (defun code-location-debug-fun-fun (code-location)
696    (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))    (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
697    
698  (defun code-location-has-debug-block-info-p (code-location)  (defun code-location-has-debug-block-info-p (code-location)
699    (handler-case    (handler-case
700        (progn (sb-di:code-location-debug-block code-location)        (progn (sb-di:code-location-debug-block code-location)
701               t)               t)
702      (sb-di:no-debug-blocks  () nil)))      (sb-di:no-debug-blocks  () nil)))
# Line 727  stack." Line 725  stack."
725        (code-location-source-location code-location)        (code-location-source-location code-location)
726        (handler-case (code-location-source-location code-location)        (handler-case (code-location-source-location code-location)
727          (error (c) (list :error (format nil "~A" c))))))          (error (c) (list :error (format nil "~A" c))))))
728    
729  (defimplementation frame-source-location-for-emacs (index)  (defimplementation frame-source-location-for-emacs (index)
730    (safe-source-location-for-emacs    (safe-source-location-for-emacs
731     (sb-di:frame-code-location (nth-frame index))))     (sb-di:frame-code-location (nth-frame index))))
732    
733  (defun frame-debug-vars (frame)  (defun frame-debug-vars (frame)
# Line 761  stack." Line 759  stack."
759  (defimplementation eval-in-frame (form index)  (defimplementation eval-in-frame (form index)
760    (let ((frame (nth-frame index)))    (let ((frame (nth-frame index)))
761      (funcall (the function      (funcall (the function
762                 (sb-di:preprocess-for-eval form                 (sb-di:preprocess-for-eval form
763                                            (sb-di:frame-code-location frame)))                                            (sb-di:frame-code-location frame)))
764               frame)))               frame)))
765    
# Line 783  stack." Line 781  stack."
781  (defimplementation restart-frame (index)  (defimplementation restart-frame (index)
782    (let ((frame (nth-frame index)))    (let ((frame (nth-frame index)))
783      (return-from-frame index (sb-debug::frame-call-as-list frame))))      (return-from-frame index (sb-debug::frame-call-as-list frame))))
784    
785  ;;;;; reference-conditions  ;;;;; reference-conditions
786    
787  (defimplementation format-sldb-condition (condition)  (defimplementation format-sldb-condition (condition)
# Line 858  stack." Line 856  stack."
856                      (:code (sb-kernel:fun-code-header o)))))                      (:code (sb-kernel:fun-code-header o)))))
857            ((= header sb-vm:closure-header-widetag)            ((= header sb-vm:closure-header-widetag)
858             (values "A closure."             (values "A closure."
859                     (append                     (append
860                      (label-value-line :function (sb-kernel:%closure-fun o))                      (label-value-line :function (sb-kernel:%closure-fun o))
861                      `("Closed over values:" (:newline))                      `("Closed over values:" (:newline))
862                      (loop for i below (1- (sb-kernel:get-closure-length o))                      (loop for i below (1- (sb-kernel:get-closure-length o))
863                            append (label-value-line                            append (label-value-line
864                                    i (sb-kernel:%closure-index-ref o i))))))                                    i (sb-kernel:%closure-index-ref o i))))))
865            (t (call-next-method o)))))            (t (call-next-method o)))))
866    
867  (defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ sbcl-inspector))  (defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ sbcl-inspector))
868    (declare (ignore _))    (declare (ignore _))
869    (values (format nil "~A is a code data-block." o)    (values (format nil "~A is a code data-block." o)
870            (append            (append
871             (label-value-line*             (label-value-line*
872              (:code-size (sb-kernel:%code-code-size o))              (:code-size (sb-kernel:%code-code-size o))
873              (:entry-points (sb-kernel:%code-entry-points o))              (:entry-points (sb-kernel:%code-entry-points o))
874              (:debug-info (sb-kernel:%code-debug-info o))              (:debug-info (sb-kernel:%code-debug-info o))
875              (:trace-table-offset (sb-kernel:code-header-ref              (:trace-table-offset (sb-kernel:code-header-ref
876                                    o sb-vm:code-trace-table-offset-slot)))                                    o sb-vm:code-trace-table-offset-slot)))
877             `("Constants:" (:newline))             `("Constants:" (:newline))
878             (loop for i from sb-vm:code-constants-offset             (loop for i from sb-vm:code-constants-offset
879                   below (sb-kernel:get-header-data o)                   below (sb-kernel:get-header-data o)
880                   append (label-value-line i (sb-kernel:code-header-ref o i)))                   append (label-value-line i (sb-kernel:code-header-ref o i)))
881             `("Code:" (:newline)             `("Code:" (:newline)
# Line 885  stack." Line 883  stack."
883                   (cond ((sb-kernel:%code-debug-info o)                   (cond ((sb-kernel:%code-debug-info o)
884                          (sb-disassem:disassemble-code-component o :stream s))                          (sb-disassem:disassemble-code-component o :stream s))
885                         (t                         (t
886                          (sb-disassem:disassemble-memory                          (sb-disassem:disassemble-memory
887                           (sb-disassem::align                           (sb-disassem::align
888                            (+ (logandc2 (sb-kernel:get-lisp-obj-address o)                            (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
889                                         sb-vm:lowtag-mask)                                         sb-vm:lowtag-mask)
890                               (* sb-vm:code-constants-offset                               (* sb-vm:code-constants-offset
# Line 902  stack." Line 900  stack."
900             (:name (sb-kernel:fdefn-name o))             (:name (sb-kernel:fdefn-name o))
901             (:function (sb-kernel:fdefn-fun o)))))             (:function (sb-kernel:fdefn-fun o)))))
902    
903  (defmethod inspect-for-emacs :around ((o generic-function)  (defmethod inspect-for-emacs :around ((o generic-function)
904                                        (inspector sbcl-inspector))                                        (inspector sbcl-inspector))
905    (declare (ignore inspector))    (declare (ignore inspector))
906    (multiple-value-bind (title contents) (call-next-method)    (multiple-value-bind (title contents) (call-next-method)
907      (values title      (values title
908              (append              (append
909               contents               contents
910               (label-value-line*               (label-value-line*
911                (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))                (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
# Line 921  stack." Line 919  stack."
919         #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))         #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
920  (progn  (progn
921    (defvar *thread-id-counter* 0)    (defvar *thread-id-counter* 0)
922    
923    (defvar *thread-id-counter-lock*    (defvar *thread-id-counter-lock*
924      (sb-thread:make-mutex :name "thread id counter lock"))      (sb-thread:make-mutex :name "thread id counter lock"))
925    
926    (defun next-thread-id ()    (defun next-thread-id ()
927      (sb-thread:with-mutex (*thread-id-counter-lock*)      (sb-thread:with-mutex (*thread-id-counter-lock*)
928        (incf *thread-id-counter*)))        (incf *thread-id-counter*)))
929    
930    (defparameter *thread-id-map* (make-hash-table))    (defparameter *thread-id-map* (make-hash-table))
931    
932    ;; This should be a thread -> id map but as weak keys are not    ;; This should be a thread -> id map but as weak keys are not
933    ;; supported it is id -> map instead.    ;; supported it is id -> map instead.
934    (defvar *thread-id-map-lock*    (defvar *thread-id-map-lock*
935      (sb-thread:make-mutex :name "thread id map lock"))      (sb-thread:make-mutex :name "thread id map lock"))
936    
937    (defimplementation spawn (fn &key name)    (defimplementation spawn (fn &key name)
938      (sb-thread:make-thread fn :name name))      (sb-thread:make-thread fn :name name))
939    
# Line 969  stack." Line 967  stack."
967                      (remhash id *thread-id-map*)                      (remhash id *thread-id-map*)
968                      nil)))                      nil)))
969              nil))))              nil))))
970    
971    (defimplementation thread-name (thread)    (defimplementation thread-name (thread)
972      ;; sometimes the name is not a string (e.g. NIL)      ;; sometimes the name is not a string (e.g. NIL)
973      (princ-to-string (sb-thread:thread-name thread)))      (princ-to-string (sb-thread:thread-name thread)))
# Line 998  stack." Line 996  stack."
996    
997    (defimplementation all-threads ()    (defimplementation all-threads ()
998      (sb-thread:list-all-threads))      (sb-thread:list-all-threads))
999    
1000    (defimplementation interrupt-thread (thread fn)    (defimplementation interrupt-thread (thread fn)
1001      (sb-thread:interrupt-thread thread fn))      (sb-thread:interrupt-thread thread fn))
1002    
# Line 1012  stack." Line 1010  stack."
1010    (defvar *mailboxes* (list))    (defvar *mailboxes* (list))
1011    (declaim (type list *mailboxes*))    (declaim (type list *mailboxes*))
1012    
1013    (defstruct (mailbox (:conc-name mailbox.))    (defstruct (mailbox (:conc-name mailbox.))
1014      thread      thread
1015      (mutex (sb-thread:make-mutex))      (mutex (sb-thread:make-mutex))
1016      (waitqueue  (sb-thread:make-waitqueue))      (waitqueue  (sb-thread:make-waitqueue))
# Line 1049  stack." Line 1047  stack."
1047    
1048    ;; XXX race conditions    ;; XXX race conditions
1049    (defvar *auto-flush-streams* '())    (defvar *auto-flush-streams* '())
1050    
1051    (defvar *auto-flush-thread* nil)    (defvar *auto-flush-thread* nil)
1052    
1053    (defimplementation make-stream-interactive (stream)    (defimplementation make-stream-interactive (stream)
1054      (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*))      (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*))
1055      (unless *auto-flush-thread*      (unless *auto-flush-thread*
1056        (setq *auto-flush-thread*        (setq *auto-flush-thread*
1057              (sb-thread:make-thread #'flush-streams              (sb-thread:make-thread #'flush-streams
1058                                     :name "auto-flush-thread"))))                                     :name "auto-flush-thread"))))
1059    
1060    (defun flush-streams ()    (defun flush-streams ()
1061      (loop      (loop
1062       (setq *auto-flush-streams*       (setq *auto-flush-streams*
1063             (remove-if (lambda (x)             (remove-if (lambda (x)
1064                          (not (and (open-stream-p x)                          (not (and (open-stream-p x)
1065                                    (output-stream-p x))))                                    (output-stream-p x))))
1066                        *auto-flush-streams*))                        *auto-flush-streams*))
# Line 1074  stack." Line 1072  stack."
1072  (defimplementation quit-lisp ()  (defimplementation quit-lisp ()
1073    #+sb-thread    #+sb-thread
1074    (dolist (thread (remove (current-thread) (all-threads)))    (dolist (thread (remove (current-thread) (all-threads)))
1075      (ignore-errors (sb-thread:interrupt-thread      (ignore-errors (sb-thread:interrupt-thread
1076                      thread (lambda () (sb-ext:quit :recklessly-p t)))))                      thread (lambda () (sb-ext:quit :recklessly-p t)))))
1077    (sb-ext:quit))    (sb-ext:quit))
1078    
# Line 1107  stack." Line 1105  stack."
1105    
1106  (defimplementation toggle-trace (spec)  (defimplementation toggle-trace (spec)
1107    (ecase (car spec)    (ecase (car spec)
1108      ((setf)      ((setf)
1109       (toggle-trace-aux spec))       (toggle-trace-aux spec))
1110      ((:defmethod)      ((:defmethod)
1111       (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))       (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))

Legend:
Removed from v.1.157  
changed lines
  Added in v.1.158

  ViewVC Help
Powered by ViewVC 1.1.5