impl-clisp.lisp - clic - Clic is an command line interactive client for gopher … | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
impl-clisp.lisp (2662B) | |
--- | |
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 (deftype thread () | |
12 'mt:thread) | |
13 | |
14 ;;; Thread Creation | |
15 (defun %make-thread (function name) | |
16 (mt:make-thread function | |
17 :name name | |
18 :initial-bindings mt:*default-special-bindings*)) | |
19 | |
20 (defun current-thread () | |
21 (mt:current-thread)) | |
22 | |
23 (defun threadp (object) | |
24 (mt:threadp object)) | |
25 | |
26 (defun thread-name (thread) | |
27 (mt:thread-name thread)) | |
28 | |
29 ;;; Resource contention: locks and recursive locks | |
30 | |
31 (deftype lock () 'mt:mutex) | |
32 | |
33 (deftype recursive-lock () | |
34 '(and mt:mutex (satisfies mt:mutex-recursive-p))) | |
35 | |
36 (defun lock-p (object) | |
37 (typep object 'mt:mutex)) | |
38 | |
39 (defun recursive-lock-p (object) | |
40 (and (typep object 'mt:mutex) | |
41 (mt:mutex-recursive-p object))) | |
42 | |
43 (defun make-lock (&optional name) | |
44 (mt:make-mutex :name (or name "Anonymous lock"))) | |
45 | |
46 (defun acquire-lock (lock &optional (wait-p t)) | |
47 (mt:mutex-lock lock :timeout (if wait-p nil 0))) | |
48 | |
49 (defun release-lock (lock) | |
50 (mt:mutex-unlock lock)) | |
51 | |
52 (defmacro with-lock-held ((place) &body body) | |
53 `(mt:with-mutex-lock (,place) ,@body)) | |
54 | |
55 (defun make-recursive-lock (&optional name) | |
56 (mt:make-mutex :name (or name "Anonymous recursive lock") | |
57 :recursive-p t)) | |
58 | |
59 (defmacro with-recursive-lock-held ((place) &body body) | |
60 `(mt:with-mutex-lock (,place) ,@body)) | |
61 | |
62 ;;; Resource contention: condition variables | |
63 | |
64 (defun make-condition-variable (&key name) | |
65 (mt:make-exemption :name (or name "Anonymous condition variable"))) | |
66 | |
67 (defun condition-wait (condition-variable lock &key timeout) | |
68 (mt:exemption-wait condition-variable lock :timeout timeout) | |
69 t) | |
70 | |
71 (defun condition-notify (condition-variable) | |
72 (mt:exemption-signal condition-variable)) | |
73 | |
74 (defun thread-yield () | |
75 (mt:thread-yield)) | |
76 | |
77 ;;; Timeouts | |
78 | |
79 (defmacro with-timeout ((timeout) &body body) | |
80 (once-only (timeout) | |
81 `(mt:with-timeout (,timeout (error 'timeout :length ,timeout)) | |
82 ,@body))) | |
83 | |
84 ;;; Introspection/debugging | |
85 | |
86 ;;; VTZ: mt:list-threads returns all threads that are not garbage collec… | |
87 (defun all-threads () | |
88 (delete-if-not #'mt:thread-active-p (mt:list-threads))) | |
89 | |
90 (defun interrupt-thread (thread function &rest args) | |
91 (mt:thread-interrupt thread :function function :arguments args)) | |
92 | |
93 (defun destroy-thread (thread) | |
94 ;;; VTZ: actually we can kill ourselelf. | |
95 ;;; suicide is part of our contemporary life :) | |
96 (signal-error-if-current-thread thread) | |
97 (mt:thread-interrupt thread :function t)) | |
98 | |
99 (defun thread-alive-p (thread) | |
100 (mt:thread-active-p thread)) | |
101 | |
102 (defun join-thread (thread) | |
103 (mt:thread-join thread)) | |
104 | |
105 (mark-supported) |