/[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.125 by lgorrie, Mon Mar 21 00:38:43 2005 UTC revision 1.126 by heller, Mon Mar 21 00:57:27 2005 UTC
# Line 135  Line 135 
135    
136  (defun accept (socket)  (defun accept (socket)
137    "Like socket-accept, but retry on EAGAIN."    "Like socket-accept, but retry on EAGAIN."
138    (loop (handler-case    (loop (handler-case
139              (return (sb-bsd-sockets:socket-accept socket))              (return (sb-bsd-sockets:socket-accept socket))
140            (sb-bsd-sockets:interrupted-error ()))))            (sb-bsd-sockets:interrupted-error ()))))
141    
# Line 149  Line 149 
149  (defimplementation lisp-implementation-type-name ()  (defimplementation lisp-implementation-type-name ()
150    "sbcl")    "sbcl")
151    
 (defimplementation quit-lisp ()  
   (sb-ext:quit))  
   
152    
153  ;;;; Support for SBCL syntax  ;;;; Support for SBCL syntax
154    
# Line 202  Line 199 
199    (let ((name (package-name package)))    (let ((name (package-name package)))
200      (eql (mismatch "SB-" name) 3)))      (eql (mismatch "SB-" name) 3)))
201    
202    (defun sbcl-source-file-p (filename)
203      (loop for (_ pattern) in (logical-pathname-translations "SYS")
204            thereis (pathname-match-p filename pattern)))
205    
206    (defun guess-readtable-for-filename (filename)
207      (if (sbcl-source-file-p filename)
208          (shebang-readtable)
209          *readtable*))
210    
211  (defvar *debootstrap-packages* t)  (defvar *debootstrap-packages* t)
212    
213    (defun call-with-debootstrapping (fun)
214      (handler-bind ((sb-int:bootstrap-package-not-found
215                      #'sb-int:debootstrap-package))
216        (funcall fun)))
217    
218  (defmacro with-debootstrapping (&body body)  (defmacro with-debootstrapping (&body body)
219    (let ((not-found (find-symbol "BOOTSTRAP-PACKAGE-NOT-FOUND" "SB-INT"))    `(call-with-debootstrapping (lambda () ,@body)))
         (debootstrap (find-symbol "DEBOOTSTRAP-PACKAGE" "SB-INT")))  
     (if (and not-found debootstrap)  
         `(handler-bind ((,not-found #',debootstrap)) ,@body)  
         `(progn ,@body))))  
220    
221  (defimplementation call-with-syntax-hooks (fn)  (defimplementation call-with-syntax-hooks (fn)
222    (cond ((and *debootstrap-packages*    (cond ((and *debootstrap-packages*
# Line 442  This is useful when debugging the defini Line 449  This is useful when debugging the defini
449        (function-source-location fun name)        (function-source-location fun name)
450        (handler-case (function-source-location fun name)        (handler-case (function-source-location fun name)
451          (error (e)          (error (e)
452            (list (list :error (format nil "Error: ~A" e)))))))            (list :error (format nil "Error: ~A" e))))))
453    
 ;;; FIXME we don't handle the compiled-interactively case yet.  That  
 ;;; should have NIL :filename & :position, and non-NIL :source-form  
454  (defun function-source-location (function &optional name)  (defun function-source-location (function &optional name)
455    "Try to find the canonical source location of FUNCTION."    "Try to find the canonical source location of FUNCTION."
456    (let* ((def (sb-introspect:find-definition-source function))    (declare (type function function))
457           (stamp (definition-source-file-write-date def)))    (if (function-from-emacs-buffer-p function)
458          (find-temp-function-source-location function)
459          (find-function-source-location function)))
460    
461    (defun find-function-source-location (function)
462      (cond #+(or) ;; doesn't work unknown reasons
463            ((function-has-start-location-p function)
464             (code-location-source-location (function-start-location function)))
465            ((not (function-source-filename function))
466             (error "Source filename not recorded for ~A" function))
467            (t
468             (let* ((pos (function-source-position function))
469                    (snippet (function-hint-snippet function pos)))
470               (make-location `(:file ,(function-source-filename function))
471                              `(:position ,pos)
472                              `(:snippet ,snippet))))))
473    
474    (defun function-source-position (function)
475      ;; We only consider the toplevel form number here.
476      (let* ((tlf (function-toplevel-form-number function))
477             (filename (function-source-filename function))
478             (*readtable* (guess-readtable-for-filename filename)))
479        (with-debootstrapping
480          (source-path-file-position (list tlf) filename))))
481    
482    (defun function-source-filename (function)
483      (ignore-errors
484        (namestring
485         (truename
486          (sb-introspect:definition-source-pathname
487           (sb-introspect:find-definition-source function))))))
488    
489    (defun function-source-write-date (function)
490      (definition-source-file-write-date
491       (sb-introspect:find-definition-source function)))
492    
493    (defun function-toplevel-form-number (function)
494      (car
495       (sb-introspect:definition-source-form-path
496        (sb-introspect:find-definition-source function))))
497    
498    (defun function-hint-snippet (function position)
499      (let ((source (get-source-code (function-source-filename function)
500                                     (function-source-write-date function))))
501        (with-input-from-string (s source)
502          (file-position s position)
503          (read-snippet s))))
504    
505    (defun function-has-start-location-p (function)
506      (ignore-errors (function-start-location function)))
507    
508    (defun function-start-location (function)
509      (let ((dfun (sb-di:fun-debug-fun function)))
510        (and dfun (sb-di:debug-fun-start-location dfun))))
511    
512    (defun find-temp-function-source-location (function)
513      (let ((info (function-debug-source-info function)))
514      (with-struct (sb-introspect::definition-source-      (with-struct (sb-introspect::definition-source-
515                    pathname form-path character-offset) def                    form-path character-offset)
516        (cond ((function-from-emacs-buffer-p function)          (sb-introspect:find-definition-source function)
517               (let ((info (function-debug-source-info function)))        (destructuring-bind (&key emacs-buffer emacs-position emacs-string) info
518                 (destructuring-bind (&key emacs-buffer emacs-position          (let ((pos (if form-path
519                                           emacs-string) info                         (with-debootstrapping
520                   (let ((pos (if form-path                           (source-path-string-position
521                                  (with-debootstrapping                            form-path emacs-string))
522                                    (source-path-string-position                         character-offset)))
523                                     form-path emacs-string))            (make-location `(:buffer ,emacs-buffer)
524                                  character-offset)))                           `(:position ,(+ pos emacs-position))
525                     (make-location `(:buffer ,(getf info :emacs-buffer))                           `(:snippet ,emacs-string)))))))
                                   `(:position ,(+ pos emacs-position))  
                                   `(:snippet ,(getf info :emacs-string)))))))  
             (t  
              (let* ((filename (namestring (truename pathname)))  
                     (pos (if form-path  
                              (with-debootstrapping  
                                (source-path-file-position form-path filename) )  
                              character-offset)))  
                (make-location  
                 `(:file ,filename)  
                 (if pos  
                     `(:position ,pos)  
                     `(:function-name  
                       ,(or (and name (string name))  
                            (string (sb-kernel:%fun-name function)))))  
                 (let ((source (get-source-code pathname stamp)))  
                   (if source  
                       (with-input-from-string (stream source)  
                         (file-position stream pos)  
                         (list :snippet (read-snippet stream))))))))))))  
526    
527  ;; FIXME: Symbol doesn't exist in released SBCL yet.  ;; FIXME: Symbol doesn't exist in released SBCL (0.8.20) yet.
528  (defun definition-source-file-write-date (def)  (defun definition-source-file-write-date (def)
529    (let ((sym (find-symbol "DEFINITION-SOURCE-FILE-WRITE-DATE"    (let ((sym (find-symbol "DEFINITION-SOURCE-FILE-WRITE-DATE"
530                            (find-package "SB-INTROSPECT"))))                            (find-package "SB-INTROSPECT"))))
# Line 493  This is useful when debugging the defini Line 534  This is useful when debugging the defini
534    (let ((methods (sb-mop:generic-function-methods gf))    (let ((methods (sb-mop:generic-function-methods gf))
535          (name (sb-mop:generic-function-name gf)))          (name (sb-mop:generic-function-name gf)))
536      (loop for method in methods      (loop for method in methods
537            collect (list `(method ,name ,(sb-pcl::unparse-specializers method))            collect (list `(method ,name ,(sb-pcl::unparse-specializers method))
538                          (safe-function-source-location method name)))))                          (method-source-location method)))))
539    
540    (defun method-source-location (method)
541      (safe-function-source-location (or (sb-pcl::method-fast-function method)
542                                         (sb-pcl:method-function method))
543                                     nil))
544    
545  ;;;;; Compiler definitions  ;;;;; Compiler definitions
546    
547  (defun compiler-definitions (name)  (defun compiler-definitions (name)
# Line 630  stack." Line 676  stack."
676                 (let ((print-sym (find-symbol "PRINT-FRAME-CALL" :sb-debug)))                 (let ((print-sym (find-symbol "PRINT-FRAME-CALL" :sb-debug)))
677                   (if (fboundp print-sym)                   (if (fboundp print-sym)
678                       (let* ((args (sb-introspect:function-arglist print-sym))                       (let* ((args (sb-introspect:function-arglist print-sym))
679                            (key-pos (position '&key args)))                              (key-pos (position '&key args)))
680                         (cond ((eql 2 key-pos)                         (cond ((eql 2 key-pos)
681                                `(,print-sym frame stream))                                `(,print-sym frame stream))
682                               ((eql 1 key-pos)                               ((eql 1 key-pos)
# Line 681  stack." Line 727  stack."
727  (defun source-file-source-location (code-location)  (defun source-file-source-location (code-location)
728    (let* ((code-date (code-location-debug-source-created code-location))    (let* ((code-date (code-location-debug-source-created code-location))
729           (filename (code-location-debug-source-name code-location))           (filename (code-location-debug-source-name code-location))
730           (source-code (get-source-code filename code-date))           (source-code (get-source-code filename code-date)))
          (cloc code-location))  
731      (with-input-from-string (s source-code)      (with-input-from-string (s source-code)
732        (make-location `(:file ,filename)        (make-location `(:file ,filename)
733                       `(:position ,(1+ (stream-source-position cloc s)))                       `(:position ,(1+(stream-source-position code-location s)))
734                       `(:snippet ,(read-snippet s))))))                       `(:snippet ,(read-snippet s))))))
735    
736  (defun string-source-position (code-location string)  (defun string-source-position (code-location string)
# Line 730  stack." Line 775  stack."
775    
776  (defun stream-source-position (code-location stream)  (defun stream-source-position (code-location stream)
777    (let* ((cloc (sb-debug::maybe-block-start-location code-location))    (let* ((cloc (sb-debug::maybe-block-start-location code-location))
778           (tlf-number (sb-di::code-location-toplevel-form-offset cloc))           (tlf-number (1- (sb-di::code-location-toplevel-form-offset cloc)))
779           (form-number (sb-di::code-location-form-number cloc)))           (form-number (sb-di::code-location-form-number cloc)))
780      (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)      (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
781        (let* ((path-table (sb-di::form-number-translations tlf 0))        (let* ((path-table (sb-di::form-number-translations tlf 0))
# Line 766  stack." Line 811  stack."
811      (printer-form)))      (printer-form)))
812    
813  (defun safe-source-location-for-emacs (code-location)  (defun safe-source-location-for-emacs (code-location)
814    (handler-case (code-location-source-location code-location)    (if *debug-definition-finding*
815      (error (c) (list :error (format nil "~A" c)))))        (code-location-source-location code-location)
816          (handler-case (code-location-source-location code-location)
817            (error (c) (list :error (format nil "~A" c))))))
818    
819  (defimplementation frame-source-location-for-emacs (index)  (defimplementation frame-source-location-for-emacs (index)
820    (safe-source-location-for-emacs    (safe-source-location-for-emacs
# Line 868  stack." Line 915  stack."
915  (defmethod inspect-for-emacs ((o t) (inspector sbcl-inspector))  (defmethod inspect-for-emacs ((o t) (inspector sbcl-inspector))
916    (declare (ignore inspector))    (declare (ignore inspector))
917    (cond ((sb-di::indirect-value-cell-p o)    (cond ((sb-di::indirect-value-cell-p o)
918           (values "A value cell."           (values "A value cell." (label-value-line*
919                   `("Value: " (:value ,(sb-kernel:value-cell-ref o)))))                                    (:value (sb-kernel:value-cell-ref o)))))
920          (t          (t
921           (multiple-value-bind (text labeledp parts)           (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
922               (sb-impl::inspected-parts o)             (if label
923             (if labeledp                 (values text (loop for (l . v) in parts
924                 (values text                                    append (label-value-line l v)))
925                         (loop for (label . value) in parts                 (values text (loop for value in parts  for i from 0
926                               collect `(:value ,label)                                    append (label-value-line i value))))))))
                              collect " = "  
                              collect `(:value ,value)  
                              collect '(:newline)))  
                (values text  
                        (loop for value in parts  
                              for i from 0  
                              collect (princ-to-string i)  
                              collect " = "  
                              collect `(:value ,value)  
                              collect '(:newline))))))))  
927    
928  (defmethod inspect-for-emacs ((o function) (inspector sbcl-inspector))  (defmethod inspect-for-emacs ((o function) (inspector sbcl-inspector))
929    (declare (ignore inspector))    (declare (ignore inspector))
930    (let ((header (sb-kernel:widetag-of o)))    (let ((header (sb-kernel:widetag-of o)))
931      (cond ((= header sb-vm:simple-fun-header-widetag)      (cond ((= header sb-vm:simple-fun-header-widetag)
932             (values "A simple-fun."             (values "A simple-fun."
933                     `("Name: " (:value ,(sb-kernel:%simple-fun-name o))                     (label-value-line*
934                       (:newline)                      (:name (sb-kernel:%simple-fun-name o))
935                       "Arglist: " (:value ,(sb-kernel:%simple-fun-arglist o))                      (:arglist (sb-kernel:%simple-fun-arglist o))
936                       (:newline)                      (:self (sb-kernel:%simple-fun-self o))
937                       ,@(when (documentation o t)                      (:next (sb-kernel:%simple-fun-next o))
938                           `("Documentation: " (:newline) ,(documentation o t) (:newline)))                      (:type (sb-kernel:%simple-fun-type o))
939                       "Self: " (:value ,(sb-kernel:%simple-fun-self o))                      (:code (sb-kernel:fun-code-header o)))))
                      (:newline)  
                      "Next: " (:value ,(sb-kernel:%simple-fun-next o))  
                      (:newline)  
                      "Type: " (:value ,(sb-kernel:%simple-fun-type o))  
                      (:newline)  
                      "Code Object: " (:value ,(sb-kernel:fun-code-header o)))))  
940            ((= header sb-vm:closure-header-widetag)            ((= header sb-vm:closure-header-widetag)
941             (values "A closure."             (values "A closure."
942                     `("Function: " (:value ,(sb-kernel:%closure-fun o))                     (append
943                       (:newline)                      (label-value-line :function (sb-kernel:%closure-fun o))
944                       ,@(when (documentation o t)                      `("Closed over values:" (:newline))
945                           `("Documentation: " (:newline) ,(documentation o t) (:newline)))                      (loop for i below (1- (sb-kernel:get-closure-length o))
946                       "Closed over values:"                            append (label-value-line
947                       (:newline)                                    i (sb-kernel:%closure-index-ref o i))))))
                      ,@(loop for i from 0  
                           below (- (sb-kernel:get-closure-length o)  
                                    (1- sb-vm:closure-info-offset))  
                           collect (princ-to-string i)  
                           collect " = "  
                           collect `(:value ,(sb-kernel:%closure-index-ref o i))  
                           collect '(:newline)))))  
948            (t (call-next-method o)))))            (t (call-next-method o)))))
949    
950  (defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ sbcl-inspector))  (defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ sbcl-inspector))
# Line 946  stack." Line 970  stack."
970                           (sb-disassem::align                           (sb-disassem::align
971                            (+ (logandc2 (sb-kernel:get-lisp-obj-address o)                            (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
972                                         sb-vm:lowtag-mask)                                         sb-vm:lowtag-mask)
973                               (* sb-vm:code-constants-offset sb-vm:n-word-bytes))                               (* sb-vm:code-constants-offset
974                                    sb-vm:n-word-bytes))
975                            (ash 1 sb-vm:n-lowtag-bits))                            (ash 1 sb-vm:n-lowtag-bits))
976                           (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)                           (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
977                           :stream s))))))))                           :stream s))))))))
# Line 954  stack." Line 979  stack."
979  (defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector sbcl-inspector))  (defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector sbcl-inspector))
980    (declare (ignore inspector))    (declare (ignore inspector))
981    (values "A fdefn object."    (values "A fdefn object."
982            `("Name: "  (:value ,(sb-kernel:fdefn-name o))            (label-value-line*
983              (:newline)             (:name (sb-kernel:fdefn-name o))
984              "Function" (:value,(sb-kernel:fdefn-fun o))             (:function (sb-kernel:fdefn-fun o)))))
             (:newline)  
             ,@(when (documentation o t)  
                 `("Documentation: " (:newline) ,(documentation o t) (:newline))))))  
985    
986  (defmethod inspect-for-emacs :around ((o generic-function) (inspector sbcl-inspector))  (defmethod inspect-for-emacs :around ((o generic-function)
987                                          (inspector sbcl-inspector))
988    (declare (ignore inspector))    (declare (ignore inspector))
989    (multiple-value-bind (title contents)    (multiple-value-bind (title contents) (call-next-method)
       (call-next-method)  
990      (values title      (values title
991              (append contents              (append
992                      `("Pretty arglist: " (:value ,(sb-pcl::generic-function-pretty-arglist o))               contents
993                        (:newline)               (label-value-line*
994                        "Initial methods: " (:value ,(sb-pcl::generic-function-initial-methods  o)))))))                (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
995                  (:initial-methods (sb-pcl::generic-function-initial-methods o))
996                  )))))
997    
998    
999  ;;;; Multiprocessing  ;;;; Multiprocessing
# Line 1034  stack." Line 1058  stack."
1058    (defimplementation kill-thread (thread)    (defimplementation kill-thread (thread)
1059      (sb-thread:terminate-thread thread))      (sb-thread:terminate-thread thread))
1060    
1061      (defimplementation thread-alive-p (thread)
1062        (ignore-errors (sb-thread:interrupt-thread thread (lambda ())) t))
1063    
1064    (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))    (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1065    (defvar *mailboxes* (list))    (defvar *mailboxes* (list))
1066    (declaim (type list *mailboxes*))    (declaim (type list *mailboxes*))
# Line 1072  stack." Line 1099  stack."
1099    
1100    )    )
1101    
1102    (defimplementation quit-lisp ()
1103      #+sb-thread
1104      (dolist (thread (remove (current-thread) (all-threads)))
1105        (ignore-errors (sb-thread:terminate-thread thread)))
1106      (sb-ext:quit))
1107    
1108    
1109  ;;Trace implementations  ;;Trace implementations
1110  ;;In SBCL, we have:  ;;In SBCL, we have:

Legend:
Removed from v.1.125  
changed lines
  Added in v.1.126

  ViewVC Help
Powered by ViewVC 1.1.5