impl-clisp.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
HTML git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
DIR Log
DIR Files
DIR Refs
DIR Tags
DIR README
DIR 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 collected.
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)