Coverage report: /home/ellis/comp/ext/cl-ppcre/util.lisp

Kind	Covered	All	%
expression	16	124	12.9
branch	0	12	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; $Header: /usr/local/cvsrep/cl-ppcre/util.lisp,v 1.48 2009/10/28 07:36:15 edi Exp $

2

3

;;; Utility functions and constants dealing with the character sets we

4

;;; use to encode character classes

5

6

7

8

;;; Redistribution and use in source and binary forms, with or without

9

;;; modification, are permitted provided that the following conditions

10

;;; are met:

11

12

;;; * Redistributions of source code must retain the above copyright

13

;;; notice, this list of conditions and the following disclaimer.

14

15

;;; * Redistributions in binary form must reproduce the above

16

;;; copyright notice, this list of conditions and the following

17

;;; disclaimer in the documentation and/or other materials

18

;;; provided with the distribution.

19

20

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED

21

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

22

;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE

23

;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY

24

;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

25

;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE

26

;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS

27

;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,

28

;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING

29

;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS

30

;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

31

32

(in-package :cl-ppcre)

33

34

(defmacro defconstant (name value &optional doc)

35

"Make sure VALUE is evaluated only once \(to appease SBCL)."

36

`(cl:defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)

37

,@(when doc (list doc))))

38

39

(defmacro with-unique-names ((&rest bindings) &body body)

40

"Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form*

41

42

Executes a series of forms with each VAR bound to a fresh,

43

uninterned symbol. The uninterned symbol is as if returned by a call

44

to GENSYM with the string denoted by X - or, if X is not supplied, the

45

string denoted by VAR - as argument.

46

47

The variable bindings created are lexical unless special declarations

48

are specified. The scopes of the name bindings and declarations do not

49

include the Xs.

50

51

The forms are evaluated in order, and the values of all but the last

52

are discarded \(that is, the body is an implicit PROGN)."

53

;; reference implementation posted to comp.lang.lisp as

54

;; <cy3bshuf30f.fsf@ljosa.com> by Vebjorn Ljosa - see also

55

;; <http://www.cliki.net/Common%20Lisp%20Utilities>

56

`(let ,(mapcar #'(lambda (binding)

57

(check-type binding (or cons symbol))

58

(if (consp binding)

59

(destructuring-bind (var x) binding

60

(check-type var symbol)

61

`(,var (gensym ,(etypecase x

62

(symbol (symbol-name x))

63

(character (string x))

64

(string x)))))

65

`(,binding (gensym ,(symbol-name binding)))))

66

bindings)

67

,@body))

68

69

(defmacro with-rebinding (bindings &body body)

70

"WITH-REBINDING ( { var | (var prefix) }* ) form*

71

72

Evaluates a series of forms in the lexical environment that is

73

formed by adding the binding of each VAR to a fresh, uninterned

74

symbol, and the binding of that fresh, uninterned symbol to VAR's

75

original value, i.e., its value in the current lexical environment.

76

77

The uninterned symbol is created as if by a call to GENSYM with the

78

string denoted by PREFIX - or, if PREFIX is not supplied, the string

79

denoted by VAR - as argument.

80

81

The forms are evaluated in order, and the values of all but the last

82

are discarded \(that is, the body is an implicit PROGN)."

83

;; reference implementation posted to comp.lang.lisp as

84

;; <cy3wv0fya0p.fsf@ljosa.com> by Vebjorn Ljosa - see also

85

;; <http://www.cliki.net/Common%20Lisp%20Utilities>

86

(loop for binding in bindings

87

for var = (if (consp binding) (car binding) binding)

88

for name = (gensym)

89

collect `(,name ,var) into renames

90

collect ``(,,var ,,name) into temps

91

finally (return `(let ,renames

92

(with-unique-names ,bindings

93

`(let (,,@temps)

94

,,@body))))))

95

96

(declaim (inline digit-char-p))

97

(defun digit-char-p (chr)

98

(declare #.*standard-optimize-settings*)

99

"Tests whether a character is a decimal digit, i.e. the same as

100

Perl's [\\d]. Note that this function shadows the standard Common

101

Lisp function CL:DIGIT-CHAR-P."

102

(char<= #\0 chr #\9))

103

104

(declaim (inline word-char-p))

105

(defun word-char-p (chr)

106

(declare #.*standard-optimize-settings*)

107

"Tests whether a character is a \"word\" character. In the ASCII

108

charset this is equivalent to a-z, A-Z, 0-9, or _, i.e. the same as

109

Perl's [\\w]."

110

(or (alphanumericp chr)

111

(char= chr #\_)))

112

113

(defconstant +whitespace-char-string+

114

(coerce '(#\Space #\Tab #\Linefeed #\Return #\Page) 'string)

115

"A string of all characters which are considered to be whitespace.

116

Same as Perl's [\\s].")

117

118

(defun whitespacep (chr)

119

(declare #.*special-optimize-settings*)

120

"Tests whether a character is whitespace, i.e. whether it would

121

match [\\s] in Perl."

122

(find chr +whitespace-char-string+ :test #'char=))

123

124

(defmacro maybe-coerce-to-simple-string (string)

125

"Coerces STRING to a simple STRING unless it already is one."

126

(with-unique-names (=string=)

127

`(let ((,=string= ,string))

128

(cond ((simple-string-p ,=string=)

129

,=string=)

130

(t

131

(coerce ,=string= 'simple-string))))))

132

133

(declaim (inline nsubseq))

134

(defun nsubseq (sequence start &optional (end (length sequence)))

135

"Returns a subsequence by pointing to location in original sequence."

136

(make-array (- end start)

137

:element-type (array-element-type sequence)

138

:displaced-to sequence

139

:displaced-index-offset start))

140

141

(defun normalize-var-list (var-list)

142

"Utility function for REGISTER-GROUPS-BIND and DO-REGISTER-GROUPS.

143

Creates the long form \(a list of \(FUNCTION VAR) entries) out of the

144

short form of VAR-LIST."

145

(loop for element in var-list

146

if (consp element)

147

nconc (loop for var in (rest element)

148

collect (list (first element) var))

149

else

150

collect (list '(function identity) element)))

151

152

(defun string-list-to-simple-string (string-list)

153

"Concatenates a list of strings to one simple-string."

154

(declare #.*standard-optimize-settings*)

155

;; this function provided by JP Massar; note that we can't use APPLY

156

;; with CONCATENATE here because of CALL-ARGUMENTS-LIMIT

157

(let ((total-size 0))

158

(declare (fixnum total-size))

159

(dolist (string string-list)

160

#-:genera (declare (string string))

161

(incf total-size (length string)))

162

(let ((result-string (make-sequence 'simple-string total-size))

163

(curr-pos 0))

164

(declare (fixnum curr-pos))

165

(dolist (string string-list)

166

#-:genera (declare (string string))

167

(replace result-string string :start1 curr-pos)

168

(incf curr-pos (length string)))

169

result-string)))

170

171

(defun complement* (test-function)

172

"Like COMPLEMENT but optimized for unary functions."

173

(declare #.*standard-optimize-settings*)

174

(typecase test-function

175

(function

176

(lambda (char)

177

(declare (character char))

178

(not (funcall (the function test-function) char))))

179

(otherwise

180

(lambda (char)

181

(declare (character char))

182

(not (funcall test-function char))))))