impl-lispworks.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
impl-lispworks.lisp (4032B)
---
1 ;;;; -*- indent-tabs-mode: nil -*-
2
3 #|
4 Copyright 2006, 2007 Greg Pfeil
5
6 Distributed under the MIT license (see LICENSE file)
7 |#
8
9 (in-package #:bordeaux-threads)
10
11 ;;; documentation on the LispWorks Multiprocessing interface can be found at
12 ;;; http://www.lispworks.com/documentation/lw445/LWUG/html/lwuser-156.htm
13
14 (deftype thread ()
15 'mp:process)
16
17 ;;; Thread Creation
18
19 (defun start-multiprocessing ()
20 (mp:initialize-multiprocessing))
21
22 (defun %make-thread (function name)
23 (mp:process-run-function
24 name nil
25 (lambda ()
26 (let ((return-values
27 (multiple-value-list (funcall function))))
28 (setf (mp:process-property 'return-values)
29 return-values)
30 (values-list return-values)))))
31
32 (defun current-thread ()
33 #-#.(cl:if (cl:find-symbol (cl:string '#:get-current-process) :mp) '(and) '(or))
34 mp:*current-process*
35 ;; introduced in LispWorks 5.1
36 #+#.(cl:if (cl:find-symbol (cl:string '#:get-current-process) :mp) '(and) '(or))
37 (mp:get-current-process))
38
39 (defun threadp (object)
40 (mp:process-p object))
41
42 (defun thread-name (thread)
43 (mp:process-name thread))
44
45 ;;; Resource contention: locks and recursive locks
46
47
48 (deftype lock () 'mp:lock)
49
50 #-(or lispworks4 lispworks5)
51 (deftype recursive-lock ()
52 '(and mp:lock (satisfies mp:lock-recursive-p)))
53
54 (defun lock-p (object)
55 (typep object 'mp:lock))
56
57 (defun recursive-lock-p (object)
58 #+(or lispworks4 lispworks5)
59 nil
60 #-(or lispworks4 lispworks5) ; version 6+
61 (and (typep object 'mp:lock)
62 (mp:lock-recursive-p object)))
63
64 (defun make-lock (&optional name)
65 (mp:make-lock :name (or name "Anonymous lock")
66 #-(or lispworks4 lispworks5) :recursivep
67 #-(or lispworks4 lispworks5) nil))
68
69 (defun acquire-lock (lock &optional (wait-p t))
70 (mp:process-lock lock nil
71 (cond ((null wait-p) 0)
72 ((numberp wait-p) wait-p)
73 (t nil))))
74
75 (defun release-lock (lock)
76 (mp:process-unlock lock))
77
78 (defmacro with-lock-held ((place) &body body)
79 `(mp:with-lock (,place) ,@body))
80
81 (defun make-recursive-lock (&optional name)
82 (mp:make-lock :name (or name "Anonymous recursive lock")
83 #-(or lispworks4 lispworks5) :recursivep
84 #-(or lispworks4 lispworks5) t))
85
86 (defun acquire-recursive-lock (lock &optional (wait-p t))
87 (acquire-lock lock wait-p))
88
89 (defun release-recursive-lock (lock)
90 (release-lock lock))
91
92 (defmacro with-recursive-lock-held ((place) &body body)
93 `(mp:with-lock (,place) ,@body))
94
95 ;;; Resource contention: condition variables
96
97 #+(or lispworks6 lispworks7)
98 (defun make-condition-variable (&key name)
99 (mp:make-condition-variable :name (or name "Anonymous condition variable")))
100
101 #+(or lispworks6 lispworks7)
102 (defun condition-wait (condition-variable lock &key timeout)
103 (mp:condition-variable-wait condition-variable lock :timeout timeout)
104 t)
105
106 #+(or lispworks6 lispworks7)
107 (defun condition-notify (condition-variable)
108 (mp:condition-variable-signal condition-variable))
109
110 (defun thread-yield ()
111 (mp:process-allow-scheduling))
112
113 ;;; Introspection/debugging
114
115 (defun all-threads ()
116 (mp:list-all-processes))
117
118 (defun interrupt-thread (thread function &rest args)
119 (apply #'mp:process-interrupt thread function args))
120
121 (defun destroy-thread (thread)
122 (signal-error-if-current-thread thread)
123 (mp:process-kill thread))
124
125 (defun thread-alive-p (thread)
126 (mp:process-alive-p thread))
127
128 (declaim (inline %join-thread))
129 (defun %join-thread (thread)
130 #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
131 (mp:process-wait (format nil "Waiting for thread ~A to complete" thread)
132 (complement #'mp:process-alive-p)
133 thread)
134 #+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
135 (mp:process-join thread))
136
137 (defun join-thread (thread)
138 (%join-thread thread)
139 (let ((return-values
140 (mp:process-property 'return-values thread)))
141 (values-list return-values)))
142
143 (mark-supported)