GopherProxy

	tbordeaux-threads.lisp - clic - Clic is an command line interactive client for …
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tbordeaux-threads.lisp (6348B)
	---
	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 (defvar supports-threads-p nil
	12 "This should be set to T if the running instance has thread support.")
	13
	14 (defun mark-supported ()
	15 (setf supports-threads-p t)
	16 (pushnew :bordeaux-threads features))
	17
	18 (define-condition bordeaux-mp-condition (error)
	19 ((message :initarg :message :reader message))
	20 (:report (lambda (condition stream)
	21 (format stream (message condition)))))
	22
	23 (defgeneric make-threading-support-error ()
	24 (:documentation "Creates a BORDEAUX-THREADS condition which specifies
	25 whether there is no BORDEAUX-THREADS support for the implementation, no
	26 threads enabled for the system, or no support for a particular
	27 function.")
	28 (:method ()
	29 (make-condition
	30 'bordeaux-mp-condition
	31 :message (if supports-threads-p
	32 "There is no support for this method on this implement…
	33 "There is no thread support in this instance."))))
	34
	35 ;;; Timeouts
	36
	37 #-sbcl
	38 (define-condition timeout (serious-condition)
	39 ((length :initform nil
	40 :initarg :length
	41 :reader timeout-length))
	42 (:report (lambda (c s)
	43 (if (timeout-length c)
	44 (format s "A timeout set to ~A seconds occurred."
	45 (timeout-length c))
	46 (format s "A timeout occurred.")))))
	47
	48 #-sbcl
	49 (defmacro with-timeout ((timeout) &body body)
	50 "Execute `BODY' and signal a condition of type TIMEOUT if the executio…
	51 BODY does not complete within `TIMEOUT' seconds. On implementations whic…
	52 support WITH-TIMEOUT natively and don't support threads either it has no…
	53 (declare (ignorable timeout body))
	54 #+thread-support
	55 (let ((ok-tag (gensym "OK"))
	56 (timeout-tag (gensym "TIMEOUT"))
	57 (caller (gensym "CALLER")))
	58 (once-only (timeout)
	59 `(multiple-value-prog1
	60 (catch ',ok-tag
	61 (catch ',timeout-tag
	62 (let ((,caller (current-thread)))
	63 (make-thread #'(lambda ()
	64 (sleep ,timeout)
	65 (interrupt-thread ,caller
	66 #'(lambda ()
	67 (ignore-errors
	68 (throw ',timeou…
	69 :name (format nil "WITH-TIMEOUT thread ser…
	70 (thread-name ,caller)))
	71 (throw ',ok-tag (progn ,@body))))
	72 (error 'timeout :length ,timeout)))))
	73 #-thread-support
	74 `(error (make-threading-support-error)))
	75
	76 ;;; Semaphores
	77
	78 ;;; We provide this structure definition unconditionally regardless of t…
	79 ;;; it may not be used not to prevent warnings from compiling default fu…
	80 ;;; for semaphore in default-implementations.lisp.
	81 (defstruct %semaphore
	82 lock
	83 condition-variable
	84 counter)
	85
	86 #-(or ccl sbcl)
	87 (deftype semaphore ()
	88 '%semaphore)
	89
	90 ;;; Thread Creation
	91
	92 ;;; See default-implementations.lisp for MAKE-THREAD.
	93
	94 ;; Forms are evaluated in the new thread or in the calling thread?
	95 (defvar default-special-bindings nil
	96 "This variable holds an alist associating special variable symbols
	97 to forms to evaluate. Special variables named in this list will
	98 be locally bound in the new thread before it begins executing user cod…
	99
	100 This variable may be rebound around calls to MAKE-THREAD to
	101 add/alter default bindings. The effect of mutating this list is
	102 undefined, but earlier forms take precedence over later forms for
	103 the same symbol, so defaults may be overridden by consing to the
	104 head of the list.")
	105
	106 (defmacro defbindings (name docstring &body initforms)
	107 (check-type docstring string)
	108 `(defparameter ,name
	109 (list
	110 ,@(loop for (special form) in initforms
	111 collect `(cons ',special ',form)))
	112 ,docstring))
	113
	114 ;; Forms are evaluated in the new thread or in the calling thread?
	115 (defbindings standard-io-bindings
	116 "Standard bindings of printer/reader control variables as per CL:WITH-…
	117 (package (find-package :common-lisp-user))
	118 (print-array t)
	119 (print-base 10)
	120 (print-case :upcase)
	121 (print-circle nil)
	122 (print-escape t)
	123 (print-gensym t)
	124 (print-length nil)
	125 (print-level nil)
	126 (print-lines nil)
	127 (print-miser-width nil)
	128 (print-pprint-dispatch (copy-pprint-dispatch nil))
	129 (print-pretty nil)
	130 (print-radix nil)
	131 (print-readably t)
	132 (print-right-margin nil)
	133 (random-state (make-random-state t))
	134 (read-base 10)
	135 (read-default-float-format 'single-float)
	136 (read-eval t)
	137 (read-suppress nil)
	138 (readtable (copy-readtable nil)))
	139
	140 (defun binding-default-specials (function special-bindings)
	141 "Return a closure that binds the symbols in SPECIAL-BINDINGS and calls
	142 FUNCTION."
	143 (let ((specials (remove-duplicates special-bindings :from-end t :key #…
	144 (lambda ()
	145 (progv (mapcar #'car specials)
	146 (loop for (nil . form) in specials collect (eval form))
	147 (funcall function)))))
	148
	149 ;;; FIXME: This test won't work if CURRENT-THREAD
	150 ;;; conses a new object each time
	151 (defun signal-error-if-current-thread (thread)
	152 (when (eq thread (current-thread))
	153 (error 'bordeaux-mp-condition
	154 :message "Cannot destroy the current thread")))
	155
	156 (defparameter no-condition-wait-timeout-message
	157 "CONDITION-WAIT with :TIMEOUT is not available for this Lisp implement…
	158
	159 (defun signal-error-if-condition-wait-timeout (timeout)
	160 (when timeout
	161 (error 'bordeaux-mp-condition
	162 :message no-condition-wait-timeout-message)))
	163
	164 (defmacro define-condition-wait-compiler-macro ()
	165 `(define-compiler-macro condition-wait
	166 (&whole whole condition-variable lock &key timeout)
	167 (declare (ignore condition-variable lock))
	168 (when timeout
	169 (simple-style-warning no-condition-wait-timeout-message))
	170 whole))