Key

Not instrumented

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-

2

;;;

3

;;; utils.lisp --- Various utilities.

4

;;;

5

6

;;;

7

;;; Permission is hereby granted, free of charge, to any person

8

;;; obtaining a copy of this software and associated documentation

9

;;; files (the "Software"), to deal in the Software without

10

;;; restriction, including without limitation the rights to use, copy,

11

;;; modify, merge, publish, distribute, sublicense, and/or sell copies

12

;;; of the Software, and to permit persons to whom the Software is

13

;;; furnished to do so, subject to the following conditions:

14

;;;

15

;;; The above copyright notice and this permission notice shall be

16

;;; included in all copies or substantial portions of the Software.

17

;;;

18

;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,

19

;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF

20

;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

21

;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT

22

;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,

23

;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,

24

;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER

25

;;; DEALINGS IN THE SOFTWARE.

26

;;;

27

28

(in-package #:cl-user)

29

30

(defpackage #:cffi-utils

31

(:use #:common-lisp)

32

(:export #:discard-docstring

33

#:parse-body

34

#:with-unique-names

35

#:once-only

36

#:ensure-list

37

#:make-gensym-list

38

#:symbolicate

39

#:keywordify

40

#:let-when

41

#:bif

42

#:post-incf

43

#:single-bit-p

44

#:warn-if-kw-or-belongs-to-cl))

45

46

(in-package #:cffi-utils)

47

48

;;;# General Utilities

49

50

;;; frodef's, see: http://paste.lisp.org/display/2771#1

51

(defmacro post-incf (place &optional (delta 1) &environment env)

52

"Increment PLACE by DELTA and return its previous value."

53

(multiple-value-bind (dummies vals new setter getter)

54

(get-setf-expansion place env)

55

`(let* (,@(mapcar #'list dummies vals) (,(car new) ,getter))

56

(prog1 ,(car new)

57

(setq ,(car new) (+ ,(car new) ,delta))

58

,setter))))

59

60

(defun ensure-list (x)

61

"Make into list if atom."

62

(if (listp x) x (list x)))

63

64

(defmacro discard-docstring (body-var)

65

"Discards the first element of the list in body-var if it's a

66

string and the only element."

67

`(when (and (stringp (car ,body-var)) (cdr ,body-var))

68

(pop ,body-var)))

69

70

;;; Parse a body of code, removing an optional documentation string

71

;;; and declaration forms. Returns the actual body, docstring, and

72

;;; declarations as three multiple values.

73

(defun parse-body (body)

74

(let ((docstring nil)

75

(declarations nil))

76

(when (and (stringp (car body)) (cdr body))

77

(setf docstring (pop body)))

78

(loop while (and (consp (car body)) (eql (caar body) 'cl:declare))

79

do (push (pop body) declarations))

80

(values body docstring (nreverse declarations))))

81

82

;;; LET-IF (renamed to BIF) and LET-WHEN taken from KMRCL

83

(defmacro let-when ((var test-form) &body body)

84

`(let ((,var ,test-form))

85

(when ,var ,@body)))

86

87

(defmacro bif ((var test-form) if-true &optional if-false)

88

`(let ((,var ,test-form))

89

(if ,var ,if-true ,if-false)))

90

91

;;; ONCE-ONLY macro taken from PAIP

92

(defun starts-with (list x)

93

"Is x a list whose first element is x?"

94

(and (consp list) (eql (first list) x)))

95

96

(defun side-effect-free? (exp)

97

"Is exp a constant, variable, or function,

98

or of the form (THE type x) where x is side-effect-free?"

99

(or (atom exp) (constantp exp)

100

(starts-with exp 'function)

101

(and (starts-with exp 'the)

102

(side-effect-free? (third exp)))))

103

104

(defmacro once-only (variables &rest body)

105

"Returns the code built by BODY. If any of VARIABLES

106

might have side effects, they are evaluated once and stored

107

in temporary variables that are then passed to BODY."

108

(assert (every #'symbolp variables))

109

(let ((temps nil))

110

(dotimes (i (length variables)) (push (gensym "ONCE") temps))

111

`(if (every #'side-effect-free? (list .,variables))

112

(progn .,body)

113

(list 'let

114

,`(list ,@(mapcar #'(lambda (tmp var)

115

`(list ',tmp ,var))

116

temps variables))

117

(let ,(mapcar #'(lambda (var tmp) `(,var ',tmp))

118

variables temps)

119

.,body)))))

120

121

;;;; The following utils were taken from SBCL's

122

;;;; src/code/*-extensions.lisp

123

124

;;; Automate an idiom often found in macros:

125

;;; (LET ((FOO (GENSYM "FOO"))

126

;;; (MAX-INDEX (GENSYM "MAX-INDEX-")))

127

;;; ...)

128

;;;

129

;;; "Good notation eliminates thought." -- Eric Siggia

130

;;;

131

;;; Incidentally, this is essentially the same operator which

132

;;; _On Lisp_ calls WITH-GENSYMS.

133

(defmacro with-unique-names (symbols &body body)

134

`(let ,(mapcar (lambda (symbol)

135

(let* ((symbol-name (symbol-name symbol))

136

(stem (if (every #'alpha-char-p symbol-name)

137

symbol-name

138

(concatenate 'string symbol-name "-"))))

139

`(,symbol (gensym ,stem))))

140

symbols)

141

,@body))

142

143

(defun make-gensym-list (n)

144

"Return a list of N gensyms."

145

(loop repeat n collect (gensym)))

146

147

(defun symbolicate (&rest things)

148

"Concatenate together the names of some strings and symbols,

149

producing a symbol in the current package."

150

(let* ((strings (mapcar (lambda (x)

151

(typecase x

152

(number (write-to-string x))

153

(t (string x))))

154

things))

155

(length (reduce #'+ strings :key #'length))

156

(name (make-array length :element-type 'character)))

157

(let ((index 0))

158

(dolist (string strings (values (intern name)))

159

(let ((len (length string)))

160

(replace name string :start1 index)

161

(incf index len))))))

162

163

(defun keywordify (&rest things)

164

(let ((*package* (find-package '#:keyword)))

165

(apply #'symbolicate things)))

166

167

(defun single-bit-p (integer)

168

"Answer whether INTEGER, which must be an integer, is a single

169

set twos-complement bit."

170

(if (<= integer 0)

171

nil ;infinite set bits for negatives

172

(loop until (logbitp 0 integer)

173

do (setf integer (ash integer -1))

174

finally (return (zerop (ash integer -1))))))

175

176

;;; This function is here because it needs to be defined early.

177

;;;

178

;;; This function is used by DEFINE-PARSE-METHOD and DEFCTYPE to warn

179

;;; users when they're defining types whose names belongs to the

180

;;; KEYWORD or CL packages. CFFI itself gets to use keywords without

181

;;; a warning though.

182

(defun warn-if-kw-or-belongs-to-cl (name)

183

(let ((package (symbol-package name)))

184

(when (or (eq package (find-package '#:cl))

185

(and (not (eq *package* (find-package '#:cffi)))

186

(eq package (find-package '#:keyword))))

187

(warn "Defining a foreign type named ~S. This symbol belongs to the ~A ~

188

package and that may interfere with other code using CFFI."

189

name (package-name package)))))

190

191

;(defun deprecation-warning (bad-name &optional good-name)

192

; (warn "using deprecated ~S~@[, should use ~S instead~]"

193

; bad-name

194

; good-name))

195

196

;;; Anaphoric macros

197

;(defmacro awhen (test &body body)

198

; `(let ((it ,test))

199

; (when it ,@body)))

200

201

;(defmacro acond (&rest clauses)

202

; (if (null clauses)

203

; `()

204

; (destructuring-bind ((test &body body) &rest rest) clauses

205

; (once-only (test)

206

; `(if ,test

207

; (let ((it ,test)) (declare (ignorable it)),@body)

208

; (acond ,@rest))))))

209

Kind	Covered	All	%
expression	123	152	80.9
branch	29	36	80.6

Coverage report: /home/luis/src/cffi/src/utils.lisp