/[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.35 by heller, Thu Mar 18 21:53:27 2004 UTC revision 1.36 by heller, Tue Mar 23 21:29:14 2004 UTC
# Line 60  Line 60 
60  (defimplementation emacs-connected ()  (defimplementation emacs-connected ()
61    ;; Set SIGINT handler on Swank request handler thread.    ;; Set SIGINT handler on Swank request handler thread.
62    #-win32    #-win32
63    (sys:set-signal-handler +sigint+ (make-sigint-handler mp:*current-process*)))    (sys:set-signal-handler +sigint+ (make-sigint-handler mp:*current-process*))
64      (let ((lw:*handle-warn-on-redefinition* :warn))
65        (defmethod env-internals:environment-display-notifier
66            (env &key restarts condition)
67          (funcall (find-symbol (string :swank-debugger-hook) :swank)
68                   condition *debugger-hook*))))
69    
70    
71  ;;; Unix signals  ;;; Unix signals
72    
# Line 83  Line 89 
89  (defimplementation lisp-implementation-type-name ()  (defimplementation lisp-implementation-type-name ()
90    "lispworks")    "lispworks")
91    
92    (defimplementation set-default-directory (directory)
93      (namestring (hcl:change-directory directory)))
94    
95  (defimplementation arglist (symbol)  (defimplementation arglist (symbol)
96    (let ((arglist (lw:function-lambda-list symbol)))    (let ((arglist (lw:function-lambda-list symbol)))
97      (etypecase arglist      (etypecase arglist
# Line 93  Line 102 
102  (defimplementation macroexpand-all (form)  (defimplementation macroexpand-all (form)
103    (walker:walk-form form))    (walker:walk-form form))
104    
105    (defun gfp (object)
106      (typep object 'generic-function))
107    
108  (defimplementation describe-symbol-for-emacs (symbol)  (defimplementation describe-symbol-for-emacs (symbol)
109    "Return a plist describing SYMBOL.    "Return a plist describing SYMBOL.
110  Return NIL if the symbol is unbound."  Return NIL if the symbol is unbound."
# Line 112  Return NIL if the symbol is unbound." Line 124  Return NIL if the symbol is unbound."
124         :variable (when (boundp symbol)         :variable (when (boundp symbol)
125                     (doc 'variable)))                     (doc 'variable)))
126        (maybe-push        (maybe-push
127         :function (if (fboundp symbol)         :generic-function (if (and (fboundp symbol)
128                                      (gfp (fdefinition symbol)))
129                                 (doc 'function)))
130          (maybe-push
131           :function (if (and (fboundp symbol)
132                              (not (gfp (fdefinition symbol))))
133                       (doc 'function)))                       (doc 'function)))
134        (maybe-push        (maybe-push
135         :class (if (find-class symbol nil)         :class (if (find-class symbol nil)
# Line 123  Return NIL if the symbol is unbound." Line 140  Return NIL if the symbol is unbound."
140    (ecase type    (ecase type
141      (:variable (describe-symbol symbol))      (:variable (describe-symbol symbol))
142      (:class (describe (find-class symbol)))      (:class (describe (find-class symbol)))
143      (:function (describe-function symbol))))      ((:function :generic-function) (describe-function symbol))))
144    
145  (defun describe-function (symbol)  (defun describe-function (symbol)
146    (cond ((fboundp symbol)    (cond ((fboundp symbol)
# Line 151  Return NIL if the symbol is unbound." Line 168  Return NIL if the symbol is unbound."
168    
169  (defimplementation call-with-debugging-environment (fn)  (defimplementation call-with-debugging-environment (fn)
170    (dbg::with-debugger-stack ()    (dbg::with-debugger-stack ()
171      (let ((*sldb-top-frame* (dbg::debugger-stack-current-frame      (let ((*sldb-top-frame*
172                               dbg::*debugger-stack*)))             (dbg::frame-next
173                (dbg::frame-next
174                 (dbg::frame-next
175                  (dbg::debugger-stack-current-frame dbg::*debugger-stack*))))))
176        (funcall fn))))        (funcall fn))))
177    
178  (defun interesting-frame-p (frame)  (defun interesting-frame-p (frame)
179    (or (dbg::call-frame-p frame)    (cond ((or (dbg::call-frame-p frame)
180        (dbg::derived-call-frame-p frame)               (dbg::derived-call-frame-p frame)
181        (dbg::foreign-frame-p frame)               (dbg::foreign-frame-p frame)
182        (dbg::interpreted-call-frame-p frame)               (dbg::interpreted-call-frame-p frame))
183        ;;(dbg::catch-frame-p frame)           t)
184        ))          ((dbg::catch-frame-p frame) dbg:*print-catch-frames*)
185            ((dbg::binding-frame-p frame) dbg:*print-binding-frames*)
186            ((dbg::handler-frame-p frame) dbg:*print-handler-frames*)
187            ((dbg::restart-frame-p frame) dbg:*print-restart-frames*)
188            ((dbg::open-frame-p frame) dbg:*print-open-frames*)
189            (t nil)))
190    
191  (defun nth-frame (index)  (defun nth-frame (index)
192    (do ((frame *sldb-top-frame* (dbg::frame-next frame))    (do ((frame *sldb-top-frame* (dbg::frame-next frame))
# Line 179  Return NIL if the symbol is unbound." Line 204  Return NIL if the symbol is unbound."
204          (incf i)          (incf i)
205          (push frame backtrace)))))          (push frame backtrace)))))
206    
207    (defun frame-actual-args (frame)
208        (mapcar (lambda (arg)
209                  (handler-case (dbg::dbg-eval arg frame)
210                    (error (format nil "<~A>" arg))))
211                (dbg::call-frame-arglist frame)))
212    
213  (defimplementation print-frame (frame stream)  (defimplementation print-frame (frame stream)
214    (cond ((dbg::call-frame-p frame)    (cond ((dbg::call-frame-p frame)
215           (format stream "~A ~A"           (format stream "~S ~S"
216                   (dbg::call-frame-function-name frame)                   (dbg::call-frame-function-name frame)
217                   (dbg::call-frame-arglist frame)))                   (frame-actual-args frame)))
218          (t (princ frame stream))))          (t (princ frame stream))))
219    
220  (defimplementation frame-locals (n)  (defimplementation frame-locals (n)
# Line 361  Return NIL if the symbol is unbound." Line 392  Return NIL if the symbol is unbound."
392  (defxref who-sets       hcl:who-sets)  (defxref who-sets       hcl:who-sets)
393  (defxref list-callees   hcl:calls-who)  (defxref list-callees   hcl:calls-who)
394    
395    (defimplementation who-specializes (classname)
396      (let ((methods (clos:class-direct-methods (find-class classname))))
397        (xref-results (mapcar #'dspec:object-dspec methods))))
398    
399  (defun xref-results (dspecs)  (defun xref-results (dspecs)
400    (loop for dspec in dspecs    (loop for dspec in dspecs
401          nconc (loop for (dspec location) in          nconc (loop for (dspec location) in

Legend:
Removed from v.1.35  
changed lines
  Added in v.1.36

  ViewVC Help
Powered by ViewVC 1.1.5