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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5