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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Sat Jan 19 15:09:33 2008 UTC (6 years, 3 months ago) by gcarncross
Branch: MAIN
Changes since 1.10: +47 -0 lines
Make ELC inspection better; should be able to handle all builtin types and CLOS objects now.
1 ;;;; -*- indent-tabs-mode: nil -*-
2 ;;;
3 ;;; swank-ecl.lisp --- SLIME backend for ECL.
4 ;;;
5 ;;; This code has been placed in the Public Domain. All warranties
6 ;;; are disclaimed.
7 ;;;
8
9 ;;; Administrivia
10
11 (in-package :swank-backend)
12
13 (import-from :ext *gray-stream-symbols* :swank-backend)
14
15 (swank-backend::import-swank-mop-symbols :clos
16 '(:eql-specializer
17 :eql-specializer-object
18 :generic-function-declarations
19 :specializer-direct-methods
20 :compute-applicable-methods-using-classes))
21
22
23 ;;;; TCP Server
24
25 (require 'sockets)
26
27 (defun resolve-hostname (name)
28 (car (sb-bsd-sockets:host-ent-addresses
29 (sb-bsd-sockets:get-host-by-name name))))
30
31 (defimplementation create-socket (host port)
32 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
33 :type :stream
34 :protocol :tcp)))
35 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
36 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
37 (sb-bsd-sockets:socket-listen socket 5)
38 socket))
39
40 (defimplementation local-port (socket)
41 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
42
43 (defimplementation close-socket (socket)
44 (sb-bsd-sockets:socket-close socket))
45
46 (defimplementation accept-connection (socket
47 &key external-format
48 buffering timeout)
49 (declare (ignore buffering timeout external-format))
50 (make-socket-io-stream (accept socket)))
51
52 (defun make-socket-io-stream (socket)
53 (sb-bsd-sockets:socket-make-stream socket
54 :output t
55 :input t
56 :element-type 'base-char))
57
58 (defun accept (socket)
59 "Like socket-accept, but retry on EAGAIN."
60 (loop (handler-case
61 (return (sb-bsd-sockets:socket-accept socket))
62 (sb-bsd-sockets:interrupted-error ()))))
63
64 (defimplementation preferred-communication-style ()
65 (values nil))
66
67
68 ;;;; Unix signals
69
70 (defimplementation getpid ()
71 (si:getpid))
72
73 #+nil
74 (defimplementation set-default-directory (directory)
75 (ext::chdir (namestring directory))
76 ;; Setting *default-pathname-defaults* to an absolute directory
77 ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
78 (setf *default-pathname-defaults* (ext::getcwd))
79 (default-directory))
80
81 #+nil
82 (defimplementation default-directory ()
83 (namestring (ext:getcwd)))
84
85 (defimplementation quit-lisp ()
86 (ext:quit))
87
88
89 ;;;; Compilation
90
91 (defvar *buffer-name* nil)
92 (defvar *buffer-start-position*)
93 (defvar *buffer-string*)
94 (defvar *compile-filename*)
95
96 (defun signal-compiler-condition (&rest args)
97 (signal (apply #'make-condition 'compiler-condition args)))
98
99 (defun handle-compiler-warning (condition)
100 (signal-compiler-condition
101 :original-condition condition
102 :message (format nil "~A" condition)
103 :severity :warning
104 :location
105 (if *buffer-name*
106 (make-location (list :buffer *buffer-name*)
107 (list :position *buffer-start-position*))
108 ;; ;; compiler::*current-form*
109 ;; (if compiler::*current-function*
110 ;; (make-location (list :file *compile-filename*)
111 ;; (list :function-name
112 ;; (symbol-name
113 ;; (slot-value compiler::*current-function*
114 ;; 'compiler::name))))
115 (list :error "No location found.")
116 ;; )
117 )))
118
119 (defimplementation call-with-compilation-hooks (function)
120 (handler-bind ((warning #'handle-compiler-warning))
121 (funcall function)))
122
123 (defimplementation swank-compile-file (*compile-filename* load-p
124 external-format)
125 (declare (ignore external-format))
126 (with-compilation-hooks ()
127 (let ((*buffer-name* nil))
128 (multiple-value-bind (fn warn fail)
129 (compile-file *compile-filename*)
130 (when load-p (unless fail (load fn)))))))
131
132 (defimplementation swank-compile-string (string &key buffer position directory)
133 (declare (ignore directory))
134 (with-compilation-hooks ()
135 (let ((*buffer-name* buffer)
136 (*buffer-start-position* position)
137 (*buffer-string* string))
138 (with-input-from-string (s string)
139 (compile-from-stream s :load t)))))
140
141 (defun compile-from-stream (stream &rest args)
142 (let ((file (si::mkstemp "TMP:ECLXXXXXX")))
143 (with-open-file (s file :direction :output :if-exists :overwrite)
144 (do ((line (read-line stream nil) (read-line stream nil)))
145 ((not line))
146 (write-line line s)))
147 (unwind-protect
148 (apply #'compile-file file args)
149 (delete-file file))))
150
151
152 ;;;; Documentation
153
154 (defimplementation arglist (name)
155 (or (functionp name) (setf name (symbol-function name)))
156 (if (functionp name)
157 (typecase name
158 (generic-function
159 (clos::generic-function-lambda-list name))
160 (compiled-function
161 ; most of the compiled functions have an Args: line in their docs
162 (with-input-from-string (s (or
163 (si::get-documentation
164 (si:compiled-function-name name) 'function)
165 ""))
166 (do ((line (read-line s nil) (read-line s nil)))
167 ((not line) :not-available)
168 (ignore-errors
169 (if (string= (subseq line 0 6) "Args: ")
170 (return-from nil
171 (read-from-string (subseq line 6))))))))
172 ;
173 (function
174 (let ((fle (function-lambda-expression name)))
175 (case (car fle)
176 (si:lambda-block (caddr fle))
177 (t :not-available)))))
178 :not-available))
179
180 (defimplementation function-name (f)
181 (si:compiled-function-name f))
182
183 (defimplementation macroexpand-all (form)
184 ;;; FIXME! This is not the same as a recursive macroexpansion!
185 (macroexpand form))
186
187 (defimplementation describe-symbol-for-emacs (symbol)
188 (let ((result '()))
189 (dolist (type '(:VARIABLE :FUNCTION :CLASS))
190 (let ((doc (describe-definition symbol type)))
191 (when doc
192 (setf result (list* type doc result)))))
193 result))
194
195 (defimplementation describe-definition (name type)
196 (case type
197 (:variable (documentation name 'variable))
198 (:function (documentation name 'function))
199 (:class (documentation name 'class))
200 (t nil)))
201
202 ;;; Debugging
203
204 (import
205 '(si::*ihs-top*
206 si::*ihs-current*
207 si::*ihs-base*
208 si::*frs-base*
209 si::*frs-top*
210 si::*tpl-commands*
211 si::*tpl-level*
212 si::frs-top
213 si::ihs-top
214 si::sch-frs-base
215 si::set-break-env
216 si::set-current-ihs
217 si::tpl-commands))
218
219 (defimplementation call-with-debugging-environment (debugger-loop-fn)
220 (declare (type function debugger-loop-fn))
221 (let* ((*tpl-commands* si::tpl-commands)
222 (*ihs-top* (ihs-top 'call-with-debugging-environment))
223 (*ihs-current* *ihs-top*)
224 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
225 (*frs-top* (frs-top))
226 (*read-suppress* nil)
227 (*tpl-level* (1+ *tpl-level*)))
228 (set-break-env)
229 (set-current-ihs)
230 (funcall debugger-loop-fn)))
231
232 ;; (defimplementation call-with-debugger-hook (hook fun)
233 ;; (let ((*debugger-hook* hook))
234 ;; (funcall fun)))
235
236 (defun nth-frame (n)
237 (cond ((>= n *ihs-top* ) nil)
238 (t (- *ihs-top* n))))
239
240 (defimplementation compute-backtrace (start end)
241 (loop for i from start below end
242 for f = (nth-frame i)
243 while f
244 collect f))
245
246 (defimplementation print-frame (frame stream)
247 (format stream "~A" (si::ihs-fname frame)))
248
249 ;;;; Inspector
250
251 (defclass ecl-inspector (inspector)
252 ())
253
254 (defimplementation make-default-inspector ()
255 (make-instance 'ecl-inspector))
256
257 (defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
258 ; ecl clos support leaves some to be desired
259 (cond
260 ((streamp o)
261 (values
262 (format nil "~S is an ordinary stream" o)
263 (append
264 (list
265 "Open for "
266 (cond
267 ((ignore-errors (interactive-stream-p o)) "Interactive")
268 ((and (input-stream-p o) (output-stream-p o)) "Input and output")
269 ((input-stream-p o) "Input")
270 ((output-stream-p o) "Output"))
271 `(:newline) `(:newline))
272 (label-value-line*
273 ("Element type" (stream-element-type o))
274 ("External format" (stream-external-format o)))
275 (ignore-errors (label-value-line*
276 ("Broadcast streams" (broadcast-stream-streams o))))
277 (ignore-errors (label-value-line*
278 ("Concatenated streams" (concatenated-stream-streams o))))
279 (ignore-errors (label-value-line*
280 ("Echo input stream" (echo-stream-input-stream o))))
281 (ignore-errors (label-value-line*
282 ("Echo output stream" (echo-stream-output-stream o))))
283 (ignore-errors (label-value-line*
284 ("Output String" (get-output-stream-string o))))
285 (ignore-errors (label-value-line*
286 ("Synonym symbol" (synonym-stream-symbol o))))
287 (ignore-errors (label-value-line*
288 ("Input stream" (two-way-stream-input-stream o))))
289 (ignore-errors (label-value-line*
290 ("Output stream" (two-way-stream-output-stream o)))))))
291 (t
292 (let* ((cl (si:instance-class o))
293 (slots (clos:class-slots cl)))
294 (values (format nil "~S is an instance of class ~A"
295 o (clos::class-name cl))
296 (loop for x in slots append
297 (let* ((name (clos:slot-definition-name x))
298 (value (clos::slot-value o name)))
299 (list
300 (format nil "~S: " name)
301 `(:value ,value)
302 `(:newline)))))))))
303
304 ;;;; Definitions
305
306 (defimplementation find-definitions (name) nil)
307
308 ;;;; Threads
309
310 #+threads
311 (progn
312 (defvar *thread-id-counter* 0)
313
314 (defvar *thread-id-counter-lock*
315 (mp:make-lock :name "thread id counter lock"))
316
317 (defun next-thread-id ()
318 (mp:with-lock (*thread-id-counter-lock*)
319 (incf *thread-id-counter*)))
320
321 (defparameter *thread-id-map* (make-hash-table))
322
323 (defvar *thread-id-map-lock*
324 (mp:make-lock :name "thread id map lock"))
325
326 ; ecl doesn't have weak pointers
327 (defimplementation spawn (fn &key name)
328 (let ((thread (mp:make-process :name name))
329 (id (next-thread-id)))
330 (mp:process-preset
331 thread
332 #'(lambda ()
333 (unwind-protect
334 (mp:with-lock (*thread-id-map-lock*)
335 (setf (gethash id *thread-id-map*) thread))
336 (funcall fn)
337 (mp:with-lock (*thread-id-map-lock*)
338 (remhash id *thread-id-map*)))))
339 (mp:process-enable thread)))
340
341 (defimplementation thread-id (thread)
342 (block thread-id
343 (mp:with-lock (*thread-id-map-lock*)
344 (loop for id being the hash-key in *thread-id-map*
345 using (hash-value thread-pointer)
346 do (if (eq thread thread-pointer)
347 (return-from thread-id id))))))
348
349 (defimplementation find-thread (id)
350 (mp:with-lock (*thread-id-map-lock*)
351 (gethash id *thread-id-map*)))
352
353 (defimplementation thread-name (thread)
354 (mp:process-name thread))
355
356 (defimplementation thread-status (thread)
357 (if (mp:process-active-p thread)
358 "RUNNING"
359 "STOPPED"))
360
361 (defimplementation make-lock (&key name)
362 (mp:make-lock :name name))
363
364 (defimplementation call-with-lock-held (lock function)
365 (declare (type function function))
366 (mp:with-lock (lock) (funcall function)))
367
368 (defimplementation make-recursive-lock (&key name)
369 (mp:make-lock :name name))
370
371 (defimplementation call-with-recursive-lock-held (lock function)
372 (declare (type function function))
373 (mp:with-lock (lock) (funcall function)))
374
375 (defimplementation current-thread ()
376 mp:*current-process*)
377
378 (defimplementation all-threads ()
379 (mp:all-processes))
380
381 (defimplementation interrupt-thread (thread fn)
382 (mp:interrupt-process thread fn))
383
384 (defimplementation kill-thread (thread)
385 (mp:process-kill thread))
386
387 (defimplementation thread-alive-p (thread)
388 (mp:process-active-p thread))
389
390 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
391
392 (defstruct (mailbox (:conc-name mailbox.))
393 (mutex (mp:make-lock :name "process mailbox"))
394 (queue '() :type list))
395
396 (defun mailbox (thread)
397 "Return THREAD's mailbox."
398 (mp:with-lock (*mailbox-lock*)
399 (or (find thread *mailboxes* :key #'mailbox.thread)
400 (let ((mb (make-mailbox :thread thread)))
401 (push mb *mailboxes*)
402 mb))))
403
404 (defimplementation send (thread message)
405 (let* ((mbox (mailbox thread))
406 (mutex (mailbox.mutex mbox)))
407 (mp:interrupt-process
408 thread
409 (lambda ()
410 (mp:with-lock (mutex)
411 (setf (mailbox.queue mbox)
412 (nconc (mailbox.queue mbox) (list message))))))))
413
414 (defimplementation receive ()
415 (block got-mail
416 (let* ((mbox (mailbox mp:*current-process*))
417 (mutex (mailbox.mutex mbox)))
418 (loop
419 (mp:with-lock (mutex)
420 (if (mailbox.queue mbox)
421 (return-from got-mail (pop (mailbox.queue mbox)))))
422 ;interrupt-process will halt this if it takes longer than 1sec
423 (sleep 1)))))
424
425 ;; Auto-flush streams
426 (defvar *auto-flush-interval* 0.15
427 "How often to flush interactive streams. This valu is passed
428 directly to cl:sleep.")
429
430 (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush"))
431
432 (defvar *auto-flush-thread* nil)
433
434 (defvar *auto-flush-streams* '())
435
436 (defimplementation make-stream-interactive (stream)
437 (call-with-recursive-lock-held
438 *auto-flush-lock*
439 (lambda ()
440 (pushnew stream *auto-flush-streams*)
441 (unless *auto-flush-thread*
442 (setq *auto-flush-thread*
443 (spawn #'flush-streams
444 :name "auto-flush-thread"))))))
445
446 (defmethod stream-finish-output ((stream stream))
447 (finish-output stream))
448
449 (defun flush-streams ()
450 (loop
451 (call-with-recursive-lock-held
452 *auto-flush-lock*
453 (lambda ()
454 (setq *auto-flush-streams*
455 (remove-if (lambda (x)
456 (not (and (open-stream-p x)
457 (output-stream-p x))))
458 *auto-flush-streams*))
459 (mapc #'stream-finish-output *auto-flush-streams*)))
460 (sleep *auto-flush-interval*)))
461
462 )
463

  ViewVC Help
Powered by ViewVC 1.1.5