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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.46 - (hide annotations)
Fri Nov 6 16:30:00 2009 UTC (4 years, 5 months ago) by sboukarev
Branch: MAIN
Changes since 1.45: +5 -1 lines
* swank-ecl.lisp (grovel-docstring-for-arglist): ECL's arglists
for macros include macro name at the first place, unlike arglists
for functions. cdr arglists only for macros and special operators.
Reported by Andy Hefner.
1 heller 1.7 ;;;; -*- indent-tabs-mode: nil -*-
2 jgarcia 1.1 ;;;
3     ;;; swank-ecl.lisp --- SLIME backend for ECL.
4 heller 1.7 ;;;
5     ;;; This code has been placed in the Public Domain. All warranties
6     ;;; are disclaimed.
7     ;;;
8 jgarcia 1.1
9     ;;; Administrivia
10    
11     (in-package :swank-backend)
12    
13 gcarncross 1.40 (declaim (optimize (debug 3)))
14    
15 gcarncross 1.19 (defvar *tmp*)
16    
17 heller 1.29 (eval-when (:compile-toplevel :load-toplevel :execute)
18 gcarncross 1.15 (if (find-package :gray)
19     (import-from :gray *gray-stream-symbols* :swank-backend)
20     (import-from :ext *gray-stream-symbols* :swank-backend))
21 jgarcia 1.1
22     (swank-backend::import-swank-mop-symbols :clos
23     '(:eql-specializer
24     :eql-specializer-object
25     :generic-function-declarations
26     :specializer-direct-methods
27 heller 1.28 :compute-applicable-methods-using-classes)))
28 jgarcia 1.1
29    
30     ;;;; TCP Server
31    
32 heller 1.28 (eval-when (:compile-toplevel :load-toplevel :execute)
33     (require 'sockets))
34 jgarcia 1.1
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
55 heller 1.6 &key external-format
56 dcrosher 1.5 buffering timeout)
57 heller 1.7 (declare (ignore buffering timeout external-format))
58     (make-socket-io-stream (accept socket)))
59 jgarcia 1.1
60 heller 1.7 (defun make-socket-io-stream (socket)
61 jgarcia 1.1 (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 trittweiler 1.44 (defvar *external-format-to-coding-system*
76     '((:iso-8859-1
77     "latin-1" "latin-1-unix" "iso-latin-1-unix"
78     "iso-8859-1" "iso-8859-1-unix")
79     (:utf-8 "utf-8" "utf-8-unix")))
80    
81     (defimplementation find-external-format (coding-system)
82     (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
83     *external-format-to-coding-system*)))
84    
85 jgarcia 1.1
86     ;;;; Unix signals
87    
88 heller 1.27 (defimplementation install-sigint-handler (handler)
89     (let ((old-handler (symbol-function 'si:terminal-interrupt)))
90     (setf (symbol-function 'si:terminal-interrupt)
91     (if (consp handler)
92     (car handler)
93     (lambda (&rest args)
94     (declare (ignore args))
95     (funcall handler)
96     (continue))))
97     (list old-handler)))
98    
99    
100 jgarcia 1.1 (defimplementation getpid ()
101     (si:getpid))
102    
103     #+nil
104     (defimplementation set-default-directory (directory)
105     (ext::chdir (namestring directory))
106     ;; Setting *default-pathname-defaults* to an absolute directory
107     ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
108     (setf *default-pathname-defaults* (ext::getcwd))
109     (default-directory))
110    
111     #+nil
112     (defimplementation default-directory ()
113     (namestring (ext:getcwd)))
114    
115     (defimplementation quit-lisp ()
116     (ext:quit))
117    
118    
119     ;;;; Compilation
120    
121     (defvar *buffer-name* nil)
122     (defvar *buffer-start-position*)
123     (defvar *buffer-string*)
124     (defvar *compile-filename*)
125    
126     (defun signal-compiler-condition (&rest args)
127     (signal (apply #'make-condition 'compiler-condition args)))
128    
129     (defun handle-compiler-warning (condition)
130     (signal-compiler-condition
131     :original-condition condition
132     :message (format nil "~A" condition)
133     :severity :warning
134     :location
135     (if *buffer-name*
136     (make-location (list :buffer *buffer-name*)
137 heller 1.30 (list :offset *buffer-start-position* 0))
138 jgarcia 1.1 ;; ;; compiler::*current-form*
139     ;; (if compiler::*current-function*
140     ;; (make-location (list :file *compile-filename*)
141     ;; (list :function-name
142     ;; (symbol-name
143     ;; (slot-value compiler::*current-function*
144     ;; 'compiler::name))))
145     (list :error "No location found.")
146     ;; )
147     )))
148    
149     (defimplementation call-with-compilation-hooks (function)
150     (handler-bind ((warning #'handle-compiler-warning))
151     (funcall function)))
152    
153 heller 1.38 (defimplementation swank-compile-file (input-file output-file
154     load-p external-format)
155 jgarcia 1.1 (declare (ignore external-format))
156     (with-compilation-hooks ()
157 heller 1.38 (let ((*buffer-name* nil)
158     (*compile-filename* input-file))
159     (compile-file input-file :output-file output-file :load t))))
160 jgarcia 1.1
161 heller 1.37 (defimplementation swank-compile-string (string &key buffer position filename
162     policy)
163     (declare (ignore filename policy))
164 jgarcia 1.1 (with-compilation-hooks ()
165     (let ((*buffer-name* buffer)
166     (*buffer-start-position* position)
167     (*buffer-string* string))
168     (with-input-from-string (s string)
169 heller 1.34 (not (nth-value 2 (compile-from-stream s :load t)))))))
170 jgarcia 1.1
171     (defun compile-from-stream (stream &rest args)
172     (let ((file (si::mkstemp "TMP:ECLXXXXXX")))
173     (with-open-file (s file :direction :output :if-exists :overwrite)
174     (do ((line (read-line stream nil) (read-line stream nil)))
175 trittweiler 1.8 ((not line))
176 jgarcia 1.1 (write-line line s)))
177     (unwind-protect
178     (apply #'compile-file file args)
179     (delete-file file))))
180    
181    
182     ;;;; Documentation
183    
184 trittweiler 1.32 (defun grovel-docstring-for-arglist (name type)
185     (flet ((compute-arglist-offset (docstring)
186     (when docstring
187     (let ((pos1 (search "Args: " docstring)))
188     (if pos1
189     (+ pos1 6)
190     (let ((pos2 (search "Syntax: " docstring)))
191     (when pos2
192     (+ pos2 8))))))))
193     (let* ((docstring (si::get-documentation name type))
194     (pos (compute-arglist-offset docstring)))
195     (if pos
196     (multiple-value-bind (arglist errorp)
197     (ignore-errors
198     (values (read-from-string docstring t nil :start pos)))
199 gcarncross 1.39 (if (or errorp (not (listp arglist)))
200     :not-available
201 sboukarev 1.46 ; ECL for some reason includes macro name at the first place
202     (if (or (macro-function name)
203     (special-operator-p name))
204     (cdr arglist)
205     arglist)))
206 trittweiler 1.32 :not-available ))))
207    
208 jgarcia 1.1 (defimplementation arglist (name)
209 trittweiler 1.32 (cond ((special-operator-p name)
210     (grovel-docstring-for-arglist name 'function))
211     ((macro-function name)
212     (grovel-docstring-for-arglist name 'function))
213     ((or (functionp name) (fboundp name))
214     (multiple-value-bind (name fndef)
215     (if (functionp name)
216     (values (function-name name) name)
217     (values name (fdefinition name)))
218     (typecase fndef
219     (generic-function
220     (clos::generic-function-lambda-list fndef))
221     (compiled-function
222     (grovel-docstring-for-arglist name 'function))
223     (function
224     (let ((fle (function-lambda-expression fndef)))
225     (case (car fle)
226     (si:lambda-block (caddr fle))
227     (t :not-available)))))))
228     (t :not-available)))
229 jgarcia 1.1
230 heller 1.6 (defimplementation function-name (f)
231 jgarcia 1.1 (si:compiled-function-name f))
232    
233     (defimplementation macroexpand-all (form)
234     ;;; FIXME! This is not the same as a recursive macroexpansion!
235     (macroexpand form))
236    
237     (defimplementation describe-symbol-for-emacs (symbol)
238     (let ((result '()))
239     (dolist (type '(:VARIABLE :FUNCTION :CLASS))
240     (let ((doc (describe-definition symbol type)))
241     (when doc
242     (setf result (list* type doc result)))))
243     result))
244    
245     (defimplementation describe-definition (name type)
246     (case type
247     (:variable (documentation name 'variable))
248     (:function (documentation name 'function))
249     (:class (documentation name 'class))
250     (t nil)))
251    
252     ;;; Debugging
253    
254 heller 1.29 (eval-when (:compile-toplevel :load-toplevel :execute)
255 heller 1.28 (import
256     '(si::*break-env*
257     si::*ihs-top*
258     si::*ihs-current*
259     si::*ihs-base*
260     si::*frs-base*
261     si::*frs-top*
262     si::*tpl-commands*
263     si::*tpl-level*
264     si::frs-top
265     si::ihs-top
266     si::ihs-fun
267     si::ihs-env
268     si::sch-frs-base
269     si::set-break-env
270     si::set-current-ihs
271     si::tpl-commands)))
272 jgarcia 1.1
273 gcarncross 1.20 (defvar *backtrace* '())
274    
275 gcarncross 1.21 (defun in-swank-package-p (x)
276 gcarncross 1.22 (and
277     (symbolp x)
278     (member (symbol-package x)
279     (list #.(find-package :swank)
280     #.(find-package :swank-backend)
281     #.(ignore-errors (find-package :swank-mop))
282     #.(ignore-errors (find-package :swank-loader))))
283     t))
284    
285     (defun is-swank-source-p (name)
286     (setf name (pathname name))
287     (pathname-match-p
288     name
289     (make-pathname :defaults swank-loader::*source-directory*
290     :name (pathname-name name)
291     :type (pathname-type name)
292     :version (pathname-version name))))
293    
294     (defun is-ignorable-fun-p (x)
295     (or
296     (in-swank-package-p (frame-name x))
297     (multiple-value-bind (file position)
298     (ignore-errors (si::bc-file (car x)))
299     (declare (ignore position))
300     (if file (is-swank-source-p file)))))
301 gcarncross 1.21
302 gcarncross 1.45 #+#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
303 gcarncross 1.40 (defmacro find-ihs-top (x)
304     (if (< ext:+ecl-version-number+ 90601)
305     `(si::ihs-top ,x)
306     '(si::ihs-top)))
307    
308 gcarncross 1.45 #-#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
309     (defmacro find-ihs-top (x)
310     `(si::ihs-top ,x))
311    
312 jgarcia 1.1 (defimplementation call-with-debugging-environment (debugger-loop-fn)
313     (declare (type function debugger-loop-fn))
314     (let* ((*tpl-commands* si::tpl-commands)
315 gcarncross 1.40 (*ihs-top* (find-ihs-top 'call-with-debugging-environment))
316 trittweiler 1.31 (*ihs-current* *ihs-top*)
317     (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
318     (*frs-top* (frs-top))
319     (*read-suppress* nil)
320     (*tpl-level* (1+ *tpl-level*))
321 gcarncross 1.40 (*backtrace* (loop for ihs from 0 below *ihs-top*
322 gcarncross 1.21 collect (list (si::ihs-fun ihs)
323 gcarncross 1.20 (si::ihs-env ihs)
324     nil))))
325 gcarncross 1.40 (declare (special *ihs-current*))
326 gcarncross 1.20 (loop for f from *frs-base* until *frs-top*
327     do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
328     (when (plusp i)
329     (let* ((x (elt *backtrace* i))
330     (name (si::frs-tag f)))
331 gcarncross 1.23 (unless (si::fixnump name)
332 gcarncross 1.20 (push name (third x)))))))
333 gcarncross 1.22 (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
334 trittweiler 1.31 (setf *tmp* *backtrace*)
335 jgarcia 1.1 (set-break-env)
336     (set-current-ihs)
337 gcarncross 1.20 (let ((*ihs-base* *ihs-top*))
338     (funcall debugger-loop-fn))))
339    
340     (defimplementation call-with-debugger-hook (hook fun)
341     (let ((*debugger-hook* hook)
342 gcarncross 1.40 (*ihs-base* (find-ihs-top 'call-with-debugger-hook)))
343 gcarncross 1.20 (funcall fun)))
344 jgarcia 1.1
345     (defimplementation compute-backtrace (start end)
346 gcarncross 1.20 (when (numberp end)
347     (setf end (min end (length *backtrace*))))
348 trittweiler 1.31 (loop for f in (subseq *backtrace* start end)
349 heller 1.35 collect f))
350 gcarncross 1.20
351     (defun frame-name (frame)
352     (let ((x (first frame)))
353     (if (symbolp x)
354     x
355     (function-name x))))
356    
357     (defun function-position (fun)
358     (multiple-value-bind (file position)
359     (si::bc-file fun)
360     (and file (make-location `(:file ,file) `(:position ,position)))))
361    
362     (defun frame-function (frame)
363     (let* ((x (first frame))
364     fun position)
365     (etypecase x
366     (symbol (and (fboundp x)
367     (setf fun (fdefinition x)
368     position (function-position fun))))
369     (function (setf fun x position (function-position x))))
370     (values fun position)))
371    
372     (defun frame-decode-env (frame)
373     (let ((functions '())
374     (blocks '())
375     (variables '()))
376 gcarncross 1.45 #+#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
377 gcarncross 1.40 #.(if (< ext:+ecl-version-number+ 90601)
378     '(setf frame (second frame))
379     '(setf frame (si::decode-ihs-env (second frame))))
380 gcarncross 1.45 #-#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
381     '(setf frame (second frame))
382 gcarncross 1.40 (dolist (record frame)
383 gcarncross 1.20 (let* ((record0 (car record))
384     (record1 (cdr record)))
385 gcarncross 1.40 (cond ((or (symbolp record0) (stringp record0))
386 gcarncross 1.20 (setq variables (acons record0 record1 variables)))
387 gcarncross 1.23 ((not (si::fixnump record0))
388 gcarncross 1.20 (push record1 functions))
389     ((symbolp record1)
390     (push record1 blocks))
391     (t
392     ))))
393     (values functions blocks variables)))
394 jgarcia 1.1
395 heller 1.35 (defimplementation print-frame (frame stream)
396     (format stream "~A" (first frame)))
397 gcarncross 1.20
398 heller 1.41 (defimplementation frame-source-location (frame-number)
399 gcarncross 1.20 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
400    
401     (defimplementation frame-catch-tags (frame-number)
402     (third (elt *backtrace* frame-number)))
403    
404     (defimplementation frame-locals (frame-number)
405     (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
406     with i = 0
407     collect (list :name name :id (prog1 i (incf i)) :value value)))
408    
409     (defimplementation frame-var-value (frame-number var-id)
410     (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
411     var-id))
412    
413     (defimplementation disassemble-frame (frame-number)
414     (let ((fun (frame-fun (elt *backtrace* frame-number))))
415     (disassemble fun)))
416    
417     (defimplementation eval-in-frame (form frame-number)
418     (let ((env (second (elt *backtrace* frame-number))))
419     (si:eval-with-env form env)))
420 jgarcia 1.1
421     ;;;; Inspector
422    
423 heller 1.13 (defmethod emacs-inspect ((o t))
424 gcarncross 1.11 ; ecl clos support leaves some to be desired
425     (cond
426     ((streamp o)
427 heller 1.14 (list*
428     (format nil "~S is an ordinary stream~%" o)
429 gcarncross 1.11 (append
430     (list
431     "Open for "
432     (cond
433     ((ignore-errors (interactive-stream-p o)) "Interactive")
434     ((and (input-stream-p o) (output-stream-p o)) "Input and output")
435     ((input-stream-p o) "Input")
436     ((output-stream-p o) "Output"))
437     `(:newline) `(:newline))
438     (label-value-line*
439     ("Element type" (stream-element-type o))
440     ("External format" (stream-external-format o)))
441     (ignore-errors (label-value-line*
442     ("Broadcast streams" (broadcast-stream-streams o))))
443     (ignore-errors (label-value-line*
444     ("Concatenated streams" (concatenated-stream-streams o))))
445     (ignore-errors (label-value-line*
446     ("Echo input stream" (echo-stream-input-stream o))))
447     (ignore-errors (label-value-line*
448     ("Echo output stream" (echo-stream-output-stream o))))
449     (ignore-errors (label-value-line*
450     ("Output String" (get-output-stream-string o))))
451     (ignore-errors (label-value-line*
452     ("Synonym symbol" (synonym-stream-symbol o))))
453     (ignore-errors (label-value-line*
454     ("Input stream" (two-way-stream-input-stream o))))
455     (ignore-errors (label-value-line*
456     ("Output stream" (two-way-stream-output-stream o)))))))
457     (t
458     (let* ((cl (si:instance-class o))
459     (slots (clos:class-slots cl)))
460 heller 1.14 (list* (format nil "~S is an instance of class ~A~%"
461 gcarncross 1.11 o (clos::class-name cl))
462     (loop for x in slots append
463     (let* ((name (clos:slot-definition-name x))
464     (value (clos::slot-value o name)))
465     (list
466     (format nil "~S: " name)
467     `(:value ,value)
468     `(:newline)))))))))
469    
470 jgarcia 1.1 ;;;; Definitions
471    
472 gcarncross 1.19 (defimplementation find-definitions (name)
473     (if (fboundp name)
474     (let ((tmp (find-source-location (symbol-function name))))
475     `(((defun ,name) ,tmp)))))
476 gcarncross 1.9
477 gcarncross 1.17 (defimplementation find-source-location (obj)
478 gcarncross 1.19 (setf *tmp* obj)
479 gcarncross 1.17 (or
480     (typecase obj
481     (function
482 gcarncross 1.20 (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj))
483 gcarncross 1.17 (if (and file pos)
484 gcarncross 1.18 (make-location
485 gcarncross 1.19 `(:file ,(namestring file))
486 gcarncross 1.18 `(:position ,pos)
487     `(:snippet
488     ,(with-open-file (s file)
489 gcarncross 1.45
490     #+#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
491 gcarncross 1.40 (if (< ext:+ecl-version-number+ 90601)
492     (skip-toplevel-forms pos s)
493     (file-position s pos))
494 gcarncross 1.45 #-#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
495     (skip-toplevel-forms pos s)
496 gcarncross 1.18 (skip-comments-and-whitespace s)
497     (read-snippet s))))))))
498 gcarncross 1.17 `(:error (format nil "Source definition of ~S not found" obj))))
499    
500 gcarncross 1.42 ;;;; Profiling
501    
502     (eval-when (:compile-toplevel :load-toplevel :execute)
503     (require 'profile))
504    
505     (defimplementation profile (fname)
506     (when fname (eval `(profile:profile ,fname))))
507    
508     (defimplementation unprofile (fname)
509     (when fname (eval `(profile:unprofile ,fname))))
510    
511     (defimplementation unprofile-all ()
512     (profile:unprofile-all)
513     "All functions unprofiled.")
514    
515     (defimplementation profile-report ()
516     (profile:report))
517    
518     (defimplementation profile-reset ()
519     (profile:reset)
520     "Reset profiling counters.")
521    
522     (defimplementation profiled-functions ()
523     (profile:profile))
524    
525 gcarncross 1.43 (defimplementation profile-package (package callers methods)
526     (declare (ignore callers methods))
527     (eval `(profile:profile ,(package-name (find-package package)))))
528    
529    
530 gcarncross 1.9 ;;;; Threads
531    
532     #+threads
533     (progn
534     (defvar *thread-id-counter* 0)
535    
536     (defvar *thread-id-counter-lock*
537     (mp:make-lock :name "thread id counter lock"))
538    
539     (defun next-thread-id ()
540     (mp:with-lock (*thread-id-counter-lock*)
541     (incf *thread-id-counter*)))
542    
543     (defparameter *thread-id-map* (make-hash-table))
544 heller 1.26 (defparameter *id-thread-map* (make-hash-table))
545 gcarncross 1.9
546     (defvar *thread-id-map-lock*
547     (mp:make-lock :name "thread id map lock"))
548    
549     ; ecl doesn't have weak pointers
550     (defimplementation spawn (fn &key name)
551     (let ((thread (mp:make-process :name name))
552     (id (next-thread-id)))
553     (mp:process-preset
554     thread
555     #'(lambda ()
556     (unwind-protect
557     (mp:with-lock (*thread-id-map-lock*)
558 heller 1.26 (setf (gethash id *thread-id-map*) thread)
559     (setf (gethash thread *id-thread-map*) id))
560 gcarncross 1.9 (funcall fn)
561     (mp:with-lock (*thread-id-map-lock*)
562 heller 1.26 (remhash thread *id-thread-map*)
563 gcarncross 1.9 (remhash id *thread-id-map*)))))
564     (mp:process-enable thread)))
565    
566     (defimplementation thread-id (thread)
567     (block thread-id
568     (mp:with-lock (*thread-id-map-lock*)
569 heller 1.26 (or (gethash thread *id-thread-map*)
570     (let ((id (next-thread-id)))
571     (setf (gethash id *thread-id-map*) thread)
572     (setf (gethash thread *id-thread-map*) id)
573     id)))))
574 gcarncross 1.9
575     (defimplementation find-thread (id)
576     (mp:with-lock (*thread-id-map-lock*)
577     (gethash id *thread-id-map*)))
578    
579     (defimplementation thread-name (thread)
580     (mp:process-name thread))
581    
582     (defimplementation thread-status (thread)
583     (if (mp:process-active-p thread)
584     "RUNNING"
585     "STOPPED"))
586    
587     (defimplementation make-lock (&key name)
588     (mp:make-lock :name name))
589    
590     (defimplementation call-with-lock-held (lock function)
591     (declare (type function function))
592     (mp:with-lock (lock) (funcall function)))
593    
594     (defimplementation current-thread ()
595     mp:*current-process*)
596    
597     (defimplementation all-threads ()
598     (mp:all-processes))
599    
600     (defimplementation interrupt-thread (thread fn)
601     (mp:interrupt-process thread fn))
602    
603     (defimplementation kill-thread (thread)
604     (mp:process-kill thread))
605    
606     (defimplementation thread-alive-p (thread)
607     (mp:process-active-p thread))
608    
609     (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
610    
611     (defstruct (mailbox (:conc-name mailbox.))
612     (mutex (mp:make-lock :name "process mailbox"))
613     (queue '() :type list))
614    
615     (defun mailbox (thread)
616     "Return THREAD's mailbox."
617     (mp:with-lock (*mailbox-lock*)
618     (or (find thread *mailboxes* :key #'mailbox.thread)
619     (let ((mb (make-mailbox :thread thread)))
620     (push mb *mailboxes*)
621     mb))))
622    
623     (defimplementation send (thread message)
624     (let* ((mbox (mailbox thread))
625     (mutex (mailbox.mutex mbox)))
626     (mp:interrupt-process
627     thread
628     (lambda ()
629     (mp:with-lock (mutex)
630     (setf (mailbox.queue mbox)
631     (nconc (mailbox.queue mbox) (list message))))))))
632    
633     (defimplementation receive ()
634     (block got-mail
635     (let* ((mbox (mailbox mp:*current-process*))
636     (mutex (mailbox.mutex mbox)))
637     (loop
638     (mp:with-lock (mutex)
639     (if (mailbox.queue mbox)
640     (return-from got-mail (pop (mailbox.queue mbox)))))
641     ;interrupt-process will halt this if it takes longer than 1sec
642     (sleep 1)))))
643    
644     (defmethod stream-finish-output ((stream stream))
645     (finish-output stream))
646    
647     )
648    

  ViewVC Help
Powered by ViewVC 1.1.5