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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5