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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5