Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 815 lines (681 sloc) 28.125 kb
5fb5464a » Helmut Eller
2006-11-19 (find-external-format, guess-external-format): New.
1 ;;;; -*- indent-tabs-mode: nil -*-
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
2 ;;;
3 ;;; swank-ecl.lisp --- SLIME backend for ECL.
5fb5464a » Helmut Eller
2006-11-19 (find-external-format, guess-external-format): New.
4 ;;;
5 ;;; This code has been placed in the Public Domain. All warranties
6 ;;; are disclaimed.
7 ;;;
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
8
9 ;;; Administrivia
10
11 (in-package :swank-backend)
12
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
13 (eval-when (:compile-toplevel :load-toplevel :execute)
14 (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT)))
cc446f7f » trittweiler
2010-03-05 * swank-ecl.lisp: Make backend depend on ECL version 10.3.1 which
15 (when (or (not version) (< (symbol-value version) 100301))
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
16 (error "~&IMPORTANT:~% ~
17 The version of ECL you're using (~A) is too old.~% ~
cc446f7f » trittweiler
2010-03-05 * swank-ecl.lisp: Make backend depend on ECL version 10.3.1 which
18 Please upgrade to at least 10.3.1.~% ~
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
19 Sorry for the inconvenience.~%~%"
20 (lisp-implementation-version)))))
21
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
22 ;; Hard dependencies.
23 (eval-when (:compile-toplevel :load-toplevel :execute)
24 (require 'sockets))
25
26 ;; Soft dependencies.
27 (eval-when (:compile-toplevel :load-toplevel :execute)
28 (when (probe-file "sys:profile.fas")
29 (require :profile)
30 (pushnew :profile *features*))
31 (when (probe-file "sys:serve-event.fas")
32 (require :serve-event)
33 (pushnew :serve-event *features*)))
34
670648a5 » Geo Carncross
2009-06-12 Support new environment changes in recent ECL/CVS
35 (declaim (optimize (debug 3)))
36
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
37 ;;; Swank-mop
98a99bda » Geo Carncross
2008-04-24 basic/simple implementation of find-definitions
38
10425c02 » Helmut Eller
2008-08-27 * swank-ecl.lisp: Add :load-toplevel and :execute to EVAL-WHENs to
39 (eval-when (:compile-toplevel :load-toplevel :execute)
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
40 (import-from :gray *gray-stream-symbols* :swank-backend)
fdfd77b0 » stassats
2009-11-13 * swank-ecl.lisp (swank-mop:compute-applicable-methods-using-classes):
41
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
42 (import-swank-mop-symbols :clos
11307945 » Juan Jose Garcia Ripoll
2012-04-20 In swank-ecl.lisp, import compute-applicable-methods-using-classes wh…
43 `(:eql-specializer
fdfd77b0 » stassats
2009-11-13 * swank-ecl.lisp (swank-mop:compute-applicable-methods-using-classes):
44 :eql-specializer-object
45 :generic-function-declarations
46 :specializer-direct-methods
11307945 » Juan Jose Garcia Ripoll
2012-04-20 In swank-ecl.lisp, import compute-applicable-methods-using-classes wh…
47 ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes)
48 '(:compute-applicable-methods-using-classes)))))
fdfd77b0 » stassats
2009-11-13 * swank-ecl.lisp (swank-mop:compute-applicable-methods-using-classes):
49
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
50
51 ;;;; TCP Server
52
8e5db041 » trittweiler
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
53 (defimplementation preferred-communication-style ()
54 ;; While ECL does provide threads, some parts of it are not
55 ;; thread-safe (2010-02-23), including the compiler and CLOS.
56 nil
57 ;; ECL on Windows does not provide condition-variables
58 ;; (or #+(and threads (not windows)) :spawn
59 ;; nil)
60 )
61
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
62 (defun resolve-hostname (name)
63 (car (sb-bsd-sockets:host-ent-addresses
64 (sb-bsd-sockets:get-host-by-name name))))
65
1a8faa2f » Helmut Eller
2011-11-27 * swank.lisp (create-server): Add a :backlog argument.
66 (defimplementation create-socket (host port &key backlog)
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
67 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
68 :type :stream
69 :protocol :tcp)))
70 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
71 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
1a8faa2f » Helmut Eller
2011-11-27 * swank.lisp (create-server): Add a :backlog argument.
72 (sb-bsd-sockets:socket-listen socket (or backlog 5))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
73 socket))
74
75 (defimplementation local-port (socket)
76 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
77
78 (defimplementation close-socket (socket)
79 (sb-bsd-sockets:socket-close socket))
80
81 (defimplementation accept-connection (socket
e51892e9 » Helmut Eller
2006-08-10 swank-backend.lisp (definterface): Drop that incredibly unportable
82 &key external-format
d4ac7e72 » Douglas Crosher
2006-03-22 * Improve the robustness of connection establishment.
83 buffering timeout)
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
84 (declare (ignore timeout))
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
85 (sb-bsd-sockets:socket-make-stream (accept socket)
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
86 :output t
87 :input t
22c29a94 » Helmut Eller
2011-11-06 * swank-ecl.lisp (accept-connection): Fix buffering arg.
88 :buffering (ecase buffering
89 ((t) :full)
90 ((nil) :none)
91 (:line line))
38309225 » stassats
2012-02-12 * swank-ecl.lisp (accept-connection): Use the proper element-type
92 :element-type (if external-format
93 'character
94 '(unsigned-byte 8))
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
95 :external-format external-format))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
96 (defun accept (socket)
97 "Like socket-accept, but retry on EAGAIN."
98 (loop (handler-case
99 (return (sb-bsd-sockets:socket-accept socket))
100 (sb-bsd-sockets:interrupted-error ()))))
101
8e5db041 » trittweiler
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
102 (defimplementation socket-fd (socket)
103 (etypecase socket
104 (fixnum socket)
105 (two-way-stream (socket-fd (two-way-stream-input-stream socket)))
106 (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
107 (file-stream (si:file-stream-fd socket))))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
108
d2530653 » trittweiler
2009-07-06 * swank-ecl.lisp (find-external-format): Copied from
109 (defvar *external-format-to-coding-system*
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
110 '((:latin-1
d2530653 » trittweiler
2009-07-06 * swank-ecl.lisp (find-external-format): Copied from
111 "latin-1" "latin-1-unix" "iso-latin-1-unix"
112 "iso-8859-1" "iso-8859-1-unix")
113 (:utf-8 "utf-8" "utf-8-unix")))
114
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
115 (defun external-format (coding-system)
116 (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
117 *external-format-to-coding-system*))
118 (find coding-system (ext:all-encodings) :test #'string-equal)))
119
d2530653 » trittweiler
2009-07-06 * swank-ecl.lisp (find-external-format): Copied from
120 (defimplementation find-external-format (coding-system)
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
121 #+unicode (external-format coding-system)
122 ;; Without unicode support, ECL uses the one-byte encoding of the
123 ;; underlying OS, and will barf on anything except :DEFAULT. We
124 ;; return NIL here for known multibyte encodings, so
125 ;; SWANK:CREATE-SERVER will barf.
126 #-unicode (let ((xf (external-format coding-system)))
127 (if (member xf '(:utf-8))
128 nil
129 :default)))
d2530653 » trittweiler
2009-07-06 * swank-ecl.lisp (find-external-format): Copied from
130
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
131
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
132 ;;;; Unix Integration
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
133
bdb66815 » trittweiler
2010-03-10 * swank-ecl.lisp (*original-sigint-handler*)
134 ;;; If ECL is built with thread support, it'll spawn a helper thread
135 ;;; executing the SIGINT handler. We do not want to BREAK into that
136 ;;; helper but into the main thread, though. This is coupled with the
137 ;;; current choice of NIL as communication-style in so far as ECL's
138 ;;; main-thread is also the Slime's REPL thread.
139
140 (defimplementation call-with-user-break-handler (real-handler function)
141 (let ((old-handler #'si:terminal-interrupt))
7be8fd7b » Helmut Eller
2008-08-11 Improve interrupt safety for single-threaded lisps.
142 (setf (symbol-function 'si:terminal-interrupt)
bdb66815 » trittweiler
2010-03-10 * swank-ecl.lisp (*original-sigint-handler*)
143 (make-interrupt-handler real-handler))
144 (unwind-protect (funcall function)
145 (setf (symbol-function 'si:terminal-interrupt) old-handler))))
146
147 #+threads
148 (defun make-interrupt-handler (real-handler)
149 (let ((main-thread (find 'si:top-level (mp:all-processes)
150 :key #'mp:process-name)))
151 #'(lambda (&rest args)
152 (declare (ignore args))
153 (mp:interrupt-process main-thread real-handler))))
154
155 #-threads
156 (defun make-interrupt-handler (real-handler)
157 #'(lambda (&rest args)
158 (declare (ignore args))
159 (funcall real-handler)))
160
7be8fd7b » Helmut Eller
2008-08-11 Improve interrupt safety for single-threaded lisps.
161
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
162 (defimplementation getpid ()
163 (si:getpid))
164
165 (defimplementation set-default-directory (directory)
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
166 (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
167 (default-directory))
168
169 (defimplementation default-directory ()
170 (namestring (ext:getcwd)))
171
172 (defimplementation quit-lisp ()
173 (ext:quit))
174
175
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
176
8e5db041 » trittweiler
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
177 ;;; Instead of busy waiting with communication-style NIL, use select()
178 ;;; on the sockets' streams.
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
179 #+serve-event
180 (progn
8e5db041 » trittweiler
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
181 (defun poll-streams (streams timeout)
182 (let* ((serve-event::*descriptor-handlers*
183 (copy-list serve-event::*descriptor-handlers*))
184 (active-fds '())
185 (fd-stream-alist
186 (loop for s in streams
187 for fd = (socket-fd s)
2f7a771a » trittweiler
2010-03-16 * swank-ecl.lisp (source-location): Also return EXT::FOO as
188 collect (cons fd s)
8e5db041 » trittweiler
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
189 do (serve-event:add-fd-handler fd :input
190 #'(lambda (fd)
191 (push fd active-fds))))))
192 (serve-event:serve-event timeout)
193 (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist)))))
194
195 (defimplementation wait-for-input (streams &optional timeout)
196 (assert (member timeout '(nil t)))
197 (loop
198 (cond ((check-slime-interrupts) (return :interrupt))
199 (timeout (return (poll-streams streams 0)))
200 (t
4e64b26a » trittweiler
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
201 (when-let (ready (poll-streams streams 0.2))
202 (return ready))))))
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
203
204 ) ; #+serve-event (progn ...
2bd7a41d » Helmut Eller
2012-06-19 * swank-ecl.lisp (wait-for-input): Provide implementation
205
206 #-serve-event
207 (defimplementation wait-for-input (streams &optional timeout)
208 (assert (member timeout '(nil t)))
209 (loop
210 (cond ((check-slime-interrupts) (return :interrupt))
211 (timeout (return (remove-if-not #'listen streams)))
212 (t
213 (let ((ready (remove-if-not #'listen streams)))
214 (if ready (return ready))
215 (sleep 0.1))))))
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
216
217
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
218 ;;;; Compilation
219
220 (defvar *buffer-name* nil)
221 (defvar *buffer-start-position*)
222
223 (defun signal-compiler-condition (&rest args)
c6b4fd56 » stassats
2012-08-04 * clean up: (signal (make-condition ...)) => (signal ...)
224 (apply #'signal 'compiler-condition args))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
225
9039150b » Juan Jose Garcia Ripoll
2011-06-05 Some changes to the ECL backend so that it works with the new bytecod…
226 #-ecl-bytecmp
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
227 (defun handle-compiler-message (condition)
228 ;; ECL emits lots of noise in compiler-notes, like "Invoking
229 ;; external command".
230 (unless (typep condition 'c::compiler-note)
231 (signal-compiler-condition
232 :original-condition condition
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
233 :message (princ-to-string condition)
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
234 :severity (etypecase condition
235 (c:compiler-fatal-error :error)
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
236 (c:compiler-error :error)
237 (error :error)
238 (style-warning :style-warning)
239 (warning :warning))
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
240 :location (condition-location condition))))
241
9039150b » Juan Jose Garcia Ripoll
2011-06-05 Some changes to the ECL backend so that it works with the new bytecod…
242 #-ecl-bytecmp
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
243 (defun condition-location (condition)
244 (let ((file (c:compiler-message-file condition))
245 (position (c:compiler-message-file-position condition)))
246 (if (and position (not (minusp position)))
247 (if *buffer-name*
8e5db041 » trittweiler
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
248 (make-buffer-location *buffer-name*
249 *buffer-start-position*
250 position)
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
251 (make-file-location file position))
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
252 (make-error-location "No location found."))))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
253
254 (defimplementation call-with-compilation-hooks (function)
9039150b » Juan Jose Garcia Ripoll
2011-06-05 Some changes to the ECL backend so that it works with the new bytecod…
255 #-ecl-bytecmp
256 (funcall function)
257 #-ecl-bytecmp
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
258 (handler-bind ((c:compiler-message #'handle-compiler-message))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
259 (funcall function)))
260
f761f28f » Helmut Eller
2009-01-10 * swank-backend.lisp (swank-compile-file): Take output-file as
261 (defimplementation swank-compile-file (input-file output-file
20bed409 » stassats
2010-03-02 * slime.el (slime-compile-and-load-file): Accept C-u arguments for
262 load-p external-format
263 &key policy)
264 (declare (ignore policy))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
265 (with-compilation-hooks ()
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
266 (compile-file input-file :output-file output-file
267 :load load-p
268 :external-format external-format)))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
269
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
270 (defvar *tmpfile-map* (make-hash-table :test #'equal))
271
272 (defun note-buffer-tmpfile (tmp-file buffer-name)
273 ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring.
274 (let ((tmp-namestring (namestring (truename tmp-file))))
bcf2fbb8 » trittweiler
2010-03-11 * swank-ecl.lisp (source-location): Move call to
275 (setf (gethash tmp-namestring *tmpfile-map*) buffer-name)
276 tmp-namestring))
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
277
278 (defun tmpfile-to-buffer (tmp-file)
279 (gethash tmp-file *tmpfile-map*))
280
4314d2ea » Helmut Eller
2009-01-08 * swank-backend.lisp (swank-compile-string): Pass the
281 (defimplementation swank-compile-string (string &key buffer position filename
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
282 policy)
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
283 (declare (ignore policy))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
284 (with-compilation-hooks ()
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
285 (let ((*buffer-name* buffer) ; for compilation hooks
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
286 (*buffer-start-position* position))
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
287 (let ((tmp-file (si:mkstemp "TMP:ecl-swank-tmpfile-"))
3d76a5c0 » trittweiler
2010-02-22 Make M-. be able to jump right into the C source for ECL.
288 (fasl-file)
289 (warnings-p)
290 (failure-p))
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
291 (unwind-protect
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
292 (with-open-file (tmp-stream tmp-file :direction :output
293 :if-exists :supersede)
294 (write-string string tmp-stream)
295 (finish-output tmp-stream)
3d76a5c0 » trittweiler
2010-02-22 Make M-. be able to jump right into the C source for ECL.
296 (multiple-value-setq (fasl-file warnings-p failure-p)
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
297 (compile-file tmp-file
298 :load t
299 :source-truename (or filename
300 (note-buffer-tmpfile tmp-file buffer))
301 :source-offset (1- position))))
302 (when (probe-file tmp-file)
303 (delete-file tmp-file))
3d76a5c0 » trittweiler
2010-02-22 Make M-. be able to jump right into the C source for ECL.
304 (when fasl-file
305 (delete-file fasl-file)))
306 (not failure-p)))))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
307
308 ;;;; Documentation
309
310 (defimplementation arglist (name)
8e5db041 » trittweiler
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
311 (multiple-value-bind (arglist foundp)
4e64b26a » trittweiler
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
312 (ext:function-lambda-list name)
8e5db041 » trittweiler
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
313 (if foundp arglist :not-available)))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
314
e51892e9 » Helmut Eller
2006-08-10 swank-backend.lisp (definterface): Drop that incredibly unportable
315 (defimplementation function-name (f)
076253cd » stassats
2009-11-13 * swank-ecl.lisp (function-name): Use clos:generic-function-name
316 (typecase f
317 (generic-function (clos:generic-function-name f))
318 (function (si:compiled-function-name f))))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
319
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
320 ;; FIXME
321 ;; (defimplementation macroexpand-all (form))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
322
323 (defimplementation describe-symbol-for-emacs (symbol)
324 (let ((result '()))
325 (dolist (type '(:VARIABLE :FUNCTION :CLASS))
4e64b26a » trittweiler
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
326 (when-let (doc (describe-definition symbol type))
327 (setf result (list* type doc result))))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
328 result))
329
330 (defimplementation describe-definition (name type)
331 (case type
332 (:variable (documentation name 'variable))
333 (:function (documentation name 'function))
334 (:class (documentation name 'class))
335 (t nil)))
336
8e5db041 » trittweiler
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
337
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
338 ;;; Debugging
339
10425c02 » Helmut Eller
2008-08-27 * swank-ecl.lisp: Add :load-toplevel and :execute to EVAL-WHENs to
340 (eval-when (:compile-toplevel :load-toplevel :execute)
990fceaf » Helmut Eller
2008-08-22 * contrib/swank-listener-hooks.lisp: Add missing IN-PACKAGE.
341 (import
342 '(si::*break-env*
343 si::*ihs-top*
344 si::*ihs-current*
345 si::*ihs-base*
346 si::*frs-base*
347 si::*frs-top*
348 si::*tpl-commands*
349 si::*tpl-level*
350 si::frs-top
351 si::ihs-top
352 si::ihs-fun
353 si::ihs-env
354 si::sch-frs-base
355 si::set-break-env
356 si::set-current-ihs
357 si::tpl-commands)))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
358
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
359 (defun make-invoke-debugger-hook (hook)
360 (when hook
361 #'(lambda (condition old-hook)
362 ;; Regard *debugger-hook* if set by user.
363 (if *debugger-hook*
364 nil ; decline, *DEBUGGER-HOOK* will be tried next.
365 (funcall hook condition old-hook)))))
366
367 (defimplementation install-debugger-globally (function)
368 (setq *debugger-hook* function)
369 (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
370
371 (defimplementation call-with-debugger-hook (hook fun)
372 (let ((*debugger-hook* hook)
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
373 (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
374 (funcall fun)))
375
a8e47da3 » Geo Carncross
2008-04-30 Backtrace and frame/eval improvements
376 (defvar *backtrace* '())
377
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
378 ;;; Commented out; it's not clear this is a good way of doing it. In
379 ;;; particular because it makes errors stemming from this file harder
380 ;;; to debug, and given the "young" age of ECL's swank backend, that's
381 ;;; a bad idea.
382
383 ;; (defun in-swank-package-p (x)
384 ;; (and
385 ;; (symbolp x)
386 ;; (member (symbol-package x)
387 ;; (list #.(find-package :swank)
388 ;; #.(find-package :swank-backend)
389 ;; #.(ignore-errors (find-package :swank-mop))
390 ;; #.(ignore-errors (find-package :swank-loader))))
391 ;; t))
392
393 ;; (defun is-swank-source-p (name)
394 ;; (setf name (pathname name))
395 ;; (pathname-match-p
396 ;; name
397 ;; (make-pathname :defaults swank-loader::*source-directory*
398 ;; :name (pathname-name name)
399 ;; :type (pathname-type name)
400 ;; :version (pathname-version name))))
401
402 ;; (defun is-ignorable-fun-p (x)
403 ;; (or
404 ;; (in-swank-package-p (frame-name x))
405 ;; (multiple-value-bind (file position)
406 ;; (ignore-errors (si::bc-file (car x)))
407 ;; (declare (ignore position))
408 ;; (if file (is-swank-source-p file)))))
36a60531 » Geo Carncross
2008-05-01 Remove frames from the backtrace that are in a swank package as those…
409
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
410 (defimplementation call-with-debugging-environment (debugger-loop-fn)
411 (declare (type function debugger-loop-fn))
4e64b26a » trittweiler
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
412 (let* ((*ihs-top* (ihs-top))
6443eec2 » trittweiler
2008-09-18 * swank-ecl.lisp: Forgot to update ECL's backend when introducing
413 (*ihs-current* *ihs-top*)
414 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
415 (*frs-top* (frs-top))
416 (*tpl-level* (1+ *tpl-level*))
670648a5 » Geo Carncross
2009-06-12 Support new environment changes in recent ECL/CVS
417 (*backtrace* (loop for ihs from 0 below *ihs-top*
36a60531 » Geo Carncross
2008-05-01 Remove frames from the backtrace that are in a swank package as those…
418 collect (list (si::ihs-fun ihs)
a8e47da3 » Geo Carncross
2008-04-30 Backtrace and frame/eval improvements
419 (si::ihs-env ihs)
420 nil))))
670648a5 » Geo Carncross
2009-06-12 Support new environment changes in recent ECL/CVS
421 (declare (special *ihs-current*))
a8e47da3 » Geo Carncross
2008-04-30 Backtrace and frame/eval improvements
422 (loop for f from *frs-base* until *frs-top*
423 do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
424 (when (plusp i)
425 (let* ((x (elt *backtrace* i))
426 (name (si::frs-tag f)))
ecef2536 » Geo Carncross
2008-05-08 Bugfix: qualify fixnump
427 (unless (si::fixnump name)
a8e47da3 » Geo Carncross
2008-04-30 Backtrace and frame/eval improvements
428 (push name (third x)))))))
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
429 (setf *backtrace* (nreverse *backtrace*))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
430 (set-break-env)
431 (set-current-ihs)
a8e47da3 » Geo Carncross
2008-04-30 Backtrace and frame/eval improvements
432 (let ((*ihs-base* *ihs-top*))
433 (funcall debugger-loop-fn))))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
434
435 (defimplementation compute-backtrace (start end)
a8e47da3 » Geo Carncross
2008-04-30 Backtrace and frame/eval improvements
436 (when (numberp end)
437 (setf end (min end (length *backtrace*))))
6443eec2 » trittweiler
2008-09-18 * swank-ecl.lisp: Forgot to update ECL's backend when introducing
438 (loop for f in (subseq *backtrace* start end)
954bd865 » Helmut Eller
2008-10-17 * swank-backend.lisp (frame-restartable-p): New function.
439 collect f))
a8e47da3 » Geo Carncross
2008-04-30 Backtrace and frame/eval improvements
440
441 (defun frame-name (frame)
442 (let ((x (first frame)))
443 (if (symbolp x)
444 x
445 (function-name x))))
446
447 (defun function-position (fun)
448 (multiple-value-bind (file position)
449 (si::bc-file fun)
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
450 (when file
451 (make-file-location file position))))
a8e47da3 » Geo Carncross
2008-04-30 Backtrace and frame/eval improvements
452
453 (defun frame-function (frame)
454 (let* ((x (first frame))
455 fun position)
456 (etypecase x
457 (symbol (and (fboundp x)
458 (setf fun (fdefinition x)
459 position (function-position fun))))
460 (function (setf fun x position (function-position x))))
461 (values fun position)))
462
463 (defun frame-decode-env (frame)
464 (let ((functions '())
465 (blocks '())
466 (variables '()))
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
467 (setf frame (si::decode-ihs-env (second frame)))
7fbc81d5 » Juan Jose Garcia Ripoll
2010-09-28 frame-decode-env did not ignore FLET bindings in bytecodes environments.
468 (dolist (record (remove-if-not #'consp frame))
a8e47da3 » Geo Carncross
2008-04-30 Backtrace and frame/eval improvements
469 (let* ((record0 (car record))
470 (record1 (cdr record)))
670648a5 » Geo Carncross
2009-06-12 Support new environment changes in recent ECL/CVS
471 (cond ((or (symbolp record0) (stringp record0))
a8e47da3 » Geo Carncross
2008-04-30 Backtrace and frame/eval improvements
472 (setq variables (acons record0 record1 variables)))
ecef2536 » Geo Carncross
2008-05-08 Bugfix: qualify fixnump
473 ((not (si::fixnump record0))
a8e47da3 » Geo Carncross
2008-04-30 Backtrace and frame/eval improvements
474 (push record1 functions))
475 ((symbolp record1)
476 (push record1 blocks))
477 (t
478 ))))
479 (values functions blocks variables)))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
480
954bd865 » Helmut Eller
2008-10-17 * swank-backend.lisp (frame-restartable-p): New function.
481 (defimplementation print-frame (frame stream)
482 (format stream "~A" (first frame)))
a8e47da3 » Geo Carncross
2008-04-30 Backtrace and frame/eval improvements
483
e94c7410 » Helmut Eller
2009-06-21 * swank-backend.lisp (frame-source-location): Renamed from
484 (defimplementation frame-source-location (frame-number)
a8e47da3 » Geo Carncross
2008-04-30 Backtrace and frame/eval improvements
485 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
486
487 (defimplementation frame-catch-tags (frame-number)
488 (third (elt *backtrace* frame-number)))
489
490 (defimplementation frame-locals (frame-number)
5d608298 » Helmut Eller
2012-04-07 Even more long line breaking.
491 (loop for (name . value) in (nth-value 2 (frame-decode-env
492 (elt *backtrace* frame-number)))
a8e47da3 » Geo Carncross
2008-04-30 Backtrace and frame/eval improvements
493 with i = 0
494 collect (list :name name :id (prog1 i (incf i)) :value value)))
495
496 (defimplementation frame-var-value (frame-number var-id)
497 (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
498 var-id))
499
500 (defimplementation disassemble-frame (frame-number)
8e5db041 » trittweiler
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
501 (let ((fun (frame-function (elt *backtrace* frame-number))))
a8e47da3 » Geo Carncross
2008-04-30 Backtrace and frame/eval improvements
502 (disassemble fun)))
503
504 (defimplementation eval-in-frame (form frame-number)
505 (let ((env (second (elt *backtrace* frame-number))))
506 (si:eval-with-env form env)))
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
507
41bb542a » trittweiler
2010-03-18 Add an ATTACH-GDB restart to SLDB.
508 (defimplementation gdb-initial-commands ()
509 ;; These signals are used by the GC.
510 #+linux '("handle SIGPWR noprint nostop"
511 "handle SIGXCPU noprint nostop"))
512
fbc22f24 » trittweiler
2010-03-19 * slime.el (slime-lisp-implementation-program): New connection
513 (defimplementation command-line-args ()
514 (loop for n from 0 below (si:argc) collect (si:argv n)))
515
8e5db041 » trittweiler
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
516
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
517 ;;;; Inspector
518
8e5db041 » trittweiler
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
519 ;;; FIXME: Would be nice if it was possible to inspect objects
520 ;;; implemented in C.
6eb426db » Geo Carncross
2008-01-19 Make ELC inspection better; should be able to handle all builtin type…
521
8e5db041 » trittweiler
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
522
f33058f1 » Juan Jose Garcia Ripoll
2005-08-03 Initial port to ECL
523 ;;;; Definitions
524
0729feb2 » stassats
2011-01-20 * swank-ecl.lisp (+TAGS+): change
525 (defvar +TAGS+ (namestring
526 (merge-pathnames "TAGS" (translate-logical-pathname "SYS:"))))
32ea92d7 » trittweiler
2010-02-22 Make swank-ecl.lisp work with latest ECL Git HEAD.
527
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
528 (defun make-file-location (file file-position)
529 ;; File positions in CL start at 0, but Emacs' buffer positions
530 ;; start at 1. We specify (:ALIGN T) because the positions comming
531 ;; from ECL point at right after the toplevel form appearing before
532 ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case.
bcf2fbb8 » trittweiler
2010-03-11 * swank-ecl.lisp (source-location): Move call to
533 (make-location `(:file ,(namestring (translate-logical-pathname file)))
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
534 `(:position ,(1+ file-position))
535 `(:align t)))
32ea92d7 » trittweiler
2010-02-22 Make swank-ecl.lisp work with latest ECL Git HEAD.
536
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
537 (defun make-buffer-location (buffer-name start-position &optional (offset 0))
538 (make-location `(:buffer ,buffer-name)
539 `(:offset ,start-position ,offset)
540 `(:align t)))
32ea92d7 » trittweiler
2010-02-22 Make swank-ecl.lisp work with latest ECL Git HEAD.
541
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
542 (defun make-TAGS-location (&rest tags)
543 (make-location `(:etags-file ,+TAGS+)
544 `(:tag ,@tags)))
32ea92d7 » trittweiler
2010-02-22 Make swank-ecl.lisp work with latest ECL Git HEAD.
545
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
546 (defimplementation find-definitions (name)
547 (let ((annotations (ext:get-annotation name 'si::location :all)))
548 (cond (annotations
549 (loop for annotation in annotations
550 collect (destructuring-bind (dspec file . pos) annotation
551 `(,dspec ,(make-file-location file pos)))))
552 (t
553 (mapcan #'(lambda (type) (find-definitions-by-type name type))
554 (classify-definition-name name))))))
3d76a5c0 » trittweiler
2010-02-22 Make M-. be able to jump right into the C source for ECL.
555
556 (defun classify-definition-name (name)
557 (let ((types '()))
558 (when (fboundp name)
559 (cond ((special-operator-p name)
560 (push :special-operator types))
561 ((macro-function name)
562 (push :macro types))
563 ((typep (fdefinition name) 'generic-function)
564 (push :generic-function types))
565 ((si:mangle-name name t)
566 (push :c-function types))
567 (t
568 (push :lisp-function types))))
4e64b26a » trittweiler
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
569 (when (boundp name)
570 (cond ((constantp name)
571 (push :constant types))
572 (t
573 (push :global-variable types))))
3d76a5c0 » trittweiler
2010-02-22 Make M-. be able to jump right into the C source for ECL.
574 types))
575
4e64b26a » trittweiler
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
576 (defun find-definitions-by-type (name type)
3d76a5c0 » trittweiler
2010-02-22 Make M-. be able to jump right into the C source for ECL.
577 (ecase type
578 (:lisp-function
4e64b26a » trittweiler
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
579 (when-let (loc (source-location (fdefinition name)))
580 (list `((defun ,name) ,loc))))
3d76a5c0 » trittweiler
2010-02-22 Make M-. be able to jump right into the C source for ECL.
581 (:c-function
4e64b26a » trittweiler
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
582 (when-let (loc (source-location (fdefinition name)))
583 (list `((c-source ,name) ,loc))))
3d76a5c0 » trittweiler
2010-02-22 Make M-. be able to jump right into the C source for ECL.
584 (:generic-function
585 (loop for method in (clos:generic-function-methods (fdefinition name))
586 for specs = (clos:method-specializers method)
587 for loc = (source-location method)
588 when loc
589 collect `((defmethod ,name ,specs) ,loc)))
590 (:macro
4e64b26a » trittweiler
2010-02-23 * swank-backend.lisp (when-let): New macro. For backends and
591 (when-let (loc (source-location (macro-function name)))
592 (list `((defmacro ,name) ,loc))))
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
593 (:constant
594 (when-let (loc (source-location name))
595 (list `((defconstant ,name) ,loc))))
596 (:global-variable
597 (when-let (loc (source-location name))
598 (list `((defvar ,name) ,loc))))
599 (:special-operator)))
3d76a5c0 » trittweiler
2010-02-22 Make M-. be able to jump right into the C source for ECL.
600
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
601 ;;; FIXME: There ought to be a better way.
602 (eval-when (:compile-toplevel :load-toplevel :execute)
603 (defun c-function-name-p (name)
604 (and (symbolp name) (si:mangle-name name t) t))
605 (defun c-function-p (object)
606 (and (functionp object)
607 (let ((fn-name (function-name object)))
608 (and fn-name (c-function-name-p fn-name))))))
609
610 (deftype c-function ()
611 `(satisfies c-function-p))
612
613 (defun assert-source-directory ()
614 (unless (probe-file #P"SRC:")
615 (error "ECL's source directory ~A does not exist. ~
616 You can specify a different location via the environment ~
617 variable `ECLSRCDIR'."
618 (namestring (translate-logical-pathname #P"SYS:")))))
619
620 (defun assert-TAGS-file ()
621 (unless (probe-file +TAGS+)
622 (error "No TAGS file ~A found. It should have been installed with ECL."
623 +TAGS+)))
32ea92d7 » trittweiler
2010-02-22 Make swank-ecl.lisp work with latest ECL Git HEAD.
624
2f7a771a » trittweiler
2010-03-16 * swank-ecl.lisp (source-location): Also return EXT::FOO as
625 (defun package-names (package)
626 (cons (package-name package) (package-nicknames package)))
627
3d76a5c0 » trittweiler
2010-02-22 Make M-. be able to jump right into the C source for ECL.
628 (defun source-location (object)
32ea92d7 » trittweiler
2010-02-22 Make swank-ecl.lisp work with latest ECL Git HEAD.
629 (converting-errors-to-error-location
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
630 (typecase object
631 (c-function
632 (assert-source-directory)
633 (assert-TAGS-file)
634 (let ((lisp-name (function-name object)))
635 (assert lisp-name)
636 (multiple-value-bind (flag c-name) (si:mangle-name lisp-name t)
637 (assert flag)
638 ;; In ECL's code base sometimes the mangled name is used
2f7a771a » trittweiler
2010-03-16 * swank-ecl.lisp (source-location): Also return EXT::FOO as
639 ;; directly, sometimes ECL's DPP magic of @SI::SYMBOL or
640 ;; @EXT::SYMBOL is used. We cannot predict here, so we just
641 ;; provide several candidates.
642 (apply #'make-TAGS-location
643 c-name
644 (loop with s = (symbol-name lisp-name)
645 for p in (package-names (symbol-package lisp-name))
646 collect (format nil "~A::~A" p s)
647 collect (format nil "~(~A::~A~)" p s))))))
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
648 (function
649 (multiple-value-bind (file pos) (ext:compiled-function-file object)
650 (cond ((not file)
651 (return-from source-location nil))
a1c30393 » stassats
2010-03-07 * swank-ecl.lisp (source-location): Don't do
652 ((tmpfile-to-buffer file)
653 (make-buffer-location (tmpfile-to-buffer file) pos))
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
654 (t
655 (assert (probe-file file))
656 (assert (not (minusp pos)))
bcf2fbb8 » trittweiler
2010-03-11 * swank-ecl.lisp (source-location): Move call to
657 (make-file-location file pos)))))
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
658 (method
659 ;; FIXME: This will always return NIL at the moment; ECL does not
660 ;; store debug information for methods yet.
661 (source-location (clos:method-function object)))
662 ((member nil t)
663 (multiple-value-bind (flag c-name) (si:mangle-name object)
664 (assert flag)
665 (make-TAGS-location c-name))))))
3d76a5c0 » trittweiler
2010-02-22 Make M-. be able to jump right into the C source for ECL.
666
667 (defimplementation find-source-location (object)
668 (or (source-location object)
8851620a » trittweiler
2010-03-05 Ecl: Make M-. work on function interactively compiled via C-c C-c.
669 (make-error-location "Source definition of ~S not found." object)))
2791323a » Geo Carncross
2008-04-24 Initial support for find-source-location with functions
670
8e5db041 » trittweiler
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
671
5c31ce66 » Geo Carncross
2009-06-25 Profiling support by Marko Kocić
672 ;;;; Profiling
673
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
674 #+profile
675 (progn
676
5c31ce66 » Geo Carncross
2009-06-25 Profiling support by Marko Kocić
677 (defimplementation profile (fname)
678 (when fname (eval `(profile:profile ,fname))))
679
680 (defimplementation unprofile (fname)
681 (when fname (eval `(profile:unprofile ,fname))))
682
683 (defimplementation unprofile-all ()
684 (profile:unprofile-all)
685 "All functions unprofiled.")
686
687 (defimplementation profile-report ()
688 (profile:report))
689
690 (defimplementation profile-reset ()
691 (profile:reset)
692 "Reset profiling counters.")
693
694 (defimplementation profiled-functions ()
695 (profile:profile))
696
07666629 » Geo Carncross
2009-07-01 swank-ecl.lisp: Package profiling support
697 (defimplementation profile-package (package callers methods)
698 (declare (ignore callers methods))
699 (eval `(profile:profile ,(package-name (find-package package)))))
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
700 ) ; #+profile (progn ...
07666629 » Geo Carncross
2009-07-01 swank-ecl.lisp: Package profiling support
701
8e5db041 » trittweiler
2010-02-23 * swank-ecl.lisp (preferred-communication-style): Go back to
702
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
703 ;;;; Threads
5415cdcc » Geo Carncross
2007-12-15 Add ECL threads implementation to swank
704
705 #+threads
706 (progn
707 (defvar *thread-id-counter* 0)
708
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
709 (defparameter *thread-id-map* (make-hash-table))
710
711 (defvar *thread-id-map-lock*
712 (mp:make-lock :name "thread id map lock"))
5415cdcc » Geo Carncross
2007-12-15 Add ECL threads implementation to swank
713
714 (defimplementation spawn (fn &key name)
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
715 (mp:process-run-function name fn))
716
717 (defimplementation thread-id (target-thread)
718 (block thread-id
719 (mp:with-lock (*thread-id-map-lock*)
720 ;; Does TARGET-THREAD have an id already?
721 (maphash (lambda (id thread-pointer)
722 (let ((thread (si:weak-pointer-value thread-pointer)))
723 (cond ((not thread)
724 (remhash id *thread-id-map*))
725 ((eq thread target-thread)
726 (return-from thread-id id)))))
727 *thread-id-map*)
728 ;; TARGET-THREAD not found in *THREAD-ID-MAP*
729 (let ((id (incf *thread-id-counter*))
730 (thread-pointer (si:make-weak-pointer target-thread)))
731 (setf (gethash id *thread-id-map*) thread-pointer)
732 id))))
5415cdcc » Geo Carncross
2007-12-15 Add ECL threads implementation to swank
733
734 (defimplementation find-thread (id)
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
735 (mp:with-lock (*thread-id-map-lock*)
4d214b67 » trittweiler
2010-02-20 More work on ECL's swank-backend.
736 (let* ((thread-ptr (gethash id *thread-id-map*))
737 (thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
738 (unless thread
739 (remhash id *thread-id-map*))
740 thread)))
5415cdcc » Geo Carncross
2007-12-15 Add ECL threads implementation to swank
741
742 (defimplementation thread-name (thread)
743 (mp:process-name thread))
744
745 (defimplementation thread-status (thread)
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
746 (if (mp:process-active-p thread)
747 "RUNNING"
748 "STOPPED"))
5415cdcc » Geo Carncross
2007-12-15 Add ECL threads implementation to swank
749
750 (defimplementation make-lock (&key name)
cf559761 » Juan Jose Garcia Ripoll
2012-04-13 In MAKE-LOCK (swank-ecl.lisp) make it explicit the need for recursive…
751 (mp:make-lock :name name :recursive t))
5415cdcc » Geo Carncross
2007-12-15 Add ECL threads implementation to swank
752
753 (defimplementation call-with-lock-held (lock function)
754 (declare (type function function))
755 (mp:with-lock (lock) (funcall function)))
756
757 (defimplementation current-thread ()
758 mp:*current-process*)
759
760 (defimplementation all-threads ()
761 (mp:all-processes))
762
763 (defimplementation interrupt-thread (thread fn)
764 (mp:interrupt-process thread fn))
765
766 (defimplementation kill-thread (thread)
767 (mp:process-kill thread))
768
769 (defimplementation thread-alive-p (thread)
770 (mp:process-active-p thread))
771
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
772 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
773 (defvar *mailboxes* (list))
774 (declaim (type list *mailboxes*))
775
5415cdcc » Geo Carncross
2007-12-15 Add ECL threads implementation to swank
776 (defstruct (mailbox (:conc-name mailbox.))
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
777 thread
778 (mutex (mp:make-lock))
779 (cvar (mp:make-condition-variable))
5415cdcc » Geo Carncross
2007-12-15 Add ECL threads implementation to swank
780 (queue '() :type list))
781
782 (defun mailbox (thread)
783 "Return THREAD's mailbox."
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
784 (mp:with-lock (*mailbox-lock*)
785 (or (find thread *mailboxes* :key #'mailbox.thread)
786 (let ((mb (make-mailbox :thread thread)))
787 (push mb *mailboxes*)
788 mb))))
5415cdcc » Geo Carncross
2007-12-15 Add ECL threads implementation to swank
789
790 (defimplementation send (thread message)
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
791 (let* ((mbox (mailbox thread))
792 (mutex (mailbox.mutex mbox)))
793 (mp:with-lock (mutex)
8fd36874 » trittweiler
2010-02-07 * swank-ecl.lisp: Update threading code. ECL doesn't still work
794 (setf (mailbox.queue mbox)
795 (nconc (mailbox.queue mbox) (list message)))
796 (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
797
798 (defimplementation receive-if (test &optional timeout)
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
799 (let* ((mbox (mailbox (current-thread)))
800 (mutex (mailbox.mutex mbox)))
8fd36874 » trittweiler
2010-02-07 * swank-ecl.lisp: Update threading code. ECL doesn't still work
801 (assert (or (not timeout) (eq timeout t)))
802 (loop
6457beb9 » trittweiler
2010-02-16 Pimp my swank.
803 (check-slime-interrupts)
804 (mp:with-lock (mutex)
805 (let* ((q (mailbox.queue mbox))
806 (tail (member-if test q)))
807 (when tail
808 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
809 (return (car tail))))
810 (when (eq timeout t) (return (values nil t)))
811 (mp:condition-variable-timedwait (mailbox.cvar mbox)
812 mutex
813 0.2)))))
814
815 ) ; #+threads (progn ...
Something went wrong with that request. Please try again.