/[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.29 by heller, Fri Mar 5 22:53:34 2004 UTC revision 1.30 by heller, Tue Mar 9 12:46:27 2004 UTC
# Line 8  Line 8 
8  ;;; are disclaimed.  ;;; are disclaimed.
9  ;;;  ;;;
10    
11  (in-package :swank)  (in-package :swank-backend)
12    
13  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
14    (require "comm"))    (require "comm"))
# Line 27  Line 27 
27    
28  ;;; TCP server  ;;; TCP server
29    
30  (setq *swank-in-background* :spawn)  (defimplementation preferred-communication-style ()
31      :spawn)
32    
33  (defun socket-fd (socket)  (defun socket-fd (socket)
34    (etypecase socket    (etypecase socket
# Line 82  Line 83 
83  (defimplementation lisp-implementation-type-name ()  (defimplementation lisp-implementation-type-name ()
84    "lispworks")    "lispworks")
85    
86  (defimplementation arglist-string (fname)  (defimplementation arglist (symbol)
87    (format-arglist fname    (let ((arglist (lw:function-lambda-list symbol)))
88                    (lambda (symbol)      (etypecase arglist
89                      (let ((arglist (lw:function-lambda-list symbol)))        ((member :dont-know)
90                        (etypecase arglist         (error "<arglist-unavailable>"))
91                          ((member :dont-know)        (list arglist))))
                          (error "<arglist-unavailable>"))  
                         (cons arglist))))))  
92    
93  (defimplementation macroexpand-all (form)  (defimplementation macroexpand-all (form)
94    (walker:walk-form form))    (walker:walk-form form))
# Line 118  Return NIL if the symbol is unbound." Line 117  Return NIL if the symbol is unbound."
117        (maybe-push        (maybe-push
118         :class (if (find-class symbol nil)         :class (if (find-class symbol nil)
119                    (doc 'class)))                    (doc 'class)))
120        (if result        result)))
           (list* :designator (to-string symbol) result)))))  
