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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.25 - (show annotations)
Fri Aug 8 13:43:33 2008 UTC (5 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.24: +0 -32 lines
Spawn the auto-flush thread in the front end.
This removes some copy&paste code in various backends.

* swank.lisp (auto-flush-loop): New function.
(open-streams): Use it.
* swank-backend.lisp (make-stream-interactive): Deleted.
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 (defvar *tmp*)
14
15 (if (find-package :gray)
16 (import-from :gray *gray-stream-symbols* :swank-backend)
17 (import-from :ext *gray-stream-symbols* :swank-backend))
18
19 (swank-backend::import-swank-mop-symbols :clos
20 '(:eql-specializer
21 :eql-specializer-object
22 :generic-function-declarations
23 :specializer-direct-methods
24 :compute-applicable-methods-using-classes))
25
26
27 ;;;; TCP Server
28
29 (require 'sockets)
30
31 (defun resolve-hostname (name)
32 (car (sb-bsd-sockets:host-ent-addresses
33 (sb-bsd-sockets:get-host-by-name name))))
34
35 (defimplementation create-socket (host port)
36 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
37 :type :stream
38 :protocol :tcp)))
39 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
40 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
41 (sb-bsd-sockets:socket-listen socket 5)
42 socket))
43
44 (defimplementation local-port (socket)
45 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
46
47 (defimplementation close-socket (socket)
48 (sb-bsd-sockets:socket-close socket))
49
50 (defimplementation accept-connection (socket
51 &key external-format
52 buffering timeout)
53 (declare (ignore buffering timeout external-format))
54 (make-socket-io-stream (accept socket)))
55
56 (defun make-socket-io-stream (socket)
57 (sb-bsd-sockets:socket-make-stream socket
58 :output t
59 :input t
60 :element-type 'base-char))
61
62 (defun accept (socket)
63 "Like socket-accept, but retry on EAGAIN."
64 (loop (handler-case
65 (return (sb-bsd-sockets:socket-accept socket))
66 (sb-bsd-sockets:interrupted-error ()))))
67
68 (defimplementation preferred-communication-style ()
69 (values nil))
70
71
72 ;;;; Unix signals
73
74 (defimplementation getpid ()
75 (si:getpid))
76
77 #+nil
78 (defimplementation set-default-directory (directory)
79 (ext::chdir (namestring directory))
80 ;; Setting *default-pathname-defaults* to an absolute directory
81 ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
82 (setf *default-pathname-defaults* (ext::getcwd))
83 (default-directory))
84
85 #+nil
86 (defimplementation default-directory ()
87 (namestring (ext:getcwd)))
88
89 (defimplementation quit-lisp ()
90 (ext:quit))
91
92
93 ;;;; Compilation
94
95 (defvar *buffer-name* nil)
96 (defvar *buffer-start-position*)
97 (defvar *buffer-string*)
98 (defvar *compile-filename*)
99
100 (defun signal-compiler-condition (&rest args)
101 (signal (apply #'make-condition 'compiler-condition args)))
102
103 (defun handle-compiler-warning (condition)
104 (signal-compiler-condition
105 :original-condition condition
106 :message (format nil "~A" condition)
107 :severity :warning
108 :location
109 (if *buffer-name*
110 (make-location (list :buffer *buffer-name*)
111 (list :position *buffer-start-position*))
112 ;; ;; compiler::*current-form*
113 ;; (if compiler::*current-function*
114 ;; (make-location (list :file *compile-filename*)
115 ;; (list :function-name
116 ;; (symbol-name
117 ;; (slot-value compiler::*current-function*
118 ;; 'compiler::name))))
119 (list :error "No location found.")
120 ;; )
121 )))
122
123 (defimplementation call-with-compilation-hooks (function)
124 (handler-bind ((warning #'handle-compiler-warning))
125 (funcall function)))
126
127 (defimplementation swank-compile-file (*compile-filename* load-p
128 external-format)
129 (declare (ignore external-format))
130 (with-compilation-hooks ()
131 (let ((*buffer-name* nil))
132 (multiple-value-bind (fn warn fail)
133 (compile-file *compile-filename*)
134 (when load-p (unless fail (load fn)))))))
135
136 (defimplementation swank-compile-string (string &key buffer position directory
137 debug)
138 (declare (ignore directory debug))
139 (with-compilation-hooks ()
140 (let ((*buffer-name* buffer)
141 (*buffer-start-position* position)
142 (*buffer-string* string))
143 (with-input-from-string (s string)
144 (compile-from-stream s :load t)))))
145
146 (defun compile-from-stream (stream &rest args)
147 (let ((file (si::mkstemp "TMP:ECLXXXXXX")))
148 (with-open-file (s file :direction :output :if-exists :overwrite)
149 (do ((line (read-line stream nil) (read-line stream nil)))
150 ((not line))
151 (write-line line s)))
152 (unwind-protect
153 (apply #'compile-file file args)
154 (delete-file file))))
155
156
157 ;;;; Documentation
158
159 (defimplementation arglist (name)
160 (or (functionp name) (setf name (symbol-function name)))
161 (if (functionp name)
162 (typecase name
163 (generic-function
164 (clos::generic-function-lambda-list name))
165 (compiled-function
166 ; most of the compiled functions have an Args: line in their docs
167 (with-input-from-string (s (or
168 (si::get-documentation
169 (si:compiled-function-name name) 'function)
170 ""))
171 (do ((line (read-line s nil) (read-line s nil)))
172 ((not line) :not-available)
173 (ignore-errors
174 (if (string= (subseq line 0 6) "Args: ")
175 (return-from nil
176 (read-from-string (subseq line 6))))))))
177 ;
178 (function
179 (let ((fle (function-lambda-expression name)))
180 (case (car fle)
181 (si:lambda-block (caddr fle))
182 (t :not-available)))))
183 :not-available))
184
185 (defimplementation function-name (f)
186 (si:compiled-function-name f))
187
188 (defimplementation macroexpand-all (form)
189 ;;; FIXME! This is not the same as a recursive macroexpansion!
190 (macroexpand form))
191
192 (defimplementation describe-symbol-for-emacs (symbol)
193 (let ((result '()))
194 (dolist (type '(:VARIABLE :FUNCTION :CLASS))
195 (let ((doc (describe-definition symbol type)))
196 (when doc
197 (setf result (list* type doc result)))))
198 result))
199
200 (defimplementation describe-definition (name type)
201 (case type
202 (:variable (documentation name 'variable))
203 (:function (documentation name 'function))
204 (:class (documentation name 'class))
205 (t nil)))
206
207 ;;; Debugging
208
209 (import
210 '(si::*break-env*
211 si::*ihs-top*
212 si::*ihs-current*
213 si::*ihs-base*
214 si::*frs-base*
215 si::*frs-top*
216 si::*tpl-commands*
217 si::*tpl-level*
218 si::frs-top
219 si::ihs-top
220 si::ihs-fun
221 si::ihs-env
222 si::sch-frs-base
223 si::set-break-env
224 si::set-current-ihs
225 si::tpl-commands))
226
227 (defvar *backtrace* '())
228
229 (defun in-swank-package-p (x)
230 (and
231 (symbolp x)
232 (member (symbol-package x)
233 (list #.(find-package :swank)
234 #.(find-package :swank-backend)
235 #.(ignore-errors (find-package :swank-mop))
236 #.(ignore-errors (find-package :swank-loader))))
237 t))
238
239 (defun is-swank-source-p (name)
240 (setf name (pathname name))
241 (pathname-match-p
242 name
243 (make-pathname :defaults swank-loader::*source-directory*
244 :name (pathname-name name)
245 :type (pathname-type name)
246 :version (pathname-version name))))
247
248 (defun is-ignorable-fun-p (x)
249 (or
250 (in-swank-package-p (frame-name x))
251 (multiple-value-bind (file position)
252 (ignore-errors (si::bc-file (car x)))
253 (declare (ignore position))
254 (if file (is-swank-source-p file)))))
255
256 (defimplementation call-with-debugging-environment (debugger-loop-fn)
257 (declare (type function debugger-loop-fn))
258 (let* ((*tpl-commands* si::tpl-commands)
259 (*ihs-top* (ihs-top 'call-with-debugging-environment))
260 (*ihs-current* *ihs-top*)
261 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
262 (*frs-top* (frs-top))
263 (*read-suppress* nil)
264 (*tpl-level* (1+ *tpl-level*))
265 (*backtrace* (loop for ihs from *ihs-base* below *ihs-top*
266 collect (list (si::ihs-fun ihs)
267 (si::ihs-env ihs)
268 nil))))
269 (loop for f from *frs-base* until *frs-top*
270 do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
271 (when (plusp i)
272 (let* ((x (elt *backtrace* i))
273 (name (si::frs-tag f)))
274 (unless (si::fixnump name)
275 (push name (third x)))))))
276 (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
277 (Setf *tmp* *backtrace*)
278 (set-break-env)
279 (set-current-ihs)
280 (let ((*ihs-base* *ihs-top*))
281 (funcall debugger-loop-fn))))
282
283 (defimplementation call-with-debugger-hook (hook fun)
284 (let ((*debugger-hook* hook)
285 (*ihs-base*(si::ihs-top 'call-with-debugger-hook)))
286 (funcall fun)))
287
288 (defimplementation compute-backtrace (start end)
289 (when (numberp end)
290 (setf end (min end (length *backtrace*))))
291 (subseq *backtrace* start end))
292
293 (defun frame-name (frame)
294 (let ((x (first frame)))
295 (if (symbolp x)
296 x
297 (function-name x))))
298
299 (defun function-position (fun)
300 (multiple-value-bind (file position)
301 (si::bc-file fun)
302 (and file (make-location `(:file ,file) `(:position ,position)))))
303
304 (defun frame-function (frame)
305 (let* ((x (first frame))
306 fun position)
307 (etypecase x
308 (symbol (and (fboundp x)
309 (setf fun (fdefinition x)
310 position (function-position fun))))
311 (function (setf fun x position (function-position x))))
312 (values fun position)))
313
314 (defun frame-decode-env (frame)
315 (let ((functions '())
316 (blocks '())
317 (variables '()))
318 (dolist (record (second frame))
319 (let* ((record0 (car record))
320 (record1 (cdr record)))
321 (cond ((symbolp record0)
322 (setq variables (acons record0 record1 variables)))
323 ((not (si::fixnump record0))
324 (push record1 functions))
325 ((symbolp record1)
326 (push record1 blocks))
327 (t
328 ))))
329 (values functions blocks variables)))
330
331 (defimplementation print-frame (frame stream)
332 (format stream "~A" (first frame)))
333
334 (defimplementation frame-source-location-for-emacs (frame-number)
335 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
336
337 (defimplementation frame-catch-tags (frame-number)
338 (third (elt *backtrace* frame-number)))
339
340 (defimplementation frame-locals (frame-number)
341 (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
342 with i = 0
343 collect (list :name name :id (prog1 i (incf i)) :value value)))
344
345 (defimplementation frame-var-value (frame-number var-id)
346 (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
347 var-id))
348
349 (defimplementation disassemble-frame (frame-number)
350 (let ((fun (frame-fun (elt *backtrace* frame-number))))
351 (disassemble fun)))
352
353 (defimplementation eval-in-frame (form frame-number)
354 (let ((env (second (elt *backtrace* frame-number))))
355 (si:eval-with-env form env)))
356
357 ;;;; Inspector
358
359 (defmethod emacs-inspect ((o t))
360 ; ecl clos support leaves some to be desired
361 (cond
362 ((streamp o)
363 (list*
364 (format nil "~S is an ordinary stream~%" o)
365 (append
366 (list
367 "Open for "
368 (cond
369 ((ignore-errors (interactive-stream-p o)) "Interactive")
370 ((and (input-stream-p o) (output-stream-p o)) "Input and output")
371 ((input-stream-p o) "Input")
372 ((output-stream-p o) "Output"))
373 `(:newline) `(:newline))
374 (label-value-line*
375 ("Element type" (stream-element-type o))
376 ("External format" (stream-external-format o)))
377 (ignore-errors (label-value-line*
378 ("Broadcast streams" (broadcast-stream-streams o))))
379 (ignore-errors (label-value-line*
380 ("Concatenated streams" (concatenated-stream-streams o))))
381 (ignore-errors (label-value-line*
382 ("Echo input stream" (echo-stream-input-stream o))))
383 (ignore-errors (label-value-line*
384 ("Echo output stream" (echo-stream-output-stream o))))
385 (ignore-errors (label-value-line*
386 ("Output String" (get-output-stream-string o))))
387 (ignore-errors (label-value-line*
388 ("Synonym symbol" (synonym-stream-symbol o))))
389 (ignore-errors (label-value-line*
390 ("Input stream" (two-way-stream-input-stream o))))
391 (ignore-errors (label-value-line*
392 ("Output stream" (two-way-stream-output-stream o)))))))
393 (t
394 (let* ((cl (si:instance-class o))
395 (slots (clos:class-slots cl)))
396 (list* (format nil "~S is an instance of class ~A~%"
397 o (clos::class-name cl))
398 (loop for x in slots append
399 (let* ((name (clos:slot-definition-name x))
400 (value (clos::slot-value o name)))
401 (list
402 (format nil "~S: " name)
403 `(:value ,value)
404 `(:newline)))))))))
405
406 ;;;; Definitions
407
408 (defimplementation find-definitions (name)
409 (if (fboundp name)
410 (let ((tmp (find-source-location (symbol-function name))))
411 `(((defun ,name) ,tmp)))))
412
413 (defimplementation find-source-location (obj)
414 (setf *tmp* obj)
415 (or
416 (typecase obj
417 (function
418 (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj))
419 (if (and file pos)
420 (make-location
421 `(:file ,(namestring file))
422 `(:position ,pos)
423 `(:snippet
424 ,(with-open-file (s file)
425 (skip-toplevel-forms pos s)
426 (skip-comments-and-whitespace s)
427 (read-snippet s))))))))
428 `(:error (format nil "Source definition of ~S not found" obj))))
429
430 ;;;; Threads
431
432 #+threads
433 (progn
434 (defvar *thread-id-counter* 0)
435
436 (defvar *thread-id-counter-lock*
437 (mp:make-lock :name "thread id counter lock"))
438
439 (defun next-thread-id ()
440 (mp:with-lock (*thread-id-counter-lock*)
441 (incf *thread-id-counter*)))
442
443 (defparameter *thread-id-map* (make-hash-table))
444
445 (defvar *thread-id-map-lock*
446 (mp:make-lock :name "thread id map lock"))
447
448 ; ecl doesn't have weak pointers
449 (defimplementation spawn (fn &key name)
450 (let ((thread (mp:make-process :name name))
451 (id (next-thread-id)))
452 (mp:process-preset
453 thread
454 #'(lambda ()
455 (unwind-protect
456 (mp:with-lock (*thread-id-map-lock*)
457 (setf (gethash id *thread-id-map*) thread))
458 (funcall fn)
459 (mp:with-lock (*thread-id-map-lock*)
460 (remhash id *thread-id-map*)))))
461 (mp:process-enable thread)))
462
463 (defimplementation thread-id (thread)
464 (block thread-id
465 (mp:with-lock (*thread-id-map-lock*)
466 (loop for id being the hash-key in *thread-id-map*
467 using (hash-value thread-pointer)
468 do (if (eq thread thread-pointer)
469 (return-from thread-id id))))))
470
471 (defimplementation find-thread (id)
472 (mp:with-lock (*thread-id-map-lock*)
473 (gethash id *thread-id-map*)))
474
475 (defimplementation thread-name (thread)
476 (mp:process-name thread))
477
478 (defimplementation thread-status (thread)
479 (if (mp:process-active-p thread)
480 "RUNNING"
481 "STOPPED"))
482
483 (defimplementation make-lock (&key name)
484 (mp:make-lock :name name))
485
486 (defimplementation call-with-lock-held (lock function)
487 (declare (type function function))
488 (mp:with-lock (lock) (funcall function)))
489
490 (defimplementation current-thread ()
491 mp:*current-process*)
492
493 (defimplementation all-threads ()
494 (mp:all-processes))
495
496 (defimplementation interrupt-thread (thread fn)
497 (mp:interrupt-process thread fn))
498
499 (defimplementation kill-thread (thread)
500 (mp:process-kill thread))
501
502 (defimplementation thread-alive-p (thread)
503 (mp:process-active-p thread))
504
505 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
506
507 (defstruct (mailbox (:conc-name mailbox.))
508 (mutex (mp:make-lock :name "process mailbox"))
509 (queue '() :type list))
510
511 (defun mailbox (thread)
512 "Return THREAD's mailbox."
513 (mp:with-lock (*mailbox-lock*)
514 (or (find thread *mailboxes* :key #'mailbox.thread)
515 (let ((mb (make-mailbox :thread thread)))
516 (push mb *mailboxes*)
517 mb))))
518
519 (defimplementation send (thread message)
520 (let* ((mbox (mailbox thread))
521 (mutex (mailbox.mutex mbox)))
522 (mp:interrupt-process
523 thread
524 (lambda ()
525 (mp:with-lock (mutex)
526 (setf (mailbox.queue mbox)
527 (nconc (mailbox.queue mbox) (list message))))))))
528
529 (defimplementation receive ()
530 (block got-mail
531 (let* ((mbox (mailbox mp:*current-process*))
532 (mutex (mailbox.mutex mbox)))
533 (loop
534 (mp:with-lock (mutex)
535 (if (mailbox.queue mbox)
536 (return-from got-mail (pop (mailbox.queue mbox)))))
537 ;interrupt-process will halt this if it takes longer than 1sec
538 (sleep 1)))))
539
540 (defmethod stream-finish-output ((stream stream))
541 (finish-output stream))
542
543 )
544

  ViewVC Help
Powered by ViewVC 1.1.5