Coverage report: /home/ellis/comp/core/lib/io/xsubseq.lisp

Kind	Covered	All	%
expression	104	418	24.9
branch	7	68	10.3

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; io/xsubseq.lisp --- Subseq Optimizations

2

3

;; This is ported from Fukamachi's XSUBSEQ

4

5

;;; Commentary:

6

7

;; ref: https://github.com/fukamachi/xsubseq

8

9

;;; Code:

10

(in-package :io/xsubseq)

11

12

(defstruct (xsubseq (:constructor make-xsubseq (data start &optional (end (length data))

13

                                                 &aux (len (- end start)))))

14

(data nil)

15

(start 0 :type integer)

16

(end 0 :type integer)

17

(len 0 :type integer))

18

19

(defstruct (octet-xsubseq (:include xsubseq)

20

                            (:constructor make-octet-xsubseq (data start &optional (end (length data))

21

                                                               &aux (len (- end start))))))

22

23

(defstruct (string-xsubseq (:include xsubseq)

24

                            (:constructor make-string-xsubseq (data start &optional (end (length data))

25

                                                               &aux (len (- end start))))))

26

27

(defstruct (concatenated-xsubseqs (:constructor %make-concatenated-xsubseqs))

28

(len 0 :type integer)

29

(last nil :type list)

30

(children nil :type list))

31

32

(defun make-concatenated-xsubseqs (&rest children)

33

(if (null children)

34

(make-null-concatenated-xsubseqs)

35

(%make-concatenated-xsubseqs :children children

36

:last (last children)

37

:len (reduce #'+

38

children

39

:key #'xsubseq-len

40

:initial-value 0))))

41

42

(defstruct (null-concatenated-xsubseqs (:include concatenated-xsubseqs)))

43

44

(defstruct (octet-concatenated-xsubseqs (:include concatenated-xsubseqs)))

45

46

(defstruct (string-concatenated-xsubseqs (:include concatenated-xsubseqs)))

47

48

(defun xsubseq (data start &optional (end (length data)))

49

(typecase data

50

(octet-vector (make-octet-xsubseq data start end))

51

(string (make-string-xsubseq data start end))

52

(t (make-xsubseq data start end))))

53

54

#+(or sbcl openmcl cmu allegro)

55

