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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5