Coverage report: /home/ellis/.stash/quicklisp/dists/ultralisp/software/sionescu-bordeaux-threads-20250412101706/apiv1/bordeaux-threads.lisp

Kind	Covered	All	%
expression	3	56	5.4
branch	0	2	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS -*-

2

;;;; The above modeline is required for Genera. Do not change.

3

4

#|

5

6

7

Distributed under the MIT license (see LICENSE file)

8

|#

9

10

(in-package #:bordeaux-threads)

11

12

(defvar *supports-threads-p* nil

13

"This should be set to T if the running instance has thread support.")

14

15

(defun mark-supported ()

16

(setf *supports-threads-p* t)

17

(pushnew :bordeaux-threads *features*))

18

19

(define-condition bordeaux-mp-condition (error)

20

((message :initarg :message :reader message))

21

(:report (lambda (condition stream)

22

(format stream (message condition)))))

23

24

(defgeneric make-threading-support-error ()

25

(:documentation "Creates a BORDEAUX-THREADS condition which specifies

26

whether there is no BORDEAUX-THREADS support for the implementation, no

27

threads enabled for the system, or no support for a particular

28

function.")

29

(:method ()

30

(make-condition

31

'bordeaux-mp-condition

32

:message (if *supports-threads-p*

33

"There is no support for this method on this implementation."

34

"There is no thread support in this instance."))))

35

36

;;; Timeouts

37

38

#-sbcl

39

(define-condition timeout (serious-condition)

40

((length :initform nil

41

:initarg :length

42

:reader timeout-length))

43

(:report (lambda (c s)

44

(if (timeout-length c)

45

(format s "A timeout set to ~A seconds occurred."

46

(timeout-length c))

47

(format s "A timeout occurred.")))))

48

49

#-sbcl

50

(define-condition interrupt ()

51

((tag :initarg :tag :reader interrupt-tag)))

52

53

#-(or sbcl genera)

54

(defmacro with-timeout ((timeout) &body body)

55

"Execute `BODY' and signal a condition of type TIMEOUT if the execution of

56

BODY does not complete within `TIMEOUT' seconds. On implementations which do not

57

support WITH-TIMEOUT natively and don't support threads either it has no effect."

58

(declare (ignorable timeout body))

59

#+thread-support

60

(once-only (timeout)

61

(with-gensyms (ok-tag interrupt-tag caller interrupt-thread c)

62

`(let (,interrupt-thread)

63

(unwind-protect-case ()

64

(catch ',ok-tag

65

(let* ((,interrupt-tag (gensym "INTERRUPT-TAG-"))

66

(,caller (current-thread)))

67

(setf ,interrupt-thread

68

(make-thread

69

#'(lambda ()

70

(sleep ,timeout)

71

(interrupt-thread

72

,caller

73

#'(lambda () (signal 'interrupt :tag ,interrupt-tag))))

74

:name (format nil "WITH-TIMEOUT thread serving: ~S."

75

(thread-name ,caller))))

76

(handler-bind

77

((interrupt #'(lambda (,c)

78

                                     (when (eql ,interrupt-tag (interrupt-tag ,c))

79

(error 'timeout :length ,timeout)))))

80

(throw ',ok-tag (progn ,@body)))))

81

(:normal

82

(when (and ,interrupt-thread (thread-alive-p ,interrupt-thread))

83

;; There's a potential race condition between THREAD-ALIVE-P

84

;; and DESTROY-THREAD but calling the latter when a thread already

85

;; terminated should not be a grave matter.

86

(ignore-errors (destroy-thread ,interrupt-thread))))))))

87

#-thread-support

88

`(error (make-threading-support-error)))

89

90

;;; Semaphores

91

92

;;; We provide this structure definition unconditionally regardless of the fact

93

;;; it may not be used not to prevent warnings from compiling default functions

94

;;; for semaphore in default-implementations.lisp.

95

(defstruct %semaphore

96

lock

97

condition-variable

98

counter)

99

100

#-(or ccl sbcl)

101

(deftype semaphore ()

102

'%semaphore)

103

104

;;; Thread Creation

105

106

;;; See default-implementations.lisp for MAKE-THREAD.

107

108

;; Forms are evaluated in the new thread or in the calling thread?

109

(defvar *default-special-bindings* nil

110

"This variable holds an alist associating special variable symbols

111

to forms to evaluate. Special variables named in this list will

112

be locally bound in the new thread before it begins executing user code.

113

114

This variable may be rebound around calls to MAKE-THREAD to

115

add/alter default bindings. The effect of mutating this list is

116

undefined, but earlier forms take precedence over later forms for

117

the same symbol, so defaults may be overridden by consing to the

118

head of the list.")

119

120

(defmacro defbindings (name docstring &body initforms)

121

(check-type docstring string)

122

`(defparameter ,name

123

(list

124

,@(loop for (special form) in initforms

125

collect `(cons ',special ',form)))

126

,docstring))

127

128

;; Forms are evaluated in the new thread or in the calling thread?

129

(defbindings *standard-io-bindings*

130

"Standard bindings of printer/reader control variables as per CL:WITH-STANDARD-IO-SYNTAX."

131

(*package* (find-package :common-lisp-user))

132

(*print-array* t)

133

(*print-base* 10)

134

(*print-case* :upcase)

135

(*print-circle* nil)

136

(*print-escape* t)

137

(*print-gensym* t)

138

(*print-length* nil)

139

(*print-level* nil)

140

(*print-lines* nil)

141

(*print-miser-width* nil)

142

(*print-pprint-dispatch* (copy-pprint-dispatch nil))

143

(*print-pretty* nil)

144

(*print-radix* nil)

145

(*print-readably* t)

146

(*print-right-margin* nil)

147

(*random-state* (make-random-state t))

148

(*read-base* 10)

149

(*read-default-float-format* 'single-float)

150

(*read-eval* t)

151

(*read-suppress* nil)

152

(*readtable* (copy-readtable nil)))

153

154

(defun binding-default-specials (function special-bindings)

155

"Return a closure that binds the symbols in SPECIAL-BINDINGS and calls

156

FUNCTION."

157

(let ((specials (remove-duplicates special-bindings :from-end t :key #'car)))

158

(named-lambda %binding-default-specials-wrapper ()

159

(progv (mapcar #'car specials)

160

(loop for (nil . form) in specials collect (eval form))

161

(funcall function)))))

162

163

;;; FIXME: This test won't work if CURRENT-THREAD

164

;;; conses a new object each time

165

(defun signal-error-if-current-thread (thread)

166

(when (eq thread (current-thread))

167

(error 'bordeaux-mp-condition

168

:message "Cannot destroy the current thread")))

169

170

(defparameter *no-condition-wait-timeout-message*

171

"CONDITION-WAIT with :TIMEOUT is not available for this Lisp implementation.")

172

173

(defun signal-error-if-condition-wait-timeout (timeout)

174

(when timeout

175

(error 'bordeaux-mp-condition

176

:message *no-condition-wait-timeout-message*)))

177

178

(defmacro define-condition-wait-compiler-macro ()

179

`(define-compiler-macro condition-wait

180

(&whole whole condition-variable lock &key timeout)

181

(declare (ignore condition-variable lock))

182

(when timeout

183

(simple-style-warning *no-condition-wait-timeout-message*))

184

whole))