GopherProxy

	timpl-abcl.lisp - clic - Clic is an command line interactive client for gopher …
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	timpl-abcl.lisp (4319B)
	---
	1 ;;;; -- indent-tabs-mode: nil --
	2
	3 #\|
	4 Copyright 2006, 2007 Greg Pfeil
	5
	6 Reimplemented with java.util.concurrent.locks.ReentrantLock by Mark Even…
	7
	8 Distributed under the MIT license (see LICENSE file)
	9 \|#
	10
	11 (in-package #:bordeaux-threads)
	12
	13 ;;; the implementation of the Armed Bear thread interface can be found in
	14 ;;; src/org/armedbear/lisp/LispThread.java
	15
	16 (deftype thread ()
	17 'threads:thread)
	18
	19 ;;; Thread Creation
	20
	21 (defun %make-thread (function name)
	22 (threads:make-thread function :name name))
	23
	24 (defun current-thread ()
	25 (threads:current-thread))
	26
	27 (defun thread-name (thread)
	28 (threads:thread-name thread))
	29
	30 (defun threadp (object)
	31 (typep object 'thread))
	32
	33 ;;; Resource contention: locks and recursive locks
	34
	35 (defstruct mutex name lock)
	36 (defstruct (mutex-recursive (:include mutex)))
	37
	38 ;; Making methods constants in this manner avoids the runtime expense of
	39 ;; introspection involved in JCALL with string arguments.
	40 (defconstant +lock+
	41 (jmethod "java.util.concurrent.locks.ReentrantLock" "lock"))
	42 (defconstant +try-lock+
	43 (jmethod "java.util.concurrent.locks.ReentrantLock" "tryLock"))
	44 (defconstant +is-held-by-current-thread+
	45 (jmethod "java.util.concurrent.locks.ReentrantLock" "isHeldByCurrentTh…
	46 (defconstant +unlock+
	47 (jmethod "java.util.concurrent.locks.ReentrantLock" "unlock"))
	48 (defconstant +get-hold-count+
	49 (jmethod "java.util.concurrent.locks.ReentrantLock" "getHoldCount"))
	50
	51 (deftype lock () 'mutex)
	52
	53 (deftype recursive-lock () 'mutex-recursive)
	54
	55 (defun lock-p (object)
	56 (typep object 'mutex))
	57
	58 (defun recursive-lock-p (object)
	59 (typep object 'mutex-recursive))
	60
	61 (defun make-lock (&optional name)
	62 (make-mutex
	63 :name (or name "Anonymous lock")
	64 :lock (jnew "java.util.concurrent.locks.ReentrantLock")))
	65
	66 (defun acquire-lock (lock &optional (wait-p t))
	67 (check-type lock mutex)
	68 (when (jcall +is-held-by-current-thread+ (mutex-lock lock))
	69 (error "Non-recursive lock being reacquired by owner."))
	70 (cond
	71 (wait-p
	72 (jcall +lock+ (mutex-lock lock))
	73 t)
	74 (t (jcall +try-lock+ (mutex-lock lock)))))
	75
	76 (defun release-lock (lock)
	77 (check-type lock mutex)
	78 (unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
	79 (error "Attempt to release lock not held by calling thread."))
	80 (jcall +unlock+ (mutex-lock lock))
	81 (values))
	82
	83 (defun make-recursive-lock (&optional name)
	84 (make-mutex-recursive
	85 :name (or name "Anonymous lock")
	86 :lock (jnew "java.util.concurrent.locks.ReentrantLock")))
	87
	88 (defun acquire-recursive-lock (lock &optional (wait-p t))
	89 (check-type lock mutex-recursive)
	90 (cond
	91 (wait-p
	92 (jcall +lock+ (mutex-recursive-lock lock))
	93 t)
	94 (t (jcall +try-lock+ (mutex-recursive-lock lock)))))
	95
	96 (defun release-recursive-lock (lock)
	97 (check-type lock mutex-recursive)
	98 (unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
	99 (error "Attempt to release lock not held by calling thread."))
	100 (jcall +unlock+ (mutex-lock lock))
	101 (values))
	102
	103 ;;; Resource contention: condition variables
	104
	105 (defun thread-yield ()
	106 (java:jstatic "yield" "java.lang.Thread"))
	107
	108 (defstruct condition-variable
	109 (name "Anonymous condition variable"))
	110
	111 (defun condition-wait (condition lock &key timeout)
	112 (threads:synchronized-on condition
	113 (release-lock lock)
	114 (if timeout
	115 ;; Since giving a zero time value to threads:object-wait means
	116 ;; an indefinite wait, use some arbitrary small number.
	117 (threads:object-wait condition
	118 (if (zerop timeout)
	119 least-positive-single-float
	120 timeout))
	121 (threads:object-wait condition)))
	122 (acquire-lock lock)
	123 t)
	124
	125 (defun condition-notify (condition)
	126 (threads:synchronized-on condition
	127 (threads:object-notify condition)))
	128
	129 ;;; Introspection/debugging
	130
	131 (defun all-threads ()
	132 (let ((threads ()))
	133 (threads:mapcar-threads (lambda (thread)
	134 (push thread threads)))
	135 (reverse threads)))
	136
	137 (defun interrupt-thread (thread function &rest args)
	138 (apply #'threads:interrupt-thread thread function args))
	139
	140 (defun destroy-thread (thread)
	141 (signal-error-if-current-thread thread)
	142 (threads:destroy-thread thread))
	143
	144 (defun thread-alive-p (thread)
	145 (threads:thread-alive-p thread))
	146
	147 (defun join-thread (thread)
	148 (threads:thread-join thread))
	149
	150 (mark-supported)