Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 593 lines (498 sloc) 19.403 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)
48bd841 ECL moved gray streams into GRAY package
Geo Carncross authored
18 (if (find-package :gray)
19 (import-from :gray *gray-stream-symbols* :swank-backend)
20 (import-from :ext *gray-stream-symbols* :swank-backend))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
21
22 (swank-backend::import-swank-mop-symbols :clos
23 '(:eql-specializer
24 :eql-specializer-object
25 :generic-function-declarations
26 :specializer-direct-methods
990fcea * contrib/swank-listener-hooks.lisp: Add missing IN-PACKAGE.
Helmut Eller authored
27 :compute-applicable-methods-using-classes)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
28
29
30 ;;;; TCP Server
31
990fcea * contrib/swank-listener-hooks.lisp: Add missing IN-PACKAGE.
Helmut Eller authored
32 (eval-when (:compile-toplevel :load-toplevel :execute)
33 (require 'sockets))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
34
35 (defun resolve-hostname (name)
36 (car (sb-bsd-sockets:host-ent-addresses
37 (sb-bsd-sockets:get-host-by-name name))))
38
39 (defimplementation create-socket (host port)
40 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
41 :type :stream
42 :protocol :tcp)))
43 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
44 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
45 (sb-bsd-sockets:socket-listen socket 5)
46 socket))
47
48 (defimplementation local-port (socket)
49 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
50
51 (defimplementation close-socket (socket)
52 (sb-bsd-sockets:socket-close socket))
53
54 (defimplementation accept-connection (socket
e51892e swank-backend.lisp (definterface): Drop that incredibly unportable
Helmut Eller authored
55 &key external-format
d4ac7e7 * Improve the robustness of connection establishment.
Douglas Crosher authored
56 buffering timeout)
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
57 (declare (ignore buffering timeout external-format))
58 (make-socket-io-stream (accept socket)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
59
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
60 (defun make-socket-io-stream (socket)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
61 (sb-bsd-sockets:socket-make-stream socket
62 :output t
63 :input t
64 :element-type 'base-char))
65
66 (defun accept (socket)
67 "Like socket-accept, but retry on EAGAIN."
68 (loop (handler-case
69 (return (sb-bsd-sockets:socket-accept socket))
70 (sb-bsd-sockets:interrupted-error ()))))
71
72 (defimplementation preferred-communication-style ()
73 (values nil))
74
75
76 ;;;; Unix signals
77
7be8fd7 Improve interrupt safety for single-threaded lisps.
Helmut Eller authored
78 (defimplementation install-sigint-handler (handler)
79 (let ((old-handler (symbol-function 'si:terminal-interrupt)))
80 (setf (symbol-function 'si:terminal-interrupt)
81 (if (consp handler)
82 (car handler)
83 (lambda (&rest args)
84 (declare (ignore args))
85 (funcall handler)
86 (continue))))
87 (list old-handler)))
88
89
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
90 (defimplementation getpid ()
91 (si:getpid))
92
93 #+nil
94 (defimplementation set-default-directory (directory)
95 (ext::chdir (namestring directory))
96 ;; Setting *default-pathname-defaults* to an absolute directory
97 ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
98 (setf *default-pathname-defaults* (ext::getcwd))
99 (default-directory))
100
101 #+nil
102 (defimplementation default-directory ()
103 (namestring (ext:getcwd)))
104
105 (defimplementation quit-lisp ()
106 (ext:quit))
107
108
109 ;;;; Compilation
110
111 (defvar *buffer-name* nil)
112 (defvar *buffer-start-position*)
113 (defvar *buffer-string*)
114 (defvar *compile-filename*)
115
116 (defun signal-compiler-condition (&rest args)
117 (signal (apply #'make-condition 'compiler-condition args)))
118
119 (defun handle-compiler-warning (condition)
120 (signal-compiler-condition
121 :original-condition condition
122 :message (format nil "~A" condition)
123 :severity :warning
124 :location
125 (if *buffer-name*
126 (make-location (list :buffer *buffer-name*)
b88eba2 Adjust positions in files with CRLF-style end-on-line markers.
Helmut Eller authored
127 (list :offset *buffer-start-position* 0))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
128 ;; ;; compiler::*current-form*
129 ;; (if compiler::*current-function*
130 ;; (make-location (list :file *compile-filename*)
131 ;; (list :function-name
132 ;; (symbol-name
133 ;; (slot-value compiler::*current-function*
134 ;; 'compiler::name))))
135 (list :error "No location found.")
136 ;; )
137 )))
138
139 (defimplementation call-with-compilation-hooks (function)
140 (handler-bind ((warning #'handle-compiler-warning))
141 (funcall function)))
142
f761f28 * swank-backend.lisp (swank-compile-file): Take output-file as
Helmut Eller authored
143 (defimplementation swank-compile-file (input-file output-file
144 load-p external-format)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
145 (declare (ignore external-format))
146 (with-compilation-hooks ()
f761f28 * swank-backend.lisp (swank-compile-file): Take output-file as
Helmut Eller authored
147 (let ((*buffer-name* nil)
148 (*compile-filename* input-file))
149 (compile-file input-file :output-file output-file :load t))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
150
4314d2e * swank-backend.lisp (swank-compile-string): Pass the
Helmut Eller authored
151 (defimplementation swank-compile-string (string &key buffer position filename
152 policy)
153 (declare (ignore filename policy))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
154 (with-compilation-hooks ()
155 (let ((*buffer-name* buffer)
156 (*buffer-start-position* position)
157 (*buffer-string* string))
158 (with-input-from-string (s string)
601b824 * swank-lispworks.lisp (with-swank-compilation-unit): Return the
Helmut Eller authored
159 (not (nth-value 2 (compile-from-stream s :load t)))))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
160
161 (defun compile-from-stream (stream &rest args)
162 (let ((file (si::mkstemp "TMP:ECLXXXXXX")))
163 (with-open-file (s file :direction :output :if-exists :overwrite)
164 (do ((line (read-line stream nil) (read-line stream nil)))
d2ab4d0 @trittweiler * swank-ecl.lisp (compile-from-stream): Fixed typo that prevented
trittweiler authored
165 ((not line))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
166 (write-line line s)))
167 (unwind-protect
168 (apply #'compile-file file args)
169 (delete-file file))))
170
171
172 ;;;; Documentation
173
5e3751b @trittweiler Improve ECL's arglist support somewhat.
trittweiler authored
174 (defun grovel-docstring-for-arglist (name type)
175 (flet ((compute-arglist-offset (docstring)
176 (when docstring
177 (let ((pos1 (search "Args: " docstring)))
178 (if pos1
179 (+ pos1 6)
180 (let ((pos2 (search "Syntax: " docstring)))
181 (when pos2
182 (+ pos2 8))))))))
183 (let* ((docstring (si::get-documentation name type))
184 (pos (compute-arglist-offset docstring)))
185 (if pos
186 (multiple-value-bind (arglist errorp)
187 (ignore-errors
188 (values (read-from-string docstring t nil :start pos)))
329a5f5 2009-01-30 Geo Carncross <geocar@gmail.com>
Geo Carncross authored
189 (if (or errorp (not (listp arglist)))
190 :not-available
191 (cdr arglist)))
5e3751b @trittweiler Improve ECL's arglist support somewhat.
trittweiler authored
192 :not-available ))))
193
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
194 (defimplementation arglist (name)
5e3751b @trittweiler Improve ECL's arglist support somewhat.
trittweiler authored
195 (cond ((special-operator-p name)
196 (grovel-docstring-for-arglist name 'function))
197 ((macro-function name)
198 (grovel-docstring-for-arglist name 'function))
199 ((or (functionp name) (fboundp name))
200 (multiple-value-bind (name fndef)
201 (if (functionp name)
202 (values (function-name name) name)
203 (values name (fdefinition name)))
204 (typecase fndef
205 (generic-function
206 (clos::generic-function-lambda-list fndef))
207 (compiled-function
208 (grovel-docstring-for-arglist name 'function))
209 (function
210 (let ((fle (function-lambda-expression fndef)))
211 (case (car fle)
212 (si:lambda-block (caddr fle))
213 (t :not-available)))))))
214 (t :not-available)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
215
e51892e swank-backend.lisp (definterface): Drop that incredibly unportable
Helmut Eller authored
216 (defimplementation function-name (f)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
217 (si:compiled-function-name f))
218
219 (defimplementation macroexpand-all (form)
220 ;;; FIXME! This is not the same as a recursive macroexpansion!
221 (macroexpand form))
222
223 (defimplementation describe-symbol-for-emacs (symbol)
224 (let ((result '()))
225 (dolist (type '(:VARIABLE :FUNCTION :CLASS))
226 (let ((doc (describe-definition symbol type)))
227 (when doc
228 (setf result (list* type doc result)))))
229 result))
230
231 (defimplementation describe-definition (name type)
232 (case type
233 (:variable (documentation name 'variable))
234 (:function (documentation name 'function))
235 (:class (documentation name 'class))
236 (t nil)))
237
238 ;;; Debugging
239
10425c0 * swank-ecl.lisp: Add :load-toplevel and :execute to EVAL-WHENs to
Helmut Eller authored
240 (eval-when (:compile-toplevel :load-toplevel :execute)
990fcea * contrib/swank-listener-hooks.lisp: Add missing IN-PACKAGE.
Helmut Eller authored
241 (import
242 '(si::*break-env*
243 si::*ihs-top*
244 si::*ihs-current*
245 si::*ihs-base*
246 si::*frs-base*
247 si::*frs-top*
248 si::*tpl-commands*
249 si::*tpl-level*
250 si::frs-top
251 si::ihs-top
252 si::ihs-fun
253 si::ihs-env
254 si::sch-frs-base
255 si::set-break-env
256 si::set-current-ihs
257 si::tpl-commands)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
258
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
259 (defvar *backtrace* '())
260
36a6053 Remove frames from the backtrace that are in a swank package as those…
Geo Carncross authored
261 (defun in-swank-package-p (x)
df8f365 Trim swank sources from the ECL backtrace.
Geo Carncross authored
262 (and
263 (symbolp x)
264 (member (symbol-package x)
265 (list #.(find-package :swank)
266 #.(find-package :swank-backend)
267 #.(ignore-errors (find-package :swank-mop))
268 #.(ignore-errors (find-package :swank-loader))))
269 t))
270
271 (defun is-swank-source-p (name)
272 (setf name (pathname name))
273 (pathname-match-p
274 name
275 (make-pathname :defaults swank-loader::*source-directory*
276 :name (pathname-name name)
277 :type (pathname-type name)
278 :version (pathname-version name))))
279
280 (defun is-ignorable-fun-p (x)
281 (or
282 (in-swank-package-p (frame-name x))
283 (multiple-value-bind (file position)
284 (ignore-errors (si::bc-file (car x)))
285 (declare (ignore position))
286 (if file (is-swank-source-p file)))))
36a6053 Remove frames from the backtrace that are in a swank package as those…
Geo Carncross authored
287
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
288 (defmacro find-ihs-top (x)
289 (if (< ext:+ecl-version-number+ 90601)
290 `(si::ihs-top ,x)
291 '(si::ihs-top)))
292
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
293 (defimplementation call-with-debugging-environment (debugger-loop-fn)
294 (declare (type function debugger-loop-fn))
295 (let* ((*tpl-commands* si::tpl-commands)
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
296 (*ihs-top* (find-ihs-top 'call-with-debugging-environment))
6443eec @trittweiler * swank-ecl.lisp: Forgot to update ECL's backend when introducing
trittweiler authored
297 (*ihs-current* *ihs-top*)
298 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
299 (*frs-top* (frs-top))
300 (*read-suppress* nil)
301 (*tpl-level* (1+ *tpl-level*))
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
302 (*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
303 collect (list (si::ihs-fun ihs)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
304 (si::ihs-env ihs)
305 nil))))
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
306 (declare (special *ihs-current*))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
307 (loop for f from *frs-base* until *frs-top*
308 do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
309 (when (plusp i)
310 (let* ((x (elt *backtrace* i))
311 (name (si::frs-tag f)))
ecef253 Bugfix: qualify fixnump
Geo Carncross authored
312 (unless (si::fixnump name)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
313 (push name (third x)))))))
df8f365 Trim swank sources from the ECL backtrace.
Geo Carncross authored
314 (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
315 (setf *tmp* *backtrace*)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
316 (set-break-env)
317 (set-current-ihs)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
318 (let ((*ihs-base* *ihs-top*))
319 (funcall debugger-loop-fn))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
320
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
321 (defimplementation call-with-debugger-hook (hook fun)
322 (let ((*debugger-hook* hook)
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
323 (*ihs-base* (find-ihs-top 'call-with-debugger-hook)))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
324 (funcall fun)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
325
326 (defimplementation compute-backtrace (start end)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
327 (when (numberp end)
328 (setf end (min end (length *backtrace*))))
6443eec @trittweiler * swank-ecl.lisp: Forgot to update ECL's backend when introducing
trittweiler authored
329 (loop for f in (subseq *backtrace* start end)
954bd86 * swank-backend.lisp (frame-restartable-p): New function.
Helmut Eller authored
330 collect f))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
331
332 (defun frame-name (frame)
333 (let ((x (first frame)))
334 (if (symbolp x)
335 x
336 (function-name x))))
337
338 (defun function-position (fun)
339 (multiple-value-bind (file position)
340 (si::bc-file fun)
341 (and file (make-location `(:file ,file) `(:position ,position)))))
342
343 (defun frame-function (frame)
344 (let* ((x (first frame))
345 fun position)
346 (etypecase x
347 (symbol (and (fboundp x)
348 (setf fun (fdefinition x)
349 position (function-position fun))))
350 (function (setf fun x position (function-position x))))
351 (values fun position)))
352
353 (defun frame-decode-env (frame)
354 (let ((functions '())
355 (blocks '())
356 (variables '()))
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
357 #.(if (< ext:+ecl-version-number+ 90601)
358 '(setf frame (second frame))
359 '(setf frame (si::decode-ihs-env (second frame))))
360 (dolist (record frame)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
361 (let* ((record0 (car record))
362 (record1 (cdr record)))
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
363 (cond ((or (symbolp record0) (stringp record0))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
364 (setq variables (acons record0 record1 variables)))
ecef253 Bugfix: qualify fixnump
Geo Carncross authored
365 ((not (si::fixnump record0))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
366 (push record1 functions))
367 ((symbolp record1)
368 (push record1 blocks))
369 (t
370 ))))
371 (values functions blocks variables)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
372
954bd86 * swank-backend.lisp (frame-restartable-p): New function.
Helmut Eller authored
373 (defimplementation print-frame (frame stream)
374 (format stream "~A" (first frame)))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
375
376 (defimplementation frame-source-location-for-emacs (frame-number)
377 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
378
379 (defimplementation frame-catch-tags (frame-number)
380 (third (elt *backtrace* frame-number)))
381
382 (defimplementation frame-locals (frame-number)
383 (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
384 with i = 0
385 collect (list :name name :id (prog1 i (incf i)) :value value)))
386
387 (defimplementation frame-var-value (frame-number var-id)
388 (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
389 var-id))
390
391 (defimplementation disassemble-frame (frame-number)
392 (let ((fun (frame-fun (elt *backtrace* frame-number))))
393 (disassemble fun)))
394
395 (defimplementation eval-in-frame (form frame-number)
396 (let ((env (second (elt *backtrace* frame-number))))
397 (si:eval-with-env form env)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
398
399 ;;;; Inspector
400
0c75cea Inspector cleanups.
Helmut Eller authored
401 (defmethod emacs-inspect ((o t))
6eb426d Make ELC inspection better; should be able to handle all builtin type…
Geo Carncross authored
402 ; ecl clos support leaves some to be desired
403 (cond
404 ((streamp o)
6a300a7 Drop the first return value of emacs-inspect.
Helmut Eller authored
405 (list*
406 (format nil "~S is an ordinary stream~%" o)
6eb426d Make ELC inspection better; should be able to handle all builtin type…
Geo Carncross authored
407 (append
408 (list
409 "Open for "
410 (cond
411 ((ignore-errors (interactive-stream-p o)) "Interactive")
412 ((and (input-stream-p o) (output-stream-p o)) "Input and output")
413 ((input-stream-p o) "Input")
414 ((output-stream-p o) "Output"))
415 `(:newline) `(:newline))
416 (label-value-line*
417 ("Element type" (stream-element-type o))
418 ("External format" (stream-external-format o)))
419 (ignore-errors (label-value-line*
420 ("Broadcast streams" (broadcast-stream-streams o))))
421 (ignore-errors (label-value-line*
422 ("Concatenated streams" (concatenated-stream-streams o))))
423 (ignore-errors (label-value-line*
424 ("Echo input stream" (echo-stream-input-stream o))))
425 (ignore-errors (label-value-line*
426 ("Echo output stream" (echo-stream-output-stream o))))
427 (ignore-errors (label-value-line*
428 ("Output String" (get-output-stream-string o))))
429 (ignore-errors (label-value-line*
430 ("Synonym symbol" (synonym-stream-symbol o))))
431 (ignore-errors (label-value-line*
432 ("Input stream" (two-way-stream-input-stream o))))
433 (ignore-errors (label-value-line*
434 ("Output stream" (two-way-stream-output-stream o)))))))
435 (t
436 (let* ((cl (si:instance-class o))
437 (slots (clos:class-slots cl)))
6a300a7 Drop the first return value of emacs-inspect.
Helmut Eller authored
438 (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
439 o (clos::class-name cl))
440 (loop for x in slots append
441 (let* ((name (clos:slot-definition-name x))
442 (value (clos::slot-value o name)))
443 (list
444 (format nil "~S: " name)
445 `(:value ,value)
446 `(:newline)))))))))
447
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
448 ;;;; Definitions
449
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
450 (defimplementation find-definitions (name)
451 (if (fboundp name)
452 (let ((tmp (find-source-location (symbol-function name))))
453 `(((defun ,name) ,tmp)))))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
454
2791323 Initial support for find-source-location with functions
Geo Carncross authored
455 (defimplementation find-source-location (obj)
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
456 (setf *tmp* obj)
2791323 Initial support for find-source-location with functions
Geo Carncross authored
457 (or
458 (typecase obj
459 (function
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
460 (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj))
2791323 Initial support for find-source-location with functions
Geo Carncross authored
461 (if (and file pos)
e8c6143 fixup flushing and location create
Geo Carncross authored
462 (make-location
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
463 `(:file ,(namestring file))
e8c6143 fixup flushing and location create
Geo Carncross authored
464 `(:position ,pos)
465 `(:snippet
466 ,(with-open-file (s file)
670648a Support new environment changes in recent ECL/CVS
Geo Carncross authored
467 (if (< ext:+ecl-version-number+ 90601)
468 (skip-toplevel-forms pos s)
469 (file-position s pos))
e8c6143 fixup flushing and location create
Geo Carncross authored
470 (skip-comments-and-whitespace s)
471 (read-snippet s))))))))
2791323 Initial support for find-source-location with functions
Geo Carncross authored
472 `(:error (format nil "Source definition of ~S not found" obj))))
473
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
474 ;;;; Threads
475
476 #+threads
477 (progn
478 (defvar *thread-id-counter* 0)
479
480 (defvar *thread-id-counter-lock*
481 (mp:make-lock :name "thread id counter lock"))
482
483 (defun next-thread-id ()
484 (mp:with-lock (*thread-id-counter-lock*)
485 (incf *thread-id-counter*)))
486
487 (defparameter *thread-id-map* (make-hash-table))
3dfff7b * swank-ecl.lisp (thread-id): Assign an non-nil id to unknown
Helmut Eller authored
488 (defparameter *id-thread-map* (make-hash-table))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
489
490 (defvar *thread-id-map-lock*
491 (mp:make-lock :name "thread id map lock"))
492
493 ; ecl doesn't have weak pointers
494 (defimplementation spawn (fn &key name)
495 (let ((thread (mp:make-process :name name))
496 (id (next-thread-id)))
497 (mp:process-preset
498 thread
499 #'(lambda ()
500 (unwind-protect
501 (mp:with-lock (*thread-id-map-lock*)
3dfff7b * swank-ecl.lisp (thread-id): Assign an non-nil id to unknown
Helmut Eller authored
502 (setf (gethash id *thread-id-map*) thread)
503 (setf (gethash thread *id-thread-map*) id))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
504 (funcall fn)
505 (mp:with-lock (*thread-id-map-lock*)
3dfff7b * swank-ecl.lisp (thread-id): Assign an non-nil id to unknown
Helmut Eller authored
506 (remhash thread *id-thread-map*)
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
507 (remhash id *thread-id-map*)))))
508 (mp:process-enable thread)))
509
510 (defimplementation thread-id (thread)
511 (block thread-id
512 (mp:with-lock (*thread-id-map-lock*)
3dfff7b * swank-ecl.lisp (thread-id): Assign an non-nil id to unknown
Helmut Eller authored
513 (or (gethash thread *id-thread-map*)
514 (let ((id (next-thread-id)))
515 (setf (gethash id *thread-id-map*) thread)
516 (setf (gethash thread *id-thread-map*) id)
517 id)))))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
518
519 (defimplementation find-thread (id)
520 (mp:with-lock (*thread-id-map-lock*)
521 (gethash id *thread-id-map*)))
522
523 (defimplementation thread-name (thread)
524 (mp:process-name thread))
525
526 (defimplementation thread-status (thread)
527 (if (mp:process-active-p thread)
528 "RUNNING"
529 "STOPPED"))
530
531 (defimplementation make-lock (&key name)
532 (mp:make-lock :name name))
533
534 (defimplementation call-with-lock-held (lock function)
535 (declare (type function function))
536 (mp:with-lock (lock) (funcall function)))
537
538 (defimplementation current-thread ()
539 mp:*current-process*)
540
541 (defimplementation all-threads ()
542 (mp:all-processes))
543
544 (defimplementation interrupt-thread (thread fn)
545 (mp:interrupt-process thread fn))
546
547 (defimplementation kill-thread (thread)
548 (mp:process-kill thread))
549
550 (defimplementation thread-alive-p (thread)
551 (mp:process-active-p thread))
552
553 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
554
555 (defstruct (mailbox (:conc-name mailbox.))
556 (mutex (mp:make-lock :name "process mailbox"))
557 (queue '() :type list))
558
559 (defun mailbox (thread)
560 "Return THREAD's mailbox."
561 (mp:with-lock (*mailbox-lock*)
562 (or (find thread *mailboxes* :key #'mailbox.thread)
563 (let ((mb (make-mailbox :thread thread)))
564 (push mb *mailboxes*)
565 mb))))
566
567 (defimplementation send (thread message)
568 (let* ((mbox (mailbox thread))
569 (mutex (mailbox.mutex mbox)))
570 (mp:interrupt-process
571 thread
572 (lambda ()
573 (mp:with-lock (mutex)
574 (setf (mailbox.queue mbox)
575 (nconc (mailbox.queue mbox) (list message))))))))
576
577 (defimplementation receive ()
578 (block got-mail
579 (let* ((mbox (mailbox mp:*current-process*))
580 (mutex (mailbox.mutex mbox)))
581 (loop
582 (mp:with-lock (mutex)
583 (if (mailbox.queue mbox)
584 (return-from got-mail (pop (mailbox.queue mbox)))))
585 ;interrupt-process will halt this if it takes longer than 1sec
586 (sleep 1)))))
587
588 (defmethod stream-finish-output ((stream stream))
589 (finish-output stream))
590
591 )
592
Something went wrong with that request. Please try again.