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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.21 - (show annotations)
Thu May 1 02:47:32 2008 UTC (5 years, 11 months ago) by gcarncross
Branch: MAIN
Changes since 1.20: +13 -2 lines
Remove frames from the backtrace that are in a swank package as those are misleading. Fixup locals display.
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 (if (consp x) (setf x (frame-name x)))
231 (when (symbolp x)
232 (and
233 (member (symbol-package x)
234 (list #.(find-package :swank)
235 #.(find-package :swank-backend)
236 #.(ignore-errors (find-package :swank-mop))
237 #.(ignore-errors (find-package :swank-loader))))
238 t)))
239
240 (defimplementation call-with-debugging-environment (debugger-loop-fn)
241 (declare (type function debugger-loop-fn))
242 (let* ((*tpl-commands* si::tpl-commands)
243 (*ihs-top* (ihs-top 'call-with-debugging-environment))
244 (*ihs-current* *ihs-top*)
245 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
246 (*frs-top* (frs-top))
247 (*read-suppress* nil)
248 (*tpl-level* (1+ *tpl-level*))
249 (*backtrace* (loop for ihs from *ihs-base* below *ihs-top*
250 collect (list (si::ihs-fun ihs)
251 (si::ihs-env ihs)
252 nil))))
253 (loop for f from *frs-base* until *frs-top*
254 do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
255 (when (plusp i)
256 (let* ((x (elt *backtrace* i))
257 (name (si::frs-tag f)))
258 (unless (fixnump name)
259 (push name (third x)))))))
260 (setf *backtrace* (remove-if #'in-swank-package-p (nreverse *backtrace*)))
261 (set-break-env)
262 (set-current-ihs)
263 (let ((*ihs-base* *ihs-top*))
264 (funcall debugger-loop-fn))))
265
266 (defimplementation call-with-debugger-hook (hook fun)
267 (let ((*debugger-hook* hook)
268 (*ihs-base*(si::ihs-top 'call-with-debugger-hook)))
269 (funcall fun)))
270
271 (defimplementation compute-backtrace (start end)
272 (when (numberp end)
273 (setf end (min end (length *backtrace*))))
274 (subseq *backtrace* start end))
275
276 (defun frame-name (frame)
277 (let ((x (first frame)))
278 (if (symbolp x)
279 x
280 (function-name x))))
281
282 (defun function-position (fun)
283 (multiple-value-bind (file position)
284 (si::bc-file fun)
285 (and file (make-location `(:file ,file) `(:position ,position)))))
286
287 (defun frame-function (frame)
288 (let* ((x (first frame))
289 fun position)
290 (etypecase x
291 (symbol (and (fboundp x)
292 (setf fun (fdefinition x)
293 position (function-position fun))))
294 (function (setf fun x position (function-position x))))
295 (values fun position)))
296
297 (defun frame-decode-env (frame)
298 (let ((functions '())
299 (blocks '())
300 (variables '()))
301 (dolist (record (second frame))
302 (let* ((record0 (car record))
303 (record1 (cdr record)))
304 (cond ((symbolp record0)
305 (setq variables (acons record0 record1 variables)))
306 ((not (fixnump record0))
307 (push record1 functions))
308 ((symbolp record1)
309 (push record1 blocks))
310 (t
311 ))))
312 (values functions blocks variables)))
313
314 (defimplementation print-frame (frame stream)
315 (format stream "~A" (first frame)))
316
317 (defimplementation frame-source-location-for-emacs (frame-number)
318 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
319
320 (defimplementation frame-catch-tags (frame-number)
321 (third (elt *backtrace* frame-number)))
322
323 (defimplementation frame-locals (frame-number)
324 (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
325 with i = 0
326 collect (list :name name :id (prog1 i (incf i)) :value value)))
327
328 (defimplementation frame-var-value (frame-number var-id)
329 (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
330 var-id))
331
332 (defimplementation disassemble-frame (frame-number)
333 (let ((fun (frame-fun (elt *backtrace* frame-number))))
334 (disassemble fun)))
335
336 (defimplementation eval-in-frame (form frame-number)
337 (let ((env (second (elt *backtrace* frame-number))))
338 (si:eval-with-env form env)))
339
340 ;;;; Inspector
341
342 (defmethod emacs-inspect ((o t))
343 ; ecl clos support leaves some to be desired
344 (cond
345 ((streamp o)
346 (list*
347 (format nil "~S is an ordinary stream~%" o)
348 (append
349 (list
350 "Open for "
351 (cond
352 ((ignore-errors (interactive-stream-p o)) "Interactive")
353 ((and (input-stream-p o) (output-stream-p o)) "Input and output")
354 ((input-stream-p o) "Input")
355 ((output-stream-p o) "Output"))
356 `(:newline) `(:newline))
357 (label-value-line*
358 ("Element type" (stream-element-type o))
359 ("External format" (stream-external-format o)))
360 (ignore-errors (label-value-line*
361 ("Broadcast streams" (broadcast-stream-streams o))))
362 (ignore-errors (label-value-line*
363 ("Concatenated streams" (concatenated-stream-streams o))))
364 (ignore-errors (label-value-line*
365 ("Echo input stream" (echo-stream-input-stream o))))
366 (ignore-errors (label-value-line*
367 ("Echo output stream" (echo-stream-output-stream o))))
368 (ignore-errors (label-value-line*
369 ("Output String" (get-output-stream-string o))))
370 (ignore-errors (label-value-line*
371 ("Synonym symbol" (synonym-stream-symbol o))))
372 (ignore-errors (label-value-line*
373 ("Input stream" (two-way-stream-input-stream o))))
374 (ignore-errors (label-value-line*
375 ("Output stream" (two-way-stream-output-stream o)))))))
376 (t
377 (let* ((cl (si:instance-class o))
378 (slots (clos:class-slots cl)))
379 (list* (format nil "~S is an instance of class ~A~%"
380 o (clos::class-name cl))
381 (loop for x in slots append
382 (let* ((name (clos:slot-definition-name x))
383 (value (clos::slot-value o name)))
384 (list
385 (format nil "~S: " name)
386 `(:value ,value)
387 `(:newline)))))))))
388
389 ;;;; Definitions
390
391 (defimplementation find-definitions (name)
392 (if (fboundp name)
393 (let ((tmp (find-source-location (symbol-function name))))
394 `(((defun ,name) ,tmp)))))
395
396 (defimplementation find-source-location (obj)
397 (setf *tmp* obj)
398 (or
399 (typecase obj
400 (function
401 (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj))
402 (if (and file pos)
403 (make-location
404 `(:file ,(namestring file))
405 `(:position ,pos)
406 `(:snippet
407 ,(with-open-file (s file)
408 (skip-toplevel-forms pos s)
409 (skip-comments-and-whitespace s)
410 (read-snippet s))))))))
411 `(:error (format nil "Source definition of ~S not found" obj))))
412
413 ;;;; Threads
414
415 #+threads
416 (progn
417 (defvar *thread-id-counter* 0)
418
419 (defvar *thread-id-counter-lock*
420 (mp:make-lock :name "thread id counter lock"))
421
422 (defun next-thread-id ()
423 (mp:with-lock (*thread-id-counter-lock*)
424 (incf *thread-id-counter*)))
425
426 (defparameter *thread-id-map* (make-hash-table))
427
428 (defvar *thread-id-map-lock*
429 (mp:make-lock :name "thread id map lock"))
430
431 ; ecl doesn't have weak pointers
432 (defimplementation spawn (fn &key name)
433 (let ((thread (mp:make-process :name name))
434 (id (next-thread-id)))
435 (mp:process-preset
436 thread
437 #'(lambda ()
438 (unwind-protect
439 (mp:with-lock (*thread-id-map-lock*)
440 (setf (gethash id *thread-id-map*) thread))
441 (funcall fn)
442 (mp:with-lock (*thread-id-map-lock*)
443 (remhash id *thread-id-map*)))))
444 (mp:process-enable thread)))
445
446 (defimplementation thread-id (thread)
447 (block thread-id
448 (mp:with-lock (*thread-id-map-lock*)
449 (loop for id being the hash-key in *thread-id-map*
450 using (hash-value thread-pointer)
451 do (if (eq thread thread-pointer)
452 (return-from thread-id id))))))
453
454 (defimplementation find-thread (id)
455 (mp:with-lock (*thread-id-map-lock*)
456 (gethash id *thread-id-map*)))
457
458 (defimplementation thread-name (thread)
459 (mp:process-name thread))
460
461 (defimplementation thread-status (thread)
462 (if (mp:process-active-p thread)
463 "RUNNING"
464 "STOPPED"))
465
466 (defimplementation make-lock (&key name)
467 (mp:make-lock :name name))
468
469 (defimplementation call-with-lock-held (lock function)
470 (declare (type function function))
471 (mp:with-lock (lock) (funcall function)))
472
473 (defimplementation make-recursive-lock (&key name)
474 (mp:make-lock :name name))
475
476 (defimplementation call-with-recursive-lock-held (lock function)
477 (declare (type function function))
478 (mp:with-lock (lock) (funcall function)))
479
480 (defimplementation current-thread ()
481 mp:*current-process*)
482
483 (defimplementation all-threads ()
484 (mp:all-processes))
485
486 (defimplementation interrupt-thread (thread fn)
487 (mp:interrupt-process thread fn))
488
489 (defimplementation kill-thread (thread)
490 (mp:process-kill thread))
491
492 (defimplementation thread-alive-p (thread)
493 (mp:process-active-p thread))
494
495 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
496
497 (defstruct (mailbox (:conc-name mailbox.))
498 (mutex (mp:make-lock :name "process mailbox"))
499 (queue '() :type list))
500
501 (defun mailbox (thread)
502 "Return THREAD's mailbox."
503 (mp:with-lock (*mailbox-lock*)
504 (or (find thread *mailboxes* :key #'mailbox.thread)
505 (let ((mb (make-mailbox :thread thread)))
506 (push mb *mailboxes*)
507 mb))))
508
509 (defimplementation send (thread message)
510 (let* ((mbox (mailbox thread))
511 (mutex (mailbox.mutex mbox)))
512 (mp:interrupt-process
513 thread
514 (lambda ()
515 (mp:with-lock (mutex)
516 (setf (mailbox.queue mbox)
517 (nconc (mailbox.queue mbox) (list message))))))))
518
519 (defimplementation receive ()
520 (block got-mail
521 (let* ((mbox (mailbox mp:*current-process*))
522 (mutex (mailbox.mutex mbox)))
523 (loop
524 (mp:with-lock (mutex)
525 (if (mailbox.queue mbox)
526 (return-from got-mail (pop (mailbox.queue mbox)))))
527 ;interrupt-process will halt this if it takes longer than 1sec
528 (sleep 1)))))
529
530 ;; Auto-flush streams
531 (defvar *auto-flush-interval* 0.15
532 "How often to flush interactive streams. This valu is passed
533 directly to cl:sleep.")
534
535 (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush"))
536
537 (defvar *auto-flush-thread* nil)
538
539 (defvar *auto-flush-streams* '())
540
541 (defimplementation make-stream-interactive (stream)
542 (call-with-recursive-lock-held
543 *auto-flush-lock*
544 (lambda ()
545 (pushnew stream *auto-flush-streams*)
546 (unless *auto-flush-thread*
547 (setq *auto-flush-thread*
548 (spawn #'flush-streams
549 :name "auto-flush-thread"))))))
550
551 (defmethod stream-finish-output ((stream stream))
552 (finish-output stream))
553
554 (defun flush-streams ()
555 (loop
556 (call-with-recursive-lock-held
557 *auto-flush-lock*
558 (lambda ()
559 (setq *auto-flush-streams*
560 (remove-if (lambda (x)
561 (not (and (open-stream-p x)
562 (output-stream-p x))))
563 *auto-flush-streams*))
564 (dolist (i *auto-flush-streams*)
565 (ignore-errors (stream-finish-output i))
566 (ignore-errors (finish-output i)))))
567 (sleep *auto-flush-interval*)))
568
569 )
570

  ViewVC Help
Powered by ViewVC 1.1.5