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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Sun Jun 27 15:00:17 2004 UTC (9 years, 9 months ago) by heller
Branch: MAIN
Changes since 1.5: +21 -8 lines
(thread-id, find-thread): New backend function.
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 (defimplementation emacs-connected (stream)
60 (declare (ignore stream)))
61
62 ;;;; Unix signals
63
64 (defimplementation call-without-interrupts (fn)
65 (funcall fn))
66
67 ;;there are too many to count
68 (defimplementation getpid ()
69 0)
70
71 (defimplementation lisp-implementation-type-name ()
72 "armedbear")
73
74 (defimplementation set-default-directory (directory)
75 (let ((dir (sys::probe-directory directory)))
76 (when dir (setf *default-pathname-defaults* dir))
77 (namestring dir)))
78
79
80 ;;;; Misc
81
82 (defimplementation arglist (symbol)
83 (handler-case (sys::arglist symbol)
84 (simple-error () :not-available)))
85
86 (defimplementation macroexpand-all (form)
87 (macroexpand form))
88
89 (defimplementation describe-symbol-for-emacs (symbol)
90 (let ((result '()))
91 (flet ((doc (kind &optional (sym symbol))
92 (or (documentation sym kind) :not-documented))
93 (maybe-push (property value)
94 (when value
95 (setf result (list* property value result)))))
96 (maybe-push
97 :variable (when (boundp symbol)
98 (doc 'variable)))
99 (maybe-push
100 :function (if (fboundp symbol)
101 (doc 'function)))
102 (maybe-push
103 :class (if (find-class symbol nil)
104 (doc 'class)))
105 result)))
106
107
108 (defimplementation describe-definition (symbol namespace)
109 (ecase namespace
110 (:variable
111 (describe symbol))
112 ((:function :generic-function)
113 (describe (symbol-function symbol)))
114 (:class
115 (describe (find-class symbol)))))
116
117 (defimplementation describe-definition (symbol namespace)
118 (ecase namespace
119 (:variable
120 (describe symbol))
121 ((:function :generic-function)
122 (describe (symbol-function symbol)))
123 (:class
124 (describe (find-class symbol)))))
125
126
127 ;;;; Debugger
128
129 (defvar *sldb-topframe*)
130
131 (defimplementation call-with-debugging-environment (debugger-loop-fn)
132 (let ((*sldb-topframe* (car (ext:backtrace-as-list)) #+nil (excl::int-newest-frame)))
133 (funcall debugger-loop-fn)))
134
135 (defun nth-frame (index)
136 (nth index (ext:backtrace-as-list)))
137
138 (defimplementation compute-backtrace (start end)
139 (let ((end (or end most-positive-fixnum)))
140 (subseq (ext:backtrace-as-list) start end)))
141
142 (defimplementation print-frame (frame stream)
143 (print frame stream))
144
145 #+nil
146 (defimplementation frame-locals (index)
147 (let ((frame (nth-frame index)))
148 (loop for i from 0 below (debugger:frame-number-vars frame)
149 collect (list :name (debugger:frame-var-name frame i)
150 :id 0
151 :value (debugger:frame-var-value frame i)))))
152
153 (defimplementation frame-catch-tags (index)
154 (declare (ignore index))
155 nil)
156
157 #+nil
158 (defimplementation disassemble-frame (index)
159 (disassemble (debugger:frame-function (nth-frame index))))
160
161 (defimplementation frame-source-location-for-emacs (index)
162 (list :error (format nil "Cannot find source for frame: ~A"
163 (nth-frame index))))
164
165 #+nil
166 (defimplementation eval-in-frame (form frame-number)
167 (debugger:eval-form-in-context
168 form
169 (debugger:environment-of-frame (nth-frame frame-number))))
170
171 #+nil
172 (defimplementation return-from-frame (frame-number form)
173 (let ((frame (nth-frame frame-number)))
174 (multiple-value-call #'debugger:frame-return
175 frame (debugger:eval-form-in-context
176 form
177 (debugger:environment-of-frame frame)))))
178
179 ;;; XXX doesn't work for frames with arguments
180 #+nil
181 (defimplementation restart-frame (frame-number)
182 (let ((frame (nth-frame frame-number)))
183 (debugger:frame-retry frame (debugger:frame-function frame))))
184
185 ;;;; Compiler hooks
186
187 (defvar *buffer-name* nil)
188 (defvar *buffer-start-position*)
189 (defvar *buffer-string*)
190 (defvar *compile-filename*)
191
192 (defun handle-compiler-warning (condition)
193 #+nil
194 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
195 (signal (make-condition
196 'compiler-condition
197 :original-condition condition
198 :severity :warning
199 :message (format nil "~A" condition)
200 :location (cond (*buffer-name*
201 (make-location
202 (list :buffer *buffer-name*)
203 (list :position *buffer-start-position*)))
204 (loc
205 (destructuring-bind (file . pos) loc
206 (make-location
207 (list :file (namestring (truename file)))
208 (list :position (1+ pos)))))
209 (t
210 (make-location
211 (list :file *compile-filename*)
212 (list :position 1))))))))
213
214 (defimplementation swank-compile-file (*compile-filename* load-p)
215 (handler-bind ((warning #'handle-compiler-warning))
216 (let ((*buffer-name* nil))
217 (multiple-value-bind (fn warn fail)
218 (compile-file *compile-filename*)
219 (when load-p (unless fail (load fn)))))))
220
221 (defimplementation swank-compile-string (string &key buffer position)
222 (handler-bind ((warning #'handle-compiler-warning))
223 (let ((*buffer-name* buffer)
224 (*buffer-start-position* position)
225 (*buffer-string* string))
226 (funcall (compile nil (read-from-string
227 (format nil "(~S () ~A)" 'lambda string)))))))
228
229 #|
230 ;;;; Definition Finding
231
232 (defun find-fspec-location (fspec type)
233 (let ((file (excl::fspec-pathname fspec type)))
234 (etypecase file
235 (pathname
236 (let ((start (scm:find-definition-in-file fspec type file)))
237 (make-location (list :file (namestring (truename file)))
238 (if start
239 (list :position (1+ start))
240 (list :function-name (string fspec))))))
241 ((member :top-level)
242 (list :error (format nil "Defined at toplevel: ~A" fspec)))
243 (null
244 (list :error (format nil "Unkown source location for ~A" fspec))))))
245
246 (defun fspec-definition-locations (fspec)
247 (let ((defs (excl::find-multiple-definitions fspec)))
248 (loop for (fspec type) in defs
249 collect (list fspec (find-fspec-location fspec type)))))
250
251 (defimplementation find-definitions (symbol)
252 (fspec-definition-locations symbol))
253
254 |#
255
256 (defun source-location (symbol)
257 (when (ext:source symbol)
258 `(((,symbol)
259 (:location
260 (:file ,(namestring (ext:source-pathname symbol)))
261 (:position ,(ext:source-file-position symbol) t)
262 (:snippet nil))))))
263
264
265 (defimplementation find-definitions (symbol)
266 (source-location symbol))
267
268
269 #|
270 Should work (with a patched xref.lisp) but is it any use without find-definitions?
271 ;;;; XREF
272 (setq pxref::*handle-package-forms* '(cl:in-package))
273
274 (defmacro defxref (name function)
275 `(defimplementation ,name (name)
276 (xref-results (,function name))))
277
278 (defxref who-calls pxref:list-callers)
279 (defxref who-references pxref:list-readers)
280 (defxref who-binds pxref:list-setters)
281 (defxref who-sets pxref:list-setters)
282 (defxref list-callers pxref:list-callers)
283 (defxref list-callees pxref:list-callees)
284
285 (defun xref-results (symbols)
286 (let ((xrefs '()))
287 (dolist (symbol symbols)
288 (push (list symbol (fspec-location symbol)) xrefs))
289 xrefs))
290
291 |#
292
293 #|
294
295 ;;;; Inspecting
296
297 (defmethod inspected-parts (o)
298 (let* ((class (class-of o))
299 (slots (clos:class-slots class)))
300 (values (format nil "~A~% is a ~A" o class)
301 (mapcar (lambda (slot)
302 (let ((name (clos:slot-definition-name slot)))
303 (cons (princ-to-string name)
304 (slot-value o name))))
305 slots))))
306 |#
307 ;;;; Multithreading
308
309 (defimplementation startup-multiprocessing ()
310 #+nil(mp:start-scheduler))
311
312 (defimplementation spawn (fn &key name)
313 (ext:make-thread (lambda () (funcall fn))))
314
315 (defvar *thread-props-lock* (ext:make-thread-lock))
316
317 (defvar *thread-props* (make-hash-table) ; should be a weak table
318 "A hashtable mapping threads to a plist.")
319
320 (defvar *thread-id-counter* 0)
321
322 (defimplementation thread-id (thread)
323 (ext:with-thread-lock (*thread-props-lock*)
324 (or (getf (gethash thread *thread-props*) 'id)
325 (setf (getf (gethash thread *thread-props*) 'id)
326 (incf *thread-id-counter*)))))
327
328 (defimplementation find-thread (id)
329 (find id (all-threads)
330 :test (lambda (thread)
331 (getf (gethash thread *thread-props*) 'id))))
332
333 (defimplementation thread-name (thread)
334 (princ-to-string thread))
335
336 (defimplementation thread-status (thread)
337 (format nil "Thread is ~:[dead~;alive~]" (ext:thread-alive-p thread)))
338
339 (defimplementation make-lock (&key name)
340 (ext:make-thread-lock))
341
342 (defimplementation call-with-lock-held (lock function)
343 (ext:with-thread-lock (lock) (funcall function)))
344
345 (defimplementation current-thread ()
346 (ext:current-thread))
347
348 (defimplementation all-threads ()
349 (copy-list (ext:mapcar-threads #'identity)))
350
351 (defimplementation interrupt-thread (thread fn)
352 (ext:interrupt-thread thread fn))
353
354 (defimplementation kill-thread (thread)
355 (ext:destroy-thread thread))
356
357 (defun mailbox (thread)
358 "Return THREAD's mailbox."
359 (ext:with-thread-lock (*thread-props-lock*)
360 (or (getf (gethash thread *thread-props*) 'mailbox)
361 (setf (getf (gethash thread *thread-props*) 'mailbox)
362 (ext:make-mailbox)))))
363
364 (defimplementation send (thread object)
365 (ext:mailbox-send (mailbox thread) object))
366
367 (defimplementation receive ()
368 (ext:mailbox-read (mailbox (ext:current-thread))))
369
370 (defimplementation quit-lisp ()
371 (ext:exit))

  ViewVC Help
Powered by ViewVC 1.1.5