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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29 - (show annotations)
Wed Aug 27 17:53:16 2008 UTC (5 years, 7 months ago) by heller
Branch: MAIN
Changes since 1.28: +2 -2 lines
* swank-ecl.lisp: Add :load-toplevel and :execute to EVAL-WHENs to
fix loading.
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 :position *buffer-start-position*))
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 (subseq *backtrace* start end))
307
308 (defun frame-name (frame)
309 (let ((x (first frame)))
310 (if (symbolp x)
311 x
312 (function-name x))))
313
314 (defun function-position (fun)
315 (multiple-value-bind (file position)
316 (si::bc-file fun)
317 (and file (make-location `(:file ,file) `(:position ,position)))))
318
319 (defun frame-function (frame)
320 (let* ((x (first frame))
321 fun position)
322 (etypecase x
323 (symbol (and (fboundp x)
324 (setf fun (fdefinition x)
325 position (function-position fun))))
326 (function (setf fun x position (function-position x))))
327 (values fun position)))
328
329 (defun frame-decode-env (frame)
330 (let ((functions '())
331 (blocks '())
332 (variables '()))
333 (dolist (record (second frame))
334 (let* ((record0 (car record))
335 (record1 (cdr record)))
336 (cond ((symbolp record0)
337 (setq variables (acons record0 record1 variables)))
338 ((not (si::fixnump record0))
339 (push record1 functions))
340 ((symbolp record1)
341 (push record1 blocks))
342 (t
343 ))))
344 (values functions blocks variables)))
345
346 (defimplementation print-frame (frame stream)
347 (format stream "~A" (first frame)))
348
349 (defimplementation frame-source-location-for-emacs (frame-number)
350 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
351
352 (defimplementation frame-catch-tags (frame-number)
353 (third (elt *backtrace* frame-number)))
354
355 (defimplementation frame-locals (frame-number)
356 (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
357 with i = 0
358 collect (list :name name :id (prog1 i (incf i)) :value value)))
359
360 (defimplementation frame-var-value (frame-number var-id)
361 (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
362 var-id))
363
364 (defimplementation disassemble-frame (frame-number)
365 (let ((fun (frame-fun (elt *backtrace* frame-number))))
366 (disassemble fun)))
367
368 (defimplementation eval-in-frame (form frame-number)
369 (let ((env (second (elt *backtrace* frame-number))))
370 (si:eval-with-env form env)))
371
372 ;;;; Inspector
373
374 (defmethod emacs-inspect ((o t))
375 ; ecl clos support leaves some to be desired
376 (cond
377 ((streamp o)
378 (list*
379 (format nil "~S is an ordinary stream~%" o)
380 (append
381 (list
382 "Open for "
383 (cond
384 ((ignore-errors (interactive-stream-p o)) "Interactive")
385 ((and (input-stream-p o) (output-stream-p o)) "Input and output")
386 ((input-stream-p o) "Input")
387 ((output-stream-p o) "Output"))
388 `(:newline) `(:newline))
389 (label-value-line*
390 ("Element type" (stream-element-type o))
391 ("External format" (stream-external-format o)))
392 (ignore-errors (label-value-line*
393 ("Broadcast streams" (broadcast-stream-streams o))))
394 (ignore-errors (label-value-line*
395 ("Concatenated streams" (concatenated-stream-streams o))))
396 (ignore-errors (label-value-line*
397 ("Echo input stream" (echo-stream-input-stream o))))
398 (ignore-errors (label-value-line*
399 ("Echo output stream" (echo-stream-output-stream o))))
400 (ignore-errors (label-value-line*
401 ("Output String" (get-output-stream-string o))))
402 (ignore-errors (label-value-line*
403 ("Synonym symbol" (synonym-stream-symbol o))))
404 (ignore-errors (label-value-line*
405 ("Input stream" (two-way-stream-input-stream o))))
406 (ignore-errors (label-value-line*
407 ("Output stream" (two-way-stream-output-stream o)))))))
408 (t
409 (let* ((cl (si:instance-class o))
410 (slots (clos:class-slots cl)))
411 (list* (format nil "~S is an instance of class ~A~%"
412 o (clos::class-name cl))
413 (loop for x in slots append
414 (let* ((name (clos:slot-definition-name x))
415 (value (clos::slot-value o name)))
416 (list
417 (format nil "~S: " name)
418 `(:value ,value)
419 `(:newline)))))))))
420
421 ;;;; Definitions
422
423 (defimplementation find-definitions (name)
424 (if (fboundp name)
425 (let ((tmp (find-source-location (symbol-function name))))
426 `(((defun ,name) ,tmp)))))
427
428 (defimplementation find-source-location (obj)
429 (setf *tmp* obj)
430 (or
431 (typecase obj
432 (function
433 (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj))
434 (if (and file pos)
435 (make-location
436 `(:file ,(namestring file))
437 `(:position ,pos)
438 `(:snippet
439 ,(with-open-file (s file)
440 (skip-toplevel-forms pos s)
441 (skip-comments-and-whitespace s)
442 (read-snippet s))))))))
443 `(:error (format nil "Source definition of ~S not found" obj))))
444
445 ;;;; Threads
446
447 #+threads
448 (progn
449 (defvar *thread-id-counter* 0)
450
451 (defvar *thread-id-counter-lock*
452 (mp:make-lock :name "thread id counter lock"))
453
454 (defun next-thread-id ()
455 (mp:with-lock (*thread-id-counter-lock*)
456 (incf *thread-id-counter*)))
457
458 (defparameter *thread-id-map* (make-hash-table))
459 (defparameter *id-thread-map* (make-hash-table))
460
461 (defvar *thread-id-map-lock*
462 (mp:make-lock :name "thread id map lock"))
463
464 ; ecl doesn't have weak pointers
465 (defimplementation spawn (fn &key name)
466 (let ((thread (mp:make-process :name name))
467 (id (next-thread-id)))
468 (mp:process-preset
469 thread
470 #'(lambda ()
471 (unwind-protect
472 (mp:with-lock (*thread-id-map-lock*)
473 (setf (gethash id *thread-id-map*) thread)
474 (setf (gethash thread *id-thread-map*) id))
475 (funcall fn)
476 (mp:with-lock (*thread-id-map-lock*)
477 (remhash thread *id-thread-map*)
478 (remhash id *thread-id-map*)))))
479 (mp:process-enable thread)))
480
481 (defimplementation thread-id (thread)
482 (block thread-id
483 (mp:with-lock (*thread-id-map-lock*)
484 (or (gethash thread *id-thread-map*)
485 (let ((id (next-thread-id)))
486 (setf (gethash id *thread-id-map*) thread)
487 (setf (gethash thread *id-thread-map*) id)
488 id)))))
489
490 (defimplementation find-thread (id)
491 (mp:with-lock (*thread-id-map-lock*)
492 (gethash id *thread-id-map*)))
493
494 (defimplementation thread-name (thread)
495 (mp:process-name thread))
496
497 (defimplementation thread-status (thread)
498 (if (mp:process-active-p thread)
499 "RUNNING"
500 "STOPPED"))
501
502 (defimplementation make-lock (&key name)
503 (mp:make-lock :name name))
504
505 (defimplementation call-with-lock-held (lock function)
506 (declare (type function function))
507 (mp:with-lock (lock) (funcall function)))
508
509 (defimplementation current-thread ()
510 mp:*current-process*)
511
512 (defimplementation all-threads ()
513 (mp:all-processes))
514
515 (defimplementation interrupt-thread (thread fn)
516 (mp:interrupt-process thread fn))
517
518 (defimplementation kill-thread (thread)
519 (mp:process-kill thread))
520
521 (defimplementation thread-alive-p (thread)
522 (mp:process-active-p thread))
523
524 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
525
526 (defstruct (mailbox (:conc-name mailbox.))
527 (mutex (mp:make-lock :name "process mailbox"))
528 (queue '() :type list))
529
530 (defun mailbox (thread)
531 "Return THREAD's mailbox."
532 (mp:with-lock (*mailbox-lock*)
533 (or (find thread *mailboxes* :key #'mailbox.thread)
534 (let ((mb (make-mailbox :thread thread)))
535 (push mb *mailboxes*)
536 mb))))
537
538 (defimplementation send (thread message)
539 (let* ((mbox (mailbox thread))
540 (mutex (mailbox.mutex mbox)))
541 (mp:interrupt-process
542 thread
543 (lambda ()
544 (mp:with-lock (mutex)
545 (setf (mailbox.queue mbox)
546 (nconc (mailbox.queue mbox) (list message))))))))
547
548 (defimplementation receive ()
549 (block got-mail
550 (let* ((mbox (mailbox mp:*current-process*))
551 (mutex (mailbox.mutex mbox)))
552 (loop
553 (mp:with-lock (mutex)
554 (if (mailbox.queue mbox)
555 (return-from got-mail (pop (mailbox.queue mbox)))))
556 ;interrupt-process will halt this if it takes longer than 1sec
557 (sleep 1)))))
558
559 (defmethod stream-finish-output ((stream stream))
560 (finish-output stream))
561
562 )
563

  ViewVC Help
Powered by ViewVC 1.1.5