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

Diff of /slime/swank-corman.lisp

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

revision 1.1 by heller, Tue May 31 18:36:52 2005 UTC revision 1.2 by ewiborg, Tue Jun 7 10:08:03 2005 UTC
# Line 1  Line 1 
1  ;;;  ;;;
2  ;;; swank-corman.lisp --- Corman Lisp specific code for SLIME.  ;;; swank-corman.lisp --- Corman Lisp specific code for SLIME.
3  ;;;  ;;;
4  ;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org)  ;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org)
5  ;;;  ;;;
6  ;;; License  ;;; License
7  ;;; =======  ;;; =======
8  ;;; This software is provided 'as-is', without any express or implied  ;;; This software is provided 'as-is', without any express or implied
9  ;;; warranty. In no event will the author be held liable for any damages  ;;; warranty. In no event will the author be held liable for any damages
10  ;;; arising from the use of this software.  ;;; arising from the use of this software.
11  ;;;  ;;;
12  ;;; Permission is granted to anyone to use this software for any purpose,  ;;; Permission is granted to anyone to use this software for any purpose,
13  ;;; including commercial applications, and to alter it and redistribute  ;;; including commercial applications, and to alter it and redistribute
14  ;;; it freely, subject to the following restrictions:  ;;; it freely, subject to the following restrictions:
15  ;;;  ;;;
16  ;;; 1. The origin of this software must not be misrepresented; you must  ;;; 1. The origin of this software must not be misrepresented; you must
17  ;;;    not claim that you wrote the original software. If you use this  ;;;    not claim that you wrote the original software. If you use this
18  ;;;    software in a product, an acknowledgment in the product documentation  ;;;    software in a product, an acknowledgment in the product documentation
19  ;;;    would be appreciated but is not required.  ;;;    would be appreciated but is not required.
20  ;;;  ;;;
21  ;;; 2. Altered source versions must be plainly marked as such, and must  ;;; 2. Altered source versions must be plainly marked as such, and must
22  ;;;    not be misrepresented as being the original software.  ;;;    not be misrepresented as being the original software.
23  ;;;  ;;;
24  ;;; 3. This notice may not be removed or altered from any source  ;;; 3. This notice may not be removed or altered from any source
25  ;;;    distribution.  ;;;    distribution.
26  ;;;  ;;;
27  ;;; Notes  ;;; Notes
28  ;;; =====  ;;; =====
29  ;;; You will need CCL 2.51, and you will *definitely* need to patch  ;;; You will need CCL 2.51, and you will *definitely* need to patch
30  ;;; CCL with the patches at  ;;; CCL with the patches at
31  ;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME  ;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME
32  ;;; will blow up in your face.  You should also follow the  ;;; will blow up in your face.  You should also follow the
33  ;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime.  ;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime.
34  ;;;  ;;;
35  ;;; The only communication style currently supported is NIL.  ;;; The only communication style currently supported is NIL.
36  ;;;  ;;;
37  ;;; Starting CCL inside emacs (with M-x slime) seems to work for me  ;;; Starting CCL inside emacs (with M-x slime) seems to work for me
38  ;;; with Corman Lisp 2.51, but I have seen random failures with 2.5  ;;; with Corman Lisp 2.51, but I have seen random failures with 2.5
39  ;;; (sometimes it works, other times it hangs on start or hangs when  ;;; (sometimes it works, other times it hangs on start or hangs when
40  ;;; initializing WinSock) - starting CCL externally and using M-x  ;;; initializing WinSock) - starting CCL externally and using M-x
41  ;;; slime-connect always works fine.  ;;; slime-connect always works fine.
42  ;;;  ;;;
43  ;;; Sometimes CCL gets confused and starts giving you random memory access violation errors on startup; if this happens,  ;;; Sometimes CCL gets confused and starts giving you random memory
44  ;;;  ;;; access violation errors on startup; if this happens, try redumping
45  ;;; What works  ;;; your image.
46  ;;; ==========  ;;;
47  ;;; * Basic editing and evaluation  ;;; What works
48  ;;; * Arglist display  ;;; ==========
49  ;;; * Compilation  ;;; * Basic editing and evaluation
50  ;;; * Loading files  ;;; * Arglist display
51  ;;; * apropos/describe  ;;; * Compilation
52  ;;; * Debugger  ;;; * Loading files
53  ;;; * Inspector  ;;; * apropos/describe
54  ;;;  ;;; * Debugger
55  ;;; TODO  ;;; * Inspector
56  ;;; ====  ;;;
57  ;;; * More debugger functionality (missing bits: restart-frame,  ;;; TODO
58  ;;; return-from-frame, disassemble-frame, activate-stepping,  ;;; ====
59  ;;; toggle-trace)  ;;; * More debugger functionality (missing bits: restart-frame,
60  ;;; * XREF  ;;; return-from-frame, disassemble-frame, activate-stepping,
61  ;;; * Profiling  ;;; toggle-trace)
62  ;;; * More sophisticated communication styles than NIL  ;;; * XREF
63  ;;;  ;;; * Profiling
64    ;;; * More sophisticated communication styles than NIL
65  (in-package :swank-backend)  ;;;
66    
67  ;;; Pull in various needed bits  (in-package :swank-backend)
68  (require :composite-streams)  
69  (require :sockets)  ;;; Pull in various needed bits
70  (require :winbase)  (require :composite-streams)
71  (require :lp)  (require :sockets)
72    (require :winbase)
73  (use-package :gs)  (require :lp)
74    
75  ;; MOP stuff  (use-package :gs)
76    
77  (defclass swank-mop:standard-slot-definition ()  ;; MOP stuff
78    ()  
79    (:documentation "Dummy class created so that swank.lisp will compile and load."))  (defclass swank-mop:standard-slot-definition ()
80      ()
81  (defun named-by-gensym-p (c)    (:documentation "Dummy class created so that swank.lisp will compile and load."))
82    (null (symbol-package (class-name c))))  
83    (defun named-by-gensym-p (c)
84  (deftype swank-mop:eql-specializer ()    (null (symbol-package (class-name c))))
85    '(satisfies named-by-gensym-p))  
86    (deftype swank-mop:eql-specializer ()
87  (defun swank-mop:eql-specializer-object (specializer)    '(satisfies named-by-gensym-p))
88    (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*)  
89      (loop (multiple-value-bind (more key value)  (defun swank-mop:eql-specializer-object (specializer)
90                (next-entry)    (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*)
91              (unless more (return nil))      (loop (multiple-value-bind (more key value)
92              (when (eq specializer value)                (next-entry)
93                (return key))))))              (unless more (return nil))
94                (when (eq specializer value)
95  (defun swank-mop:class-finalized-p (class)                (return key))))))
96    (declare (ignore class))  
97    t)  (defun swank-mop:class-finalized-p (class)
98      (declare (ignore class))
99  (defun swank-mop:class-prototype (class)    t)
100    (make-instance class))  
101    (defun swank-mop:class-prototype (class)
102  (defun swank-mop:specializer-direct-methods (obj)    (make-instance class))
103    (declare (ignore obj))  
104    nil)  (defun swank-mop:specializer-direct-methods (obj)
105      (declare (ignore obj))
106  (defun swank-mop:generic-function-argument-precedence-order (gf)    nil)
107    (generic-function-lambda-list gf))  
108    (defun swank-mop:generic-function-argument-precedence-order (gf)
109  (defun swank-mop:generic-function-method-combination (gf)    (generic-function-lambda-list gf))
110    (declare (ignore gf))  
111    :standard)  (defun swank-mop:generic-function-method-combination (gf)
112      (declare (ignore gf))
113  (defun swank-mop:generic-function-declarations (gf)    :standard)
114    (declare (ignore gf))  
115    nil)  (defun swank-mop:generic-function-declarations (gf)
116      (declare (ignore gf))
117  (defun swank-mop:slot-definition-documentation (slot)    nil)
118    (declare (ignore slot))  
119    (getf slot :documentation nil))  (defun swank-mop:slot-definition-documentation (slot)
120      (declare (ignore slot))
121  (defun swank-mop:slot-definition-type (slot)    (getf slot :documentation nil))
122    (declare (ignore slot))  
123    t)  (defun swank-mop:slot-definition-type (slot)
124      (declare (ignore slot))
125  (import-swank-mop-symbols :cl '(;; classes    t)
126                                  :standard-slot-definition  
127                                  :eql-specializer  (import-swank-mop-symbols :cl '(;; classes
128                                  :eql-specializer-object                                  :standard-slot-definition
129                                  ;; standard class readers                                  :eql-specializer
130                                  :class-default-initargs                                  :eql-specializer-object
131                                  :class-direct-default-initargs                                  ;; standard class readers
132                                  :class-finalized-p                                  :class-default-initargs
133                                  :class-prototype                                  :class-direct-default-initargs
134                                  :specializer-direct-methods                                  :class-finalized-p
135                                  ;; gf readers                                  :class-prototype
136                                  :generic-function-argument-precedence-order                                  :specializer-direct-methods
137                                  :generic-function-declarations                                  ;; gf readers
138                                  :generic-function-method-combination                                  :generic-function-argument-precedence-order
139                                  ;; method readers                                  :generic-function-declarations
140                                  ;; slot readers                                  :generic-function-method-combination
141                                  :slot-definition-documentation                                  ;; method readers
142                                  :slot-definition-type))                                  ;; slot readers
143                                    :slot-definition-documentation
144  ;;;; swank implementations                                  :slot-definition-type))
145    
146  ;;; Debugger  ;;;; swank implementations
147    
148  (defvar *stack-trace* nil)  ;;; Debugger
149  (defvar *frame-trace* nil)  
150    (defvar *stack-trace* nil)
151  (defstruct frame  (defvar *frame-trace* nil)
152    name function address debug-info variables)  
153    (defstruct frame
154  (defimplementation call-with-debugging-environment (fn)    name function address debug-info variables)
155    (let* ((real-stack-trace (cl::stack-trace))  
156           (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace  (defimplementation call-with-debugging-environment (fn)
157                                       :key #'car)))    (let* ((real-stack-trace (cl::stack-trace))
158           (*frame-trace*           (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace
159            (let* ((db::*debug-level*         1)                                       :key #'car)))
160                   (db::*debug-frame-pointer* (db::stash-ebp           (*frame-trace*
161                                               (ct:create-foreign-ptr)))            (let* ((db::*debug-level*         1)
162                   (db::*debug-max-level*     (length real-stack-trace))                   (db::*debug-frame-pointer* (db::stash-ebp
163                   (db::*debug-min-level*     1))                                               (ct:create-foreign-ptr)))
164              (cdr (member #'cl:invoke-debugger                   (db::*debug-max-level*     (length real-stack-trace))
165                           (cons                   (db::*debug-min-level*     1))
166                            (make-frame :function nil)              (cdr (member #'cl:invoke-debugger
167                            (loop for i from db::*debug-min-level*                           (cons
168                               upto db::*debug-max-level*                            (make-frame :function nil)
169                               until (eq (db::get-frame-function i) cl::*top-level*)                            (loop for i from db::*debug-min-level*
170                               collect                               upto db::*debug-max-level*
171                                 (make-frame :function (db::get-frame-function i)                               until (eq (db::get-frame-function i) cl::*top-level*)
172                                             :address (db::get-frame-address i))))                               collect
173                           :key #'frame-function)))))                                 (make-frame :function (db::get-frame-function i)
174      (funcall fn)))                                             :address (db::get-frame-address i))))
175                             :key #'frame-function)))))
176  (defimplementation compute-backtrace (start end)      (funcall fn)))
177    (subseq *stack-trace* start (min end (length *stack-trace*))))  
178    (defimplementation compute-backtrace (start end)
179  (defimplementation print-frame (frame stream)    (subseq *stack-trace* start (min end (length *stack-trace*))))
180    (format stream "~S" frame))  
181    (defimplementation print-frame (frame stream)
182  (defun get-frame-debug-info (frame)    (format stream "~S" frame))
183    (let ((info (frame-debug-info frame)))  
184      (if info  (defun get-frame-debug-info (frame)
185          info    (let ((info (frame-debug-info frame)))
186          (setf (frame-debug-info frame)      (if info
187                (db::prepare-frame-debug-info (frame-function frame)          info
188                                              (frame-address frame))))))          (setf (frame-debug-info frame)
189                  (db::prepare-frame-debug-info (frame-function frame)
190  (defimplementation frame-locals (frame-number)                                              (frame-address frame))))))
191    (let* ((frame (elt *frame-trace* frame-number))  
192           (info (get-frame-debug-info frame)))  (defimplementation frame-locals (frame-number)
193      (let ((var-list    (let* ((frame (elt *frame-trace* frame-number))
194             (loop for i from 4 below (length info) by 2           (info (get-frame-debug-info frame)))
195                collect `(list :name ',(svref info i) :id 0      (let ((var-list
196                               :value (db::debug-filter ,(svref info i))))))             (loop for i from 4 below (length info) by 2
197        (let ((vars (eval-in-frame `(list ,@var-list) frame-number)))                collect `(list :name ',(svref info i) :id 0
198          (setf (frame-variables frame) vars)))))                               :value (db::debug-filter ,(svref info i))))))
199          (let ((vars (eval-in-frame `(list ,@var-list) frame-number)))
200  (defimplementation eval-in-frame (form frame-number)          (setf (frame-variables frame) vars)))))
201    (let ((frame (elt *frame-trace* frame-number)))  
202      (let ((cl::*compiler-environment* (get-frame-debug-info frame)))  (defimplementation eval-in-frame (form frame-number)
203        (eval form))))    (let ((frame (elt *frame-trace* frame-number)))
204        (let ((cl::*compiler-environment* (get-frame-debug-info frame)))
205  (defimplementation frame-catch-tags (index)        (eval form))))
206    (declare (ignore index))  
207    nil)  (defimplementation frame-catch-tags (index)
208      (declare (ignore index))
209  (defimplementation frame-var-value (frame-number var)    nil)
210    (let ((vars (frame-variables (elt *frame-trace* frame-number))))  
211      (when vars  (defimplementation frame-var-value (frame-number var)
212        (second (elt vars var)))))    (let ((vars (frame-variables (elt *frame-trace* frame-number))))
213        (when vars
214  (defimplementation frame-source-location-for-emacs (frame-number)        (second (elt vars var)))))
215    (fspec-location (frame-function (elt *frame-trace* frame-number))))  
216    (defimplementation frame-source-location-for-emacs (frame-number)
217  ;;; Socket communication    (fspec-location (frame-function (elt *frame-trace* frame-number))))
218    
219  (defimplementation create-socket (host port)  ;;; Socket communication
220    (sockets:start-sockets)  
221    (sockets:make-server-socket :host host :port (if (zerop port) 4005 port)))  (defimplementation create-socket (host port)
222      (sockets:start-sockets)
223  (defimplementation local-port (socket)    (sockets:make-server-socket :host host :port port))
224    (sockets:socket-port socket))  
225    (defimplementation local-port (socket)
226  (defimplementation close-socket (socket)    (sockets:socket-port socket))
227    (close socket))  
228    (defimplementation close-socket (socket)
229  (defimplementation accept-connection (socket    (close socket))
230                                        &key (external-format :iso-latin-1-unix))  
231    (ecase external-format  (defimplementation accept-connection (socket
232      (:iso-latin-1-unix                                        &key (external-format :iso-latin-1-unix))
233       (sockets:make-socket-stream (sockets:accept-socket socket)))))    (ecase external-format
234        (:iso-latin-1-unix
235  ;;; Misc       (sockets:make-socket-stream (sockets:accept-socket socket)))))
236    
237  (defimplementation preferred-communication-style ()  ;;; Misc
238    nil)  
239    (defimplementation preferred-communication-style ()
240  (defimplementation getpid ()    nil)
241    ccl:*current-process-id*)  
242    (defimplementation getpid ()
243  (defimplementation lisp-implementation-type-name ()    ccl:*current-process-id*)
244    "cormanlisp")  
245    (defimplementation lisp-implementation-type-name ()
246  (defimplementation quit-lisp ()    "cormanlisp")
247    (sockets:stop-sockets)  
248    (win32:exitprocess 0))  (defimplementation quit-lisp ()
249      (sockets:stop-sockets)
250  (defimplementation set-default-directory (directory)    (win32:exitprocess 0))
251    (setf (ccl:current-directory) directory)  
252    (directory-namestring (setf *default-pathname-defaults*  (defimplementation set-default-directory (directory)
253                                (truename (merge-pathnames directory)))))    (setf (ccl:current-directory) directory)
254      (directory-namestring (setf *default-pathname-defaults*
255  (defimplementation default-directory ()                                (truename (merge-pathnames directory)))))
256    (ccl:current-directory))  
257    (defimplementation default-directory ()
258  (defimplementation macroexpand-all (form)    (ccl:current-directory))
259    (ccl:macroexpand-all form))  
260    (defimplementation macroexpand-all (form)
261  ;;; Documentation    (ccl:macroexpand-all form))
262    
263  (defun fspec-location (fspec)  ;;; Documentation
264    (when (symbolp fspec)  
265      (setq fspec (symbol-function fspec)))  (defun fspec-location (fspec)
266    (let ((file (ccl::function-source-file fspec)))    (when (symbolp fspec)
267      (if file      (setq fspec (symbol-function fspec)))
268          (handler-case    (let ((file (ccl::function-source-file fspec)))
269              (let ((truename (truename      (if file
270                               (merge-pathnames file          (handler-case
271                                                ccl:*cormanlisp-directory*))))              (let ((truename (truename
272                (make-location (list :file (namestring truename))                               (merge-pathnames file
273                               (if (ccl::function-source-line fspec)                                                ccl:*cormanlisp-directory*))))
274                                   (list :line (ccl::function-source-line fspec))                (make-location (list :file (namestring truename))
275                                   (list :function-name (princ-to-string                               (if (ccl::function-source-line fspec)
276                                                         (function-name fspec))))))                                   (list :line (ccl::function-source-line fspec))
277            (error (c) (list :error (princ-to-string c))))                                   (list :function-name (princ-to-string
278          (list :error (format nil "No source information available for ~S"                                                         (function-name fspec))))))
279                               fspec)))))            (error (c) (list :error (princ-to-string c))))
280            (list :error (format nil "No source information available for ~S"
281  (defimplementation find-definitions (name)                               fspec)))))
282    (list (list name (fspec-location name))))  
283    (defimplementation find-definitions (name)
284  (defimplementation arglist (name)    (list (list name (fspec-location name))))
285    (handler-case  
286        (cond ((and (symbolp name)  (defimplementation arglist (name)
287                    (macro-function name))    (handler-case
288               (ccl::macro-lambda-list (symbol-function name)))        (cond ((and (symbolp name)
289              (t                    (macro-function name))
290               (when (symbolp name)               (ccl::macro-lambda-list (symbol-function name)))
291                 (setq name (symbol-function name)))              (t
292               (if (eq (class-of name) cl::the-class-standard-gf)               (when (symbolp name)
293                   (generic-function-lambda-list name)                 (setq name (symbol-function name)))
294                   (ccl:function-lambda-list name))))               (if (eq (class-of name) cl::the-class-standard-gf)
295      (error () :not-available)))                   (generic-function-lambda-list name)
296                     (ccl:function-lambda-list name))))
297  (defimplementation function-name (fn)      (error () :not-available)))
298    (handler-case (getf (cl::function-info-list fn) 'cl::function-name)  
299      (error () nil)))  (defimplementation function-name (fn)
300      (handler-case (getf (cl::function-info-list fn) 'cl::function-name)
301  (defimplementation describe-symbol-for-emacs (symbol)      (error () nil)))
302    (let ((result '()))  
303      (flet ((doc (kind &optional (sym symbol))  (defimplementation describe-symbol-for-emacs (symbol)
304               (or (documentation sym kind) :not-documented))    (let ((result '()))
305             (maybe-push (property value)      (flet ((doc (kind &optional (sym symbol))
306               (when value               (or (documentation sym kind) :not-documented))
307                 (setf result (list* property value result)))))             (maybe-push (property value)
308        (maybe-push               (when value
309         :variable (when (boundp symbol)                 (setf result (list* property value result)))))
310                     (doc 'variable)))        (maybe-push
311        (maybe-push         :variable (when (boundp symbol)
312         :function (if (fboundp symbol)                     (doc 'variable)))
313                       (doc 'function)))        (maybe-push
314        (maybe-push         :function (if (fboundp symbol)
315         :class (if (find-class symbol nil)                       (doc 'function)))
316                    (doc 'class)))        (maybe-push
317        result)))         :class (if (find-class symbol nil)
318                      (doc 'class)))
319  (defimplementation describe-definition (symbol namespace)        result)))
320    (ecase namespace  
321      (:variable  (defimplementation describe-definition (symbol namespace)
322       (describe symbol))    (ecase namespace
323      ((:function :generic-function)      (:variable
324       (describe (symbol-function symbol)))       (describe symbol))
325      (:class      ((:function :generic-function)
326       (describe (find-class symbol)))))       (describe (symbol-function symbol)))
327        (:class
328  ;;; Compiler       (describe (find-class symbol)))))
329    
330  (defvar *buffer-name* nil)  ;;; Compiler
331  (defvar *buffer-position*)  
332  (defvar *buffer-string*)  (defvar *buffer-name* nil)
333  (defvar *compile-filename* nil)  (defvar *buffer-position*)
334    (defvar *buffer-string*)
335  ;; FIXME  (defvar *compile-filename* nil)
336  (defimplementation call-with-compilation-hooks (FN)  
337    (handler-bind ((error (lambda (c)  ;; FIXME
338                            (signal (make-condition  (defimplementation call-with-compilation-hooks (FN)
339                                     'compiler-condition    (handler-bind ((error (lambda (c)
340                                     :original-condition c                            (signal (make-condition
341                                     :severity :warning                                     'compiler-condition
342                                     :message (format nil "~A" c)                                     :original-condition c
343                                     :location                                     :severity :warning
344                                     (cond (*buffer-name*                                     :message (format nil "~A" c)
345                                            (make-location                                     :location
346                                             (list :buffer *buffer-name*)                                     (cond (*buffer-name*
347                                             (list :position *buffer-position*)))                                            (make-location
348                                           (*compile-filename*                                             (list :buffer *buffer-name*)
349                                            (make-location                                             (list :position *buffer-position*)))
350                                             (list :file *compile-filename*)                                           (*compile-filename*
351                                             (list :position 1)))                                            (make-location
352                                           (t                                             (list :file *compile-filename*)
353                                            (list :error "No location"))))))))                                             (list :position 1)))
354      (funcall fn)))                                           (t
355                                              (list :error "No location"))))))))
356  (defimplementation swank-compile-file (*compile-filename* load-p)      (funcall fn)))
357    (with-compilation-hooks ()  
358      (let ((*buffer-name* nil))  (defimplementation swank-compile-file (*compile-filename* load-p)
359        (compile-file *compile-filename*)    (with-compilation-hooks ()
360        (when load-p      (let ((*buffer-name* nil))
361          (load (compile-file-pathname *compile-filename*))))))        (compile-file *compile-filename*)
362          (when load-p
363  (defimplementation swank-compile-string (string &key buffer position directory)          (load (compile-file-pathname *compile-filename*))))))
364    (declare (ignore directory))  
365    (with-compilation-hooks ()  (defimplementation swank-compile-string (string &key buffer position directory)
366      (let ((*buffer-name* buffer)    (declare (ignore directory))
367            (*buffer-position* position)    (with-compilation-hooks ()
368            (*buffer-string* string))      (let ((*buffer-name* buffer)
369        (funcall (compile nil (read-from-string            (*buffer-position* position)
370                               (format nil "(~S () ~A)" 'lambda string)))))))            (*buffer-string* string))
371          (funcall (compile nil (read-from-string
372  ;;;; Inspecting                               (format nil "(~S () ~A)" 'lambda string)))))))
373    
374  (defclass corman-inspector (inspector)  ;;;; Inspecting
375    ())  
376    (defclass corman-inspector (inspector)
377  (defimplementation make-default-inspector ()    ())
378    (make-instance 'corman-inspector))  
379    (defimplementation make-default-inspector ()
380  (defun comma-separated (list &optional (callback (lambda (v)    (make-instance 'corman-inspector))
381                                                     `(:value ,v))))  
382    (butlast (loop for e in list  (defun comma-separated (list &optional (callback (lambda (v)
383                collect (funcall callback e)                                                     `(:value ,v))))
384                collect ", ")))    (butlast (loop for e in list
385                  collect (funcall callback e)
386  (defmethod inspect-for-emacs ((class standard-class)                collect ", ")))
387                                (inspector corman-inspector))  
388    (declare (ignore inspector))  (defimplementation inspect-for-emacs ((class standard-class)
389    (values "A class."                                (inspector corman-inspector))
390            `("Name: " (:value ,(class-name class))    (declare (ignore inspector))
391              (:newline)    (values "A class."
392              "Super classes: "            `("Name: " (:value ,(class-name class))
393              ,@(comma-separated (swank-mop:class-direct-superclasses class))              (:newline)
394              (:newline)              "Super classes: "
395              "Direct Slots: "              ,@(comma-separated (swank-mop:class-direct-superclasses class))
396              ,@(comma-separated              (:newline)
397                 (swank-mop:class-direct-slots class)              "Direct Slots: "
398                 (lambda (slot)              ,@(comma-separated
399                   `(:value ,slot ,(princ-to-string (swank-mop:slot-definition-name slot)))))                 (swank-mop:class-direct-slots class)
400              (:newline)                 (lambda (slot)
401              "Effective Slots: "                   `(:value ,slot ,(princ-to-string (swank-mop:slot-definition-name slot)))))
402              ,@(if (swank-mop:class-finalized-p class)              (:newline)
403                    (comma-separated              "Effective Slots: "
404                     (swank-mop:class-slots class)              ,@(if (swank-mop:class-finalized-p class)
405                     (lambda (slot)                    (comma-separated
406                       `(:value ,slot ,(princ-to-string                     (swank-mop:class-slots class)
407                                        (swank-mop:slot-definition-name slot)))))                     (lambda (slot)
408                    '("#<N/A (class not finalized)>"))                       `(:value ,slot ,(princ-to-string
409              (:newline)                                        (swank-mop:slot-definition-name slot)))))
410              ,@(when (documentation class t)                    '("#<N/A (class not finalized)>"))
411                  `("Documentation:" (:newline) ,(documentation class t) (:newline)))              (:newline)
412              "Sub classes: "              ,@(when (documentation class t)
413              ,@(comma-separated (swank-mop:class-direct-subclasses class)                  `("Documentation:" (:newline) ,(documentation class t) (:newline)))
414                                 (lambda (sub)              "Sub classes: "
415                                   `(:value ,sub ,(princ-to-string (class-name sub)))))              ,@(comma-separated (swank-mop:class-direct-subclasses class)
416              (:newline)                                 (lambda (sub)
417              "Precedence List: "                                   `(:value ,sub ,(princ-to-string (class-name sub)))))
418              ,@(if (swank-mop:class-finalized-p class)              (:newline)
419                    (comma-separated (swank-mop:class-precedence-list class)              "Precedence List: "
420                                           (lambda (class)              ,@(if (swank-mop:class-finalized-p class)
421                                             `(:value ,class ,(princ-to-string (class-name class)))))                    (comma-separated (swank-mop:class-precedence-list class)
422                    '("#<N/A (class not finalized)>"))                                           (lambda (class)
423              (:newline))))                                             `(:value ,class ,(princ-to-string (class-name class)))))
424                      '("#<N/A (class not finalized)>"))
425  (defmethod inspect-for-emacs ((slot cons) (inspector corman-inspector))              (:newline))))
426    ;; Inspects slot definitions  
427    (declare (ignore corman-inspector))  (defimplementation inspect-for-emacs ((slot cons) (inspector corman-inspector))
428    (if (eq (car slot) :name)    ;; Inspects slot definitions
429        (values "A slot."    (declare (ignore corman-inspector))
430                `("Name: " (:value ,(swank-mop:slot-definition-name slot))    (if (eq (car slot) :name)
431                           (:newline)        (values "A slot."
432                           ,@(when (swank-mop:slot-definition-documentation slot)                `("Name: " (:value ,(swank-mop:slot-definition-name slot))
433                               `("Documentation:"  (:newline)                           (:newline)
434                                                   (:value ,(swank-mop:slot-definition-documentation slot))                           ,@(when (swank-mop:slot-definition-documentation slot)
435                                                   (:newline)))                               `("Documentation:"  (:newline)
436                           "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline)                                                   (:value ,(swank-mop:slot-definition-documentation slot))
437                           "Init form: "  ,(if (swank-mop:slot-definition-initfunction slot)                                                   (:newline)))
438                                               `(:value ,(swank-mop:slot-definition-initform slot))                           "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline)
439                                               "#<unspecified>") (:newline)                           "Init form: "  ,(if (swank-mop:slot-definition-initfunction slot)
440                                               "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))                                               `(:value ,(swank-mop:slot-definition-initform slot))
441                                               (:newline)))                                               "#<unspecified>") (:newline)
442        (call-next-method)))                                               "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))
443                                                 (:newline)))
444  (defmethod inspect-for-emacs ((pathname pathnames::pathname-internal)        (call-next-method)))
445                                inspector)  
446    (declare (ignore inspector))  (defimplementation inspect-for-emacs ((pathname pathnames::pathname-internal)
447    (values (if (wild-pathname-p pathname)                                inspector)
448                "A wild pathname."    (declare (ignore inspector))
449                "A pathname.")    (values (if (wild-pathname-p pathname)
450            (append (label-value-line*                "A wild pathname."
451                     ("Namestring" (namestring pathname))                "A pathname.")
452                     ("Host"       (pathname-host pathname))            (append (label-value-line*
453                     ("Device"     (pathname-device pathname))                     ("Namestring" (namestring pathname))
454                     ("Directory"  (pathname-directory pathname))                     ("Host"       (pathname-host pathname))
455                     ("Name"       (pathname-name pathname))                     ("Device"     (pathname-device pathname))
456                     ("Type"       (pathname-type pathname))                     ("Directory"  (pathname-directory pathname))
457                     ("Version"    (pathname-version pathname)))                     ("Name"       (pathname-name pathname))
458                    (unless (or (wild-pathname-p pathname)                     ("Type"       (pathname-type pathname))
459                                (not (probe-file pathname)))                     ("Version"    (pathname-version pathname)))
460                      (label-value-line "Truename" (truename pathname))))))                    (unless (or (wild-pathname-p pathname)
461                                  (not (probe-file pathname)))
462  ;;; This is probably not good, but it WFM                      (label-value-line "Truename" (truename pathname))))))
463  (in-package :common-lisp)  
464    ;;; This is probably not good, but it WFM
465  (defvar *old-documentation* #'documentation)  (in-package :common-lisp)
466  (defun documentation (thing &optional (type 'function))  
467    (if (symbolp thing)  (defvar *old-documentation* #'documentation)
468        (funcall *old-documentation* thing type)  (defun documentation (thing &optional (type 'function))
469        (values)))    (if (symbolp thing)
470          (funcall *old-documentation* thing type)
471  (defmethod print-object ((restart restart) stream)        (values)))
472    (if (or *print-escape*  
473            *print-readably*)  (defmethod print-object ((restart restart) stream)
474        (print-unreadable-object (restart stream :type t :identity t)    (if (or *print-escape*
475          (princ (restart-name restart) stream))            *print-readably*)
476        (when (functionp (restart-report-function restart))        (print-unreadable-object (restart stream :type t :identity t)
477          (funcall (restart-report-function restart) stream))))          (princ (restart-name restart) stream))
478          (when (functionp (restart-report-function restart))
479            (funcall (restart-report-function restart) stream))))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.5