Skip to content
Newer
Older
100644 656 lines (547 sloc) 21.4 KB
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
1 ;;;; -*- indent-tabs-mode: nil -*-
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
2 ;;;
3 ;;; swank-ecl.lisp --- SLIME backend for ECL.
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
4 ;;;
5 ;;; This code has been placed in the Public Domain. All warranties
6 ;;; are disclaimed.
7 ;;;
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
8
9 ;;; Administrivia
10
11 (in-package :swank-backend)
12
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
13 (declaim (optimize (debug 3)))
14
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
15 (defvar *tmp*)
16
10425c0 * swank-ecl.lisp: Add :load-toplevel and :execute to EVAL-WHENs to
Helmut Eller authored
17 (eval-when (:compile-toplevel :load-toplevel :execute)
fdfd77b @stassats * swank-ecl.lisp (swank-mop:compute-applicable-methods-using-classes):
stassats authored
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))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
32
33
34 ;;;; TCP Server
35
990fcea * contrib/swank-listener-hooks.lisp: Add missing IN-PACKAGE.
Helmut Eller authored
36 (eval-when (:compile-toplevel :load-toplevel :execute)
37 (require 'sockets))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
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
e51892e swank-backend.lisp (definterface): Drop that incredibly unportable
Helmut Eller authored
59 &key external-format
d4ac7e7 * Improve the robustness of connection establishment.
Douglas Crosher authored
60 buffering timeout)
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
61 (declare (ignore buffering timeout external-format))
62 (make-socket-io-stream (accept socket)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
63
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
64 (defun make-socket-io-stream (socket)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
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
d253065 @trittweiler * swank-ecl.lisp (find-external-format): Copied from
trittweiler authored
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
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
89
90 ;;;; Unix signals
91
7be8fd7 Improve interrupt safety for single-threaded lisps.
Helmut Eller authored
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
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
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*)
b88eba2 Adjust positions in files with CRLF-style end-on-line markers.
Helmut Eller authored
141 (list :offset *buffer-start-position* 0))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
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
f761f28 * swank-backend.lisp (swank-compile-file): Take output-file as
Helmut Eller authored
157 (defimplementation swank-compile-file (input-file output-file
158 load-p external-format)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
159 (declare (ignore external-format))
160 (with-compilation-hooks ()
f761f28 * swank-backend.lisp (swank-compile-file): Take output-file as
Helmut Eller authored
161 (let ((*buffer-name* nil)
162 (*compile-filename* input-file))
163 (compile-file input-file :output-file output-file :load t))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
164
4314d2e * swank-backend.lisp (swank-compile-string): Pass the
Helmut Eller authored
165 (defimplementation swank-compile-string (string &key buffer position filename
166 policy)
167 (declare (ignore filename policy))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
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)
601b824 * swank-lispworks.lisp (with-swank-compilation-unit): Return the
Helmut Eller authored
173 (not (nth-value 2 (compile-from-stream s :load t)))))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
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)))
d2ab4d0 @trittweiler * swank-ecl.lisp (compile-from-stream): Fixed typo that prevented
trittweiler authored
179 ((not line))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
180 (write-line line s)))
181 (unwind-protect
182 (apply #'compile-file file args)
183 (delete-file file))))
184
185
186 ;;;; Documentation
187
5e3751b @trittweiler Improve ECL's arglist support somewhat.
trittweiler authored
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)))
329a5f5 2009-01-30 Geo Carncross <geocar@gmail.com>
Geo Carncross authored
203 (if (or errorp (not (listp arglist)))
204 :not-available
d7f9353 @stassats * swank-ecl.lisp (grovel-docstring-for-arglist): ECL's arglists
stassats authored
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)))
5e3751b @trittweiler Improve ECL's arglist support somewhat.
trittweiler authored
210 :not-available ))))
211
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
212 (defimplementation arglist (name)
076253c @stassats * swank-ecl.lisp (function-name): Use clos:generic-function-name
stassats authored
213 (cond ((and (symbolp name) (special-operator-p name))
5e3751b @trittweiler Improve ECL's arglist support somewhat.
trittweiler authored
214 (grovel-docstring-for-arglist name 'function))
076253c @stassats * swank-ecl.lisp (function-name): Use clos:generic-function-name
stassats authored
215 ((and (symbolp name) (macro-function name))
5e3751b @trittweiler Improve ECL's arglist support somewhat.
trittweiler authored
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)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
233
e51892e swank-backend.lisp (definterface): Drop that incredibly unportable
Helmut Eller authored
234 (defimplementation function-name (f)
076253c @stassats * swank-ecl.lisp (function-name): Use clos:generic-function-name
stassats authored
235 (typecase f
236 (generic-function (clos:generic-function-name f))
237 (function (si:compiled-function-name f))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
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
10425c0 * swank-ecl.lisp: Add :load-toplevel and :execute to EVAL-WHENs to
Helmut Eller authored
260 (eval-when (:compile-toplevel :load-toplevel :execute)
990fcea * contrib/swank-listener-hooks.lisp: Add missing IN-PACKAGE.
Helmut Eller authored
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)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
278
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
279 (defvar *backtrace* '())
280
36a6053 Remove frames from the backtrace that are in a swank package as those…
Geo Carncross authored
281 (defun in-swank-package-p (x)
df8f365 Trim swank sources from the ECL backtrace.
Geo Carncross authored
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)))))
36a6053 Remove frames from the backtrace that are in a swank package as those…
Geo Carncross authored
307
5e6f6b1 @stassats * contrib/swank-asdf.lisp (asdf:operation-done-p): ASDF included with…
stassats authored
308 #+#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
309 (defmacro find-ihs-top (x)
310 (if (< ext:+ecl-version-number+ 90601)
311 `(si::ihs-top ,x)
312 '(si::ihs-top)))
313
5e6f6b1 @stassats * contrib/swank-asdf.lisp (asdf:operation-done-p): ASDF included with…
stassats authored
314 #-#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
6521dd9 2009-07-27 Geo Carncross <geocar@gmail.com>
Geo Carncross authored
315 (defmacro find-ihs-top (x)
316 `(si::ihs-top ,x))
317
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
318 (defimplementation call-with-debugging-environment (debugger-loop-fn)
319 (declare (type function debugger-loop-fn))
320 (let* ((*tpl-commands* si::tpl-commands)
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
321 (*ihs-top* (find-ihs-top 'call-with-debugging-environment))
6443eec @trittweiler * swank-ecl.lisp: Forgot to update ECL's backend when introducing
trittweiler authored
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*))
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
327 (*backtrace* (loop for ihs from 0 below *ihs-top*
36a6053 Remove frames from the backtrace that are in a swank package as those…
Geo Carncross authored
328 collect (list (si::ihs-fun ihs)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
329 (si::ihs-env ihs)
330 nil))))
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
331 (declare (special *ihs-current*))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
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)))
ecef253 Bugfix: qualify fixnump
Geo Carncross authored
337 (unless (si::fixnump name)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
338 (push name (third x)))))))
df8f365 Trim swank sources from the ECL backtrace.
Geo Carncross authored
339 (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
6443eec @trittweiler * swank-ecl.lisp: Forgot to update ECL's backend when introducing
trittweiler authored
340 (setf *tmp* *backtrace*)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
341 (set-break-env)
342 (set-current-ihs)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
343 (let ((*ihs-base* *ihs-top*))
344 (funcall debugger-loop-fn))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
345
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
346 (defimplementation call-with-debugger-hook (hook fun)
347 (let ((*debugger-hook* hook)
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
348 (*ihs-base* (find-ihs-top 'call-with-debugger-hook)))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
349 (funcall fun)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
350
351 (defimplementation compute-backtrace (start end)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
352 (when (numberp end)
353 (setf end (min end (length *backtrace*))))
6443eec @trittweiler * swank-ecl.lisp: Forgot to update ECL's backend when introducing
trittweiler authored
354 (loop for f in (subseq *backtrace* start end)
954bd86 * swank-backend.lisp (frame-restartable-p): New function.
Helmut Eller authored
355 collect f))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
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 '()))
5e6f6b1 @stassats * contrib/swank-asdf.lisp (asdf:operation-done-p): ASDF included with…
stassats authored
382 #+#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
383 #.(if (< ext:+ecl-version-number+ 90601)
384 '(setf frame (second frame))
385 '(setf frame (si::decode-ihs-env (second frame))))
5e6f6b1 @stassats * contrib/swank-asdf.lisp (asdf:operation-done-p): ASDF included with…
stassats authored
386 #-#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
6521dd9 2009-07-27 Geo Carncross <geocar@gmail.com>
Geo Carncross authored
387 '(setf frame (second frame))
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
388 (dolist (record frame)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
389 (let* ((record0 (car record))
390 (record1 (cdr record)))
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
391 (cond ((or (symbolp record0) (stringp record0))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
392 (setq variables (acons record0 record1 variables)))
ecef253 Bugfix: qualify fixnump
Geo Carncross authored
393 ((not (si::fixnump record0))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
394 (push record1 functions))
395 ((symbolp record1)
396 (push record1 blocks))
397 (t
398 ))))
399 (values functions blocks variables)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
400
954bd86 * swank-backend.lisp (frame-restartable-p): New function.
Helmut Eller authored
401 (defimplementation print-frame (frame stream)
402 (format stream "~A" (first frame)))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
403
e94c741 * swank-backend.lisp (frame-source-location): Renamed from
Helmut Eller authored
404 (defimplementation frame-source-location (frame-number)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
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)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
426
427 ;;;; Inspector
428
0c75cea Inspector cleanups.
Helmut Eller authored
429 (defmethod emacs-inspect ((o t))
6eb426d Make ELC inspection better; should be able to handle all builtin type…
Geo Carncross authored
430 ; ecl clos support leaves some to be desired
431 (cond
432 ((streamp o)
6a300a7 Drop the first return value of emacs-inspect.
Helmut Eller authored
433 (list*
434 (format nil "~S is an ordinary stream~%" o)
6eb426d Make ELC inspection better; should be able to handle all builtin type…
Geo Carncross authored
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)))
6a300a7 Drop the first return value of emacs-inspect.
Helmut Eller authored
466 (list* (format nil "~S is an instance of class ~A~%"
6eb426d Make ELC inspection better; should be able to handle all builtin type…
Geo Carncross authored
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
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
476 ;;;; Definitions
477
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
478 (defimplementation find-definitions (name)
479 (if (fboundp name)
480 (let ((tmp (find-source-location (symbol-function name))))
481 `(((defun ,name) ,tmp)))))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
482
2791323 Initial support for find-source-location with functions
Geo Carncross authored
483 (defimplementation find-source-location (obj)
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
484 (setf *tmp* obj)
2791323 Initial support for find-source-location with functions
Geo Carncross authored
485 (or
486 (typecase obj
487 (function
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
488 (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj))
2791323 Initial support for find-source-location with functions
Geo Carncross authored
489 (if (and file pos)
e8c6143 fixup flushing and location create
Geo Carncross authored
490 (make-location
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
491 `(:file ,(namestring file))
e8c6143 fixup flushing and location create
Geo Carncross authored
492 `(:position ,pos)
493 `(:snippet
494 ,(with-open-file (s file)
6521dd9 2009-07-27 Geo Carncross <geocar@gmail.com>
Geo Carncross authored
495
5e6f6b1 @stassats * contrib/swank-asdf.lisp (asdf:operation-done-p): ASDF included with…
stassats authored
496 #+#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
497 (if (< ext:+ecl-version-number+ 90601)
498 (skip-toplevel-forms pos s)
499 (file-position s pos))
5e6f6b1 @stassats * contrib/swank-asdf.lisp (asdf:operation-done-p): ASDF included with…
stassats authored
500 #-#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
6521dd9 2009-07-27 Geo Carncross <geocar@gmail.com>
Geo Carncross authored
501 (skip-toplevel-forms pos s)
e8c6143 fixup flushing and location create
Geo Carncross authored
502 (skip-comments-and-whitespace s)
503 (read-snippet s))))))))
e2ca210 @stassats swank-ecl.lisp(find-source-location): Missing comma before error mess…
stassats authored
504 `(:error ,(format nil "Source definition of ~S not found" obj))))
2791323 Initial support for find-source-location with functions
Geo Carncross authored
505
5c31ce6 Profiling support by Marko Kocić
Geo Carncross authored
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
0766662 swank-ecl.lisp: Package profiling support
Geo Carncross authored
531 (defimplementation profile-package (package callers methods)
532 (declare (ignore callers methods))
533 (eval `(profile:profile ,(package-name (find-package package)))))
534
8fd3687 @trittweiler * swank-ecl.lisp: Update threading code. ECL doesn't still work
trittweiler authored
535 ;;;; Communication-Styles
0766662 swank-ecl.lisp: Package profiling support
Geo Carncross authored
536
8fd3687 @trittweiler * swank-ecl.lisp: Update threading code. ECL doesn't still work
trittweiler authored
537 ;;; :SPAWN
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
538
539 #+threads
540 (progn
8fd3687 @trittweiler * swank-ecl.lisp: Update threading code. ECL doesn't still work
trittweiler authored
541
542 ;;; THREAD-PLIST
543 (defvar *thread-plists* (make-hash-table))
544 (defvar *thread-plists-lock*
545 (mp:make-lock :name "thread plists lock"))
546
547 (defun thread-plist (thread)
548 (mp:with-lock (*thread-plists-lock*)
549 ;; FIXME: Do we have to synchronize reads here?
550 (gethash thread *thread-plists*)))
551
552 (defun remove-thread-plist (thread)
553 (mp:with-lock (*thread-plists-lock*)
554 (remhash thread *thread-plists*)))
555
556 (defun put-thread-property (thread property value)
557 (mp:with-lock (*thread-plists-lock*)
558 (setf (getf (gethash thread *thread-plists*) property) value))
559 value)
560
561 ;;; THREAD-ID
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
562 (defvar *thread-id-counter* 0)
563 (defvar *thread-id-counter-lock*
564 (mp:make-lock :name "thread id counter lock"))
565
566 (defun next-thread-id ()
567 (mp:with-lock (*thread-id-counter-lock*)
568 (incf *thread-id-counter*)))
569
570 (defimplementation spawn (fn &key name)
8fd3687 @trittweiler * swank-ecl.lisp: Update threading code. ECL doesn't still work
trittweiler authored
571 (let ((thread (mp:make-process :name name)))
572 (put-thread-property thread 'thread-id (next-thread-id))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
573 (mp:process-preset
8fd3687 @trittweiler * swank-ecl.lisp: Update threading code. ECL doesn't still work
trittweiler authored
574 thread
575 #'(lambda ()
576 ;; ecl doesn't have weak pointers
577 (unwind-protect (funcall fn)
578 (remove-thread-plist thread))))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
579 (mp:process-enable thread)))
580
581 (defimplementation thread-id (thread)
8fd3687 @trittweiler * swank-ecl.lisp: Update threading code. ECL doesn't still work
trittweiler authored
582 (or (getf (thread-plist thread) 'thread-id)
583 (put-thread-property thread 'thread-id (next-thread-id))))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
584
585 (defimplementation find-thread (id)
8fd3687 @trittweiler * swank-ecl.lisp: Update threading code. ECL doesn't still work
trittweiler authored
586 (find id (mp:all-processes)
587 :key #'(lambda (thread)
588 (getf (thread-plist thread) 'thread-id))))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
589
590 (defimplementation thread-name (thread)
591 (mp:process-name thread))
592
593 (defimplementation thread-status (thread)
8fd3687 @trittweiler * swank-ecl.lisp: Update threading code. ECL doesn't still work
trittweiler authored
594 (let ((whostate (process-whostate thread)))
595 (cond (whostate (princ-to-string whostate))
596 ((mp:process-active-p thread) "RUNNING")
597 (t "STOPPED"))))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
598
599 (defimplementation make-lock (&key name)
600 (mp:make-lock :name name))
601
602 (defimplementation call-with-lock-held (lock function)
603 (declare (type function function))
604 (mp:with-lock (lock) (funcall function)))
605
606 (defimplementation current-thread ()
607 mp:*current-process*)
608
609 (defimplementation all-threads ()
610 (mp:all-processes))
611
612 (defimplementation interrupt-thread (thread fn)
613 (mp:interrupt-process thread fn))
614
615 (defimplementation kill-thread (thread)
616 (mp:process-kill thread))
617
618 (defimplementation thread-alive-p (thread)
619 (mp:process-active-p thread))
620
621 (defstruct (mailbox (:conc-name mailbox.))
8fd3687 @trittweiler * swank-ecl.lisp: Update threading code. ECL doesn't still work
trittweiler authored
622 (lock (mp:make-lock :name "mailbox lock"))
623 (cvar (mp:make-condition-variable))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
624 (queue '() :type list))
625
626 (defun mailbox (thread)
627 "Return THREAD's mailbox."
8fd3687 @trittweiler * swank-ecl.lisp: Update threading code. ECL doesn't still work
trittweiler authored
628 (or (getf (thread-plist thread) 'mailbox)
629 (put-thread-property thread 'mailbox (make-mailbox))))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
630
631 (defimplementation send (thread message)
8fd3687 @trittweiler * swank-ecl.lisp: Update threading code. ECL doesn't still work
trittweiler authored
632 (let ((mbox (mailbox thread)))
633 (mp:with-lock ((mailbox.lock mbox))
634 (setf (mailbox.queue mbox)
635 (nconc (mailbox.queue mbox) (list message)))
636 (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
637
638 (defimplementation receive-if (test &optional timeout)
639 (let ((mbox (mailbox mp:*current-process*)))
640 (assert (or (not timeout) (eq timeout t)))
641 (loop
642 (check-slime-interrupts)
643 (mp:with-lock ((mailbox.lock mbox))
644 (let* ((q (mailbox.queue mbox))
645 (tail (member-if test q)))
646 (when tail
647 (setf (mailbox.queue mbox)
648 (nconc (ldiff q tail) (cdr tail)))
649 (return (car tail))))
650 (when (eq timeout t) (return (values nil t)))
651 (mp:condition-variable-timedwait (mailbox.cvar mbox)
652 (mailbox.lock mbox)
653 0.2)))))
654 ) ; #+thread (progn ...
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
655
Something went wrong with that request. Please try again.