GopherProxy

	timpl-clozure.lisp - clic - Clic is an command line interactive client for goph…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	timpl-clozure.lisp (3061B)
	---
	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 OpenMCL Threads interface can be found at
	12 ;;; http://openmcl.clozure.com/Doc/Programming-with-Threads.html
	13
	14 (deftype thread ()
	15 'ccl:process)
	16
	17 ;;; Thread Creation
	18
	19 (defun %make-thread (function name)
	20 (ccl:process-run-function name function))
	21
	22 (defun current-thread ()
	23 ccl:current-process)
	24
	25 (defun threadp (object)
	26 (typep object 'ccl:process))
	27
	28 (defun thread-name (thread)
	29 (ccl:process-name thread))
	30
	31 ;;; Resource contention: locks and recursive locks
	32
	33 (deftype lock () 'ccl:lock)
	34
	35 (deftype recursive-lock () 'ccl:lock)
	36
	37 (defun lock-p (object)
	38 (typep object 'ccl:lock))
	39
	40 (defun recursive-lock-p (object)
	41 (typep object 'ccl:lock))
	42
	43 (defun make-lock (&optional name)
	44 (ccl:make-lock (or name "Anonymous lock")))
	45
	46 (defun acquire-lock (lock &optional (wait-p t))
	47 (if wait-p
	48 (ccl:grab-lock lock)
	49 (ccl:try-lock lock)))
	50
	51 (defun release-lock (lock)
	52 (ccl:release-lock lock))
	53
	54 (defmacro with-lock-held ((place) &body body)
	55 `(ccl:with-lock-grabbed (,place)
	56 ,@body))
	57
	58 (defun make-recursive-lock (&optional name)
	59 (ccl:make-lock (or name "Anonymous recursive lock")))
	60
	61 (defun acquire-recursive-lock (lock)
	62 (ccl:grab-lock lock))
	63
	64 (defun release-recursive-lock (lock)
	65 (ccl:release-lock lock))
	66
	67 (defmacro with-recursive-lock-held ((place) &body body)
	68 `(ccl:with-lock-grabbed (,place)
	69 ,@body))
	70
	71 ;;; Resource contention: condition variables
	72
	73 (defun make-condition-variable (&key name)
	74 (declare (ignore name))
	75 (ccl:make-semaphore))
	76
	77 (defun condition-wait (condition-variable lock &key timeout)
	78 (release-lock lock)
	79 (unwind-protect
	80 (if timeout
	81 (ccl:timed-wait-on-semaphore condition-variable timeout)
	82 (ccl:wait-on-semaphore condition-variable))
	83 (acquire-lock lock t))
	84 t)
	85
	86 (defun condition-notify (condition-variable)
	87 (ccl:signal-semaphore condition-variable))
	88
	89 (defun thread-yield ()
	90 (ccl:process-allow-schedule))
	91
	92 ;;; Semaphores
	93
	94 (deftype semaphore ()
	95 'ccl:semaphore)
	96
	97 (defun make-semaphore (&key name (count 0))
	98 (declare (ignore name))
	99 (let ((semaphore (ccl:make-semaphore)))
	100 (dotimes (c count) (ccl:signal-semaphore semaphore))
	101 semaphore))
	102
	103 (defun signal-semaphore (semaphore &key (count 1))
	104 (dotimes (c count) (ccl:signal-semaphore semaphore)))
	105
	106 (defun wait-on-semaphore (semaphore &key timeout)
	107 (if timeout
	108 (ccl:timed-wait-on-semaphore semaphore timeout)
	109 (ccl:wait-on-semaphore semaphore)))
	110
	111 ;;; Introspection/debugging
	112
	113 (defun all-threads ()
	114 (ccl:all-processes))
	115
	116 (defun interrupt-thread (thread function &rest args)
	117 (declare (dynamic-extent args))
	118 (apply #'ccl:process-interrupt thread function args))
	119
	120 (defun destroy-thread (thread)
	121 (signal-error-if-current-thread thread)
	122 (ccl:process-kill thread))
	123
	124 (defun thread-alive-p (thread)
	125 (not (ccl:process-exhausted-p thread)))
	126
	127 (defun join-thread (thread)
	128 (ccl:join-process thread))
	129
	130 (mark-supported)