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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5