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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.37 - (show annotations)
Thu Jan 8 10:33:44 2009 UTC (5 years, 3 months ago) by heller
Branch: MAIN
Changes since 1.36: +3 -3 lines
* swank-backend.lisp (swank-compile-string): Pass the
buffer-file-name to Lisp, not only the directory.
Update callers accordingly
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 :offset *buffer-start-position* 0))
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 (compile-file *compile-filename* :load t))))
147
148 (defimplementation swank-compile-string (string &key buffer position filename
149 policy)
150 (declare (ignore filename policy))
151 (with-compilation-hooks ()
152 (let ((*buffer-name* buffer)
153 (*buffer-start-position* position)
154 (*buffer-string* string))
155 (with-input-from-string (s string)
156 (not (nth-value 2 (compile-from-stream s :load t)))))))
157
158 (defun compile-from-stream (stream &rest args)
159 (let ((file (si::mkstemp "TMP:ECLXXXXXX")))
160 (with-open-file (s file :direction :output :if-exists :overwrite)
161 (do ((line (read-line stream nil) (read-line stream nil)))
162 ((not line))
163 (write-line line s)))
164 (unwind-protect
165 (apply #'compile-file file args)
166 (delete-file file))))
167
168
169 ;;;; Documentation
170
171 (defun grovel-docstring-for-arglist (name type)
172 (flet ((compute-arglist-offset (docstring)
173 (when docstring
174 (let ((pos1 (search "Args: " docstring)))
175 (if pos1
176 (+ pos1 6)
177 (let ((pos2 (search "Syntax: " docstring)))
178 (when pos2
179 (+ pos2 8))))))))
180 (let* ((docstring (si::get-documentation name type))
181 (pos (compute-arglist-offset docstring)))
182 (if pos
183 (multiple-value-bind (arglist errorp)
184 (ignore-errors
185 (values (read-from-string docstring t nil :start pos)))
186 (if errorp :not-available (cdr arglist)))
187 :not-available ))))
188
189 (defimplementation arglist (name)
190 (cond ((special-operator-p name)
191 (grovel-docstring-for-arglist name 'function))
192 ((macro-function name)
193 (grovel-docstring-for-arglist name 'function))
194 ((or (functionp name) (fboundp name))
195 (multiple-value-bind (name fndef)
196 (if (functionp name)
197 (values (function-name name) name)
198 (values name (fdefinition name)))
199 (typecase fndef
200 (generic-function
201 (clos::generic-function-lambda-list fndef))
202 (compiled-function
203 (grovel-docstring-for-arglist name 'function))
204 (function
205 (let ((fle (function-lambda-expression fndef)))
206 (case (car fle)
207 (si:lambda-block (caddr fle))
208 (t :not-available)))))))
209 (t :not-available)))
210
211 (defimplementation function-name (f)
212 (si:compiled-function-name f))
213
214 (defimplementation macroexpand-all (form)
215 ;;; FIXME! This is not the same as a recursive macroexpansion!
216 (macroexpand form))
217
218 (defimplementation describe-symbol-for-emacs (symbol)
219 (let ((result '()))
220 (dolist (type '(:VARIABLE :FUNCTION :CLASS))
221 (let ((doc (describe-definition symbol type)))
222 (when doc
223 (setf result (list* type doc result)))))
224 result))
225
226 (defimplementation describe-definition (name type)
227 (case type
228 (:variable (documentation name 'variable))
229 (:function (documentation name 'function))
230 (:class (documentation name 'class))
231 (t nil)))
232
233 ;;; Debugging
234
235 (eval-when (:compile-toplevel :load-toplevel :execute)
236 (import
237 '(si::*break-env*
238 si::*ihs-top*
239 si::*ihs-current*
240 si::*ihs-base*
241 si::*frs-base*
242 si::*frs-top*
243 si::*tpl-commands*
244 si::*tpl-level*
245 si::frs-top
246 si::ihs-top
247 si::ihs-fun
248 si::ihs-env
249 si::sch-frs-base
250 si::set-break-env
251 si::set-current-ihs
252 si::tpl-commands)))
253
254 (defvar *backtrace* '())
255
256 (defun in-swank-package-p (x)
257 (and
258 (symbolp x)
259 (member (symbol-package x)
260 (list #.(find-package :swank)
261 #.(find-package :swank-backend)
262 #.(ignore-errors (find-package :swank-mop))
263 #.(ignore-errors (find-package :swank-loader))))
264 t))
265
266 (defun is-swank-source-p (name)
267 (setf name (pathname name))
268 (pathname-match-p
269 name
270 (make-pathname :defaults swank-loader::*source-directory*
271 :name (pathname-name name)
272 :type (pathname-type name)
273 :version (pathname-version name))))
274
275 (defun is-ignorable-fun-p (x)
276 (or
277 (in-swank-package-p (frame-name x))
278 (multiple-value-bind (file position)
279 (ignore-errors (si::bc-file (car x)))
280 (declare (ignore position))
281 (if file (is-swank-source-p file)))))
282
283 (defimplementation call-with-debugging-environment (debugger-loop-fn)
284 (declare (type function debugger-loop-fn))
285 (let* ((*tpl-commands* si::tpl-commands)
286 (*ihs-top* (ihs-top 'call-with-debugging-environment))
287 (*ihs-current* *ihs-top*)
288 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
289 (*frs-top* (frs-top))
290 (*read-suppress* nil)
291 (*tpl-level* (1+ *tpl-level*))
292 (*backtrace* (loop for ihs from *ihs-base* below *ihs-top*
293 collect (list (si::ihs-fun ihs)
294 (si::ihs-env ihs)
295 nil))))
296 (loop for f from *frs-base* until *frs-top*
297 do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
298 (when (plusp i)
299 (let* ((x (elt *backtrace* i))
300 (name (si::frs-tag f)))
301 (unless (si::fixnump name)
302 (push name (third x)))))))
303 (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
304 (setf *tmp* *backtrace*)
305 (set-break-env)
306 (set-current-ihs)
307 (let ((*ihs-base* *ihs-top*))
308 (funcall debugger-loop-fn))))
309
310 (defimplementation call-with-debugger-hook (hook fun)
311 (let ((*debugger-hook* hook)
312 (*ihs-base*(si::ihs-top 'call-with-debugger-hook)))
313 (funcall fun)))
314
315 (defimplementation compute-backtrace (start end)
316 (when (numberp end)
317 (setf end (min end (length *backtrace*))))
318 (loop for f in (subseq *backtrace* start end)
319 collect f))
320
321 (defun frame-name (frame)
322 (let ((x (first frame)))
323 (if (symbolp x)
324 x
325 (function-name x))))
326
327 (defun function-position (fun)
328 (multiple-value-bind (file position)
329 (si::bc-file fun)
330 (and file (make-location `(:file ,file) `(:position ,position)))))
331
332 (defun frame-function (frame)
333 (let* ((x (first frame))
334 fun position)
335 (etypecase x
336 (symbol (and (fboundp x)
337 (setf fun (fdefinition x)
338 position (function-position fun))))
339 (function (setf fun x position (function-position x))))
340 (values fun position)))
341
342 (defun frame-decode-env (frame)
343 (let ((functions '())
344 (blocks '())
345 (variables '()))
346 (dolist (record (second frame))
347 (let* ((record0 (car record))
348 (record1 (cdr record)))
349 (cond ((symbolp record0)
350 (setq variables (acons record0 record1 variables)))
351 ((not (si::fixnump record0))
352 (push record1 functions))
353 ((symbolp record1)
354 (push record1 blocks))
355 (t
356 ))))
357 (values functions blocks variables)))
358
359 (defimplementation print-frame (frame stream)
360 (format stream "~A" (first frame)))
361
362 (defimplementation frame-source-location-for-emacs (frame-number)
363 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
364
365 (defimplementation frame-catch-tags (frame-number)
366 (third (elt *backtrace* frame-number)))
367
368 (defimplementation frame-locals (frame-number)
369 (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
370 with i = 0
371 collect (list :name name :id (prog1 i (incf i)) :value value)))
372
373 (defimplementation frame-var-value (frame-number var-id)
374 (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
375 var-id))
376
377 (defimplementation disassemble-frame (frame-number)
378 (let ((fun (frame-fun (elt *backtrace* frame-number))))
379 (disassemble fun)))
380
381 (defimplementation eval-in-frame (form frame-number)
382 (let ((env (second (elt *backtrace* frame-number))))
383 (si:eval-with-env form env)))
384
385 ;;;; Inspector
386
387 (defmethod emacs-inspect ((o t))
388 ; ecl clos support leaves some to be desired
389 (cond
390 ((streamp o)
391 (list*
392 (format nil "~S is an ordinary stream~%" o)
393 (append
394 (list
395 "Open for "
396 (cond
397 ((ignore-errors (interactive-stream-p o)) "Interactive")
398 ((and (input-stream-p o) (output-stream-p o)) "Input and output")
399 ((input-stream-p o) "Input")
400 ((output-stream-p o) "Output"))
401 `(:newline) `(:newline))
402 (label-value-line*
403 ("Element type" (stream-element-type o))
404 ("External format" (stream-external-format o)))
405 (ignore-errors (label-value-line*
406 ("Broadcast streams" (broadcast-stream-streams o))))
407 (ignore-errors (label-value-line*
408 ("Concatenated streams" (concatenated-stream-streams o))))
409 (ignore-errors (label-value-line*
410 ("Echo input stream" (echo-stream-input-stream o))))
411 (ignore-errors (label-value-line*
412 ("Echo output stream" (echo-stream-output-stream o))))
413 (ignore-errors (label-value-line*
414 ("Output String" (get-output-stream-string o))))
415 (ignore-errors (label-value-line*
416 ("Synonym symbol" (synonym-stream-symbol o))))
417 (ignore-errors (label-value-line*
418 ("Input stream" (two-way-stream-input-stream o))))
419 (ignore-errors (label-value-line*
420 ("Output stream" (two-way-stream-output-stream o)))))))
421 (t
422 (let* ((cl (si:instance-class o))
423 (slots (clos:class-slots cl)))
424 (list* (format nil "~S is an instance of class ~A~%"
425 o (clos::class-name cl))
426 (loop for x in slots append
427 (let* ((name (clos:slot-definition-name x))
428 (value (clos::slot-value o name)))
429 (list
430 (format nil "~S: " name)
431 `(:value ,value)
432 `(:newline)))))))))
433
434 ;;;; Definitions
435
436 (defimplementation find-definitions (name)
437 (if (fboundp name)
438 (let ((tmp (find-source-location (symbol-function name))))
439 `(((defun ,name) ,tmp)))))
440
441 (defimplementation find-source-location (obj)
442 (setf *tmp* obj)
443 (or
444 (typecase obj
445 (function
446 (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj))
447 (if (and file pos)
448 (make-location
449 `(:file ,(namestring file))
450 `(:position ,pos)
451 `(:snippet
452 ,(with-open-file (s file)
453 (skip-toplevel-forms pos s)
454 (skip-comments-and-whitespace s)
455 (read-snippet s))))))))
456 `(:error (format nil "Source definition of ~S not found" obj))))
457
458 ;;;; Threads
459
460 #+threads
461 (progn
462 (defvar *thread-id-counter* 0)
463
464 (defvar *thread-id-counter-lock*
465 (mp:make-lock :name "thread id counter lock"))
466
467 (defun next-thread-id ()
468 (mp:with-lock (*thread-id-counter-lock*)
469 (incf *thread-id-counter*)))
470
471 (defparameter *thread-id-map* (make-hash-table))
472 (defparameter *id-thread-map* (make-hash-table))
473
474 (defvar *thread-id-map-lock*
475 (mp:make-lock :name "thread id map lock"))
476
477 ; ecl doesn't have weak pointers
478 (defimplementation spawn (fn &key name)
479 (let ((thread (mp:make-process :name name))
480 (id (next-thread-id)))
481 (mp:process-preset
482 thread
483 #'(lambda ()
484 (unwind-protect
485 (mp:with-lock (*thread-id-map-lock*)
486 (setf (gethash id *thread-id-map*) thread)
487 (setf (gethash thread *id-thread-map*) id))
488 (funcall fn)
489 (mp:with-lock (*thread-id-map-lock*)
490 (remhash thread *id-thread-map*)
491 (remhash id *thread-id-map*)))))
492 (mp:process-enable thread)))
493
494 (defimplementation thread-id (thread)
495 (block thread-id
496 (mp:with-lock (*thread-id-map-lock*)
497 (or (gethash thread *id-thread-map*)
498 (let ((id (next-thread-id)))
499 (setf (gethash id *thread-id-map*) thread)
500 (setf (gethash thread *id-thread-map*) id)
501 id)))))
502
503 (defimplementation find-thread (id)
504 (mp:with-lock (*thread-id-map-lock*)
505 (gethash id *thread-id-map*)))
506
507 (defimplementation thread-name (thread)
508 (mp:process-name thread))
509
510 (defimplementation thread-status (thread)
511 (if (mp:process-active-p thread)
512 "RUNNING"
513 "STOPPED"))
514
515 (defimplementation make-lock (&key name)
516 (mp:make-lock :name name))
517
518 (defimplementation call-with-lock-held (lock function)
519 (declare (type function function))
520 (mp:with-lock (lock) (funcall function)))
521
522 (defimplementation current-thread ()
523 mp:*current-process*)
524
525 (defimplementation all-threads ()
526 (mp:all-processes))
527
528 (defimplementation interrupt-thread (thread fn)
529 (mp:interrupt-process thread fn))
530
531 (defimplementation kill-thread (thread)
532 (mp:process-kill thread))
533
534 (defimplementation thread-alive-p (thread)
535 (mp:process-active-p thread))
536
537 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
538
539 (defstruct (mailbox (:conc-name mailbox.))
540 (mutex (mp:make-lock :name "process mailbox"))
541 (queue '() :type list))
542
543 (defun mailbox (thread)
544 "Return THREAD's mailbox."
545 (mp:with-lock (*mailbox-lock*)
546 (or (find thread *mailboxes* :key #'mailbox.thread)
547 (let ((mb (make-mailbox :thread thread)))
548 (push mb *mailboxes*)
549 mb))))
550
551 (defimplementation send (thread message)
552 (let* ((mbox (mailbox thread))
553 (mutex (mailbox.mutex mbox)))
554 (mp:interrupt-process
555 thread
556 (lambda ()
557 (mp:with-lock (mutex)
558 (setf (mailbox.queue mbox)
559 (nconc (mailbox.queue mbox) (list message))))))))
560
561 (defimplementation receive ()
562 (block got-mail
563 (let* ((mbox (mailbox mp:*current-process*))
564 (mutex (mailbox.mutex mbox)))
565 (loop
566 (mp:with-lock (mutex)
567 (if (mailbox.queue mbox)
568 (return-from got-mail (pop (mailbox.queue mbox)))))
569 ;interrupt-process will halt this if it takes longer than 1sec
570 (sleep 1)))))
571
572 (defmethod stream-finish-output ((stream stream))
573 (finish-output stream))
574
575 )
576

  ViewVC Help
Powered by ViewVC 1.1.5