121    
122  (defimplementation describe-definition (symbol-name type)  (defimplementation describe-definition (symbol type)
123    (case type    (ecase type
124      ;; FIXME: This should cover all types returned by      (:variable (describe-symbol symbol))
125      ;; DESCRIBE-SYMBOL-FOR-EMACS.      (:class (describe (find-class symbol)))
126      (:function (describe-function symbol-name))))      (:function (describe-function symbol))))
127    
128  (defun describe-function (symbol-name)  (defun describe-function (symbol)
129    (with-output-to-string (*standard-output*)    (cond ((fboundp symbol)
130      (let ((sym (from-string symbol-name)))           (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"
131        (cond ((fboundp sym)                   (string-downcase symbol)
132               (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"                   (mapcar #'string-upcase
133                       (string-downcase sym)                           (lispworks:function-lambda-list symbol))
134                       (mapcar #'string-upcase                   (documentation symbol 'function))
135                               (lispworks:function-lambda-list sym))           (describe (symbol-function symbol)))
136                       (documentation sym 'function))          (t (format t "~S is not fbound" symbol))))
              (describe (symbol-function sym)))  
             (t (format t "~S is not fbound" sym))))))  
137    
138  #+(or)  (defun describe-symbol (sym)
 (defimplementation describe-object ((sym symbol) *standard-output*)  
139    (format t "~A is a symbol in package ~A." sym (symbol-package sym))    (format t "~A is a symbol in package ~A." sym (symbol-package sym))
140    (when (boundp sym)    (when (boundp sym)
141      (format t "~%~%Value: ~A" (symbol-value sym)))      (format t "~%~%Value: ~A" (symbol-value sym)))
# Line 148  Return NIL if the symbol is unbound." Line 143  Return NIL if the symbol is unbound."
143      (when doc      (when doc
144        (format t "~%~%Variable documentation:~%~A"  doc)))        (format t "~%~%Variable documentation:~%~A"  doc)))
145    (when (fboundp sym)    (when (fboundp sym)
146      (format t "~%~%(~A~{ ~A~})"      (describe-function sym)))
             (string-downcase sym)  
             (mapcar #'string-upcase  
                     (lispworks:function-lambda-list sym))))  
   (let ((doc (documentation sym 'function)))  
     (when doc (format t "~%~%~A~%"  doc))))  
147    
148  ;;; Debugging  ;;; Debugging
149    
 (defvar *sldb-restarts*)  
150  (defvar *sldb-top-frame*)  (defvar *sldb-top-frame*)
151    
 (defslimefun sldb-abort ()  
   (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))  
   
152  (defimplementation call-with-debugging-environment (fn)  (defimplementation call-with-debugging-environment (fn)
153    (dbg::with-debugger-stack ()    (dbg::with-debugger-stack ()
154      (let ((*sldb-restarts* (compute-restarts *swank-debugger-condition*))      (let ((*sldb-top-frame* (dbg::debugger-stack-current-frame
           (*sldb-top-frame* (dbg::debugger-stack-current-frame  
155                               dbg::*debugger-stack*)))                               dbg::*debugger-stack*)))
156        (funcall fn))))        (funcall fn))))
157    
 (defun format-restarts-for-emacs ()  
   (loop for restart in *sldb-restarts*  
         collect (list (princ-to-string (restart-name restart))  
                       (princ-to-string restart))))  
   
158  (defun interesting-frame-p (frame)  (defun interesting-frame-p (frame)
159    (or (dbg::call-frame-p frame)    (or (dbg::call-frame-p frame)
160        ;;(dbg::catch-frame-p frame)        ;;(dbg::catch-frame-p frame)
# Line 186  Return NIL if the symbol is unbound." Line 166  Return NIL if the symbol is unbound."
166        ((and (interesting-frame-p frame) (zerop i)) frame)        ((and (interesting-frame-p frame) (zerop i)) frame)
167      (assert frame)))      (assert frame)))
168    
169  (defun compute-backtrace (start end)  (defimplementation compute-backtrace (start end)
170    (let ((end (or end most-positive-fixnum))    (let ((end (or end most-positive-fixnum))
171          (backtrace '()))          (backtrace '()))
172      (do ((frame (nth-frame start) (dbg::frame-next frame))      (do ((frame (nth-frame start) (dbg::frame-next frame))
# Line 196  Return NIL if the symbol is unbound." Line 176  Return NIL if the symbol is unbound."
176          (incf i)          (incf i)
177          (push frame backtrace)))))          (push frame backtrace)))))
178    
179  (defimplementation backtrace (start end)  (defimplementation print-frame (frame stream)
180    (flet ((format-frame (f i)    (cond ((dbg::call-frame-p frame)
181             (print-with-frame-label           (format stream "~A ~A"
182              i (lambda (s)                   (dbg::call-frame-function-name frame)
183                 (cond ((dbg::call-frame-p f)                   (dbg::call-frame-arglist frame)))
184                        (format s "~A ~A"          (t (princ frame stream))))
                               (dbg::call-frame-function-name f)  
                               (dbg::call-frame-arglist f)))  
                      (t (princ f s)))))))  
     (loop for i from start  
           for f in (compute-backtrace start end)  
           collect (list i (format-frame f i)))))  
   
 (defimplementation debugger-info-for-emacs (start end)  
   (list (debugger-condition-for-emacs)  
         (format-restarts-for-emacs)  
         (backtrace start end)))  
   
 (defun nth-restart (index)  
   (nth index *sldb-restarts*))  
   
 (defslimefun invoke-nth-restart (index)  
   (invoke-restart-interactively (nth-restart index)))  
185    
186  (defimplementation frame-locals (n)  (defimplementation frame-locals (n)
187    (let ((frame (nth-frame n)))    (let ((frame (nth-frame n)))
# Line 242  Return NIL if the symbol is unbound." Line 205  Return NIL if the symbol is unbound."
205      (if (dbg::call-frame-p frame)      (if (dbg::call-frame-p frame)
206          (let ((func (dbg::call-frame-function-name frame)))          (let ((func (dbg::call-frame-function-name frame)))
207            (if func            (if func
208                (name-source-location func))))))                (cadr (name-source-location func)))))))
209    
210  (defimplementation eval-in-frame (form frame-number)  (defimplementation eval-in-frame (form frame-number)
211    (let ((frame (nth-frame frame-number)))    (let ((frame (nth-frame frame-number)))
# Line 250  Return NIL if the symbol is unbound." Line 213  Return NIL if the symbol is unbound."
213    
214  (defimplementation return-from-frame (frame-number form)  (defimplementation return-from-frame (frame-number form)
215    (let* ((frame (nth-frame frame-number))    (let* ((frame (nth-frame frame-number))
216           (return-frame (dbg::find-frame-for-return frame))           (return-frame (dbg::find-frame-for-return frame)))
          (form (from-string form)))  
217      (dbg::dbg-return-from-call-frame frame form return-frame      (dbg::dbg-return-from-call-frame frame form return-frame
218                                       dbg::*debugger-stack*)))                                       dbg::*debugger-stack*)))
219    
# Line 270  Return NIL if the symbol is unbound." Line 232  Return NIL if the symbol is unbound."
232             (list :error (format nil "Cannot find source for ~S" name)))             (list :error (format nil "Cannot find source for ~S" name)))
233            (t            (t
234             (loop for (dspec location) in locations             (loop for (dspec location) in locations
235                   collect (make-dspec-location dspec location))))))                   collect (list dspec (make-dspec-location dspec location)))))))
236    
237  (defimplementation find-function-locations (fname)  (defimplementation find-definitions (name)
238    (name-source-locations (from-string fname)))    (name-source-locations name))
239    
240  ;;; Compilation  ;;; Compilation
241    
242  (defimplementation compile-file-for-emacs (filename load-p)  (defimplementation swank-compile-file (filename load-p)
243    (let ((compiler::*error-database* '()))    (let ((compiler::*error-database* '()))
244      (with-compilation-unit ()      (with-compilation-unit ()
245        (compile-file filename :load load-p)        (compile-file filename :load load-p)
# Line 376  Return NIL if the symbol is unbound." Line 338  Return NIL if the symbol is unbound."
338                  nil)))                  nil)))
339             htab))             htab))
340    
341  (defimplementation compile-string-for-emacs (string &key buffer position)  (defimplementation swank-compile-string (string &key buffer position)
342    (assert buffer)    (assert buffer)
343    (assert position)    (assert position)
344    (let* ((*package* *buffer-package*)    (let* ((location (list :emacs-buffer buffer position string))
          (location (list :emacs-buffer buffer position string))  
345           (compiler::*error-database* '())           (compiler::*error-database* '())
346           (tmpname (hcl:make-temp-file nil "lisp")))           (tmpname (hcl:make-temp-file nil "lisp")))
347      (with-compilation-unit ()      (with-compilation-unit ()
# Line 395  Return NIL if the symbol is unbound." Line 356  Return NIL if the symbol is unbound."
356    
357  ;;; xref  ;;; xref
358    
359  (defun lookup-xrefs (finder name)  (defun xrefs (dspecs)
360    (xref-results-for-emacs (funcall finder (from-string name))))    (loop for dspec in dspecs
361            nconc (loop for (dspec location) in
362  (defimplementation who-calls (function-name)                      (dspec:dspec-definition-locations dspec)
363    (lookup-xrefs #'hcl:who-calls function-name))                      collect (list dspec
364                                      (make-dspec-location dspec location)))))
365  (defimplementation who-references (variable)  
366    (lookup-xrefs #'hcl:who-references variable))  (defimplementation who-calls (name)
367      (xrefs (hcl:who-calls name)))
368    
369    (defimplementation who-references (name)
370      (xrefs (hcl:who-references name)))
371    
372    (defimplementation who-binds (name)
373      (xrefs (hcl:who-binds name)))
374    
375  (defimplementation who-binds (variable)  (defimplementation who-sets (name)
376    (lookup-xrefs #'hcl:who-binds variable))    (xrefs (hcl:who-sets name)))
   
 (defimplementation who-sets (variable)  
   (lookup-xrefs #'hcl:who-sets variable))  
   
 (defun xref-results-for-emacs (dspecs)  
   (let ((xrefs '()))  
     (dolist (dspec dspecs)  
       (loop for (dspec location) in (dspec:find-dspec-locations dspec)  
             do (push (cons (to-string dspec)  
                            (make-dspec-location dspec location))  
                      xrefs)))  
     (group-xrefs xrefs)))  
377    
378  (defimplementation list-callers (symbol-name)  (defimplementation list-callers (name)
379    (lookup-xrefs #'hcl:who-calls symbol-name))    (xrefs (hcl:who-calls name)))
380    
381  (defimplementation list-callees (symbol-name)  (defimplementation list-callees (name)
382    (lookup-xrefs #'hcl:calls-who symbol-name))    (xrefs (hcl:calls-who name)))
383    
384  ;;; Inspector  ;;; Inspector
385    

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

  ViewVC Help
Powered by ViewVC 1.1.5