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

Contents of /slime/swank-corman.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5