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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (show annotations)
Tue Sep 14 22:42:52 2004 UTC (9 years, 7 months ago) by asimon
Branch: MAIN
Changes since 1.15: +13 -1 lines
Inspector for functions.
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
2 ;;;
3 ;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME.
4 ;;;
5 ;;; Adapted from swank-acl.lisp, Andras Simon, 2004
6 ;;;
7 ;;; This code has been placed in the Public Domain. All warranties
8 ;;; are disclaimed.
9 ;;;
10
11 (in-package :swank-backend)
12
13
14 (eval-when (:compile-toplevel :load-toplevel :execute)
15 (require :collect) ;just so that it doesn't spoil the flying letters
16 (require :gray-streams)
17 (require :pprint)
18 )
19
20 (import
21 '(gs:fundamental-character-output-stream
22 gs:stream-write-char
23 gs:stream-force-output
24 gs:fundamental-character-input-stream
25 gs:stream-read-char
26 gs:stream-listen
27 gs:stream-unread-char
28 gs:stream-clear-input
29 gs:stream-line-column
30 gs:stream-read-char-no-hang
31 ))
32
33 ;;; swank-mop
34
35 ;;dummies:
36
37 (defclass standard-slot-definition ()())
38
39 (defun class-finalized-p (class) t)
40
41 (defun slot-definition-documentation (slot) #+nil (documentation slot 't))
42 (defun slot-definition-type (slot) t)
43 (defun class-prototype (class))
44 (defun generic-function-declarations (gf))
45
46 (import-to-swank-mop
47 '( ;; classes
48 cl:standard-generic-function
49 standard-slot-definition ;;dummy
50 cl:method
51 cl:standard-class
52 ;; standard-class readers
53 sys::class-default-initargs
54 sys::class-direct-default-initargs
55 sys::class-direct-slots
56 sys::class-direct-subclasses
57 sys::class-direct-superclasses
58 class-finalized-p ;;dummy
59 cl:class-name
60 sys::class-precedence-list
61 class-prototype ;;dummy
62 sys::class-slots
63 ;; generic function readers
64 sys::generic-function-argument-precedence-order
65 generic-function-declarations ;;dummy
66 sys::generic-function-lambda-list
67 sys::generic-function-methods
68 sys::generic-function-method-class
69 sys::generic-function-method-combination
70 sys::generic-function-name
71 ;; method readers
72 sys::method-generic-function
73 sys::method-function
74 sys::method-lambda-list
75 sys::method-specializers
76 sys::method-qualifiers
77 ;; slot readers
78 sys::slot-definition-allocation
79 slot-definition-documentation ;;dummy
80 sys::slot-definition-initargs
81 sys::slot-definition-initform
82 sys::slot-definition-initfunction
83 sys::slot-definition-name
84 slot-definition-type ;;dummy
85 sys::slot-definition-readers
86 sys::slot-definition-writers))
87
88 ;;;; TCP Server
89
90
91 (defimplementation preferred-communication-style ()
92 :spawn)
93
94
95
96 (defimplementation create-socket (host port)
97 (ext:make-server-socket port))
98
99
100 (defimplementation local-port (socket)
101 (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket))
102
103
104 (defimplementation close-socket (socket)
105 (ext:server-socket-close socket))
106
107
108 (defimplementation accept-connection (socket)
109 (ext:get-socket-stream (ext:socket-accept socket)))
110
111 (defimplementation emacs-connected (stream)
112 (declare (ignore stream)))
113
114 ;;;; Unix signals
115
116 (defimplementation call-without-interrupts (fn)
117 (funcall fn))
118
119 ;;there are too many to count
120 (defimplementation getpid ()
121 0)
122
123 (defimplementation lisp-implementation-type-name ()
124 "armedbear")
125
126 (defimplementation set-default-directory (directory)
127 (let ((dir (sys::probe-directory directory)))
128 (when dir (setf *default-pathname-defaults* dir))
129 (namestring dir)))
130
131
132 ;;;; Misc
133
134
135 (defimplementation arglist ((symbol symbol))
136 (handler-case (sys::arglist symbol)
137 (simple-error () :not-available)))
138
139 ;;It's a string, not a symbol, but this is better than nothing.
140 (defimplementation function-name (function)
141 (nth-value 2 (function-lambda-expression function)))
142
143 (defimplementation macroexpand-all (form)
144 (macroexpand form))
145
146 (defimplementation describe-symbol-for-emacs (symbol)
147 (let ((result '()))
148 (flet ((doc (kind &optional (sym symbol))
149 (or (documentation sym kind) :not-documented))
150 (maybe-push (property value)
151 (when value
152 (setf result (list* property value result)))))
153 (maybe-push
154 :variable (when (boundp symbol)
155 (doc 'variable)))
156 (maybe-push
157 :function (if (fboundp symbol)
158 (doc 'function)))
159 (maybe-push
160 :class (if (find-class symbol nil)
161 (doc 'class)))
162 result)))
163
164
165 (defimplementation describe-definition (symbol namespace)
166 (ecase namespace
167 (:variable
168 (describe symbol))
169 ((:function :generic-function)
170 (describe (symbol-function symbol)))
171 (:class
172 (describe (find-class symbol)))))
173
174 (defimplementation describe-definition (symbol namespace)
175 (ecase namespace
176 (:variable
177 (describe symbol))
178 ((:function :generic-function)
179 (describe (symbol-function symbol)))
180 (:class
181 (describe (find-class symbol)))))
182
183
184 ;;;; Debugger
185
186 (defvar *sldb-topframe*)
187
188 (defimplementation call-with-debugging-environment (debugger-loop-fn)
189 (let ((*sldb-topframe* (car (ext:backtrace-as-list)) #+nil (excl::int-newest-frame)))
190 (funcall debugger-loop-fn)))
191
192 (defun nth-frame (index)
193 (nth index (ext:backtrace-as-list)))
194
195 (defimplementation compute-backtrace (start end)
196 (let ((end (or end most-positive-fixnum)))
197 (subseq (ext:backtrace-as-list) start end)))
198
199 (defimplementation print-frame (frame stream)
200 (print frame stream))
201
202 #+nil
203 (defimplementation frame-locals (index)
204 (let ((frame (nth-frame index)))
205 (loop for i from 0 below (debugger:frame-number-vars frame)
206 collect (list :name (debugger:frame-var-name frame i)
207 :id 0
208 :value (debugger:frame-var-value frame i)))))
209
210 (defimplementation frame-catch-tags (index)
211 (declare (ignore index))
212 nil)
213
214 #+nil
215 (defimplementation disassemble-frame (index)
216 (disassemble (debugger:frame-function (nth-frame index))))
217
218 (defimplementation frame-source-location-for-emacs (index)
219 (list :error (format nil "Cannot find source for frame: ~A"
220 (nth-frame index))))
221
222 #+nil
223 (defimplementation eval-in-frame (form frame-number)
224 (debugger:eval-form-in-context
225 form
226 (debugger:environment-of-frame (nth-frame frame-number))))
227
228 #+nil
229 (defimplementation return-from-frame (frame-number form)
230 (let ((frame (nth-frame frame-number)))
231 (multiple-value-call #'debugger:frame-return
232 frame (debugger:eval-form-in-context
233 form
234 (debugger:environment-of-frame frame)))))
235
236 ;;; XXX doesn't work for frames with arguments
237 #+nil
238 (defimplementation restart-frame (frame-number)
239 (let ((frame (nth-frame frame-number)))
240 (debugger:frame-retry frame (debugger:frame-function frame))))
241
242 ;;;; Compiler hooks
243
244 (defvar *buffer-name* nil)
245 (defvar *buffer-start-position*)
246 (defvar *buffer-string*)
247 (defvar *compile-filename*)
248
249 (defun handle-compiler-warning (condition)
250 #+nil
251 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
252 (signal (make-condition
253 'compiler-condition
254 :original-condition condition
255 :severity :warning
256 :message (format nil "~A" condition)
257 :location (cond (*buffer-name*
258 (make-location
259 (list :buffer *buffer-name*)
260 (list :position *buffer-start-position*)))
261 (loc
262 (destructuring-bind (file . pos) loc
263 (make-location
264 (list :file (namestring (truename file)))
265 (list :position (1+ pos)))))
266 (t
267 (make-location
268 (list :file *compile-filename*)
269 (list :position 1))))))))
270
271 (defimplementation swank-compile-file (*compile-filename* load-p)
272 (handler-bind ((warning #'handle-compiler-warning))
273 (let ((*buffer-name* nil))
274 (multiple-value-bind (fn warn fail)
275 (compile-file *compile-filename*)
276 (when load-p (unless fail (load fn)))))))
277
278 (defimplementation swank-compile-string (string &key buffer position directory)
279 (declare (ignore directory))
280 (handler-bind ((warning #'handle-compiler-warning))
281 (let ((*buffer-name* buffer)
282 (*buffer-start-position* position)
283 (*buffer-string* string))
284 (funcall (compile nil (read-from-string
285 (format nil "(~S () ~A)" 'lambda string)))))))
286
287 #|
288 ;;;; Definition Finding
289
290 (defun find-fspec-location (fspec type)
291 (let ((file (excl::fspec-pathname fspec type)))
292 (etypecase file
293 (pathname
294 (let ((start (scm:find-definition-in-file fspec type file)))
295 (make-location (list :file (namestring (truename file)))
296 (if start
297 (list :position (1+ start))
298 (list :function-name (string fspec))))))
299 ((member :top-level)
300 (list :error (format nil "Defined at toplevel: ~A" fspec)))
301 (null
302 (list :error (format nil "Unkown source location for ~A" fspec))))))
303
304 (defun fspec-definition-locations (fspec)
305 (let ((defs (excl::find-multiple-definitions fspec)))
306 (loop for (fspec type) in defs
307 collect (list fspec (find-fspec-location fspec type)))))
308
309 (defimplementation find-definitions (symbol)
310 (fspec-definition-locations symbol))
311
312 |#
313
314 (defun source-location (symbol)
315 (when (ext:source symbol)
316 `(((,symbol)
317 (:location
318 (:file ,(namestring (ext:source-pathname symbol)))
319 (:position ,(or (ext:source-file-position symbol) 0) t)
320 (:snippet nil))))))
321
322
323 (defimplementation find-definitions (symbol)
324 (source-location symbol))
325
326
327 #|
328 Should work (with a patched xref.lisp) but is it any use without find-definitions?
329 ;;;; XREF
330 (setq pxref::*handle-package-forms* '(cl:in-package))
331
332 (defmacro defxref (name function)
333 `(defimplementation ,name (name)
334 (xref-results (,function name))))
335
336 (defxref who-calls pxref:list-callers)
337 (defxref who-references pxref:list-readers)
338 (defxref who-binds pxref:list-setters)
339 (defxref who-sets pxref:list-setters)
340 (defxref list-callers pxref:list-callers)
341 (defxref list-callees pxref:list-callees)
342
343 (defun xref-results (symbols)
344 (let ((xrefs '()))
345 (dolist (symbol symbols)
346 (push (list symbol (fspec-location symbol)) xrefs))
347 xrefs))
348
349 |#
350
351 ;;;; Inspecting
352
353 (defclass abcl-inspector (inspector)
354 ())
355
356 (defimplementation make-default-inspector ()
357 (make-instance 'abcl-inspector))
358
359 (defmethod inspect-for-emacs ((slot sys::slot-definition) (inspector abcl-inspector))
360 (declare (ignore inspector))
361 (values "A slot."
362 `("Name: " (:value ,(sys::slot-definition-name slot))
363 (:newline)
364 "Documentation:" (:newline)
365 ,@(when (slot-definition-documentation slot)
366 `((:value ,(slot-definition-documentation slot)) (:newline)))
367 "Initialization:" (:newline)
368 " Args: " (:value ,(sys::slot-definition-initargs slot)) (:newline)
369 " Form: " ,(if (sys::slot-definition-initfunction slot)
370 `(:value ,(sys::slot-definition-initform slot))
371 "#<unspecified>") (:newline)
372 " Function: " (:value ,(sys::slot-definition-initfunction slot))
373 (:newline))))
374
375 (defmethod inspect-for-emacs ((f function) (inspector abcl-inspector))
376 (declare (ignore inspector))
377 (values "A function."
378 `("Name: " (:value ,(function-name f)) (:newline)
379 "Argument list: " ,(princ-to-string (sys::arglist f))
380 (:newline)
381 #+nil,@(when (documentation f t)
382 `("Documentation:" (:newline) ,(documentation f t) (:newline)))
383 ,@(when (function-lambda-expression f)
384 `("Lambda expression:"
385 (:newline) ,(prin1-to-string (function-lambda-expression f)) (:newline))))))
386
387 #|
388
389 (defimplementation inspect-for-emacs ((o t) (inspector abcl-inspector))
390 (let* ((class (class-of o))
391 (slots (sys::class-slots class)))
392 (values (format nil "~A~% is a ~A" o class)
393 (mapcar (lambda (slot)
394 (let ((name (sys::slot-definition-name slot)))
395 (cons (princ-to-string name)
396 (slot-value o name))))
397 slots))))
398 |#
399
400 ;;;; Multithreading
401
402 (defimplementation startup-multiprocessing ()
403 #+nil(mp:start-scheduler))
404
405 (defimplementation spawn (fn &key name)
406 (ext:make-thread (lambda () (funcall fn)) :name name))
407
408 (defvar *thread-props-lock* (ext:make-thread-lock))
409
410 (defvar *thread-props* (make-hash-table) ; should be a weak table
411 "A hashtable mapping threads to a plist.")
412
413 (defvar *thread-id-counter* 0)
414
415 (defimplementation thread-id (thread)
416 (ext:with-thread-lock (*thread-props-lock*)
417 (or (getf (gethash thread *thread-props*) 'id)
418 (setf (getf (gethash thread *thread-props*) 'id)
419 (incf *thread-id-counter*)))))
420
421 (defimplementation find-thread (id)
422 (find id (all-threads)
423 :key (lambda (thread)
424 (getf (gethash thread *thread-props*) 'id))))
425
426 (defimplementation thread-name (thread)
427 (ext:thread-name thread))
428
429 (defimplementation thread-status (thread)
430 (format nil "Thread is ~:[dead~;alive~]" (ext:thread-alive-p thread)))
431
432 (defimplementation make-lock (&key name)
433 (ext:make-thread-lock))
434
435 (defimplementation call-with-lock-held (lock function)
436 (ext:with-thread-lock (lock) (funcall function)))
437
438 (defimplementation current-thread ()
439 (ext:current-thread))
440
441 (defimplementation all-threads ()
442 (copy-list (ext:mapcar-threads #'identity)))
443
444 (defimplementation interrupt-thread (thread fn)
445 (ext:interrupt-thread thread fn))
446
447 (defimplementation kill-thread (thread)
448 (ext:destroy-thread thread))
449
450 (defun mailbox (thread)
451 "Return THREAD's mailbox."
452 (ext:with-thread-lock (*thread-props-lock*)
453 (or (getf (gethash thread *thread-props*) 'mailbox)
454 (setf (getf (gethash thread *thread-props*) 'mailbox)
455 (ext:make-mailbox)))))
456
457 (defimplementation send (thread object)
458 (ext:mailbox-send (mailbox thread) object))
459
460 (defimplementation receive ()
461 (ext:mailbox-read (mailbox (ext:current-thread))))
462
463 (defimplementation quit-lisp ()
464 (ext:exit))
465

  ViewVC Help
Powered by ViewVC 1.1.5