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

Diff of /slime/swank-cmucl.lisp

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

revision 1.30 by heller, Sun Nov 30 08:09:44 2003 UTC revision 1.32 by heller, Wed Dec 3 22:34:50 2003 UTC
# Line 26  Line 26 
26           (address (car (ext:host-entry-addr-list hostent))))           (address (car (ext:host-entry-addr-list hostent))))
27      (ext:htonl address)))      (ext:htonl address)))
28    
29  (defun create-swank-server (port &key reuse-address (address "localhost"))  (defun create-swank-server (port &key (reuse-address t)
30                                (address "localhost"))
31    "Create a SWANK TCP server."    "Create a SWANK TCP server."
32    (let* ((ip (resolve-hostname address))    (let* ((ip (resolve-hostname address))
33           (fd (ext:create-inet-listener port :stream           (fd (ext:create-inet-listener port :stream
# Line 233  the error-context redundant." Line 234  the error-context redundant."
234      (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"      (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"
235              enclosing source condition)))              enclosing source condition)))
236    
237    
238  (defun compiler-note-location (context)  (defun compiler-note-location (context)
239    (cond (context    (cond (context
240           (resolve-note-location           (resolve-note-location
# Line 258  the error-context redundant." Line 260  the error-context redundant."
260     `(:position ,(+ *buffer-start-position*     `(:position ,(+ *buffer-start-position*
261                     (source-path-string-position path *buffer-substring*)))))                     (source-path-string-position path *buffer-substring*)))))
262    
263    (defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))
264      (make-location
265       `(:source-form ,source)
266       `(:position 1)))
267    
268  (defmethod resolve-note-location (buffer  (defmethod resolve-note-location (buffer
269                                    (file (eql nil))                                    (file (eql nil))
270                                    (pos (eql nil))                                    (pos (eql nil))
# Line 328  the error-context redundant." Line 335  the error-context redundant."
335    (lookup-xrefs #'xref:who-sets variable))    (lookup-xrefs #'xref:who-sets variable))
336    
337  #+cmu19  #+cmu19
338  (defslimefun who-macroexpands (macro)  (progn
339    "Return the places where MACRO is expanded."    (defslimefun who-macroexpands (macro)
340    (lookup-xrefs #'xref:who-macroexpands macro))      "Return the places where MACRO is expanded."
341        (lookup-xrefs #'xref:who-macroexpands macro))
342    
343      (defslimefun who-specializes (class)
344        "Return the methods with specializers for CLASS."
345        (let* ((methods (xref::who-specializes (find-class (from-string class))))
346               (locations (mapcar #'method-source-location methods)))
347          (group-xrefs (mapcar (lambda (m l)
348                                 (cons (let ((*print-pretty* nil))
349                                         (to-string m))
350                                       l))
351                               methods locations))))
352      )
353    
354  (defun resolve-xref-location (xref)  (defun resolve-xref-location (xref)
355    (let ((name (xref:xref-context-name xref))    (let ((name (xref:xref-context-name xref))
# Line 581  The second return value is the condition Line 600  The second return value is the condition
600    
601  (defun dd-source-location (dd)  (defun dd-source-location (dd)
602    (let ((constructor (or (kernel:dd-default-constructor dd)    (let ((constructor (or (kernel:dd-default-constructor dd)
603                           (car (kernel::dd-constructors dd)))))                           (car (kernel::dd-constructors dd)))))
604      (cond (constructor      (when (or (not constructor) (and (consp constructor)
605             (function-source-location                                       (not (car constructor))))
606              (coerce (if (consp constructor) (car constructor) constructor)        (error "Cannot locate struct without constructor: ~S"
607                      'function)))               (kernel::dd-name dd)))
608            (t (error "Cannot locate struct without constructor: ~S"      (function-source-location
609                      (kernel::dd-name dd))))))       (coerce (if (consp constructor) (car constructor) constructor)
610                 'function))))
611    
612  (defun genericp (fn)  (defun genericp (fn)
613    (typep fn 'generic-function))    (typep fn 'generic-function))
# Line 658  The second return value is the condition Line 678  The second return value is the condition
678            ((macro-function symbol)            ((macro-function symbol)
679             (function-source-locations (macro-function symbol)))             (function-source-locations (macro-function symbol)))
680            ((special-operator-p symbol)            ((special-operator-p symbol)
681             (list (list :error (format nil "~A is special-operator" symbol))))             (list (list :error (format nil "~A is a special-operator" symbol))))
682            ((fboundp symbol)            ((fboundp symbol)
683             (function-source-locations (coerce symbol 'function)))             (function-source-locations (coerce symbol 'function)))
684            (t (list (list :error            (t (list (list :error
# Line 906  of deepest (i.e. smallest) possible form Line 926  of deepest (i.e. smallest) possible form
926      ;; select the first subform present in source-map      ;; select the first subform present in source-map
927      (loop for form in (reverse forms)      (loop for form in (reverse forms)
928            for positions = (gethash form source-map)            for positions = (gethash form source-map)
929            until positions            until (and positions (null (cdr positions)))
930            finally (destructuring-bind ((start . end)) positions            finally (destructuring-bind ((start . end)) positions
931                      (return (values (1- start) end))))))                      (return (values (1- start) end))))))
932    
# Line 935  to find the position of the correspondin Line 955  to find the position of the correspondin
955    (with-open-file (s filename :direction :input)    (with-open-file (s filename :direction :input)
956      (code-location-stream-position code-location s)))      (code-location-stream-position code-location s)))
957    
 (defun make-file-location (pathname code-location)  
   (make-location  
    `(:file ,(unix-truename pathname))  
    `(:position ,(1+ (code-location-file-position code-location pathname)))))  
   
 (defun make-buffer-location (buffer start string code-location)  
   (make-location  
    `(:buffer ,buffer)  
    `(:position ,(+ start (code-location-string-offset code-location string)))))  
   
958  (defun debug-source-info-from-emacs-buffer-p (debug-source)  (defun debug-source-info-from-emacs-buffer-p (debug-source)
959    (let ((info (c::debug-source-info debug-source)))    (let ((info (c::debug-source-info debug-source)))
960      (and info      (and info
# Line 960  to find the position of the correspondin Line 970  to find the position of the correspondin
970           (from (di:debug-source-from debug-source))           (from (di:debug-source-from debug-source))
971           (name (di:debug-source-name debug-source)))           (name (di:debug-source-name debug-source)))
972      (ecase from      (ecase from
973        (:file (make-file-location name code-location))        (:file
974           (make-location (list :file (unix-truename name))
975                          (list :position (1+ (code-location-file-position
976                                               code-location name)))))
977        (:stream        (:stream
978         (assert (debug-source-info-from-emacs-buffer-p debug-source))         (assert (debug-source-info-from-emacs-buffer-p debug-source))
979         (let ((info (c::debug-source-info debug-source)))         (let ((info (c::debug-source-info debug-source)))
980           (make-buffer-location (getf info :emacs-buffer)           (make-location
981                                 (getf info :emacs-buffer-offset)            (list :buffer (getf info :emacs-buffer))
982                                 (getf info :emacs-buffer-string)            (list :position (+ (getf info :emacs-buffer-offset)
983                                 code-location)))                               (code-location-string-offset
984                                  code-location
985                                  (getf info :emacs-buffer-string)))))))
986        (:lisp        (:lisp
987         `(:sexp , (with-output-to-string (*standard-output*)         (make-location
988                     (debug::print-code-location-source-form          (list :source-form (with-output-to-string (*standard-output*)
989                      code-location 100 t)))))))                               (debug::print-code-location-source-form
990                                  code-location 100 t)))
991            (list :position 1))))))
992    
993  (defun code-location-source-location (code-location)  (defun code-location-source-location (code-location)
994    "Safe wrapper around `code-location-from-source-location'."    "Safe wrapper around `code-location-from-source-location'."
# Line 1083  stack." Line 1100  stack."
1100          collect `(,tag . ,(code-location-source-location code-location))))          collect `(,tag . ,(code-location-source-location code-location))))
1101    
1102  (defslimefun invoke-nth-restart (index)  (defslimefun invoke-nth-restart (index)
1103    (invoke-restart (nth-restart index)))    (invoke-restart-interactively (nth-restart index)))
1104    
1105  (defslimefun sldb-abort ()  (defslimefun sldb-abort ()
1106    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))

Legend:
Removed from v.1.30  
changed lines
  Added in v.1.32

  ViewVC Help
Powered by ViewVC 1.1.5