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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Wed Jun 9 20:08:16 2004 UTC (9 years, 10 months ago) by heller
Branch: MAIN
ABCL backend from Andras Simon.
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 #|
258 Should work (with a patched xref.lisp) but is it any use without find-definitions?
259 ;;;; XREF
260 (setq pxref::*handle-package-forms* '(cl:in-package))
261
262 (defmacro defxref (name function)
263 `(defimplementation ,name (name)
264 (xref-results (,function name))))
265
266 (defxref who-calls pxref:list-callers)
267 (defxref who-references pxref:list-readers)
268 (defxref who-binds pxref:list-setters)
269 (defxref who-sets pxref:list-setters)
270 (defxref list-callers pxref:list-callers)
271 (defxref list-callees pxref:list-callees)
272
273 (defun xref-results (symbols)
274 (let ((xrefs '()))
275 (dolist (symbol symbols)
276 (push (list symbol (fspec-location symbol)) xrefs))
277 xrefs))
278
279 |#
280
281 #|
282
283 ;;;; Inspecting
284
285 (defmethod inspected-parts (o)
286 (let* ((class (class-of o))
287 (slots (clos:class-slots class)))
288 (values (format nil "~A~% is a ~A" o class)
289 (mapcar (lambda (slot)
290 (let ((name (clos:slot-definition-name slot)))
291 (cons (princ-to-string name)
292 (slot-value o name))))
293 slots))))
294 |#
295 ;;;; Multithreading
296
297 (defimplementation startup-multiprocessing ()
298 #+nil(mp:start-scheduler))
299
300
301 (defimplementation spawn (fn &key name)
302 (ext:make-thread (lambda () (funcall fn))))
303
304 (defimplementation thread-name (thread)
305 "thread-name not implemented")
306
307 (defimplementation thread-status (thread)
308 (format nil "Thread is ~[dead~;alive~]" (thread-alive-p thread)))
309
310 (defimplementation make-lock (&key name)
311 (ext:make-thread-lock))
312
313 (defimplementation call-with-lock-held (lock function)
314 (ext:with-thread-lock (lock) (funcall function)))
315
316 (defimplementation current-thread ()
317 (ext:current-thread))
318
319 (defimplementation all-threads ()
320 (copy-list (ext:mapcar-threads #'identity)))
321
322 (defimplementation interrupt-thread (thread fn)
323 (ext:interrupt-thread thread fn))
324
325 (defimplementation kill-thread (thread)
326 (ext:destroy-thread thread))
327
328 (defvar *mailbox-lock* (ext:make-thread-lock))
329
330 (defstruct (mailbox (:conc-name mailbox.))
331 (mutex (ext:make-thread-lock))
332 (queue '() :type list))
333
334 (defvar *thread-mailbox* (make-hash-table))
335
336
337 (defun mailbox (thread)
338 "Return THREAD's mailbox."
339 (ext:with-thread-lock (*mailbox-lock*)
340 (or (gethash thread *thread-mailbox*)
341 (setf (gethash thread *thread-mailbox*)
342 (make-mailbox)))))
343
344 (defimplementation send (thread message)
345 (let* ((mbox (mailbox thread))
346 (mutex (mailbox.mutex mbox)))
347 #+nil
348 (mp:process-wait-with-timeout
349 "yielding before sending" 0.1
350 (lambda ()
351 (mp:with-process-lock (mutex)
352 (< (length (mailbox.queue mbox)) 10))))
353 ;(sleep 0.1)
354 (ext:with-thread-lock (mutex)
355 (setf (mailbox.queue mbox)
356 (nconc (mailbox.queue mbox) (list message))))))
357
358 (defimplementation receive ()
359 (let* ((mbox (mailbox (ext:current-thread)))
360 (mutex (mailbox.mutex mbox)))
361 #+nil(mp:process-wait "receive" #'mailbox.queue mbox)
362 (loop until (mailbox.queue mbox) do (sleep 0.1)) ;;FIXME
363 (ext:with-thread-lock (mutex)
364 (pop (mailbox.queue mbox)))))
365
366
367
368 (defimplementation quit-lisp ()
369 (ext:exit))

  ViewVC Help
Powered by ViewVC 1.1.5