Coverage report: /home/ellis/.stash/quicklisp/dists/ultralisp/software/edicl-flexi-streams-20240429143708/in-memory.lisp

Kind	Covered	All	%
expression	0	312	0.0
branch	0	28	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-

2

;;; $Header: /usr/local/cvsrep/flexi-streams/in-memory.lisp,v 1.31 2008/05/19 07:57:07 edi Exp $

3

4

5

6

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

7

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

8

;;; are met:

9

10

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

11

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

12

13

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

14

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

15

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

16

;;; provided with the distribution.

17

18

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

19

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

20

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

21

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

22

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

23

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

24

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

25

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

26

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

27

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

28

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

29

30

(in-package :flexi-streams)

31

32

(defclass in-memory-stream (trivial-gray-stream-mixin)

33

((transformer :initarg :transformer

34

:accessor in-memory-stream-transformer

35

:documentation "A function used to transform the

36

written/read octet to the value stored/retrieved in/from the

37

underlying vector.")

38

#+:cmu

39

(open-p :initform t

40

:accessor in-memory-stream-open-p

41

:documentation "For CMUCL we have to keep track of this

42

manually."))

43

(:documentation "An IN-MEMORY-STREAM is a binary stream that reads

44

octets from or writes octets to a sequence in RAM."))

45

46

(defclass in-memory-input-stream (in-memory-stream fundamental-binary-input-stream)

47

()

48

(:documentation "An IN-MEMORY-INPUT-STREAM is a binary stream that

49

reads octets from a sequence in RAM."))

50

51

#+:cmu

52

(defmethod output-stream-p ((stream in-memory-input-stream))

53

"Explicitly states whether this is an output stream."

54

(declare (optimize speed))

55

nil)

56

57

(defclass in-memory-output-stream (in-memory-stream fundamental-binary-output-stream)

58

()

59

(:documentation "An IN-MEMORY-OUTPUT-STREAM is a binary stream that

60

writes octets to a sequence in RAM."))

61

62

#+:cmu

63

(defmethod input-stream-p ((stream in-memory-output-stream))

64

"Explicitly states whether this is an input stream."

65

(declare (optimize speed))

66

nil)

67

68

(defclass list-stream ()

69

((list :initarg :list

70

:accessor list-stream-list

71

:documentation "The underlying list of the stream."))

72

(:documentation "A LIST-STREAM is a mixin for IN-MEMORY streams

73

where the underlying sequence is a list."))

74

75

(defclass vector-stream ()

76

((vector :initarg :vector

77

:accessor vector-stream-vector

78

:documentation "The underlying vector of the stream which

79

\(for output) must always be adjustable and have a fill pointer."))

80

(:documentation "A VECTOR-STREAM is a mixin for IN-MEMORY streams

81

where the underlying sequence is a vector."))

82

83

(defclass list-input-stream (list-stream in-memory-input-stream)

84

()

85

(:documentation "A binary input stream that gets its data from an

86

associated list of octets."))

87

88

(defclass vector-input-stream (vector-stream in-memory-input-stream)

89

((index :initarg :index

90

:accessor vector-stream-index

91

:type (integer 0 #.array-dimension-limit)

92

:documentation "An index into the underlying vector denoting

93

the current position.")

94

(end :initarg :end

95

:accessor vector-stream-end

96

:type (integer 0 #.array-dimension-limit)

97

:documentation "An index into the underlying vector denoting

98

the end of the available data."))

99

(:documentation "A binary input stream that gets its data from an

100

associated vector of octets."))

101

102

(defclass vector-output-stream (vector-stream in-memory-output-stream)

103

()

104

(:documentation "A binary output stream that writes its data to an

105

associated vector."))

106

107

#+:cmu

108

(defmethod open-stream-p ((stream in-memory-stream))

109

"Returns a true value if STREAM is open. See ANSI standard."

110

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

111

(in-memory-stream-open-p stream))

112

113

#+:cmu

114

(defmethod close ((stream in-memory-stream) &key abort)

115

"Closes the stream STREAM. See ANSI standard."

116

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

117

(declare (ignore abort))

118

(prog1

119

(in-memory-stream-open-p stream)

120

(setf (in-memory-stream-open-p stream) nil)))

121

122

(defmethod check-if-open ((stream in-memory-stream))

123

"Checks if STREAM is open and signals an error otherwise."

124

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

125

(unless (open-stream-p stream)

126

(error 'in-memory-stream-closed-error

127

:stream stream)))

128

129

(defmethod stream-element-type ((stream in-memory-stream))

130

"The element type is always OCTET by definition."

131

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

132

'octet)

133

134

(defgeneric peek-byte (stream &optional peek-type eof-err-p eof-value)

135

(:documentation

136

"PEEK-BYTE is like PEEK-CHAR, i.e. it returns a byte from the stream without

137

actually removing it. If PEEK-TYPE is NIL the next byte is returned, if

138

PEEK-TYPE is T, the next byte which is not 0 is returned, if PEEK-TYPE is an

139

byte, the next byte which equals PEEK-TYPE is returned. EOF-ERROR-P and

140

EOF-VALUE are interpreted as usual."))

141

142

(defmethod peek-byte ((stream vector-input-stream) &optional peek-type (eof-error-p t) eof-value)

143

"Returns a byte from VECTOR-INPUT-STREAM without actually removing it."

144

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

145

(let ((index (vector-stream-index stream)))

146

(loop :for byte = (read-byte stream eof-error-p :eof)

147

:for new-index :from index

148

:until (cond ((eq byte :eof)

149

(return eof-value))

150

((null peek-type))

151

((eq peek-type 't)

152

(plusp byte))

153

((= byte peek-type)))

154

:finally (setf (slot-value stream 'index) new-index)

155

(return byte))))

156

157

(defmethod peek-byte ((stream list-input-stream) &optional peek-type (eof-error-p t) eof-value)

158

"Returns a byte from VECTOR-INPUT-STREAM without actually removing it."

159

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

160

(loop

161

:for list-elem = (car (list-stream-list stream))

162

:for byte = (read-byte stream eof-error-p :eof)

163

:until (cond ((eq byte :eof)

164

(return eof-value))

165

((null peek-type))

166

((eq peek-type 't)

167

(plusp byte))

168

((= byte peek-type)))

169

:finally (push list-elem (list-stream-list stream))

170

(return byte)))

171

172

(defmethod transform-octet ((stream in-memory-stream) octet)

173

"Applies the transformer of STREAM to octet and returns the result."

174

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

175

(funcall (or (in-memory-stream-transformer stream)

176

#'identity) octet))

177

178

(defmethod stream-read-byte ((stream list-input-stream))

179

"Reads one byte by simply popping it off of the top of the list."

180

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

181

(check-if-open stream)

182

(with-accessors ((list list-stream-list))

183

stream

184

(transform-octet stream (or (pop list) (return-from stream-read-byte :eof)))))

185

186

(defmethod stream-listen ((stream list-input-stream))

187

"Checks whether list is not empty."

188

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

189

(check-if-open stream)

190

(with-accessors ((list list-stream-list))

191

stream

192

list))

193

194

(defmethod stream-read-sequence ((stream list-input-stream) sequence start end &key)

195

"Repeatedly pops elements from the list until it's empty."

196

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

197

(declare (fixnum start end))

198

(with-accessors ((list list-stream-list))

199

stream

200

(loop with transformer = (in-memory-stream-transformer stream)

201

for index of-type fixnum from start below end

202

while list

203

do (let ((elt (pop list)))

204

(setf (elt sequence index)

205

(if transformer

206

(funcall transformer elt)

207

elt)))

208

finally (return index))))

209

210

(defmethod stream-read-byte ((stream vector-input-stream))

211

"Reads one byte and increments INDEX pointer unless we're beyond

212

END pointer."

213

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

214

(check-if-open stream)

215

(with-accessors ((index vector-stream-index)

216

(end vector-stream-end)

217

(vector vector-stream-vector))

218

stream

219

(let ((current-index index))

220

(declare (fixnum current-index))

221

(cond ((< current-index (the fixnum end))

222

(incf (the fixnum index))

223

(transform-octet stream (aref vector current-index)))

224

(t :eof)))))

225

226

(defmethod stream-listen ((stream vector-input-stream))

227

"Checking whether INDEX is beyond END."

228

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

229

(check-if-open stream)

230

(with-accessors ((index vector-stream-index)

231

(end vector-stream-end))

232

stream

233

(< (the fixnum index) (the fixnum end))))

234

235

(defmethod stream-read-sequence ((stream vector-input-stream) sequence start end &key)

236

"Traverses both sequences in parallel until the end of one of them

237

is reached."

238

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

239

(declare (fixnum start end))

240

(loop with vector-end of-type fixnum = (vector-stream-end stream)

241

with vector = (vector-stream-vector stream)

242

with transformer = (in-memory-stream-transformer stream)

243

for index of-type fixnum from start below end

244

for vector-index of-type fixnum = (vector-stream-index stream)

245

while (< vector-index vector-end)

246

do (let ((elt (aref vector vector-index)))

247

(setf (elt sequence index)

248

(if transformer

249

(funcall transformer elt)

250

elt)))

251

(incf (the fixnum (vector-stream-index stream)))

252

finally (return index)))

253

254

(defmethod stream-write-byte ((stream vector-output-stream) byte)

255

"Writes a byte \(octet) by extending the underlying vector."

256

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

257

(check-if-open stream)

258

(with-accessors ((vector vector-stream-vector))

259

stream

260

(vector-push-extend (transform-octet stream byte) vector)))

261

262

(defmethod stream-write-sequence ((stream vector-output-stream) sequence start end &key)

263

"Just calls VECTOR-PUSH-EXTEND repeatedly."

264

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

265

(declare (fixnum start end))

266

(with-accessors ((vector vector-stream-vector))

267

stream

268

(loop for index of-type fixnum from start below end

269

do (vector-push-extend (transform-octet stream (elt sequence index)) vector))

270

sequence))

271

272

(defmethod stream-file-position ((stream vector-input-stream))

273

"Simply returns the index into the underlying vector."

274

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

275

(with-accessors ((index vector-stream-index))

276

stream

277

index))

278

279

(defmethod (setf stream-file-position) (position-spec (stream vector-input-stream))

280

"Sets the index into the underlying vector if POSITION-SPEC is acceptable."

281

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

282

(with-accessors ((index vector-stream-index)

283

(end vector-stream-end))

284

stream

285

(setq index

286

(case position-spec

287

(:start 0)

288

(:end end)

289

(otherwise

290

(unless (integerp position-spec)

291

(error 'in-memory-stream-position-spec-error

292

:format-control "Unknown file position designator: ~S."

293

:format-arguments (list position-spec)

294

:stream stream

295

:position-spec position-spec))

296

(unless (<= 0 position-spec end)

297

(error 'in-memory-stream-position-spec-error

298

:format-control "File position designator ~S is out of bounds."

299

:format-arguments (list position-spec)

300

:stream stream

301

:position-spec position-spec))

302

position-spec)))

303

position-spec))

304

305

(defmethod stream-file-position ((stream vector-output-stream))

306

"Simply returns the fill pointer of the underlying vector."

307

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

308

(with-accessors ((vector vector-stream-vector))

309

stream

310

(fill-pointer vector)))

311

312

(defmethod (setf stream-file-position) (position-spec (stream vector-output-stream))

313

"Sets the fill pointer underlying vector if POSITION-SPEC is

314

acceptable. Adjusts the vector if necessary."

315

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

316

(with-accessors ((vector vector-stream-vector))

317

stream

318

(let* ((total-size (array-total-size vector))

319

(new-fill-pointer

320

(case position-spec

321

(:start 0)

322

(:end

323

                (warn "File position designator :END doesn't really make sense for an output stream.")

324

total-size)

325

(otherwise

326

(unless (integerp position-spec)

327

(error 'in-memory-stream-position-spec-error

328

:format-control "Unknown file position designator: ~S."

329

:format-arguments (list position-spec)

330

:stream stream

331

:position-spec position-spec))

332

(unless (<= 0 position-spec array-total-size-limit)

333

(error 'in-memory-stream-position-spec-error

334

                         :format-control "File position designator ~S is out of bounds."

335

:format-arguments (list position-spec)

336

:stream stream

337

:position-spec position-spec))

338

position-spec))))

339

(declare (fixnum total-size new-fill-pointer))

340

(when (> new-fill-pointer total-size)

341

(adjust-array vector new-fill-pointer))

342

(setf (fill-pointer vector) new-fill-pointer)

343

position-spec)))

344

345

(defmethod make-in-memory-input-stream ((vector vector) &key (start 0)

346

                                                              (end (length vector))

347

                                                              transformer)

348

"Returns a binary input stream which will supply, in order, the

349

octets in the subsequence of VECTOR bounded by START and END.

350

Each octet returned will be transformed in turn by the optional

351

TRANSFORMER function."

352

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

353

(make-instance 'vector-input-stream

354

:vector vector

355

:index start

356

:end end

357

:transformer transformer))

358

359

(defmethod make-in-memory-input-stream ((list list) &key (start 0)

360

                                                          (end (length list))

361

                                                          transformer)

362

"Returns a binary input stream which will supply, in order, the

363

octets in the subsequence of LIST bounded by START and END. Each

364

octet returned will be transformed in turn by the optional

365

TRANSFORMER function."

366

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

367

(make-instance 'list-input-stream

368

:list (subseq list start end)

369

:transformer transformer))

370

371

(defun make-output-vector (&key (element-type 'octet))

372

"Creates and returns an array which can be used as the underlying

373

vector for a VECTOR-OUTPUT-STREAM."

374

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

375

(make-array 0 :adjustable t

376

:fill-pointer 0

377

:element-type element-type))

378

379

(defun make-in-memory-output-stream (&key (element-type 'octet) transformer)

380

"Returns a binary output stream which accepts objects of type

381

ELEMENT-TYPE \(a subtype of OCTET) and makes available a sequence

382

that contains the octes that were actually output. The octets

383

stored will each be transformed by the optional TRANSFORMER

384

function."

385

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

386

(make-instance 'vector-output-stream

387

:vector (make-output-vector :element-type element-type)

388

:transformer transformer))

389

390

(defmethod get-output-stream-sequence ((stream in-memory-output-stream) &key as-list)

391

"Returns a vector containing, in order, all the octets that have

392

been output to the IN-MEMORY stream STREAM. This operation clears any

393

octets on STREAM, so the vector contains only those octets which have

394

been output since the last call to GET-OUTPUT-STREAM-SEQUENCE or since

395

the creation of the stream, whichever occurred most recently. If

396

AS-LIST is true the return value is coerced to a list."

397

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

398

(with-accessors ((vector vector-stream-vector))

399

stream

400

(prog1

401

(if as-list

402

(coerce vector 'list)

403

vector)

404

(setq vector

405

(make-output-vector)))))

406

407

(defmethod output-stream-sequence-length ((stream in-memory-output-stream))

408

"Returns the current length of the underlying vector of the

409

IN-MEMORY output stream STREAM."

410

(declare (optimize speed))

411

(length (the vector (vector-stream-vector stream))))

412

413

(defmacro with-input-from-sequence ((var sequence &key start end transformer)

414

&body body)

415

"Creates an IN-MEMORY input stream from SEQUENCE using the

416

parameters START and END, binds VAR to this stream and then

417

executes the code in BODY. A function TRANSFORMER may optionally

418

be specified to transform the returned octets. The stream is

419

automatically closed on exit from WITH-INPUT-FROM-SEQUENCE, no

420

matter whether the exit is normal or abnormal. The return value

421

of this macro is the return value of BODY."

422

(with-rebinding (sequence)

423

`(let (,var)

424

(unwind-protect

425

(progn

426

(setq ,var (make-in-memory-input-stream ,sequence

427

                                                      :start (or ,start 0)

428

                                                      :end (or ,end (length ,sequence))

429

                                                      :transformer ,transformer))

430

,@body)

431

(when ,var (close ,var))))))

432

433

(defmacro with-output-to-sequence ((var &key as-list (element-type ''octet) transformer)

434

&body body)

435

"Creates an IN-MEMORY output stream, binds VAR to this stream

436

and then executes the code in BODY. The stream stores data of

437

type ELEMENT-TYPE \(a subtype of OCTET) which is \(optionally)

438

transformed by the function TRANSFORMER prior to storage. The

439

stream is automatically closed on exit from

440

WITH-OUTPUT-TO-SEQUENCE, no matter whether the exit is normal or

441

abnormal. The return value of this macro is a vector \(or a list

442

if AS-LIST is true) containing the octets that were sent to the

443

stream within BODY."

444

`(let (,var)

445

(unwind-protect

446

(progn

447

(setq ,var (make-in-memory-output-stream :element-type ,element-type

448

                                                     :transformer ,transformer))

449

,@body

450

(get-output-stream-sequence ,var :as-list ,as-list))

451

(when ,var (close ,var)))))