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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.45 - (show annotations)
Mon Jul 27 04:08:41 2009 UTC (4 years, 8 months ago) by gcarncross
Branch: MAIN
Changes since 1.44: +12 -0 lines
2009-07-27  Geo Carncross  <geocar@gmail.com>

	* swank-ecl.lisp: Support for older ECL installs
	from patch by Mark Evenson
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 #+#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
299 (defmacro find-ihs-top (x)
300 (if (< ext:+ecl-version-number+ 90601)
301 `(si::ihs-top ,x)
302 '(si::ihs-top)))
303
304 #-#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
305 (defmacro find-ihs-top (x)
306 `(si::ihs-top ,x))
307
308 (defimplementation call-with-debugging-environment (debugger-loop-fn)
309 (declare (type function debugger-loop-fn))
310 (let* ((*tpl-commands* si::tpl-commands)
311 (*ihs-top* (find-ihs-top 'call-with-debugging-environment))
312 (*ihs-current* *ihs-top*)
313 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
314 (*frs-top* (frs-top))
315 (*read-suppress* nil)
316 (*tpl-level* (1+ *tpl-level*))
317 (*backtrace* (loop for ihs from 0 below *ihs-top*
318 collect (list (si::ihs-fun ihs)
319 (si::ihs-env ihs)
320 nil))))
321 (declare (special *ihs-current*))
322 (loop for f from *frs-base* until *frs-top*
323 do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
324 (when (plusp i)
325 (let* ((x (elt *backtrace* i))
326 (name (si::frs-tag f)))
327 (unless (si::fixnump name)
328 (push name (third x)))))))
329 (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
330 (setf *tmp* *backtrace*)
331 (set-break-env)
332 (set-current-ihs)
333 (let ((*ihs-base* *ihs-top*))
334 (funcall debugger-loop-fn))))
335
336 (defimplementation call-with-debugger-hook (hook fun)
337 (let ((*debugger-hook* hook)
338 (*ihs-base* (find-ihs-top 'call-with-debugger-hook)))
339 (funcall fun)))
340
341 (defimplementation compute-backtrace (start end)
342 (when (numberp end)
343 (setf end (min end (length *backtrace*))))
344 (loop for f in (subseq *backtrace* start end)
345 collect f))
346
347 (defun frame-name (frame)
348 (let ((x (first frame)))
349 (if (symbolp x)
350 x
351 (function-name x))))
352
353 (defun function-position (fun)
354 (multiple-value-bind (file position)
355 (si::bc-file fun)
356 (and file (make-location `(:file ,file) `(:position ,position)))))
357
358 (defun frame-function (frame)
359 (let* ((x (first frame))
360 fun position)
361 (etypecase x
362 (symbol (and (fboundp x)
363 (setf fun (fdefinition x)
364 position (function-position fun))))
365 (function (setf fun x position (function-position x))))
366 (values fun position)))
367
368 (defun frame-decode-env (frame)
369 (let ((functions '())
370 (blocks '())
371 (variables '()))
372 #+#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
373 #.(if (< ext:+ecl-version-number+ 90601)
374 '(setf frame (second frame))
375 '(setf frame (si::decode-ihs-env (second frame))))
376 #-#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
377 '(setf frame (second frame))
378 (dolist (record frame)
379 (let* ((record0 (car record))
380 (record1 (cdr record)))
381 (cond ((or (symbolp record0) (stringp record0))
382 (setq variables (acons record0 record1 variables)))
383 ((not (si::fixnump record0))
384 (push record1 functions))
385 ((symbolp record1)
386 (push record1 blocks))
387 (t
388 ))))
389 (values functions blocks variables)))
390
391 (defimplementation print-frame (frame stream)
392 (format stream "~A" (first frame)))
393
394 (defimplementation frame-source-location (frame-number)
395 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
396
397 (defimplementation frame-catch-tags (frame-number)
398 (third (elt *backtrace* frame-number)))
399
400 (defimplementation frame-locals (frame-number)
401 (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
402 with i = 0
403 collect (list :name name :id (prog1 i (incf i)) :value value)))
404
405 (defimplementation frame-var-value (frame-number var-id)
406 (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
407 var-id))
408
409 (defimplementation disassemble-frame (frame-number)
410 (let ((fun (frame-fun (elt *backtrace* frame-number))))
411 (disassemble fun)))
412
413 (defimplementation eval-in-frame (form frame-number)
414 (let ((env (second (elt *backtrace* frame-number))))
415 (si:eval-with-env form env)))
416
417 ;;;; Inspector
418
419 (defmethod emacs-inspect ((o t))
420 ; ecl clos support leaves some to be desired
421 (cond
422 ((streamp o)
423 (list*
424 (format nil "~S is an ordinary stream~%" o)
425 (append
426 (list
427 "Open for "
428 (cond
429 ((ignore-errors (interactive-stream-p o)) "Interactive")
430 ((and (input-stream-p o) (output-stream-p o)) "Input and output")
431 ((input-stream-p o) "Input")
432 ((output-stream-p o) "Output"))
433 `(:newline) `(:newline))
434 (label-value-line*
435 ("Element type" (stream-element-type o))
436 ("External format" (stream-external-format o)))
437 (ignore-errors (label-value-line*
438 ("Broadcast streams" (broadcast-stream-streams o))))
439 (ignore-errors (label-value-line*
440 ("Concatenated streams" (concatenated-stream-streams o))))
441 (ignore-errors (label-value-line*
442 ("Echo input stream" (echo-stream-input-stream o))))
443 (ignore-errors (label-value-line*
444 ("Echo output stream" (echo-stream-output-stream o))))
445 (ignore-errors (label-value-line*
446 ("Output String" (get-output-stream-string o))))
447 (ignore-errors (label-value-line*
448 ("Synonym symbol" (synonym-stream-symbol o))))
449 (ignore-errors (label-value-line*
450 ("Input stream" (two-way-stream-input-stream o))))
451 (ignore-errors (label-value-line*
452 ("Output stream" (two-way-stream-output-stream o)))))))
453 (t
454 (let* ((cl (si:instance-class o))
455 (slots (clos:class-slots cl)))
456 (list* (format nil "~S is an instance of class ~A~%"
457 o (clos::class-name cl))
458 (loop for x in slots append
459 (let* ((name (clos:slot-definition-name x))
460 (value (clos::slot-value o name)))
461 (list
462 (format nil "~S: " name)
463 `(:value ,value)
464 `(:newline)))))))))
465
466 ;;;; Definitions
467
468 (defimplementation find-definitions (name)
469 (if (fboundp name)
470 (let ((tmp (find-source-location (symbol-function name))))
471 `(((defun ,name) ,tmp)))))
472
473 (defimplementation find-source-location (obj)
474 (setf *tmp* obj)
475 (or
476 (typecase obj
477 (function
478 (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj))
479 (if (and file pos)
480 (make-location
481 `(:file ,(namestring file))
482 `(:position ,pos)
483 `(:snippet
484 ,(with-open-file (s file)
485
486 #+#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
487 (if (< ext:+ecl-version-number+ 90601)
488 (skip-toplevel-forms pos s)
489 (file-position s pos))
490 #-#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
491 (skip-toplevel-forms pos s)
492 (skip-comments-and-whitespace s)
493 (read-snippet s))))))))
494 `(:error (format nil "Source definition of ~S not found" obj))))
495
496 ;;;; Profiling
497
498 (eval-when (:compile-toplevel :load-toplevel :execute)
499 (require 'profile))
500
501 (defimplementation profile (fname)
502 (when fname (eval `(profile:profile ,fname))))
503
504 (defimplementation unprofile (fname)
505 (when fname (eval `(profile:unprofile ,fname))))
506
507 (defimplementation unprofile-all ()
508 (profile:unprofile-all)
509 "All functions unprofiled.")
510
511 (defimplementation profile-report ()
512 (profile:report))
513
514 (defimplementation profile-reset ()
515 (profile:reset)
516 "Reset profiling counters.")
517
518 (defimplementation profiled-functions ()
519 (profile:profile))
520
521 (defimplementation profile-package (package callers methods)
522 (declare (ignore callers methods))
523 (eval `(profile:profile ,(package-name (find-package package)))))
524
525
526 ;;;; Threads
527
528 #+threads
529 (progn
530 (defvar *thread-id-counter* 0)
531
532 (defvar *thread-id-counter-lock*
533 (mp:make-lock :name "thread id counter lock"))
534
535 (defun next-thread-id ()
536 (mp:with-lock (*thread-id-counter-lock*)
537 (incf *thread-id-counter*)))
538
539 (defparameter *thread-id-map* (make-hash-table))
540 (defparameter *id-thread-map* (make-hash-table))
541
542 (defvar *thread-id-map-lock*
543 (mp:make-lock :name "thread id map lock"))
544
545 ; ecl doesn't have weak pointers
546 (defimplementation spawn (fn &key name)
547 (let ((thread (mp:make-process :name name))
548 (id (next-thread-id)))
549 (mp:process-preset
550 thread
551 #'(lambda ()
552 (unwind-protect
553 (mp:with-lock (*thread-id-map-lock*)
554 (setf (gethash id *thread-id-map*) thread)
555 (setf (gethash thread *id-thread-map*) id))
556 (funcall fn)
557 (mp:with-lock (*thread-id-map-lock*)
558 (remhash thread *id-thread-map*)
559 (remhash id *thread-id-map*)))))
560 (mp:process-enable thread)))
561
562 (defimplementation thread-id (thread)
563 (block thread-id
564 (mp:with-lock (*thread-id-map-lock*)
565 (or (gethash thread *id-thread-map*)
566 (let ((id (next-thread-id)))
567 (setf (gethash id *thread-id-map*) thread)
568 (setf (gethash thread *id-thread-map*) id)
569 id)))))
570
571 (defimplementation find-thread (id)
572 (mp:with-lock (*thread-id-map-lock*)
573 (gethash id *thread-id-map*)))
574
575 (defimplementation thread-name (thread)
576 (mp:process-name thread))
577
578 (defimplementation thread-status (thread)
579 (if (mp:process-active-p thread)
580 "RUNNING"
581 "STOPPED"))
582
583 (defimplementation make-lock (&key name)
584 (mp:make-lock :name name))
585
586 (defimplementation call-with-lock-held (lock function)
587 (declare (type function function))
588 (mp:with-lock (lock) (funcall function)))
589
590 (defimplementation current-thread ()
591 mp:*current-process*)
592
593 (defimplementation all-threads ()
594 (mp:all-processes))
595
596 (defimplementation interrupt-thread (thread fn)
597 (mp:interrupt-process thread fn))
598
599 (defimplementation kill-thread (thread)
600 (mp:process-kill thread))
601
602 (defimplementation thread-alive-p (thread)
603 (mp:process-active-p thread))
604
605 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
606
607 (defstruct (mailbox (:conc-name mailbox.))
608 (mutex (mp:make-lock :name "process mailbox"))
609 (queue '() :type list))
610
611 (defun mailbox (thread)
612 "Return THREAD's mailbox."
613 (mp:with-lock (*mailbox-lock*)
614 (or (find thread *mailboxes* :key #'mailbox.thread)
615 (let ((mb (make-mailbox :thread thread)))
616 (push mb *mailboxes*)
617 mb))))
618
619 (defimplementation send (thread message)
620 (let* ((mbox (mailbox thread))
621 (mutex (mailbox.mutex mbox)))
622 (mp:interrupt-process
623 thread
624 (lambda ()
625 (mp:with-lock (mutex)
626 (setf (mailbox.queue mbox)
627 (nconc (mailbox.queue mbox) (list message))))))))
628
629 (defimplementation receive ()
630 (block got-mail
631 (let* ((mbox (mailbox mp:*current-process*))
632 (mutex (mailbox.mutex mbox)))
633 (loop
634 (mp:with-lock (mutex)
635 (if (mailbox.queue mbox)
636 (return-from got-mail (pop (mailbox.queue mbox)))))
637 ;interrupt-process will halt this if it takes longer than 1sec
638 (sleep 1)))))
639
640 (defmethod stream-finish-output ((stream stream))
641 (finish-output stream))
642
643 )
644

  ViewVC Help
Powered by ViewVC 1.1.5