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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.36 - (hide annotations)
Wed May 24 21:26:19 2006 UTC (7 years, 10 months ago) by aruttenberg
Branch: MAIN
Changes since 1.35: +25 -9 lines
2006-05-24  Alan Ruttenberg <alanr-l@mumble.net>
	* swank-abcl: Add some more mop functions to you can inspect classes,
	generic functions, methods, slots.
1 heller 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
2     ;;;
3     ;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME.
4     ;;;
5 asimon 1.9 ;;; Adapted from swank-acl.lisp, Andras Simon, 2004
6 heller 1.1 ;;;
7     ;;; This code has been placed in the Public Domain. All warranties
8 asimon 1.9 ;;; are disclaimed.
9 heller 1.1 ;;;
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 asimon 1.17 (require :pprint))
17    
18 heller 1.25 (defun sys::break (&optional (format-control "BREAK called")
19     &rest format-arguments)
20 aruttenberg 1.31 (let ((*saved-backtrace* (backtrace-as-list-ignoring-swank-calls)))
21 asimon 1.20 (with-simple-restart (continue "Return from BREAK.")
22     (invoke-debugger
23     (sys::%make-condition 'simple-condition
24     (list :format-control format-control
25     :format-arguments format-arguments))))
26     nil))
27    
28 asimon 1.19 (defimplementation make-fn-streams (input-fn output-fn)
29     (let* ((output (ext:make-slime-output-stream output-fn))
30     (input (ext:make-slime-input-stream input-fn output)))
31     (values input output)))
32 heller 1.1
33 aruttenberg 1.34 (defimplementation call-with-compilation-hooks (function)
34     (funcall function))
35    
36 asimon 1.12 ;;; swank-mop
37 asimon 1.13
38 aruttenberg 1.36 ;;dummies and definition
39 asimon 1.15
40 asimon 1.12 (defclass standard-slot-definition ()())
41 asimon 1.15
42 aruttenberg 1.36 ;(defun class-finalized-p (class) t)
43 asimon 1.15
44     (defun slot-definition-documentation (slot) #+nil (documentation slot 't))
45 asimon 1.13 (defun slot-definition-type (slot) t)
46 asimon 1.14 (defun class-prototype (class))
47     (defun generic-function-declarations (gf))
48 aruttenberg 1.36 (defun specializer-direct-methods (spec) (mop::class-direct-methods spec))
49    
50     (defun slot-definition-name (slot)
51     (mop::%slot-definition-name slot))
52    
53     (defun class-slots (class)
54     (mop::%class-slots class))
55    
56     (defun method-generic-function (method)
57     (mop::%method-generic-function method))
58    
59     (defun method-function (method)
60     (mop::%method-function method))
61    
62 asimon 1.12
63     (import-to-swank-mop
64     '( ;; classes
65     cl:standard-generic-function
66     standard-slot-definition ;;dummy
67     cl:method
68     cl:standard-class
69     ;; standard-class readers
70 asimon 1.26 mop::class-default-initargs
71     mop::class-direct-default-initargs
72     mop::class-direct-slots
73     mop::class-direct-subclasses
74     mop::class-direct-superclasses
75     mop::eql-specializer
76 aruttenberg 1.36 mop::class-finalized-p
77 asimon 1.12 cl:class-name
78 asimon 1.26 mop::class-precedence-list
79 asimon 1.14 class-prototype ;;dummy
80 aruttenberg 1.36 class-slots
81     specializer-direct-methods
82 asimon 1.17 ;; eql-specializer accessors
83 asimon 1.26 mop::eql-specializer-object
84 asimon 1.12 ;; generic function readers
85 asimon 1.26 mop::generic-function-argument-precedence-order
86 asimon 1.14 generic-function-declarations ;;dummy
87 asimon 1.26 mop::generic-function-lambda-list
88     mop::generic-function-methods
89     mop::generic-function-method-class
90     mop::generic-function-method-combination
91     mop::generic-function-name
92 asimon 1.12 ;; method readers
93 aruttenberg 1.36 method-generic-function
94     method-function
95 asimon 1.26 mop::method-lambda-list
96     mop::method-specializers
97     mop::method-qualifiers
98 asimon 1.12 ;; slot readers
99 asimon 1.26 mop::slot-definition-allocation
100 asimon 1.13 slot-definition-documentation ;;dummy
101 asimon 1.26 mop::slot-definition-initargs
102     mop::slot-definition-initform
103     mop::slot-definition-initfunction
104 aruttenberg 1.36 slot-definition-name
105 asimon 1.13 slot-definition-type ;;dummy
106 asimon 1.26 mop::slot-definition-readers
107     mop::slot-definition-writers))
108 asimon 1.12
109 heller 1.1 ;;;; TCP Server
110    
111    
112     (defimplementation preferred-communication-style ()
113     :spawn)
114    
115    
116    
117     (defimplementation create-socket (host port)
118     (ext:make-server-socket port))
119    
120    
121     (defimplementation local-port (socket)
122     (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket))
123    
124    
125     (defimplementation close-socket (socket)
126     (ext:server-socket-close socket))
127    
128 heller 1.23 (defimplementation accept-connection (socket
129 asimon 1.35 &key (external-format :iso-latin-1-unix) buffering timeout)
130     (declare (ignore buffering timeout))
131 heller 1.22 (assert (eq external-format :iso-latin-1-unix))
132 heller 1.1 (ext:get-socket-stream (ext:socket-accept socket)))
133    
134     ;;;; Unix signals
135    
136     (defimplementation call-without-interrupts (fn)
137     (funcall fn))
138    
139     ;;there are too many to count
140     (defimplementation getpid ()
141     0)
142    
143     (defimplementation lisp-implementation-type-name ()
144     "armedbear")
145    
146     (defimplementation set-default-directory (directory)
147     (let ((dir (sys::probe-directory directory)))
148     (when dir (setf *default-pathname-defaults* dir))
149     (namestring dir)))
150    
151    
152     ;;;; Misc
153    
154 asimon 1.13
155 asimon 1.17 (defimplementation arglist ((symbol t))
156     (multiple-value-bind (arglist present)
157     (sys::arglist symbol)
158     (if present arglist :not-available)))
159    
160 asimon 1.13
161     (defimplementation function-name (function)
162     (nth-value 2 (function-lambda-expression function)))
163 heller 1.1
164     (defimplementation macroexpand-all (form)
165     (macroexpand form))
166    
167     (defimplementation describe-symbol-for-emacs (symbol)
168     (let ((result '()))
169     (flet ((doc (kind &optional (sym symbol))
170     (or (documentation sym kind) :not-documented))
171     (maybe-push (property value)
172     (when value
173     (setf result (list* property value result)))))
174     (maybe-push
175     :variable (when (boundp symbol)
176     (doc 'variable)))
177     (maybe-push
178     :function (if (fboundp symbol)
179     (doc 'function)))
180     (maybe-push
181     :class (if (find-class symbol nil)
182     (doc 'class)))
183     result)))
184    
185    
186     (defimplementation describe-definition (symbol namespace)
187     (ecase namespace
188     (:variable
189     (describe symbol))
190     ((:function :generic-function)
191     (describe (symbol-function symbol)))
192     (:class
193     (describe (find-class symbol)))))
194    
195     (defimplementation describe-definition (symbol namespace)
196     (ecase namespace
197     (:variable
198     (describe symbol))
199     ((:function :generic-function)
200     (describe (symbol-function symbol)))
201     (:class
202     (describe (find-class symbol)))))
203    
204    
205     ;;;; Debugger
206    
207     (defvar *sldb-topframe*)
208    
209 aruttenberg 1.31 (defun backtrace-as-list-ignoring-swank-calls ()
210     (let ((list (ext:backtrace-as-list)))
211 aruttenberg 1.33 (subseq list (1+ (or (position (intern "SWANK-DEBUGGER-HOOK" 'swank) list :key 'car) -1)))))
212 aruttenberg 1.31
213 heller 1.1 (defimplementation call-with-debugging-environment (debugger-loop-fn)
214 aruttenberg 1.31 (let ((*sldb-topframe* (car (backtrace-as-list-ignoring-swank-calls)) #+nil (excl::int-newest-frame)))
215 heller 1.1 (funcall debugger-loop-fn)))
216    
217     (defun nth-frame (index)
218 aruttenberg 1.31 (nth index (backtrace-as-list-ignoring-swank-calls)))
219 heller 1.1
220     (defimplementation compute-backtrace (start end)
221     (let ((end (or end most-positive-fixnum)))
222 aruttenberg 1.31 (subseq (backtrace-as-list-ignoring-swank-calls) start end)))
223 heller 1.1
224     (defimplementation print-frame (frame stream)
225 heller 1.25 (write-string (string-trim '(#\space #\newline)
226     (prin1-to-string frame))
227     stream))
228 heller 1.1
229     (defimplementation frame-locals (index)
230 aruttenberg 1.31 `(,(list :name "??" :id 0 :value "??")))
231 heller 1.25
232 heller 1.1
233     (defimplementation frame-catch-tags (index)
234     (declare (ignore index))
235     nil)
236    
237     #+nil
238     (defimplementation disassemble-frame (index)
239     (disassemble (debugger:frame-function (nth-frame index))))
240    
241     (defimplementation frame-source-location-for-emacs (index)
242     (list :error (format nil "Cannot find source for frame: ~A"
243     (nth-frame index))))
244    
245     #+nil
246     (defimplementation eval-in-frame (form frame-number)
247     (debugger:eval-form-in-context
248     form
249     (debugger:environment-of-frame (nth-frame frame-number))))
250    
251     #+nil
252     (defimplementation return-from-frame (frame-number form)
253     (let ((frame (nth-frame frame-number)))
254     (multiple-value-call #'debugger:frame-return
255     frame (debugger:eval-form-in-context
256     form
257     (debugger:environment-of-frame frame)))))
258    
259     ;;; XXX doesn't work for frames with arguments
260     #+nil
261     (defimplementation restart-frame (frame-number)
262     (let ((frame (nth-frame frame-number)))
263     (debugger:frame-retry frame (debugger:frame-function frame))))
264    
265     ;;;; Compiler hooks
266    
267     (defvar *buffer-name* nil)
268     (defvar *buffer-start-position*)
269     (defvar *buffer-string*)
270     (defvar *compile-filename*)
271    
272     (defun handle-compiler-warning (condition)
273     #+nil
274     (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
275     (signal (make-condition
276     'compiler-condition
277     :original-condition condition
278     :severity :warning
279     :message (format nil "~A" condition)
280     :location (cond (*buffer-name*
281     (make-location
282     (list :buffer *buffer-name*)
283     (list :position *buffer-start-position*)))
284     (loc
285     (destructuring-bind (file . pos) loc
286     (make-location
287     (list :file (namestring (truename file)))
288     (list :position (1+ pos)))))
289     (t
290     (make-location
291     (list :file *compile-filename*)
292     (list :position 1))))))))
293    
294 heller 1.27 (defimplementation swank-compile-file (filename load-p
295     &optional external-format)
296     (declare (ignore external-format))
297 heller 1.1 (handler-bind ((warning #'handle-compiler-warning))
298 heller 1.27 (let ((*buffer-name* nil)
299     (*compile-filename* filename))
300     (multiple-value-bind (fn warn fail) (compile-file filename)
301     (when (and load-p (not fail))
302     (load fn))))))
303 heller 1.1
304 pseibel 1.10 (defimplementation swank-compile-string (string &key buffer position directory)
305     (declare (ignore directory))
306 heller 1.1 (handler-bind ((warning #'handle-compiler-warning))
307     (let ((*buffer-name* buffer)
308     (*buffer-start-position* position)
309     (*buffer-string* string))
310     (funcall (compile nil (read-from-string
311     (format nil "(~S () ~A)" 'lambda string)))))))
312    
313     #|
314     ;;;; Definition Finding
315    
316     (defun find-fspec-location (fspec type)
317     (let ((file (excl::fspec-pathname fspec type)))
318     (etypecase file
319     (pathname
320     (let ((start (scm:find-definition-in-file fspec type file)))
321     (make-location (list :file (namestring (truename file)))
322     (if start
323     (list :position (1+ start))
324     (list :function-name (string fspec))))))
325     ((member :top-level)
326     (list :error (format nil "Defined at toplevel: ~A" fspec)))
327     (null
328     (list :error (format nil "Unkown source location for ~A" fspec))))))
329    
330     (defun fspec-definition-locations (fspec)
331     (let ((defs (excl::find-multiple-definitions fspec)))
332     (loop for (fspec type) in defs
333     collect (list fspec (find-fspec-location fspec type)))))
334    
335     (defimplementation find-definitions (symbol)
336     (fspec-definition-locations symbol))
337    
338     |#
339    
340 asimon 1.2 (defun source-location (symbol)
341 asimon 1.24 (when (pathnamep (ext:source-pathname symbol))
342 asimon 1.2 `(((,symbol)
343     (:location
344     (:file ,(namestring (ext:source-pathname symbol)))
345 asimon 1.9 (:position ,(or (ext:source-file-position symbol) 0) t)
346 asimon 1.2 (:snippet nil))))))
347 asimon 1.24
348 asimon 1.2
349     (defimplementation find-definitions (symbol)
350     (source-location symbol))
351    
352 asimon 1.17 #|
353     Uncomment this if you have patched xref.lisp, as in
354     http://article.gmane.org/gmane.lisp.slime.devel/2425
355     Also, make sure that xref.lisp is loaded by modifying the armedbear
356     part of *sysdep-pathnames* in swank.loader.lisp.
357 asimon 1.2
358 heller 1.1 ;;;; XREF
359 asimon 1.17 (setq pxref:*handle-package-forms* '(cl:in-package))
360 heller 1.1
361     (defmacro defxref (name function)
362     `(defimplementation ,name (name)
363     (xref-results (,function name))))
364    
365     (defxref who-calls pxref:list-callers)
366     (defxref who-references pxref:list-readers)
367     (defxref who-binds pxref:list-setters)
368     (defxref who-sets pxref:list-setters)
369     (defxref list-callers pxref:list-callers)
370     (defxref list-callees pxref:list-callees)
371    
372     (defun xref-results (symbols)
373     (let ((xrefs '()))
374     (dolist (symbol symbols)
375 asimon 1.17 (push (list symbol (cadar (source-location symbol))) xrefs))
376 heller 1.1 xrefs))
377     |#
378    
379 asimon 1.15 ;;;; Inspecting
380    
381     (defclass abcl-inspector (inspector)
382     ())
383    
384     (defimplementation make-default-inspector ()
385     (make-instance 'abcl-inspector))
386    
387 asimon 1.26 (defmethod inspect-for-emacs ((slot mop::slot-definition) (inspector abcl-inspector))
388 asimon 1.15 (declare (ignore inspector))
389     (values "A slot."
390 asimon 1.28 `("Name: " (:value ,(mop::%slot-definition-name slot))
391 asimon 1.15 (:newline)
392     "Documentation:" (:newline)
393     ,@(when (slot-definition-documentation slot)
394     `((:value ,(slot-definition-documentation slot)) (:newline)))
395     "Initialization:" (:newline)
396 asimon 1.28 " Args: " (:value ,(mop::%slot-definition-initargs slot)) (:newline)
397     " Form: " ,(if (mop::%slot-definition-initfunction slot)
398     `(:value ,(mop::%slot-definition-initform slot))
399 asimon 1.15 "#<unspecified>") (:newline)
400 asimon 1.28 " Function: " (:value ,(mop::%slot-definition-initfunction slot))
401 asimon 1.15 (:newline))))
402 asimon 1.16
403     (defmethod inspect-for-emacs ((f function) (inspector abcl-inspector))
404     (declare (ignore inspector))
405     (values "A function."
406 asimon 1.17 `(,@(when (function-name f)
407     `("Name: "
408     ,(princ-to-string (function-name f)) (:newline)))
409     ,@(multiple-value-bind (args present)
410     (sys::arglist f)
411     (when present `("Argument list: " ,(princ-to-string args) (:newline))))
412 asimon 1.16 (:newline)
413     #+nil,@(when (documentation f t)
414     `("Documentation:" (:newline) ,(documentation f t) (:newline)))
415     ,@(when (function-lambda-expression f)
416     `("Lambda expression:"
417 asimon 1.17 (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline))))))
418 asimon 1.15
419 heller 1.1 #|
420    
421 asimon 1.15 (defimplementation inspect-for-emacs ((o t) (inspector abcl-inspector))
422 heller 1.1 (let* ((class (class-of o))
423 asimon 1.26 (slots (mop::class-slots class)))
424 heller 1.1 (values (format nil "~A~% is a ~A" o class)
425     (mapcar (lambda (slot)
426 asimon 1.26 (let ((name (mop::slot-definition-name slot)))
427 heller 1.1 (cons (princ-to-string name)
428     (slot-value o name))))
429     slots))))
430     |#
431 asimon 1.15
432 heller 1.1 ;;;; Multithreading
433    
434     (defimplementation startup-multiprocessing ()
435     #+nil(mp:start-scheduler))
436    
437     (defimplementation spawn (fn &key name)
438 asimon 1.8 (ext:make-thread (lambda () (funcall fn)) :name name))
439 heller 1.1
440 heller 1.6 (defvar *thread-props-lock* (ext:make-thread-lock))
441    
442     (defvar *thread-props* (make-hash-table) ; should be a weak table
443     "A hashtable mapping threads to a plist.")
444    
445     (defvar *thread-id-counter* 0)
446    
447     (defimplementation thread-id (thread)
448     (ext:with-thread-lock (*thread-props-lock*)
449     (or (getf (gethash thread *thread-props*) 'id)
450     (setf (getf (gethash thread *thread-props*) 'id)
451     (incf *thread-id-counter*)))))
452    
453     (defimplementation find-thread (id)
454     (find id (all-threads)
455 asimon 1.7 :key (lambda (thread)
456 heller 1.6 (getf (gethash thread *thread-props*) 'id))))
457    
458 heller 1.1 (defimplementation thread-name (thread)
459 asimon 1.8 (ext:thread-name thread))
460 heller 1.1
461     (defimplementation thread-status (thread)
462 asimon 1.4 (format nil "Thread is ~:[dead~;alive~]" (ext:thread-alive-p thread)))
463 heller 1.1
464     (defimplementation make-lock (&key name)
465     (ext:make-thread-lock))
466    
467     (defimplementation call-with-lock-held (lock function)
468     (ext:with-thread-lock (lock) (funcall function)))
469    
470     (defimplementation current-thread ()
471     (ext:current-thread))
472    
473     (defimplementation all-threads ()
474     (copy-list (ext:mapcar-threads #'identity)))
475    
476     (defimplementation interrupt-thread (thread fn)
477     (ext:interrupt-thread thread fn))
478    
479     (defimplementation kill-thread (thread)
480     (ext:destroy-thread thread))
481    
482     (defun mailbox (thread)
483     "Return THREAD's mailbox."
484 heller 1.6 (ext:with-thread-lock (*thread-props-lock*)
485     (or (getf (gethash thread *thread-props*) 'mailbox)
486     (setf (getf (gethash thread *thread-props*) 'mailbox)
487 asimon 1.5 (ext:make-mailbox)))))
488 heller 1.1
489 asimon 1.5 (defimplementation send (thread object)
490     (ext:mailbox-send (mailbox thread) object))
491 heller 1.1
492     (defimplementation receive ()
493 asimon 1.5 (ext:mailbox-read (mailbox (ext:current-thread))))
494 heller 1.1
495 asimon 1.29 ;;; Auto-flush streams
496    
497     ;; XXX race conditions
498     (defvar *auto-flush-streams* '())
499    
500     (defvar *auto-flush-thread* nil)
501    
502     (defimplementation make-stream-interactive (stream)
503     (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*))
504     (unless *auto-flush-thread*
505     (setq *auto-flush-thread*
506     (ext:make-thread #'flush-streams
507     :name "auto-flush-thread"))))
508    
509     (defun flush-streams ()
510     (loop
511     (setq *auto-flush-streams*
512     (remove-if (lambda (x)
513     (not (and (open-stream-p x)
514     (output-stream-p x))))
515     *auto-flush-streams*))
516     (mapc #'finish-output *auto-flush-streams*)
517     (sleep 0.15)))
518    
519 heller 1.1 (defimplementation quit-lisp ()
520     (ext:exit))
521 asimon 1.12
522 aruttenberg 1.36
523    
524    

  ViewVC Help
Powered by ViewVC 1.1.5