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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.52 - (hide annotations)
Sun Aug 1 06:26:02 2004 UTC (9 years, 8 months ago) by heller
Branch: MAIN
CVS Tags: SLIME-1-0-BETA
Changes since 1.51: +25 -30 lines
Minor refactoring.
1 lgorrie 1.17 ;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 heller 1.1 ;;;
3     ;;; swank-lispworks.lisp --- LispWorks specific code for SLIME.
4     ;;;
5     ;;; Created 2003, Helmut Eller
6     ;;;
7     ;;; This code has been placed in the Public Domain. All warranties
8     ;;; are disclaimed.
9     ;;;
10    
11 heller 1.30 (in-package :swank-backend)
12 heller 1.1
13     (eval-when (:compile-toplevel :load-toplevel :execute)
14     (require "comm"))
15    
16     (import
17     '(stream:fundamental-character-output-stream
18     stream:stream-write-char
19     stream:stream-force-output
20     stream:fundamental-character-input-stream
21     stream:stream-read-char
22     stream:stream-listen
23     stream:stream-unread-char
24     stream:stream-clear-input
25     stream:stream-line-column
26     ))
27    
28 heller 1.49 (when (fboundp 'dspec::define-form-parser)
29     (dspec::define-form-parser defimplementation (name args &rest body)
30     `(defmethod ,name ,args ,@body)))
31    
32 heller 1.13 ;;; TCP server
33 lgorrie 1.12
34 heller 1.30 (defimplementation preferred-communication-style ()
35     :spawn)
36 heller 1.18
37 heller 1.13 (defun socket-fd (socket)
38     (etypecase socket
39     (fixnum socket)
40     (comm:socket-stream (comm:socket-stream-socket socket))))
41    
42 heller 1.22 (defimplementation create-socket (host port)
43 heller 1.13 (multiple-value-bind (socket where errno)
44 heller 1.37 #-lispworks4.1(comm::create-tcp-socket-for-service port :address host)
45     #+lispworks4.1(comm::create-tcp-socket-for-service port)
46 heller 1.13 (cond (socket socket)
47 heller 1.14 (t (error 'network-error
48 heller 1.13 :format-control "~A failed: ~A (~D)"
49     :format-arguments (list where
50     (list #+unix (lw:get-unix-error errno))
51 heller 1.14 errno))))))
52 heller 1.13
53 lgorrie 1.17 (defimplementation local-port (socket)
54 heller 1.13 (nth-value 1 (comm:get-socket-address (socket-fd socket))))
55    
56 lgorrie 1.17 (defimplementation close-socket (socket)
57 heller 1.13 (comm::close-socket (socket-fd socket)))
58    
59 lgorrie 1.17 (defimplementation accept-connection (socket)
60 heller 1.13 (let ((fd (comm::get-fd-from-socket socket)))
61     (assert (/= fd -1))
62     (make-instance 'comm:socket-stream :socket fd :direction :io
63     :element-type 'base-char)))
64    
65 heller 1.37 (defun set-sigint-handler ()
66     ;; Set SIGINT handler on Swank request handler thread.
67     #-win32
68     (sys::set-signal-handler +sigint+
69     (make-sigint-handler mp:*current-process*)))
70    
71 heller 1.43 (defimplementation emacs-connected (stream)
72     (declare (ignore stream))
73 heller 1.37 (set-sigint-handler)
74 heller 1.36 (let ((lw:*handle-warn-on-redefinition* :warn))
75 heller 1.40 (defmethod stream:stream-soft-force-output ((o comm:socket-stream))
76     (force-output o))
77     (defmethod stream:stream-soft-force-output ((o slime-output-stream))
78     (force-output o))
79 heller 1.36 (defmethod env-internals:environment-display-notifier
80     (env &key restarts condition)
81 heller 1.40 (declare (ignore restarts))
82 heller 1.36 (funcall (find-symbol (string :swank-debugger-hook) :swank)
83 heller 1.49 condition *debugger-hook*))
84     (defmethod env-internals:environment-display-debugger
85     (env)
86     *debug-io*)))
87 heller 1.36
88 heller 1.15 ;;; Unix signals
89    
90 heller 1.18 (defun sigint-handler ()
91 heller 1.16 (with-simple-restart (continue "Continue from SIGINT handler.")
92     (invoke-debugger "SIGINT")))
93 heller 1.1
94 heller 1.18 (defun make-sigint-handler (process)
95     (lambda (&rest args)
96     (declare (ignore args))
97     (mp:process-interrupt process #'sigint-handler)))
98    
99 heller 1.38 (defimplementation call-without-interrupts (fn)
100 heller 1.37 (lw:without-interrupts (funcall fn)))
101 heller 1.48
102 heller 1.29 (defimplementation getpid ()
103     #+win32 (win32:get-current-process-id)
104     #-win32 (system::getpid))
105 heller 1.1
106 heller 1.23 (defimplementation lisp-implementation-type-name ()
107     "lispworks")
108    
109 heller 1.36 (defimplementation set-default-directory (directory)
110     (namestring (hcl:change-directory directory)))
111 heller 1.40
112     ;;;; Documentation
113 heller 1.36
114 heller 1.30 (defimplementation arglist (symbol)
115     (let ((arglist (lw:function-lambda-list symbol)))
116     (etypecase arglist
117 heller 1.39 ((member :dont-know)
118     :not-available)
119     (list
120     arglist))))
121 heller 1.1
122 lgorrie 1.17 (defimplementation macroexpand-all (form)
123 heller 1.1 (walker:walk-form form))
124    
125 heller 1.37 (defun generic-function-p (object)
126 heller 1.36 (typep object 'generic-function))
127    
128 lgorrie 1.17 (defimplementation describe-symbol-for-emacs (symbol)
129 heller 1.1 "Return a plist describing SYMBOL.
130     Return NIL if the symbol is unbound."
131     (let ((result '()))
132     (labels ((first-line (string)
133     (let ((pos (position #\newline string)))
134     (if (null pos) string (subseq string 0 pos))))
135     (doc (kind &optional (sym symbol))
136     (let ((string (documentation sym kind)))
137     (if string
138     (first-line string)
139     :not-documented)))
140     (maybe-push (property value)
141     (when value
142     (setf result (list* property value result)))))
143     (maybe-push
144     :variable (when (boundp symbol)
145     (doc 'variable)))
146     (maybe-push
147 heller 1.36 :generic-function (if (and (fboundp symbol)
148 heller 1.37 (generic-function-p (fdefinition symbol)))
149 heller 1.36 (doc 'function)))
150     (maybe-push
151     :function (if (and (fboundp symbol)
152 heller 1.37 (not (generic-function-p (fdefinition symbol))))
153 heller 1.1 (doc 'function)))
154     (maybe-push
155 heller 1.49 :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol))))
156     (if (fboundp setf-name)
157     (doc 'setf))))
158     (maybe-push
159 heller 1.1 :class (if (find-class symbol nil)
160     (doc 'class)))
161 heller 1.30 result)))
162 heller 1.1
163 heller 1.30 (defimplementation describe-definition (symbol type)
164     (ecase type
165     (:variable (describe-symbol symbol))
166     (:class (describe (find-class symbol)))
167 heller 1.49 ((:function :generic-function) (describe-function symbol))
168     (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol))))))
169 heller 1.30
170     (defun describe-function (symbol)
171     (cond ((fboundp symbol)
172     (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"
173     (string-downcase symbol)
174     (mapcar #'string-upcase
175     (lispworks:function-lambda-list symbol))
176     (documentation symbol 'function))
177 heller 1.38 (describe (fdefinition symbol)))
178 heller 1.30 (t (format t "~S is not fbound" symbol))))
179 heller 1.4
180 heller 1.30 (defun describe-symbol (sym)
181 heller 1.1 (format t "~A is a symbol in package ~A." sym (symbol-package sym))
182     (when (boundp sym)
183     (format t "~%~%Value: ~A" (symbol-value sym)))
184     (let ((doc (documentation sym 'variable)))
185     (when doc
186     (format t "~%~%Variable documentation:~%~A" doc)))
187     (when (fboundp sym)
188 heller 1.30 (describe-function sym)))
189 heller 1.1
190     ;;; Debugging
191    
192 heller 1.26 (defvar *sldb-top-frame*)
193 heller 1.1
194     (defun interesting-frame-p (frame)
195 heller 1.36 (cond ((or (dbg::call-frame-p frame)
196     (dbg::derived-call-frame-p frame)
197     (dbg::foreign-frame-p frame)
198     (dbg::interpreted-call-frame-p frame))
199     t)
200     ((dbg::catch-frame-p frame) dbg:*print-catch-frames*)
201     ((dbg::binding-frame-p frame) dbg:*print-binding-frames*)
202     ((dbg::handler-frame-p frame) dbg:*print-handler-frames*)
203     ((dbg::restart-frame-p frame) dbg:*print-restart-frames*)
204     ((dbg::open-frame-p frame) dbg:*print-open-frames*)
205     (t nil)))
206 heller 1.1
207 heller 1.41 (defun nth-next-frame (frame n)
208     "Unwind FRAME N times."
209     (do ((frame frame (dbg::frame-next frame))
210     (i n (if (interesting-frame-p frame) (1- i) i)))
211 heller 1.48 ((or (not frame)
212     (and (interesting-frame-p frame) (zerop i)))
213     frame)))
214 heller 1.41
215     (defun nth-frame (index)
216     (nth-next-frame *sldb-top-frame* index))
217    
218     (defun find-top-frame ()
219     "Return the most suitable top-frame for the debugger."
220     (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
221     (nth-next-frame frame 1)))
222     ((and (dbg::call-frame-p frame)
223     (eq (dbg::call-frame-function-name frame)
224     'invoke-debugger))
225     (nth-next-frame frame 1))))
226    
227     (defimplementation call-with-debugging-environment (fn)
228     (dbg::with-debugger-stack ()
229     (let ((*sldb-top-frame* (find-top-frame)))
230     (funcall fn))))
231 heller 1.1
232 heller 1.30 (defimplementation compute-backtrace (start end)
233 heller 1.1 (let ((end (or end most-positive-fixnum))
234     (backtrace '()))
235     (do ((frame (nth-frame start) (dbg::frame-next frame))
236     (i start))
237     ((or (not frame) (= i end)) (nreverse backtrace))
238     (when (interesting-frame-p frame)
239     (incf i)
240     (push frame backtrace)))))
241    
242 heller 1.36 (defun frame-actual-args (frame)
243 heller 1.50 (let ((*break-on-signals* nil))
244     (mapcar (lambda (arg)
245     (case arg
246     ((&rest &optional &key) arg)
247     (t
248     (handler-case (dbg::dbg-eval arg frame)
249     (error (format nil "<~A>" arg))))))
250     (dbg::call-frame-arglist frame))))
251 heller 1.36
252 heller 1.30 (defimplementation print-frame (frame stream)
253     (cond ((dbg::call-frame-p frame)
254 heller 1.36 (format stream "~S ~S"
255 heller 1.30 (dbg::call-frame-function-name frame)
256 heller 1.36 (frame-actual-args frame)))
257 heller 1.30 (t (princ frame stream))))
258 heller 1.1
259 heller 1.47 (defun frame-vars (frame)
260     (first (dbg::frame-locals-format-list frame #'list 75 0)))
261    
262 lgorrie 1.17 (defimplementation frame-locals (n)
263 heller 1.29 (let ((frame (nth-frame n)))
264 heller 1.1 (if (dbg::call-frame-p frame)
265 heller 1.47 (mapcar (lambda (var)
266     (destructuring-bind (name value symbol location) var
267     (declare (ignore name location))
268     (list :name symbol :id 0
269     :value value)))
270     (frame-vars frame)))))
271    
272     (defimplementation frame-var-value (frame var)
273     (let ((frame (nth-frame frame)))
274     (destructuring-bind (_n value _s _l) (nth var (frame-vars frame))
275     (declare (ignore _n _s _l))
276     value)))
277 heller 1.1
278 lgorrie 1.17 (defimplementation frame-catch-tags (index)
279 heller 1.1 (declare (ignore index))
280     nil)
281    
282 lgorrie 1.17 (defimplementation frame-source-location-for-emacs (frame)
283 heller 1.1 (let ((frame (nth-frame frame)))
284     (if (dbg::call-frame-p frame)
285 heller 1.33 (let ((name (dbg::call-frame-function-name frame)))
286     (if name
287     (function-name-location name))))))
288 heller 1.26
289     (defimplementation eval-in-frame (form frame-number)
290     (let ((frame (nth-frame frame-number)))
291     (dbg::dbg-eval form frame)))
292    
293     (defimplementation return-from-frame (frame-number form)
294     (let* ((frame (nth-frame frame-number))
295 heller 1.30 (return-frame (dbg::find-frame-for-return frame)))
296 heller 1.26 (dbg::dbg-return-from-call-frame frame form return-frame
297     dbg::*debugger-stack*)))
298    
299     (defimplementation restart-frame (frame-number)
300     (let ((frame (nth-frame frame-number)))
301     (dbg::restart-frame frame :same-args t)))
302 heller 1.1
303 heller 1.18 ;;; Definition finding
304    
305 heller 1.33 (defun function-name-location (name)
306     (let ((defs (find-definitions name)))
307     (cond (defs (cadr (first defs)))
308     (t (list :error (format nil "Source location not available for: ~S"
309     name))))))
310 heller 1.4
311 heller 1.33 (defimplementation find-definitions (name)
312 heller 1.26 (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
313 heller 1.33 (loop for (dspec location) in locations
314     collect (list dspec (make-dspec-location dspec location)))))
315 heller 1.6
316 heller 1.18 ;;; Compilation
317    
318 msimmons 1.42 (defmacro with-swank-compilation-unit ((location &rest options) &body body)
319     (lw:rebinding (location)
320     `(let ((compiler::*error-database* '()))
321     (with-compilation-unit ,options
322     ,@body
323     (signal-error-data-base compiler::*error-database* ,location)
324     (signal-undefined-functions compiler::*unknown-functions* ,location)))))
325    
326 heller 1.30 (defimplementation swank-compile-file (filename load-p)
327 msimmons 1.42 (with-swank-compilation-unit (filename)
328     (compile-file filename :load load-p)))
329 heller 1.1
330     (defun map-error-database (database fn)
331     (loop for (filename . defs) in database do
332     (loop for (dspec . conditions) in defs do
333     (dolist (c conditions)
334     (funcall fn filename dspec c)))))
335    
336     (defun lispworks-severity (condition)
337     (cond ((not condition) :warning)
338     (t (etypecase condition
339 heller 1.6 (error :error)
340 heller 1.1 (style-warning :warning)
341     (warning :warning)))))
342    
343     (defun signal-compiler-condition (message location condition)
344     (check-type message string)
345     (signal
346     (make-instance 'compiler-condition :message message
347     :severity (lispworks-severity condition)
348     :location location
349     :original-condition condition)))
350    
351     (defun compile-from-temp-file (string filename)
352     (unwind-protect
353     (progn
354     (with-open-file (s filename :direction :output :if-exists :supersede)
355     (write-string string s)
356     (finish-output s))
357     (let ((binary-filename (compile-file filename :load t)))
358 heller 1.6 (when binary-filename
359     (delete-file binary-filename))))
360 heller 1.1 (delete-file filename)))
361    
362 heller 1.34 (defun dspec-buffer-position (dspec offset)
363     (etypecase dspec
364     (cons (let ((name (dspec:dspec-primary-name dspec)))
365 heller 1.37 (typecase name
366 heller 1.34 ((or symbol string)
367     (list :function-name (string name)))
368     (t (list :position offset)))))
369     (null (list :position offset))
370     (symbol (list :function-name (string dspec)))))
371 heller 1.18
372 lgorrie 1.45 (defmacro with-fairly-standard-io-syntax (&body body)
373     "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*."
374     (let ((package (gensym))
375     (readtable (gensym)))
376     `(let ((,package *package*)
377     (,readtable *readtable*))
378     (with-standard-io-syntax
379     (let ((*package* ,package)
380     (*readtable* ,readtable))
381     ,@body)))))
382    
383 heller 1.52 #-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
384 msimmons 1.42 (defun dspec-stream-position (stream dspec)
385 lgorrie 1.45 (with-fairly-standard-io-syntax
386 lgorrie 1.44 (loop (let* ((pos (file-position stream))
387     (form (read stream nil '#1=#:eof)))
388     (when (eq form '#1#)
389     (return nil))
390     (labels ((check-dspec (form)
391     (when (consp form)
392     (let ((operator (car form)))
393     (case operator
394     ((progn)
395     (mapcar #'check-dspec
396     (cdr form)))
397     ((eval-when locally macrolet symbol-macrolet)
398     (mapcar #'check-dspec
399     (cddr form)))
400     ((in-package)
401     (let ((package (find-package (second form))))
402     (when package
403     (setq *package* package))))
404     (otherwise
405     (let ((form-dspec (dspec:parse-form-dspec form)))
406     (when (dspec:dspec-equal dspec form-dspec)
407     (return pos)))))))))
408     (check-dspec form))))))
409 msimmons 1.42
410 heller 1.52 (defun dspec-file-position (file dspec)
411     (with-open-file (stream file)
412     (let ((pos
413     #-(or lispworks4.1 lispworks4.2)
414     (dspec-stream-position stream dspec)))
415     (if pos
416     (list :position (1+ pos) t)
417     (dspec-buffer-position dspec 1)))))
418    
419 heller 1.25 (defun emacs-buffer-location-p (location)
420     (and (consp location)
421     (eq (car location) :emacs-buffer)))
422    
423 heller 1.26 (defun make-dspec-location (dspec location)
424 heller 1.52 (etypecase location
425     ((or pathname string)
426     (multiple-value-bind (file err)
427     (ignore-errors (namestring (truename location)))
428     (if err
429     (list :error (princ-to-string err))
430     (make-location `(:file ,file)
431     (dspec-file-position file dspec)))))
432     (symbol
433     `(:error ,(format nil "Cannot resolve location: ~S" location)))
434     ((satisfies emacs-buffer-location-p)
435     (destructuring-bind (_ buffer offset string) location
436     (declare (ignore _ string))
437     (make-location `(:buffer ,buffer)
438     (dspec-buffer-position dspec offset))))))
439 heller 1.1
440 msimmons 1.42 (defun make-dspec-progenitor-location (dspec location)
441     (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
442     (make-dspec-location
443     (if canon-dspec
444     (if (dspec:local-dspec-p canon-dspec)
445     (dspec:dspec-progenitor canon-dspec)
446     canon-dspec)
447     nil)
448     location)))
449    
450 heller 1.26 (defun signal-error-data-base (database location)
451 heller 1.1 (map-error-database
452     database
453     (lambda (filename dspec condition)
454 heller 1.26 (declare (ignore filename))
455 heller 1.1 (signal-compiler-condition
456     (format nil "~A" condition)
457 msimmons 1.42 (make-dspec-progenitor-location dspec location)
458 heller 1.1 condition))))
459    
460 heller 1.26 (defun signal-undefined-functions (htab filename)
461 heller 1.1 (maphash (lambda (unfun dspecs)
462     (dolist (dspec dspecs)
463     (signal-compiler-condition
464     (format nil "Undefined function ~A" unfun)
465 msimmons 1.42 (make-dspec-progenitor-location dspec filename)
466 heller 1.1 nil)))
467     htab))
468 heller 1.2
469 heller 1.30 (defimplementation swank-compile-string (string &key buffer position)
470 heller 1.1 (assert buffer)
471     (assert position)
472 heller 1.30 (let* ((location (list :emacs-buffer buffer position string))
473 heller 1.26 (tmpname (hcl:make-temp-file nil "lisp")))
474 msimmons 1.42 (with-swank-compilation-unit (location)
475 heller 1.26 (compile-from-temp-file
476 heller 1.35 (format nil "~S~%~A" `(eval-when (:compile-toplevel)
477     (setq dspec::*location* (list ,@location)))
478     string)
479 msimmons 1.42 tmpname))))
480 heller 1.1
481 heller 1.3 ;;; xref
482    
483 heller 1.31 (defmacro defxref (name function)
484     `(defimplementation ,name (name)
485     (xref-results (,function name))))
486    
487     (defxref who-calls hcl:who-calls)
488 msimmons 1.42 (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
489 heller 1.31 (defxref list-callees hcl:calls-who)
490 msimmons 1.42 (defxref list-callers list-callers-internal)
491    
492     (defun list-callers-internal (name)
493     (let ((callers (make-array 100
494     :fill-pointer 0
495     :adjustable t)))
496     (hcl:sweep-all-objects
497     #'(lambda (object)
498     (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
499     #-Harlequin-PC-Lisp (sys::callablep object)
500     (system::find-constant$funcallable name object))
501     (vector-push-extend object callers))))
502     ;; Delay dspec:object-dspec until after sweep-all-objects
503     ;; to reduce allocation problems.
504     (loop for object across callers
505     collect (if (symbolp object)
506     (list 'function object)
507 heller 1.43 (dspec:object-dspec object)))))
508 heller 1.36
509 heller 1.37 ;; only for lispworks 4.2 and above
510     #-lispworks4.1
511     (progn
512     (defxref who-references hcl:who-references)
513     (defxref who-binds hcl:who-binds)
514     (defxref who-sets hcl:who-sets))
515    
516 heller 1.36 (defimplementation who-specializes (classname)
517     (let ((methods (clos:class-direct-methods (find-class classname))))
518     (xref-results (mapcar #'dspec:object-dspec methods))))
519 heller 1.31
520     (defun xref-results (dspecs)
521     (loop for dspec in dspecs
522 heller 1.37 nconc (loop for (dspec location)
523     in (dspec:dspec-definition-locations dspec)
524 heller 1.31 collect (list dspec
525     (make-dspec-location dspec location)))))
526 heller 1.25 ;;; Inspector
527    
528     (defmethod inspected-parts (o)
529     (multiple-value-bind (names values _getter _setter type)
530     (lw:get-inspector-values o nil)
531     (declare (ignore _getter _setter))
532     (values (format nil "~A~% is a ~A" o type)
533 heller 1.37 (mapcar #'cons names values))))
534 heller 1.25
535 lgorrie 1.46 ;;; Miscellaneous
536    
537     (defimplementation quit-lisp ()
538     (lispworks:quit))
539    
540 heller 1.16 ;;; Multithreading
541    
542 heller 1.18 (defimplementation startup-multiprocessing ()
543 heller 1.16 (mp:initialize-multiprocessing))
544    
545 heller 1.18 (defimplementation spawn (fn &key name)
546 heller 1.38 (let ((mp:*process-initial-bindings*
547     (remove (find-package :cl)
548     mp:*process-initial-bindings*
549     :key (lambda (x) (symbol-package (car x))))))
550     (mp:process-run-function name () fn)))
551 heller 1.48
552     (defvar *id-lock* (mp:make-lock))
553     (defvar *thread-id-counter* 0)
554    
555     (defimplementation thread-id (thread)
556     (mp:with-lock (*id-lock*)
557     (or (getf (mp:process-plist thread) 'id)
558     (setf (getf (mp:process-plist thread) 'id)
559     (incf *thread-id-counter*)))))
560    
561     (defimplementation find-thread (id)
562     (find id (mp:list-all-processes)
563     :key (lambda (p) (getf (mp:process-plist p) 'id))))
564 heller 1.16
565 heller 1.21 (defimplementation thread-name (thread)
566     (mp:process-name thread))
567 heller 1.16
568 heller 1.21 (defimplementation thread-status (thread)
569     (format nil "~A ~D"
570     (mp:process-whostate thread)
571     (mp:process-priority thread)))
572 heller 1.16
573 heller 1.18 (defimplementation make-lock (&key name)
574 heller 1.16 (mp:make-lock :name name))
575    
576 heller 1.18 (defimplementation call-with-lock-held (lock function)
577 heller 1.16 (mp:with-lock (lock) (funcall function)))
578 heller 1.20
579     (defimplementation current-thread ()
580     mp:*current-process*)
581 heller 1.21
582     (defimplementation all-threads ()
583     (mp:list-all-processes))
584 heller 1.20
585     (defimplementation interrupt-thread (thread fn)
586     (mp:process-interrupt thread fn))
587 heller 1.25
588     (defimplementation kill-thread (thread)
589     (mp:process-kill thread))
590 heller 1.27
591     (defimplementation thread-alive-p (thread)
592     (mp:process-alive-p thread))
593 heller 1.20
594     (defvar *mailbox-lock* (mp:make-lock))
595    
596     (defun mailbox (thread)
597     (mp:with-lock (*mailbox-lock*)
598     (or (getf (mp:process-plist thread) 'mailbox)
599     (setf (getf (mp:process-plist thread) 'mailbox)
600     (mp:make-mailbox)))))
601    
602     (defimplementation receive ()
603     (mp:mailbox-read (mailbox mp:*current-process*)))
604    
605     (defimplementation send (thread object)
606     (mp:mailbox-send (mailbox thread) object))
607 heller 1.3

  ViewVC Help
Powered by ViewVC 1.1.5