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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.56 - (hide annotations)
Wed Sep 8 16:08:26 2004 UTC (9 years, 7 months ago) by msimmons
Branch: MAIN
Changes since 1.55: +5 -0 lines
Implement call-with-compilation-hooks.
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.55 (when (fboundp 'dspec::define-dspec-alias)
29     (dspec::define-dspec-alias defimplementation (name args &rest body)
30 heller 1.49 `(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 msimmons 1.53 (error (e) (format nil "<~A>" arg))))))
250 heller 1.50 (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 msimmons 1.56
317 heller 1.18 ;;; Compilation
318    
319 msimmons 1.42 (defmacro with-swank-compilation-unit ((location &rest options) &body body)
320     (lw:rebinding (location)
321     `(let ((compiler::*error-database* '()))
322     (with-compilation-unit ,options
323     ,@body
324     (signal-error-data-base compiler::*error-database* ,location)
325     (signal-undefined-functions compiler::*unknown-functions* ,location)))))
326    
327 heller 1.30 (defimplementation swank-compile-file (filename load-p)
328 msimmons 1.42 (with-swank-compilation-unit (filename)
329     (compile-file filename :load load-p)))
330 msimmons 1.56
331     (defimplementation call-with-compilation-hooks (function)
332     ;; #'pray instead of #'handler-bind
333     (funcall function))
334 heller 1.1
335     (defun map-error-database (database fn)
336     (loop for (filename . defs) in database do
337     (loop for (dspec . conditions) in defs do
338     (dolist (c conditions)
339     (funcall fn filename dspec c)))))
340    
341     (defun lispworks-severity (condition)
342     (cond ((not condition) :warning)
343     (t (etypecase condition
344 heller 1.6 (error :error)
345 heller 1.1 (style-warning :warning)
346     (warning :warning)))))
347    
348     (defun signal-compiler-condition (message location condition)
349     (check-type message string)
350     (signal
351     (make-instance 'compiler-condition :message message
352     :severity (lispworks-severity condition)
353     :location location
354     :original-condition condition)))
355    
356     (defun compile-from-temp-file (string filename)
357     (unwind-protect
358     (progn
359     (with-open-file (s filename :direction :output :if-exists :supersede)
360     (write-string string s)
361     (finish-output s))
362     (let ((binary-filename (compile-file filename :load t)))
363 heller 1.6 (when binary-filename
364     (delete-file binary-filename))))
365 heller 1.1 (delete-file filename)))
366    
367 heller 1.34 (defun dspec-buffer-position (dspec offset)
368     (etypecase dspec
369     (cons (let ((name (dspec:dspec-primary-name dspec)))
370 heller 1.37 (typecase name
371 heller 1.34 ((or symbol string)
372     (list :function-name (string name)))
373     (t (list :position offset)))))
374     (null (list :position offset))
375     (symbol (list :function-name (string dspec)))))
376 heller 1.18
377 lgorrie 1.45 (defmacro with-fairly-standard-io-syntax (&body body)
378     "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*."
379     (let ((package (gensym))
380     (readtable (gensym)))
381     `(let ((,package *package*)
382     (,readtable *readtable*))
383     (with-standard-io-syntax
384     (let ((*package* ,package)
385     (*readtable* ,readtable))
386     ,@body)))))
387    
388 heller 1.52 #-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
389 msimmons 1.42 (defun dspec-stream-position (stream dspec)
390 lgorrie 1.45 (with-fairly-standard-io-syntax
391 lgorrie 1.44 (loop (let* ((pos (file-position stream))
392     (form (read stream nil '#1=#:eof)))
393     (when (eq form '#1#)
394     (return nil))
395     (labels ((check-dspec (form)
396     (when (consp form)
397     (let ((operator (car form)))
398     (case operator
399     ((progn)
400     (mapcar #'check-dspec
401     (cdr form)))
402     ((eval-when locally macrolet symbol-macrolet)
403     (mapcar #'check-dspec
404     (cddr form)))
405     ((in-package)
406     (let ((package (find-package (second form))))
407     (when package
408     (setq *package* package))))
409     (otherwise
410     (let ((form-dspec (dspec:parse-form-dspec form)))
411     (when (dspec:dspec-equal dspec form-dspec)
412     (return pos)))))))))
413     (check-dspec form))))))
414 msimmons 1.42
415 heller 1.52 (defun dspec-file-position (file dspec)
416     (with-open-file (stream file)
417     (let ((pos
418     #-(or lispworks4.1 lispworks4.2)
419     (dspec-stream-position stream dspec)))
420     (if pos
421     (list :position (1+ pos) t)
422     (dspec-buffer-position dspec 1)))))
423    
424 heller 1.25 (defun emacs-buffer-location-p (location)
425     (and (consp location)
426     (eq (car location) :emacs-buffer)))
427    
428 heller 1.26 (defun make-dspec-location (dspec location)
429 heller 1.52 (etypecase location
430     ((or pathname string)
431     (multiple-value-bind (file err)
432     (ignore-errors (namestring (truename location)))
433     (if err
434     (list :error (princ-to-string err))
435     (make-location `(:file ,file)
436     (dspec-file-position file dspec)))))
437     (symbol
438     `(:error ,(format nil "Cannot resolve location: ~S" location)))
439     ((satisfies emacs-buffer-location-p)
440     (destructuring-bind (_ buffer offset string) location
441     (declare (ignore _ string))
442     (make-location `(:buffer ,buffer)
443     (dspec-buffer-position dspec offset))))))
444 heller 1.1
445 msimmons 1.42 (defun make-dspec-progenitor-location (dspec location)
446     (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
447     (make-dspec-location
448     (if canon-dspec
449     (if (dspec:local-dspec-p canon-dspec)
450     (dspec:dspec-progenitor canon-dspec)
451     canon-dspec)
452     nil)
453     location)))
454    
455 heller 1.26 (defun signal-error-data-base (database location)
456 heller 1.1 (map-error-database
457     database
458     (lambda (filename dspec condition)
459 heller 1.26 (declare (ignore filename))
460 heller 1.1 (signal-compiler-condition
461     (format nil "~A" condition)
462 msimmons 1.42 (make-dspec-progenitor-location dspec location)
463 heller 1.1 condition))))
464    
465 heller 1.26 (defun signal-undefined-functions (htab filename)
466 heller 1.1 (maphash (lambda (unfun dspecs)
467     (dolist (dspec dspecs)
468     (signal-compiler-condition
469     (format nil "Undefined function ~A" unfun)
470 msimmons 1.42 (make-dspec-progenitor-location dspec filename)
471 heller 1.1 nil)))
472     htab))
473 heller 1.2
474 pseibel 1.54 (defimplementation swank-compile-string (string &key buffer position directory)
475     (declare (ignore directory))
476 heller 1.1 (assert buffer)
477     (assert position)
478 heller 1.30 (let* ((location (list :emacs-buffer buffer position string))
479 heller 1.26 (tmpname (hcl:make-temp-file nil "lisp")))
480 msimmons 1.42 (with-swank-compilation-unit (location)
481 heller 1.26 (compile-from-temp-file
482 heller 1.35 (format nil "~S~%~A" `(eval-when (:compile-toplevel)
483     (setq dspec::*location* (list ,@location)))
484     string)
485 msimmons 1.42 tmpname))))
486 heller 1.1
487 heller 1.3 ;;; xref
488    
489 heller 1.31 (defmacro defxref (name function)
490     `(defimplementation ,name (name)
491     (xref-results (,function name))))
492    
493     (defxref who-calls hcl:who-calls)
494 msimmons 1.42 (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
495 heller 1.31 (defxref list-callees hcl:calls-who)
496 msimmons 1.42 (defxref list-callers list-callers-internal)
497    
498     (defun list-callers-internal (name)
499     (let ((callers (make-array 100
500     :fill-pointer 0
501     :adjustable t)))
502     (hcl:sweep-all-objects
503     #'(lambda (object)
504     (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
505     #-Harlequin-PC-Lisp (sys::callablep object)
506     (system::find-constant$funcallable name object))
507     (vector-push-extend object callers))))
508     ;; Delay dspec:object-dspec until after sweep-all-objects
509     ;; to reduce allocation problems.
510     (loop for object across callers
511     collect (if (symbolp object)
512     (list 'function object)
513 heller 1.43 (dspec:object-dspec object)))))
514 heller 1.36
515 heller 1.37 ;; only for lispworks 4.2 and above
516     #-lispworks4.1
517     (progn
518     (defxref who-references hcl:who-references)
519     (defxref who-binds hcl:who-binds)
520     (defxref who-sets hcl:who-sets))
521    
522 heller 1.36 (defimplementation who-specializes (classname)
523     (let ((methods (clos:class-direct-methods (find-class classname))))
524     (xref-results (mapcar #'dspec:object-dspec methods))))
525 heller 1.31
526     (defun xref-results (dspecs)
527     (loop for dspec in dspecs
528 heller 1.37 nconc (loop for (dspec location)
529     in (dspec:dspec-definition-locations dspec)
530 heller 1.31 collect (list dspec
531     (make-dspec-location dspec location)))))
532 heller 1.25 ;;; Inspector
533    
534     (defmethod inspected-parts (o)
535     (multiple-value-bind (names values _getter _setter type)
536     (lw:get-inspector-values o nil)
537     (declare (ignore _getter _setter))
538     (values (format nil "~A~% is a ~A" o type)
539 heller 1.37 (mapcar #'cons names values))))
540 heller 1.25
541 lgorrie 1.46 ;;; Miscellaneous
542    
543     (defimplementation quit-lisp ()
544     (lispworks:quit))
545    
546 heller 1.16 ;;; Multithreading
547    
548 heller 1.18 (defimplementation startup-multiprocessing ()
549 heller 1.16 (mp:initialize-multiprocessing))
550    
551 heller 1.18 (defimplementation spawn (fn &key name)
552 heller 1.38 (let ((mp:*process-initial-bindings*
553     (remove (find-package :cl)
554     mp:*process-initial-bindings*
555     :key (lambda (x) (symbol-package (car x))))))
556     (mp:process-run-function name () fn)))
557 heller 1.48
558     (defvar *id-lock* (mp:make-lock))
559     (defvar *thread-id-counter* 0)
560    
561     (defimplementation thread-id (thread)
562     (mp:with-lock (*id-lock*)
563     (or (getf (mp:process-plist thread) 'id)
564     (setf (getf (mp:process-plist thread) 'id)
565     (incf *thread-id-counter*)))))
566    
567     (defimplementation find-thread (id)
568     (find id (mp:list-all-processes)
569     :key (lambda (p) (getf (mp:process-plist p) 'id))))
570 heller 1.16
571 heller 1.21 (defimplementation thread-name (thread)
572     (mp:process-name thread))
573 heller 1.16
574 heller 1.21 (defimplementation thread-status (thread)
575     (format nil "~A ~D"
576     (mp:process-whostate thread)
577     (mp:process-priority thread)))
578 heller 1.16
579 heller 1.18 (defimplementation make-lock (&key name)
580 heller 1.16 (mp:make-lock :name name))
581    
582 heller 1.18 (defimplementation call-with-lock-held (lock function)
583 heller 1.16 (mp:with-lock (lock) (funcall function)))
584 heller 1.20
585     (defimplementation current-thread ()
586     mp:*current-process*)
587 heller 1.21
588     (defimplementation all-threads ()
589     (mp:list-all-processes))
590 heller 1.20
591     (defimplementation interrupt-thread (thread fn)
592     (mp:process-interrupt thread fn))
593 heller 1.25
594     (defimplementation kill-thread (thread)
595     (mp:process-kill thread))
596 heller 1.27
597     (defimplementation thread-alive-p (thread)
598     (mp:process-alive-p thread))
599 heller 1.20
600     (defvar *mailbox-lock* (mp:make-lock))
601    
602     (defun mailbox (thread)
603     (mp:with-lock (*mailbox-lock*)
604     (or (getf (mp:process-plist thread) 'mailbox)
605     (setf (getf (mp:process-plist thread) 'mailbox)
606     (mp:make-mailbox)))))
607    
608     (defimplementation receive ()
609     (mp:mailbox-read (mailbox mp:*current-process*)))
610    
611     (defimplementation send (thread object)
612     (mp:mailbox-send (mailbox thread) object))
613 heller 1.3

  ViewVC Help
Powered by ViewVC 1.1.5