Coverage report: /development/source/library/org/datagraph/spocq-shard/src/store/rlmdb/revision-identifier.lisp

Kind	Covered	All	%
expression	0	865	0.0
branch	0	102	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: org.datagraph.spocq.implementation; -*-

2

3

(in-package :org.datagraph.spocq.implementation)

4

5

6

7

(defconstant +rsid-type+ :sha1)

8

(defconstant +rsid-length+ 20)

9

10

(defgeneric copy-uuid-vector (from)

11

(:method ((from string))

12

(string-to-uuid from (make-uuid-vector)))

13

(:method ((from uuid:uuid))

14

(uuid:uuid-to-byte-array from))

15

(:method ((from spocq:uuid))

16

(string-to-uuid (spocq:uuid-lexical-form from) (make-uuid-vector))))

17

18

(defgeneric uuid-state (uuid)

19

(:method ((%uuid SB-SYS:SYSTEM-AREA-POINTER))

20

     (let ((version-byte (cffi:mem-aref (cffi:foreign-slot-pointer %uuid '(:struct v1-uuid) 'time_hi_and_version)

21

:uint8 0)))

22

(if (zerop (logand version-byte #x80))

23

:insert :delete)))

24

(:method ((uuid vector))

25

(let ((version-byte (aref uuid 6)))

26

(if (zerop (logand version-byte #x80))

27

:insert :delete))))

28

29

(defgeneric (setf uuid-state) (state uuid)

30

(:method (state (%uuid SB-SYS:SYSTEM-AREA-POINTER))

31

     (let* ((version-byte (cffi:mem-aref (cffi:foreign-slot-pointer %uuid '(:struct v1-uuid) 'time_hi_and_version)

32

:uint8 0))

33

(new-version-byte (ecase state

34

(:insert (logand #x7f version-byte))

35

(:delete (logior #x80 version-byte)))))

36

(setf (cffi:mem-aref (cffi:foreign-slot-pointer %uuid '(:struct v1-uuid) 'time_hi_and_version)

37

:uint8 0)

38

new-version-byte))

39

state)

40

(:method (state (uuid vector))

41

(setf (aref uuid 6) (ecase state

42

(:insert (logand #x7f (aref uuid 6)))

43

(:delete (logior #x80 (aref uuid 6)))))

44

state))

45

46

(defun set-uuid-state (uuid state)

47

(setf (uuid-state uuid) state)

48

uuid)

49

50

(defun reset-uuid-state (uuid)

51

(setf (uuid-state uuid) :insert)

52

uuid)

53

54

(defun insert-uuid-p (uuid)

55

(eq (uuid-state uuid) :insert))

56

57

(defun delete-uuid-p (uuid)

58

(eq (uuid-state uuid) :delete))

59

60

(defun make-revision-identifier (&key (timestamp nil) (state nil) (node nil))

61

"Given possible overriding attributes, first construct a v1 uuid array,

62

then, optionally, replace the timestamp, state and node id.

63

Start with a generated uuid in order to get the current clock sequence.

64

The default state will be as bit zero, which means insertion."

65

(let ((uuid (make-v1-uuid-array)))

66

(etypecase timestamp

67

(null)

68

(spocq:date-time (setf (v1-uuid-timestamp uuid) (date-time-timeline-location timestamp)))

69

(integer (setf (v1-uuid-timestamp uuid) timestamp))

70

(string (setf (v1-uuid-timestamp uuid)

71

(date-time-timeline-location (|-yyyy-MM-ddTHH:mm:ss(ZZZZZZ)?| timestamp)))))

72

(when state

73

(set-uuid-state uuid state))

74

(flet ((set-node (node)

75

(loop for position from 0 upto 40 by 8

76

for offset downfrom 15

77

do (setf (aref uuid offset) (ldb (byte 8 position) node)))))

78

(etypecase node

79

(null )

80

(string (set-node (parse-integer node :radix 16)))

81

((vector (unsigned-byte 8) 12) (replace uuid node :start1 10))

82

(integer (set-node node))))

83

uuid))

84

;;; (make-revision-identifier :timestamp #x0001000200000003 :node 4)

85

;;; (make-revision-identifier :timestamp #@"1970-01-01T00:00:00Z" :node 4)

86

87

(defparameter *revision-identifier-scanner*

88

(cl-ppcre:create-scanner '(:sequence

89

:start-anchor

90

                              (:register (:greedy-repetition 1 12 (:inverted-char-class #\+ #\-)))

91

(:register (:char-class #\+ #\-))

92

#\@

93

(:register date-time-string)

94

:end-anchor)))

95

96

(defun read-revision-identifier (stream &rest args)

97

(declare (ignore args))

98

   (let* ((string (read-buffer stream #'(lambda (c) (case c ((#\space #\tab #\newline #\( #\)) nil) (t t))))))

99

(multiple-value-bind (match-p parts) (cl-ppcre:scan-to-strings *revision-identifier-scanner* string)

100

(assert match-p ()

101

"Invalid revision identifier: ~s" string)

102

(let ((location (aref parts 0))

103

(operator (aref parts 1))

104

(timestamp (aref parts 2)))

105

(make-revision-identifier :timestamp timestamp

106

                                   :state (ecase (aref operator 0) (#\+ :insert) (#\- :delete))

107

:node location)))))

108

109

110

(set-packaged-dispatch-macro-character #\# #\! 'read-revision-identifier)

111

;;; #!00000f/+/1970-01-01T00:00:00Z

112

;;; #!00000f/+/1970-01-01T01:00:00Z

113

114

(defun cl-user::format-uuid-operation (stream uuid &optional colon at)

115

(declare (ignore colon at))

116

(let* ((iod (insert-uuid-p uuid))

117

(clean-uuid (set-uuid-state (copy-seq uuid) :insert))

118

(timestamp (v1-uuid-timestamp clean-uuid))

119

(date-time (timeline-location-date-time timestamp)))

120

(format stream "~/format-uuid/~c@~/spocq:format-date-time/"

121

clean-uuid

122

(if iod #\+ #\-)

123

date-time)))

124

125

126

(defun %compare-v1-uuid-date (%uuid1 %uuid2)

127

"Compare just the date portion of the uuid w/o concern for version, clock seq or node"

128

(declare (type SB-SYS:SYSTEM-AREA-POINTER %uuid1 %uuid2))

129

(flet ((compare-bytes (start count)

130

(loop for index from start

131

while (> count 0)

132

do (progn (decf count)

133

(let ((b1 (cffi:mem-aref %uuid1 :uint8 index))

134

(b2 (cffi:mem-aref %uuid2 :uint8 index)))

135

(cond ((< b1 b2)

136

(return-from %compare-v1-uuid-date -1))

137

((> b1 b2)

138

(return-from %compare-v1-uuid-date 1))))))))

139

(let ((b1 (logand #x0f (cffi:mem-aref %uuid1 :uint8 6)))

140

(b2 (logand #x0f (cffi:mem-aref %uuid2 :uint8 6))))

141

(cond ((< b1 b2)

142

(return-from %compare-v1-uuid-date -1))

143

((> b1 b2)

144

(return-from %compare-v1-uuid-date 1))))

145

(compare-bytes 7 1) ;; low byte of high

146

(compare-bytes 4 2) ;; two bytes mid

147

(compare-bytes 0 4) ;; four bytes low

148

0))

149

150

(defun compare-v1-uuid-date-vector (uuid1 uuid2)

151

"Compare just the date portion of the uuid w/o concern for version, clock seq or node"

152

(declare (type (simple-array (unsigned-byte 8) (16)) uuid1 uuid2))

153

(flet ((compare-bytes (start count)

154

(loop for index from start

155

while (> count 0)

156

do (progn (decf count)

157

(let ((b1 (aref uuid1 index))

158

(b2 (aref uuid2 index)))

159

(cond ((< b1 b2)

160

(return-from compare-v1-uuid-date-vector -1))

161

((> b1 b2)

162

(return-from compare-v1-uuid-date-vector 1))))))))

163

(let ((b1 (logand #x0f (aref uuid1 6)))

164

(b2 (logand #x0f (aref uuid2 6))))

165

(cond ((< b1 b2)

166

(return-from compare-v1-uuid-date-vector -1))

167

((> b1 b2)

168

(return-from compare-v1-uuid-date-vector 1))))

169

(compare-bytes 7 1)

170

(compare-bytes 4 2)

171

(compare-bytes 0 4)

172

0))

173

174

(defun %compare-v1-uuid (%uuid1 %uuid2)

175

(declare (type SB-SYS:SYSTEM-AREA-POINTER %uuid1 %uuid2))

176

(let ((date-order (%compare-v1-uuid-date %uuid1 %uuid2)))

177

(if (zerop date-order)

178

(flet ((compare-bytes (start count)

179

(loop for index from start

180

while (> count 0)

181

do (progn (decf count)

182

(let ((b1 (cffi:mem-aref %uuid1 :uint8 index))

183

(b2 (cffi:mem-aref %uuid2 :uint8 index)))

184

(cond ((< b1 b2)

185

(return-from %compare-v1-uuid -1))

186

((> b1 b2)

187

(return-from %compare-v1-uuid 1))))))))

188

;; then by insert/delete

189

(let ((b1 (logand #xf0 (cffi:mem-aref %uuid1 :uint8 6)))

190

(b2 (logand #xf0 (cffi:mem-aref %uuid2 :uint8 6))))

191

(cond ((< b1 b2)

192

(return-from %compare-v1-uuid -1))

193

((> b1 b2)

194

(return-from %compare-v1-uuid 1))))

195

;; then by node

196

(compare-bytes 10 6)

197

;; finally by clock sequence

198

(compare-bytes 8 2)

199

0)

200

date-order)))

201

202

(defun compare-v1-uuid-vector (uuid1 uuid2)

203

"Compare just the date portion of the uuid w/o concern for version, clock seq or node"

204

(declare (type (simple-array (unsigned-byte 8) (16)) uuid1 uuid2))

205

(let ((date-order (compare-v1-uuid-date-vector uuid1 uuid2)))

206

;; compare first by date,

207

(if (zerop date-order)

208

(flet ((compare-bytes (start count)

209

(loop for index from start

210

while (> count 0)

211

do (progn (decf count)

212

(let ((b1 (aref uuid1 index))

213

(b2 (aref uuid2 index)))

214

(cond ((< b1 b2)

215

(return-from compare-v1-uuid-vector -1))

216

((> b1 b2)

217

(return-from compare-v1-uuid-vector 1))))))))

218

;; then by insert/delete

219

(let ((b1 (logand #xf0 (aref uuid1 6)))

220

(b2 (logand #xf0 (aref uuid2 6))))

221

(cond ((< b1 b2)

222

(return-from compare-v1-uuid-vector -1))

223

((> b1 b2)

224

(return-from compare-v1-uuid-vector 1))))

225

;; then by node

226

(compare-bytes 10 6)

227

;; finally by clock sequence

228

(compare-bytes 8 2)

229

0)

230

date-order)))

231

232

233

234

(defgeneric compare-v1-uuid (uuid1 uuid2)

235

(:method ((%uuid1 SB-SYS:SYSTEM-AREA-POINTER) (%uuid2 SB-SYS:SYSTEM-AREA-POINTER))

236

(%compare-v1-uuid %uuid1 %uuid2))

237

(:method ((uuid1 vector) (uuid2 vector))

238

(compare-v1-uuid-vector uuid1 uuid2)))

239

240

(defgeneric compare-v1-uuid-date (uuid1 uuid2)

241

(:method ((%uuid1 SB-SYS:SYSTEM-AREA-POINTER) (%uuid2 SB-SYS:SYSTEM-AREA-POINTER))

242

(%compare-v1-uuid-date %uuid1 %uuid2))

243

(:method ((uuid1 vector) (uuid2 vector))

244

(compare-v1-uuid-date-vector uuid1 uuid2)))

245

246

(defun uuid-greater-p (uuid1 uuid2)

247

(> (compare-v1-uuid uuid1 uuid2) 0))

248

(defun uuid-less-p (uuid1 uuid2)

249

(< (compare-v1-uuid uuid1 uuid2) 0))

250

251

(defun uuid-vector-before-p (u1 u2)

252

(minusp (compare-v1-uuid-date-vector u1 u2)))

253

(defun uuid-vector-after-p (u1 u2)

254

(plusp (compare-v1-uuid-date-vector u1 u2)))

255

(defun uuid-vector-coincident-p (u1 u2)

256

(zerop (compare-v1-uuid-date-vector u1 u2)))

257

258

(defgeneric revision-before-p (u1 u2)

259

(:method ((u1 vector) (u2 vector))

260

(minusp (compare-v1-uuid-date-vector u1 u2)))

261

(:method ((%uuid1 SB-SYS:SYSTEM-AREA-POINTER) (%uuid2 SB-SYS:SYSTEM-AREA-POINTER))

262

(minusp (%compare-v1-uuid %uuid1 %uuid2))))

263

(defgeneric revision-coincident-p (u1 u2)

264

(:method ((u1 vector) (u2 vector))

265

(zerop (compare-v1-uuid-date-vector u1 u2)))

266

(:method ((%uuid1 SB-SYS:SYSTEM-AREA-POINTER) (%uuid2 SB-SYS:SYSTEM-AREA-POINTER))

267

(zerop (%compare-v1-uuid %uuid1 %uuid2))))

268

(defgeneric revision-after-p (u1 u2)

269

(:method ((u1 vector) (u2 vector))

270

(plusp (compare-v1-uuid-date-vector u1 u2)))

271

(:method ((%uuid1 SB-SYS:SYSTEM-AREA-POINTER) (%uuid2 SB-SYS:SYSTEM-AREA-POINTER))

272

(plusp (%compare-v1-uuid %uuid1 %uuid2))))

273

;;; @1M calls, function=110ms, generic=120ms, function->generic=200ms

274

275

(defun %position-uuid (%uuid %vector

276

                              &key (length (error "position-uuid: length is required")) (test #'%compare-v1-uuid-date))

277

"Locate the highest uuid less that that given.

278

Iff it indicates insertion, then the quad is visible in that revision.

279

Handle the degenerate cases without searching."

280

(labels ((test-position (position)

281

(funcall test (cffi:mem-aptr %vector '(:struct v1-uuid) position) %uuid))

282

(binary-search (start end)

283

(let* ((test-position (ash (+ start end) -1))

284

(result (test-position test-position)))

285

                ;; (format t "~&next: start ~s end ~s test-position ~s result ~s~%" start end test-position result)

286

(ecase result

287

(0 test-position)

288

(-1 (if (= test-position start)

289

start

290

(binary-search test-position end)))

291

(+1 (if (= test-position start)

292

nil

293

(binary-search start test-position)))))))

294

#+(or)

295

(print (list (%uuid-to-string %uuid)

296

(let ((vector (make-array length)))

297

(loop for i below length

298

do (setf (aref vector i)

299

                               (%uuid-to-string (cffi:mem-aptr %vector '(:struct v1-uuid) i))))

300

vector)

301

length))

302

(case length

303

(0 nil) ;; indicate not present

304

(1 (when (>= (funcall test %uuid %vector) 0)

305

0))

306

(t (let ((position (binary-search 0 length)))

307

(when position

308

(loop for second-position from (1+ position) below length

309

;; advance to the last which is a duplicate according to the predicate

310

                until (< (funcall test %uuid (cffi:mem-aptr %vector '(:struct v1-uuid) second-position)) 0)

311

do (setf position second-position))

312

position))))))

313

314

(defun position-uuid-vector (uuid vector &key (length (length vector)) (test #'compare-v1-uuid-date-vector))

315

(labels ((test-position (position)

316

(funcall test (aref vector position) uuid))

317

(binary-search (start end)

318

(let* ((test-position (ash (+ start end) -1))

319

(result (test-position test-position)))

320

                ;;(format t "~&next: start ~s end ~s test-position ~s result ~s~%" start end test-position result)

321

(ecase result

322

(0 test-position)

323

(-1 (if (= test-position start)

324

start

325

(binary-search test-position end)))

326

(+1 (if (= test-position start)

327

nil

328

(binary-search start test-position)))))))

329

#+(or)

330

(print (list (uuid-to-string uuid)

331

(let ((pvector (make-array length)))

332

(loop for i below length

333

do (setf (aref pvector i) (uuid-to-string (aref vector i))))

334

pvector)

335

length))

336

(case length

337

(0 nil) ; indiate not present

338

(1 (when (>= (funcall test uuid (aref vector 0)) 0)

339

0))

340

(t (let ((position (binary-search 0 length)))

341

;(print (list :found position))

342

(when position

343

(loop for second-position from (1+ position) below length

344

;; advance to the last which is a duplicate according to the predicate

345

until (< (funcall test uuid (aref vector second-position)) 0)

346

do (setf position second-position))

347

;(print (list :advanced position))

348

position))))))

349

350

(defun revision-transition-next (start vector &key (length (length vector))

351

(test #'uuid-vector-coincident-p)

352

(transition-p #'delete-uuid-p))

353

   "Given a vector of uuids and a starting position, return the uuid which indicates transition of the specified kind

354

    and its position. This is the first deletion uuid which ends a uuid set for a respective timestamp.

355

Skip any sets which ultimately indicate an insertion."

356

(when (< start length)

357

(loop for found-uuid = (aref vector start) then next-uuid

358

for position from (1+ start) below length

359

for next-uuid = (aref vector position)

360

;;do (print (list :found found-uuid :next next-uuid :position position))

361

if (and (not (funcall test found-uuid next-uuid))

362

(funcall transition-p found-uuid))

363

return (1- position)

364

finally (when (funcall transition-p found-uuid)

365

(return (1- position))))))

366

367

(defun revision-transition-previous (end vector &key (length (length vector))

368

(test #'uuid-vector-coincident-p)

369

(transition-p #'insert-uuid-p))

370

   "Given a vector of uuids and an initial position, return the uuid which indicates transition of the specified kind

371

    and its position. This is the first qualifying uuid which ends a uuid set for a respective timestamp.

372

Skip any sets which ultimately indicate an insertion."

373

(when (and (>= end 0) (< end length))

374

(let ((found-uuid (aref vector end)))

375

(if (funcall transition-p found-uuid)

376

end

377

(let ((start (revision-set-start end vector :test test)))

378

             (when start (revision-transition-previous (1- start) vector :test test :transition-p transition-p)))))))

379

380

381

(defun revision-set-end (start vector &key (length (length vector))

382

(test #'uuid-vector-coincident-p))

383

   "Given a vector of uuids and a starting position, return the uuid which ends the located timestamp set."

384

(when (< start length)

385

(loop for found-uuid = (aref vector start) then next-uuid

386

for position from (1+ start) below length

387

for next-uuid = (aref vector position)

388

;;do (print (list :found found-uuid :next next-uuid :position position))

389

if (not (funcall test found-uuid next-uuid))

390

return (1- position)

391

finally (return (1- position)))))

392

393

(defun revision-set-start (end vector &key (length (length vector))

394

(test #'uuid-vector-coincident-p))

395

"Given a vector of uuids and an ending position, return the uuid which ends the previous set."

396

(when (and (>= end 0) (< end length))

397

(loop for found-uuid = (aref vector end) then next-uuid

398

for position from (1- end) downto 0

399

for next-uuid = (aref vector position)

400

;;do (print (list :found found-uuid :next next-uuid :position position))

401

if (not (funcall test found-uuid next-uuid))

402

return position)))

403

404

 ;;; (loop with v = #(11 11 12 12) for i from 0 upto (length v) collect (list i (multiple-value-list (position-uuid-vector-end i v :test #'= :end-p #'evenp))))

405

 ;;; (loop with v = #(11 11 12 12) for i from 0 upto (length v) collect (list i (multiple-value-list (position-uuid-vector-end i v :test #'= :end-p #'oddp))))

406

 ;;; (loop with v = #(11) for i from 0 upto (length v) collect (list i (multiple-value-list (position-uuid-vector-end i v :test #'= :end-p #'oddp))))

407

 ;;; (loop with v = #() for i from 0 upto (length v) collect (list i (multiple-value-list (position-uuid-vector-end i v :test #'= :end-p #'oddp))))

408

409

410

(defgeneric position-uuid (revision-uuid revision-sequence &key length test)

411

(:method ((%uuid SB-SYS:SYSTEM-AREA-POINTER) (%vector SB-SYS:SYSTEM-AREA-POINTER)

412

             &key (length (error "position-uuid: length is required")) (test #'%compare-v1-uuid-date))

413

(%position-uuid %uuid %vector :length length :test test))

414

(:method ((uuid vector) (sequence vector)

415

&key (length (length sequence)) (test #'compare-v1-uuid-date-vector))

416

(position-uuid-vector uuid sequence :length length :test test)))

417

418

419

(defgeneric test-uuid-visibility (revision-uuid revision-sequence &key length)

420

(:documentation "Locate the highest uuid less that that given.

421

Iff it indicates insertion, then the quad is visible in that revision.

422

Handle the degenerate cases without searching.")

423

(:method ((%uuid SB-SYS:SYSTEM-AREA-POINTER) (%vector SB-SYS:SYSTEM-AREA-POINTER)

424

&key (length (error "position-uuid: length is required")))

425

(let ((position (%position-uuid %uuid %vector :length length :test #'%compare-v1-uuid-date)))

426

(when position

427

(values (insert-uuid-p (cffi:mem-aptr %vector '(:struct v1-uuid) position))

428

position))))

429

(:method ((uuid vector) (sequence vector) &key length)

430

(declare (ignore length))

431

(let ((position (position-uuid-vector uuid sequence :test #'compare-v1-uuid-date-vector)))

432

(when position

433

(values (insert-uuid-p (aref sequence position))

434

position)))))

435

436

(defgeneric merge-uuid-visibility (uuid vector &key length)

437

(:documentation "Locate the highest uuid less that that given.

438

Iff it is identical tot he givenuuid, return the sequenc unchanged.

439

Otherwise merge the new uuid after that found.")

440

#+(or)

441

(:method ((%uuid SB-SYS:SYSTEM-AREA-POINTER) (%vector SB-SYS:SYSTEM-AREA-POINTER)

442

&key (length (error "position-uuid: length is required")))

443

(let ((position (%position-uuid %uuid %vector :length length :test #'%compare-v1-uuid-date)))

444

(cond (position

445

(cond ((%uuid-equal uuid (cffi:mem-aptr %vector '(:struct v1-uuid) position))

446

%vector)

447

(t

448

                      (let ((%result (cffi:foreign-alloc '(:struct v1-uuid) :count (1+ length))))

449

(cffi:%mem-copy %vector %result '(:struct v1-uuid) (1+ position))

450

                        (cffi:%mem-copy %uuid (cffi:mem-aptr %vector '(:struct v1-uuid) 1) '(:struct v1-uuid) (+ 1 position))

451

                        (cffi:%mem-copy (cffi:mem-aptr %vector '(:struct v1-uuid)  (+ 2 position))

452

                                        (cffi:mem-aptr resultvector '(:struct v1-uuid) (+ 1 position))

453

                                        '(:struct v1-uuid) (- length position))

454

%result))))

455

(t

456

(let ((%result (cffi:foreign-alloc '(:struct v1-uuid) :count (1+ length))))

457

                (cffi:%mem-copy %vector (cffi:mem-aptr %vector '(:struct v1-uuid) 1) '(:struct v1-uuid) length)

458

(cffi:%mem-copy %uuid %vector '(:struct v1-uuid) 1)

459

%result)))))

460

461

(:method ((uuid vector) (vector vector) &key (length (length vector)))

462

(let ((position (position-uuid-vector uuid vector :test #'compare-v1-uuid :length length)))

463

(cond (position

464

(cond ((equalp uuid (aref vector position))

465

vector)

466

(t

467

(let ((result (make-array (1+ (length vector)))))

468

                       (replace result vector :start1 0 :end1 (+ 1 position) :start2 0 :end2 (+ 1 position))

469

(setf (aref result (+ 1 position)) uuid)

470

                       (replace result vector :start1 (+ 2 position) :start2 (+ 1 position))

471

result))))

472

(t

473

(let ((result (make-array (1+ (length vector)))))

474

(replace result vector :start1 1)

475

(setf (aref result 0) uuid)

476

result))))))

477

478

(defgeneric test-uuid-range-visibility (start-revision-uuid end-revision-uuid revision-sequence &key mode)

479

(:documentation "Locate the highest uuid less that that given.

480

Iff it indicates insertion, then the quad is visible in that revision.

481

Handle the degenerate cases without searching.")

482

(:method ((uuid-start vector) (uuid-end vector) (sequence vector) &key (mode 'every))

483

(let ((position-start (position-uuid-vector uuid-start sequence :test #'compare-v1-uuid-date-vector)))

484

(when position-start

485

(if (equalp uuid-start uuid-end)

486

(values (insert-uuid-p (aref sequence position-start))

487

position-start)

488

             (let ((position-end (position-uuid-vector uuid-end sequence :test #'compare-v1-uuid-date-vector)))

489

(unless position-end

490

                 (log-warn "uuid-range end not present: [~s ~s] ~s" uuid-start uuid-end sequence)

491

(setf position-end (1- (length sequence))))

492

(loop for position from position-start upto position-end

493

for visible = (insert-uuid-p (aref sequence position))

494

do (ecase mode

495

                      (some (when visible (return-from test-uuid-range-visibility (values t position))))

496

                      (every (when (not visible) (return-from test-uuid-range-visibility (values nil position))))

497

                      (not-any (when visible (return-from test-uuid-range-visibility (values nil position))))

498

                      (not-every (when (not visible) (return-from test-uuid-range-visibility (values t position)))))

499

finally (return-from test-uuid-range-visibility

500

(case mode

501

(some nil)

502

(every t)

503

(not-any t)

504

(not-every nil))))))))))

505

506

(defgeneric compute-revision-sequence-id (revision-sequence)

507

(:method ((revision-sequence vector))

508

(let ((digest (ironclad:make-digest +rsid-type+)))

509

(loop for uuid across revision-sequence

510

do (ironclad:update-digest digest uuid))

511

(ironclad:produce-digest digest))))

512