Skip to content

HTTPS clone URL

Subversion checkout URL

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