(define-compiler-macro xsubseq (&whole form &environment env data start &optional end)

56

(let ((type (cond

57

((constantp data) (type-of data))

58

((and (symbolp data)

59

(assoc 'type (nth-value 2 (variable-information data env)))))

60

((and (listp data)

61

(eq (car data) 'make-string))

62

'string)

63

((and (listp data)

64

(eq (car data) 'the)

65

(cadr data)))

66

((and (listp data)

67

(eq (car data) 'make-array)

68

(null (cadr (member :adjustable data)))

69

(null (cadr (member :fill-pointer data)))

70

(cadr (member :element-type data))))))

71

(g-data (gensym "DATA")))

72

(if (null type)

73

form

74

(cond

75

((subtypep type 'octet-vector) `(let ((,g-data ,data))

76

                                       (make-octet-xsubseq ,g-data ,start ,(or end `(length ,g-data)))))

77

((subtypep type 'string) `(let ((,g-data ,data))

78

                                       (make-string-xsubseq ,g-data ,start ,(or end `(length ,g-data)))))

79

(t form)))))

80

81

(defun %xnconc2 (seq1 seq2)

82

(flet ((seq-values (seq)

83

(if (concatenated-xsubseqs-p seq)

84

(values (concatenated-xsubseqs-children seq)

85

(concatenated-xsubseqs-last seq)

86

(concatenated-xsubseqs-len seq))

87

(let ((children (list seq)))

88

(values children children

89

(xsubseq-len seq))))))

90

(macrolet ((make-concatenated (type seq1 seq2)

91

`(multiple-value-bind (children last len)

92

(seq-values ,seq2)

93

(,(cond

94

((eq type 'octet-vector) 'make-octet-concatenated-xsubseqs)

95

((eq type 'string) 'make-string-concatenated-xsubseqs)

96

(t '%make-concatenated-xsubseqs))

97

:len (+ (xsubseq-len ,seq1) len)

98

:children (cons ,seq1 children)

99

:last last))))

100

(etypecase seq1

101

(null-concatenated-xsubseqs seq2)

102

(concatenated-xsubseqs

103

(multiple-value-bind (children last len)

104

(seq-values seq2)

105

(if (concatenated-xsubseqs-last seq1)

106

(progn

107

(rplacd (concatenated-xsubseqs-last seq1)

108

children)

109

(setf (concatenated-xsubseqs-last seq1) last)

110

(incf (concatenated-xsubseqs-len seq1) len))

111

;; empty concatenated-xsubseqs

112

(progn

113

(setf (concatenated-xsubseqs-children seq1) children

114

(concatenated-xsubseqs-len seq1) len

115

(concatenated-xsubseqs-last seq1) last)))

116

seq1))

117

(octet-xsubseq

118

(make-concatenated octet-vector seq1 seq2))

119

(string-xsubseq

120

(make-concatenated string seq1 seq2))

121

(xsubseq (make-concatenated t seq1 seq2))))))

122

123

(defun xnconc (subseq &rest more-subseqs)

124

(reduce #'%xnconc2 more-subseqs :initial-value subseq))

125

126

(define-modify-macro xnconcf (subseq &rest more-subseqs) xnconc)

127

128

(defun xlength (seq)

129

(etypecase seq

130

(xsubseq (xsubseq-len seq))

131

(concatenated-xsubseqs (concatenated-xsubseqs-len seq))))

132

133

(defun coerce-to-sequence (seq)

134

(etypecase seq

135

(octet-concatenated-xsubseqs (octet-concatenated-xsubseqs-to-sequence seq))

136

(string-concatenated-xsubseqs (string-concatenated-xsubseqs-to-sequence seq))

137

(concatenated-xsubseqs (concatenated-xsubseqs-to-sequence seq))

138

(xsubseq (xsubseq-to-sequence seq))))

139

140

#+(or sbcl openmcl cmu allegro)

141

(define-compiler-macro coerce-to-sequence (&whole form &environment env seq)

142

(let ((type (cond

143

((constantp seq) (type-of seq))

144

((and (symbolp seq)

145

(assoc 'type (nth-value 2 (variable-information seq env)))))

146

((and (listp seq)

147

(eq (car seq) 'the)

148

(cadr seq))))))

149

(if (null type)

150

form

151

(cond

152

((subtypep type 'octet-concatenated-xsubseqs) `(octet-concatenated-xsubseqs-to-sequence ,seq))

153

           ((subtypep type 'string-concatenated-xsubseqs) `(string-concatenated-xsubseqs-to-sequence ,seq))

154

((subtypep type 'concatenated-xsubseqs) `(concatenated-xsubseqs-to-sequence ,seq))

155

((subtypep type 'xsubseq) `(xsubseq-to-sequence ,seq))

156

(t form)))))

157

158

(defun coerce-to-string (seq)

159

(etypecase seq

160

(null-concatenated-xsubseqs "")

161

(octet-concatenated-xsubseqs (octet-concatenated-xsubseqs-to-string seq))

162

(string-concatenated-xsubseqs (string-concatenated-xsubseqs-to-sequence seq))

163

(octet-xsubseq (octet-xsubseq-to-string seq))

164

(string-xsubseq (xsubseq-to-sequence seq))))

165

166

#+(or sbcl openmcl cmu allegro)

167

(define-compiler-macro coerce-to-string (&whole form &environment env seq)

168

(let ((type (cond

169

((constantp seq) (type-of seq))

170

((and (symbolp seq)

171

(assoc 'type (nth-value 2 (variable-information seq env)))))

172

((and (listp seq)

173

(eq (car seq) 'the)

174

(cadr seq))))))

175

(if (null type)

176

form

177

(cond

178

((subtypep type 'octet-concatenated-xsubseqs) `(octet-concatenated-xsubseqs-to-string ,seq))

179

           ((subtypep type 'string-concatenated-xsubseqs) `(string-concatenated-xsubseqs-to-sequence ,seq))

180

((subtypep type 'octet-xsubseq) `(octet-xsubseq-to-string ,seq))

181

((subtypep type 'string-xsubseq) `(xsubseq-to-sequence ,seq))

182

(t form)))))

183

184

(defun xsubseq-to-sequence (seq)

185

(let ((result (make-array (xsubseq-len seq)

186

:element-type

187

(array-element-type (xsubseq-data seq)))))

188

(replace result (xsubseq-data seq)

189

:start2 (xsubseq-start seq)

190

:end2 (xsubseq-end seq))

191

result))

192

193

(defun octet-xsubseq-to-string (seq)

194

(let ((result (make-array (xsubseq-len seq)

195

:element-type 'character)))

196

(declare (type simple-string result))

197

(let ((data (xsubseq-data seq))

198

(end (xsubseq-end seq)))

199

(do ((i (xsubseq-start seq) (1+ i))

200

(j 0 (1+ j)))

201

((= i end) result)

202

(setf (aref result j)

203

(code-char

204

(the (unsigned-byte 8)

205

(aref (the octet-vector data) i))))))))

206

207

(defun concatenated-xsubseqs-to-sequence (seq)

208

(let ((result (make-array (concatenated-xsubseqs-len seq)

209

:element-type

210

                             (array-element-type (xsubseq-data (car (concatenated-xsubseqs-children seq)))))))

211

(loop with current-pos = 0

212

for seq in (concatenated-xsubseqs-children seq)

213

do (replace result (xsubseq-data seq)

214

:start1 current-pos

215

:start2 (xsubseq-start seq)

216

:end2 (xsubseq-end seq))

217

(incf current-pos

218

(xsubseq-len seq)))

219

result))

220

221

(defun octet-concatenated-xsubseqs-to-sequence (seq)

222

(let ((result (make-array (concatenated-xsubseqs-len seq)

223

:element-type '(unsigned-byte 8))))

224

(declare (type octet-vector result))

225

(loop with current-pos of-type integer = 0

226

for seq in (concatenated-xsubseqs-children seq)

227

do (replace result (the octet-vector (xsubseq-data seq))

228

:start1 current-pos

229

:start2 (xsubseq-start seq)

230

:end2 (xsubseq-end seq))

231

(incf current-pos

232

(xsubseq-len seq)))

233

result))

234

235

(defun octet-concatenated-xsubseqs-to-string (seq)

236

(let ((result (make-array (concatenated-xsubseqs-len seq)

237

:element-type 'character)))

238

(declare (type simple-string result))

239

(loop with current-pos = 0

240

for seq in (concatenated-xsubseqs-children seq)

241

do (do ((i (xsubseq-start seq) (1+ i))

242

(j current-pos (1+ j)))

243

((= i (xsubseq-end seq))

244

(setf current-pos j))

245

(setf (aref result j)

246

(code-char

247

(the (unsigned-byte 8)

248

(aref (the octet-vector (xsubseq-data seq)) i))))))

249

result))

250

251

(defun string-concatenated-xsubseqs-to-sequence (seq)

252

(let ((result (make-string (concatenated-xsubseqs-len seq))))

253

(declare (type simple-string result))

254

(loop with current-pos of-type integer = 0

255

for seq in (concatenated-xsubseqs-children seq)

256

do (replace result (the simple-string (xsubseq-data seq))

257

:start1 current-pos

258

:start2 (xsubseq-start seq)

259

:end2 (xsubseq-end seq))

260

(incf current-pos

261

(xsubseq-len seq)))

262

result))

263

264

(defmacro with-xsubseqs ((xsubseqs &key initial-value) &body body)

265

`(let ((,xsubseqs ,(or initial-value

266

`(make-null-concatenated-xsubseqs))))

267

,@body

268

269

(typecase ,xsubseqs

270

(null-concatenated-xsubseqs nil)

271

(xsubseq (xsubseq-to-sequence ,xsubseqs))

272

(t (concatenated-xsubseqs-to-sequence ,xsubseqs)))))