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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5