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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5