Coverage report: /home/ellis/comp/core/std/seq.lisp

KindCoveredAll%
expression3531307 27.0
branch36162 22.2
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; std/seq.lisp --- Standard Sequences
2
 
3
 ;;
4
 
5
 ;;; Code:
6
 (in-package :std/seq)
7
 
8
 (definline sequencep (object)
9
   (typecase object
10
     (sequence t)
11
     (t nil)))
12
 
13
 (defmacro nth-value-or (nth-value &body forms)
14
   "Evaluates FORM arguments one at a time, until the NTH-VALUE returned by one
15
 of the forms is true. It then returns all the values returned by evaluating
16
 that form. If none of the forms return a true nth value, this form returns
17
 NIL."
18
   (once-only (nth-value)
19
     (with-gensyms (values)
20
       `(let ((,values (multiple-value-list ,(first forms))))
21
          (if (nth ,nth-value ,values)
22
              (values-list ,values)
23
              ,(if (rest forms)
24
                   `(nth-value-or ,nth-value ,@(rest forms))
25
                   nil))))))
26
 
27
 (defun starts-with (object sequence &key (test #'eql) (key #'identity))
28
   "Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT.
29
 Returns NIL if the SEQUENCE is not a sequence or is an empty sequence."
30
   (let ((first-elt (typecase sequence
31
                      (cons (car sequence))
32
                      (sequence
33
                       (if (sequence:emptyp sequence)
34
                           (return-from starts-with nil)
35
                           (elt sequence 0)))
36
                      (t
37
                       (return-from starts-with nil)))))
38
     (funcall test (funcall key first-elt) object)))
39
 
40
 (defun take (n seq)
41
   "Return, at most, the first N elements of SEQ, as a *new* sequence
42
 of the same type as SEQ.
43
 
44
 If N is longer than SEQ, SEQ is simply copied.
45
 
46
 If N is negative, then |N| elements are taken (in their original
47
 order) from the end of SEQ."
48
   (declare (type signed-array-length n))
49
   (sb-impl::seq-dispatch 
50
    seq
51
    (if (minusp n)
52
        (last seq (abs n))
53
        (firstn n seq))
54
    (if (minusp n)
55
        (subseq seq (max 0 (+ (length seq) n)))
56
        (subseq seq 0 (min n (length seq))))))
57
 
58
 (defun take* (n list)
59
   "Returns a list with the first n elements of the given list, and the
60
 remaining tail of the list as a second value."
61
   (loop for l on list
62
         repeat n
63
         collect (car l) into result
64
         finally (return (values result l))))
65
 
66
 (defun starts-with-subseq (prefix sequence 
67
                            &rest args
68
                            &key return-suffix &allow-other-keys)
69
   "Test whether the first elements of SEQUENCE are the same (as per TEST) as the
70
 elements of PREFIX.
71
 
72
 If RETURN-SUFFIX is T the function returns, as a second value, a sub-sequence
73
 or displaced array pointing to the sequence after PREFIX."
74
   (declare (dynamic-extent args))
75
   (let ((sequence-length (length sequence))
76
         (prefix-length (length prefix)))
77
     (when (< sequence-length prefix-length)
78
       (return-from starts-with-subseq (values nil nil)))
79
     (flet ((make-suffix (start)
80
              (when return-suffix
81
                (cond
82
                  ((not (arrayp sequence))
83
                   (if start
84
                       (subseq sequence start)
85
                       (subseq sequence 0 0)))
86
                  ((not start)
87
                   (make-array 0 :element-type (array-element-type sequence)
88
                                 :adjustable nil))
89
                  (t (make-array (- sequence-length start)
90
                                 :element-type (array-element-type sequence)
91
                                 :displaced-to sequence
92
                                 :displaced-index-offset start
93
                                 :adjustable nil))))))
94
       (remf args :return-suffix)
95
       (let ((mismatch (apply #'mismatch prefix sequence args)))
96
         (cond ((not mismatch) (values t (make-suffix nil)))
97
               ((= mismatch prefix-length) (values t (make-suffix mismatch)))
98
               (t (values nil nil)))))))
99
 
100
 (defun ends-with-subseq (suffix sequence &key (test #'eql))
101
   "Test whether SEQUENCE ends with SUFFIX. In other words: return true if
102
 the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX."
103
   (let ((sequence-length (length sequence))
104
         (suffix-length (length suffix)))
105
     (when (< sequence-length suffix-length)
106
       ;; if SEQUENCE is shorter than SUFFIX, then SEQUENCE can't end with SUFFIX.
107
       (return-from ends-with-subseq nil))
108
     (loop for sequence-index from (- sequence-length suffix-length) below sequence-length
109
           for suffix-index from 0 below suffix-length
110
           when (not (funcall test (elt sequence sequence-index) (elt suffix suffix-index)))
111
           do (return-from ends-with-subseq nil)
112
           finally (return t))))
113
 
114
 (defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied))
115
   "Return a list of subsequences in seq delimited by delimiter.
116
 
117
 If :remove-empty-subseqs is NIL, empty subsequences will be included in the
118
 result; otherwise they will be discarded. All other keywords work analogously
119
 to those for CL:SUBSTITUTE. In particular, the behaviour of :from-end is
120
 possibly different from other versions of this function; :from-end values of
121
 NIL and T are equivalent unless :count is supplied. The second return value is
122
 an index suitable as an argument to CL:SUBSEQ into the sequence indicating
123
 where processing stopped."
124
   (let ((len (length seq))
125
         (other-keys 
126
           (nconc (when test-supplied 
127
                    (list :test test))
128
                  (when test-not-supplied 
129
                    (list :test-not test-not))
130
                  (when key-supplied 
131
                    (list :key key)))))
132
     (unless end (setq end len))
133
     (if from-end
134
         (loop for right = end then left
135
               for left = (max (or (apply #'position delimiter seq 
136
                                          :end right
137
                                          :from-end t
138
                                          other-keys)
139
                                   -1)
140
                               (1- start))
141
               unless (and (= right (1+ left))
142
                           remove-empty-subseqs) ; empty subseq we don't want
143
               if (and count (>= nr-elts count))
144
               ;; We can't take any more. Return now.
145
               return (values (nreverse subseqs) right)
146
               else 
147
               collect (subseq seq (1+ left) right) into subseqs
148
               and sum 1 into nr-elts
149
               until (< left start)
150
               finally (return (values (nreverse subseqs) (1+ left))))
151
         (loop for left = start then (+ right 1)
152
               for right = (min (or (apply #'position delimiter seq 
153
                                           :start left
154
                                           other-keys)
155
                                    len)
156
                                end)
157
               unless (and (= right left) 
158
                           remove-empty-subseqs) ; empty subseq we don't want
159
               if (and count (>= nr-elts count))
160
               ;; We can't take any more. Return now.
161
               return (values subseqs left)
162
               else
163
               collect (subseq seq left right) into subseqs
164
               and sum 1 into nr-elts
165
               until (>= right end)
166
               finally (return (values subseqs right))))))
167
 
168
 (defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
169
   "Return a list of subsequences in seq delimited by items satisfying
170
 predicate.
171
 
172
 If :remove-empty-subseqs is NIL, empty subsequences will be included in the
173
 result; otherwise they will be discarded. All other keywords work analogously
174
 to those for CL:SUBSTITUTE-IF. In particular, the behaviour of :from-end is
175
 possibly different from other versions of this function; :from-end values of
176
 NIL and T are equivalent unless :count is supplied. The second return value is
177
 an index suitable as an argument to CL:SUBSEQ into the sequence indicating
178
 where processing stopped."
179
   (let ((len (length seq))
180
         (other-keys (when key-supplied (list :key key))))
181
     (unless end (setq end len))
182
     (if from-end
183
         (loop for right = end then left
184
               for left = (max (or (apply #'position-if predicate seq 
185
                                          :end right
186
                                          :from-end t
187
                                          other-keys)
188
                                   -1)
189
                               (1- start))
190
               unless (and (= right (1+ left))
191
                           remove-empty-subseqs) ; empty subseq we don't want
192
               if (and count (>= nr-elts count))
193
               ;; We can't take any more. Return now.
194
               return (values (nreverse subseqs) right)
195
               else 
196
               collect (subseq seq (1+ left) right) into subseqs
197
               and sum 1 into nr-elts
198
               until (< left start)
199
               finally (return (values (nreverse subseqs) (1+ left))))
200
         (loop for left = start then (+ right 1)
201
               for right = (min (or (apply #'position-if predicate seq 
202
                                           :start left
203
                                           other-keys)
204
                                    len)
205
                                end)
206
               unless (and (= right left) 
207
                           remove-empty-subseqs) ; empty subseq we don't want
208
               if (and count (>= nr-elts count))
209
               ;; We can't take any more. Return now.
210
               return (values subseqs left)
211
               else
212
               collect (subseq seq left right) into subseqs
213
               and sum 1 into nr-elts
214
               until (>= right end)
215
               finally (return (values subseqs right))))))
216
 
217
 (defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
218
   "Return a list of subsequences in seq delimited by items satisfying
219
 (CL:COMPLEMENT predicate).
220
 
221
 If :remove-empty-subseqs is NIL, empty subsequences will be included
222
 in the result; otherwise they will be discarded.  All other keywords
223
 work analogously to those for CL:SUBSTITUTE-IF-NOT.  In particular,
224
 the behaviour of :from-end is possibly different from other versions
225
 of this function; :from-end values of NIL and T are equivalent unless
226
 :count is supplied. The second return value is an index suitable as an
227
 argument to CL:SUBSEQ into the sequence indicating where processing
228
 stopped."
229
   (let ((len (length seq))
230
         (other-keys (when key-supplied (list :key key))))
231
     (unless end (setq end len))
232
     (if from-end
233
         (loop for right = end then left
234
               for left = (max (or (apply #'position-if-not predicate seq 
235
                                          :end right
236
                                          :from-end t
237
                                          other-keys)
238
                                   -1)
239
                               (1- start))
240
               unless (and (= right (1+ left))
241
                           remove-empty-subseqs) ; empty subseq we don't want
242
               if (and count (>= nr-elts count))
243
               ;; We can't take any more. Return now.
244
               return (values (nreverse subseqs) right)
245
               else 
246
               collect (subseq seq (1+ left) right) into subseqs
247
               and sum 1 into nr-elts
248
               until (< left start)
249
               finally (return (values (nreverse subseqs) (1+ left))))
250
         (loop for left = start then (+ right 1)
251
               for right = (min (or (apply #'position-if-not predicate seq 
252
                                           :start left
253
                                           other-keys)
254
                                    len)
255
                                end)
256
               unless (and (= right left) 
257
                           remove-empty-subseqs) ; empty subseq we don't want
258
               if (and count (>= nr-elts count))
259
               ;; We can't take any more. Return now.
260
               return (values subseqs left)
261
               else
262
               collect (subseq seq left right) into subseqs
263
               and sum 1 into nr-elts
264
               until (>= right end)
265
               finally (return (values subseqs right))))))
266
 
267
 ;; from hunchentoot
268
 (defun starts-with-p (seq subseq &key (test 'eql))
269
   "Tests whether the sequence SEQ starts with the sequence
270
 SUBSEQ.  Individual elements are compared with TEST."
271
   (let* ((length (length subseq))
272
          (mismatch (mismatch subseq seq :test test)))
273
     (or (null mismatch) (<= length mismatch))))
274
 
275
 ;; from hunchentoot
276
 (defun starts-with-one-of-p (seq subseq-list &key (test 'eql))
277
   "Tests whether the sequence SEQ starts with one of the
278
 sequences in SUBSEQ-LIST.  Individual elements are compared with
279
 TEST."
280
   (some (lambda (subseq) (starts-with-p seq subseq :test test)) subseq-list))
281
 
282
 ;; matlisp
283
 (definline copy-n (vec lst n)
284
   "Copy N elements of vector VEC into list LST."
285
   (declare (type vector vec)
286
            (type list lst)
287
            (type fixnum n))
288
   (loop for i of-type fixnum from 0 below n
289
         for vlst = lst then (cdr vlst)
290
         do (setf (car vlst) (aref vec i)))
291
   lst)
292
 
293
 ;;; Queues
294
 ;;;; Conditions
295
 (defun queue-size-limit-reached (condition stream)
296
   (let ((queue (error-queue condition))
297
         (element (error-element condition)))
298
     (format stream "Size limit (~D) reached for non-extensible ~
299
                     queue ~S while trying to enqueue element ~S onto it."
300
             (length (data queue)) queue element)))
301
 
302
 (define-condition queue-size-limit-reached (error)
303
   ((queue :reader error-queue :initarg :queue)
304
    (element :reader error-element :initarg :element))
305
   (:report queue-size-limit-reached)
306
   (:documentation "Error signaled when a queue is saturated."))
307
 
308
 ;;;; Basic Queue
309
 (defstruct (basic-queue (:conc-name nil)
310
                         (:constructor %make-basic-queue (head tail)))
311
   "A basic queue structure."
312
   (head (error "no head") :type list)
313
   (tail (error "no tail") :type list))
314
 
315
 (defun make-basic-queue ()
316
   "Make a BASIC-QUEUE with nil head and tail."
317
   (%make-basic-queue nil nil))
318
 
319
 (defun push-basic-queue (val queue)
320
   "Push VAL to QUEUE."
321
   (declare (basic-queue queue))
322
   (let ((new (cons val nil)))
323
     (if (head queue)
324
         (setf (cdr (tail queue)) new
325
               (head queue) new)
326
         (setf (tail queue) new))))
327
 
328
 (defun pop-basic-queue (queue)
329
   "Pop the next value off of QUEUE."
330
   (declare (basic-queue queue))
331
   (let ((node (head queue)))
332
     (if node
333
         (multiple-value-prog1 (values (car node) t)
334
           (when (null (setf (head queue) (cdr node)))
335
             (setf (tail queue) nil))
336
           ;; clear node for conservative gcs
337
           (setf (car node) nil
338
                 (cdr node) nil))
339
         (values nil nil))))
340
 
341
 (defun basic-queue-count (queue) 
342
   "Return the count of QUEUE."
343
   (length (the list (head queue))))
344
 (defun basic-queue-empty-p (queue) 
345
   "Return T if QUEUE is empty."
346
   (not (head queue)))
347
 (defun peek-basic-queue (queue) 
348
   "Peek at the next value of QUEUE."
349
   (let ((node (head queue)))
350
     (values (car node)
351
             (if node t nil))))
352
 
353
 ;;;; Raw Queue (vectorized)
354
 (deftype raw-queue-count () 
355
   "The integer type of RAW-QUEUE counts."
356
   'std/type:array-length)
357
 
358
 (defstruct (raw-queue (:constructor %make-raw-queue))
359
   "A raw queue based on a simple vector."
360
   (data (vector) :type simple-array)
361
   (start 0 :type std/type:array-index)
362
   (count 0 :type raw-queue-count))
363
 
364
 (defmethod data ((self raw-queue))
365
   (raw-queue-data self))
366
 
367
 (defun make-raw-queue (capacity &rest args)
368
   "Return a fresh queue with specified CAPACITY."
369
   (%make-raw-queue :data (apply 'make-array capacity args)))
370
 
371
 (defun push-raw-queue (val queue)
372
   "Push VAL to QUEUE."
373
   (declare (raw-queue queue))
374
   (with-slots (data start count) queue
375
     (setf (svref data (mod (+ start count) (length data))) val)
376
     (incf count))
377
   (values))
378
 
379
 (defun pop-raw-queue (queue)
380
   "Pop the next value off of QUEUE."
381
   (declare (raw-queue queue))
382
   (with-slots (data start count) queue
383
     (let ((data data))
384
       (if (plusp count)
385
           (multiple-value-prog1 (values (svref data start) t)
386
             (setf (svref data start) nil
387
                   start (mod (1+ start) (length data)))
388
             (decf count))
389
           (values nil nil)))))
390
 
391
 (defun peek-raw-queue (queue)
392
   "Peek at the next value of QUEUE."
393
   (declare (raw-queue queue))
394
   (with-slots (data start count) queue
395
     (if (plusp count)
396
         (values (svref data start) t)
397
         (values nil nil))))
398
 
399
 (defun raw-queue-empty-p (queue) 
400
   "Return T if the QUEUE is empty."
401
   (declare (raw-queue queue))
402
   (zerop (raw-queue-count queue)))
403
 
404
 (defun raw-queue-full-p (queue) 
405
   "Return T if the QUEUE is full."
406
   (declare (raw-queue queue))
407
   (eql (raw-queue-count queue) (length (raw-queue-data queue))))
408
 
409
 (defun raw-queue-capacity (queue) 
410
   "Return the capacity of QUEUE."
411
   (declare (raw-queue queue))
412
   (length (raw-queue-data queue)))
413
 
414
 ;;;; Vector Queue
415
 ;; A thread-safe queue backed by a vector
416
 (defstruct (vector-queue (:constructor %make-vector-queue))
417
   "A vector queue backed by a primitive queue - defaults to RAW-QUEUE."
418
   (impl (make-raw-queue 0) :type raw-queue)
419
   (lock (make-mutex))
420
   (%push nil)
421
   (%pop nil))
422
 
423
 (defaccessor data ((self vector-queue))
424
   (raw-queue-data (vector-queue-impl self)))
425
 
426
 (defaccessor lock ((self vector-queue))
427
   (vector-queue-lock self))
428
 
429
 (defun make-vector-queue* (capacity &rest args)
430
   "Return a fresh VECTOR-QUEUE with specified CAPACITY."
431
   (%make-vector-queue :impl (apply 'make-raw-queue capacity args)))
432
 
433
 (defmacro with-vector-queue-lock (queue &body body)
434
   "Eval BODY while holding a lock on QUEUE."
435
   `(with-mutex ((vector-queue-lock ,queue))
436
      ,@body))
437
 
438
 ;; no lock
439
 (declaim (inline push-vector-queue* pop-vector-queue*))
440
 (defun push-vector-queue* (obj queue)
441
   "Push OBJ to QUEUE without locking Returns the current count of QUEUE before
442
 push."
443
   (with-slots (impl lock %push %pop) queue
444
     (let ((count (raw-queue-count impl)))
445
       (loop (cond ((< count (raw-queue-capacity impl))
446
                    (push-raw-queue obj impl)
447
                    (when %push
448
                      (condition-notify %push))
449
                    (return count))
450
                   (t
451
                    (condition-wait
452
                     (or %pop
453
                         (setf %pop (make-waitqueue)))
454
                     lock)))))))
455
 
456
 (defun push-vector-queue (obj queue)
457
   "Push OBJ to QUEUE with locking."
458
   (declare (vector-queue queue))
459
   (with-mutex ((vector-queue-lock queue))
460
     (push-vector-queue* obj queue)
461
     (values)))
462
 
463
 (defun pop-vector-queue* (queue)
464
   "Pop the next element from QUEUE without locking."
465
   (declare (vector-queue queue))
466
   (with-slots (impl lock %push %pop) queue
467
     (loop (multiple-value-bind (value presentp) (pop-raw-queue impl)
468
             (cond (presentp
469
                    (when %pop
470
                      (condition-notify %pop))
471
                    (return value))
472
                   (t 
473
                    (condition-wait
474
                     (or %push
475
                         (setf %push (make-waitqueue)))
476
                     lock)))))))
477
 
478
 (defun pop-vector-queue (queue)
479
   "Pop the next element from QUEUE with locking."
480
   (declare (vector-queue queue))
481
   (with-mutex ((vector-queue-lock queue))
482
     (pop-vector-queue* queue)))
483
 
484
 (defun %try-pop-vector-queue (queue timeout)
485
   ;; queue is empty and timeout is positive
486
   (with-countdown timeout
487
     (with-slots (impl lock %push %pop) queue
488
       (loop (multiple-value-bind (value presentp) (pop-raw-queue impl)
489
               (when presentp
490
                 (when %pop (condition-notify %pop))
491
                 (return (values value t)))
492
               (let ((time-remaining (time-remaining)))
493
                 (when (or (not (plusp time-remaining))
494
                           (null (condition-wait
495
                                  (or %push (setf %push (make-waitqueue)))
496
                                  lock :timeout time-remaining)))
497
                   (return (values nil nil)))))))))
498
 
499
 (defun %try-pop-vector-queue-with-timeout (queue timeout)
500
   (with-slots (impl) queue
501
     (if (raw-queue-empty-p impl)
502
         (%try-pop-vector-queue queue timeout)
503
         (pop-raw-queue impl))))
504
 
505
 (defun try-pop-vector-queue* (queue)
506
   "Attempt to pop the next element from QUEUE without locking."
507
   (with-slots (impl %pop) queue
508
     (multiple-value-bind (value presentp) (pop-raw-queue impl)
509
       (cond (presentp
510
              (when %pop (condition-notify %pop))
511
              (values value t))
512
             (t (values nil nil))))))
513
 
514
 (defun try-pop-vector-queue (queue timeout)
515
   "Attempt to pop the next element from QUEUE with locking."
516
   (if (raw-queue-empty-p (vector-queue-impl queue))
517
       (%try-pop-vector-queue-with-timeout queue timeout)
518
       (try-pop-vector-queue* queue)))
519
 
520
 (macrolet ((define-queue-fn (name type raw)
521
              `(progn
522
                 (defun ,name (queue) 
523
                   (declare (,type queue))
524
                   (with-mutex ((vector-queue-lock queue))
525
                     (,raw (vector-queue-impl queue))))
526
                 (defun ,(symbolicate (concatenate 'string (symbol-name name) "*")) (queue)
527
                   (declare (,type queue))
528
                   (,raw (vector-queue-impl queue))))))
529
   (define-queue-fn vector-queue-count vector-queue raw-queue-count)
530
   (define-queue-fn vector-queue-empty-p vector-queue raw-queue-empty-p)
531
   (define-queue-fn vector-queue-full-p vector-queue raw-queue-full-p)
532
   (define-queue-fn peek-vector-queue vector-queue peek-raw-queue))
533
 
534
 (defun make-vector-queue (capacity &rest args &key initial-contents &allow-other-keys)
535
   "Make a new VECTOR-QUEUE with specified CAPACITY and INITIAL-CONTENTS."
536
   (remf args :initial-contents)
537
   (let ((queue (apply 'make-vector-queue* capacity args)))
538
     (when initial-contents
539
       (block done
540
         (flet ((push-elem (elem)
541
                  (when (vector-queue-full-p queue)
542
                    (return-from done))
543
                  (push-vector-queue elem queue)))
544
           (declare (dynamic-extent #'push-elem))
545
           (map nil #'push-elem initial-contents))))
546
     queue))
547
 
548
 ;;;; Cons Queue
549
 ;; A thread-safe queue backed by a linked list.
550
 (defstruct (cons-queue (:constructor %make-cons-queue))
551
   "A cons-based queue backed by a BASIC-QUEUE."
552
   (impl (make-basic-queue) :type basic-queue)
553
   (lock (sb-thread:make-mutex))
554
   (cvar nil))
555
 
556
 (defmethod data ((self cons-queue))
557
   (cons-queue-impl self))
558
 
559
 (defmethod next ((self cons-queue))
560
   (head (data self)))
561
 
562
 (defmethod prev ((self cons-queue))
563
   (tail (data self)))
564
 
565
 (defmacro with-cons-queue-lock (queue &body body)
566
   "Eval BODY while holding a lock on QUEUE."
567
   `(with-mutex ((cons-queue-lock ,queue))
568
      ,@body))
569
 
570
 (declaim (inline push-cons-queue* pop-cons-queue*))
571
 (defun push-cons-queue* (obj queue) 
572
   "Push OBJ to QUEUE without locking."
573
   (declare (cons-queue queue))
574
   (with-slots (impl cvar) queue
575
     (push-basic-queue obj impl)
576
     (when cvar
577
       (condition-notify cvar)))
578
   (values))
579
 
580
 (defun push-cons-queue (obj queue) 
581
   "Push OBJ to QUEUE with locking."
582
   (declare (cons-queue queue))
583
   (with-mutex ((cons-queue-lock queue))
584
     (push-cons-queue* obj queue)))
585
 
586
 (defun pop-cons-queue* (queue)
587
   "Pop the next element off QUEUE without locking."
588
   (declare (cons-queue queue))
589
   (with-slots (impl lock cvar) queue
590
     (loop (multiple-value-bind (value presentp) (pop-basic-queue impl)
591
             (if presentp
592
                 (return value)
593
                 (condition-wait (or cvar (setf cvar (make-waitqueue)))
594
                                 lock))))))
595
 
596
 (defun pop-cons-queue (queue) 
597
   "Pop the next element off QUEUE with locking."
598
   (declare (cons-queue queue))
599
   (with-mutex ((cons-queue-lock queue))
600
     (pop-cons-queue* queue)))
601
 
602
 (defun %try-pop-cons-queue (queue timeout)
603
   ;; queue is empty and timeout is positive
604
   (with-countdown timeout
605
     (with-slots (impl lock cvar) queue
606
       (loop (multiple-value-bind (value presentp) (pop-basic-queue impl)
607
               (when presentp
608
                 (return (values value t)))
609
               (let ((time-remaining (time-remaining)))
610
                 (when (or (not (plusp time-remaining))
611
                           (null (condition-wait
612
                                  (or cvar (setf cvar (make-waitqueue)))
613
                                  lock :timeout time-remaining)))
614
                   (return (values nil nil)))))))))
615
 
616
 (defun try-pop-cons-queue-with-timeout (queue timeout)
617
   (with-slots (impl) queue
618
     (if (basic-queue-empty-p impl)
619
         (%try-pop-cons-queue queue timeout)
620
         (pop-basic-queue impl))))
621
 
622
 (defun try-pop-cons-queue (queue timeout)
623
   "Attempt to pop the next element from QUEUE waiting at most TIMEOUT seconds."
624
   (with-slots (impl lock) queue
625
     (cond ((plusp timeout)
626
            (with-mutex (lock)
627
              (try-pop-cons-queue queue timeout)))
628
           (t
629
            ;; optimization: don't lock if nothing is there
630
            (with-mutex (lock :wait-p nil) 
631
              (when (not (basic-queue-empty-p impl))
632
                (return-from try-pop-cons-queue (pop-basic-queue impl))))
633
            (values nil nil)))))
634
 
635
 (defun try-pop-cons-queue* (queue timeout)
636
   "Attempt to pop the next element from QUEUE, waiting at most TIMEOUT seconds
637
 for a lock before calling without it."
638
   (if (plusp timeout)
639
       (try-pop-cons-queue-with-timeout queue timeout)
640
       (pop-basic-queue (cons-queue-impl queue))))
641
 
642
 (macrolet ((define-queue-fn (name type raw)
643
              `(progn
644
                 (defun ,name (queue) 
645
                   (declare (,type queue))
646
                   (with-mutex ((cons-queue-lock queue))
647
                     (,raw (cons-queue-impl queue))))
648
                 (defun ,(symbolicate (concatenate 'string (symbol-name name) "*")) (queue)
649
                   (declare (,type queue))
650
                   (,raw (cons-queue-impl queue))))))
651
   (define-queue-fn cons-queue-count cons-queue basic-queue-count)
652
   (define-queue-fn cons-queue-empty-p cons-queue basic-queue-empty-p)
653
   (define-queue-fn peek-cons-queue cons-queue peek-basic-queue))
654
 
655
 (defun make-cons-queue (&key initial-contents)
656
   "Make a new CONS-QUEUE with INITIAL-CONTENTS."
657
   (let ((queue (%make-cons-queue)))
658
     (when initial-contents
659
       (flet ((push-elem (elem)
660
                (push-cons-queue elem queue)))
661
         (declare (dynamic-extent #'push-elem))
662
         (map nil #'push-elem initial-contents)))
663
     queue))
664
 
665
 ;;; Priority Queue
666
 ;; this queue implementation is based on phoe's DAMN-FAST-PRIORITY-QUEUE
667
 ;; ref: https://github.com/phoe/damn-fast-priority-queue/blob/main/damn-fast-priority-queue/src.lisp
668
 
669
 ;; TODO 2025-05-27: make thread-safe version? currently not needed
670
 (defvar *default-priority* 0
671
   "The default priority of elements pushed to a PRIORITY-QUEUE.")
672
 (defvar *default-priority-queue-size* 256
673
   "The default size of a PRIORITY-QUEUE.")
674
 (deftype priority () '(unsigned-byte 32))
675
 (deftype priority-vector () '(simple-array priority (*)))
676
 (deftype priority-vector-extension () '(integer 2 256))
677
 
678
 (defstruct (priority-queue (:constructor %make-priority-queue))
679
   "An (optionally) adjustable Priority Queue backed by a data vector and
680
 associated priority vector."
681
   (data (make-array *default-priority-queue-size*) :type simple-array)
682
   (priorities (make-array *default-priority-queue-size* :element-type 'priority) :type priority-vector)
683
   (size 0 :type array-length)
684
   (extension 256 :type priority-vector-extension)
685
   (extend-p t :type boolean))
686
 
687
 (defmethod data ((self priority-queue))
688
   (priority-queue-data self))
689
 
690
 (declaim (ftype (function (simple-array priority-vector array-length)
691
                     (values null &optional))
692
                 heapify-upwards))
693
 (definline heapify-upwards (data-vector prio-vector index)
694
   (declare (type simple-array data-vector))
695
   (declare (type priority-vector prio-vector))
696
   (declare (type array-length index))
697
   (do ((child-index index parent-index)
698
        (parent-index (ash (1- index) -1) (ash (1- parent-index) -1)))
699
       ((= child-index 0))
700
     (let ((child-priority (aref prio-vector child-index))
701
           (parent-priority (aref prio-vector parent-index)))
702
       (cond ((< child-priority parent-priority)
703
              (rotatef (aref prio-vector parent-index)
704
                       (aref prio-vector child-index))
705
              (rotatef (aref data-vector parent-index)
706
                       (aref data-vector child-index)))
707
             (t (return))))))
708
 
709
 (declaim (ftype (function (queue t priority) (values null &optional)) push-priority-queue))
710
 (definline push-priority-queue (queue object priority)
711
   "Push OBJECT to QUEUE with supplied PRIORITY."
712
   (symbol-macrolet ((data-vector (priority-queue-data queue))
713
                     (prio-vector (priority-queue-priorities queue)))
714
     (let ((size (priority-queue-size queue))
715
           (extension-factor (priority-queue-extension queue))
716
           (length (array-total-size data-vector)))
717
       (when (>= size length)
718
         (unless (priority-queue-extend-p queue)
719
           (error 'queue-size-limit-reached :queue queue :element object))
720
         (let ((new-length (max 1 (mod (* length extension-factor)
721
                                       (ash 1 64)))))
722
           (declare (type array-length new-length))
723
           (when (<= new-length length)
724
             (error "Integer overflow while resizing array: new-length ~D is ~
725
                     smaller than old length ~D" new-length length))
726
           (setf data-vector (adjust-array data-vector new-length)
727
                 prio-vector (adjust-array prio-vector new-length))))
728
       (setf (aref data-vector size) object
729
             (aref prio-vector size) priority)
730
       (heapify-upwards data-vector prio-vector (priority-queue-size queue))
731
       (incf (priority-queue-size queue))
732
       nil)))
733
 
734
 (declaim (ftype (function (simple-array priority-vector array-index)
735
                     (values null &optional))
736
                 heapify-downwards))
737
 (definline heapify-downwards (data-vector prio-vector size)
738
   (declare (type simple-array data-vector))
739
   (declare (type priority-vector prio-vector))
740
   (let ((parent-index 0))
741
     (loop
742
       (let* ((left-index (+ (* parent-index 2) 1))
743
              (left-index-validp (< left-index size))
744
              (right-index (+ (* parent-index 2) 2))
745
              (right-index-validp (< right-index size)))
746
         (flet ((swap-left ()
747
                  (rotatef (aref prio-vector parent-index)
748
                           (aref prio-vector left-index))
749
                  (rotatef (aref data-vector parent-index)
750
                           (aref data-vector left-index))
751
                  (setf parent-index left-index))
752
                (swap-right ()
753
                  (rotatef (aref prio-vector parent-index)
754
                           (aref prio-vector right-index))
755
                  (rotatef (aref data-vector parent-index)
756
                           (aref data-vector right-index))
757
                  (setf parent-index right-index)))
758
           (declare (inline swap-left swap-right))
759
           (when (and (not left-index-validp)
760
                      (not right-index-validp))
761
             (return))
762
           (when (and left-index-validp
763
                      (< (aref prio-vector parent-index)
764
                         (aref prio-vector left-index))
765
                      (or (not right-index-validp)
766
                          (< (aref prio-vector parent-index)
767
                             (aref prio-vector right-index))))
768
             (return))
769
           (if (and right-index-validp
770
                    (<= (aref prio-vector right-index)
771
                        (aref prio-vector left-index)))
772
               (swap-right)
773
               (swap-left)))))))
774
 
775
 (declaim (ftype (function (queue) (values t boolean &optional)) dequeue))
776
 (definline pop-priority-queue (queue)
777
   "Pop the next element from QUEUE."
778
   (declare (type queue queue))
779
   (if (= 0 (priority-queue-size queue))
780
       (values nil nil)
781
       (let ((data-vector (priority-queue-data queue))
782
             (prio-vector (priority-queue-priorities queue)))
783
         (multiple-value-prog1 (values (aref data-vector 0) t)
784
           (decf (priority-queue-size queue))
785
           (let ((old-data (aref data-vector (priority-queue-size queue)))
786
                 (old-prio (aref prio-vector (priority-queue-size queue))))
787
             (setf (aref data-vector 0) old-data
788
                   (aref prio-vector 0) old-prio))
789
           (heapify-downwards data-vector prio-vector (priority-queue-size queue))))))
790
 
791
 (defun make-priority-queue (capacity &key initial-contents prioritize (element-type t) initial-element)
792
   "Make a new PRIORITY-QUEUE with specified CAPACITY."
793
   (let ((queue (%make-priority-queue
794
                 :data (make-array capacity :element-type element-type :initial-element initial-element)
795
                 :priorities (make-array capacity :element-type 'priority))))
796
     (setf (priority-queue-size queue) capacity)
797
     (when initial-contents
798
       (flet ((push-elem (elem)
799
                (push-priority-queue elem queue (if prioritize (funcall prioritize elem) *default-priority*))))
800
         (declare (dynamic-extent #'push-elem))
801
         (map nil #'push-elem initial-contents)))
802
     queue))
803
 
804
 ;;; Spin Queue
805
 (defconstant +dummy+ :null
806
   "Dummy SPIN-QUEUE value.")
807
 
808
 (defconstant +dead-end+ :dead
809
   "Dead-end value for SPIN-QUEUEs.")
810
 
811
 (defun make-spin-lock () 
812
   "Allocate a fresh 'spin-lock' which is simply NIL."
813
   nil)
814
 
815
 (defstruct (spin-queue (:constructor %make-spin-queue (head tail)))
816
   "CAS-based spin-lock queue."
817
   (head (error "no head") :type cons)
818
   (tail (error "no tail") :type cons))
819
 
820
 (defun make-spin-queue ()
821
   "Make a fresh SPIN-QUEUE."
822
   (let ((dummy (cons +dummy+ nil)))
823
     (%make-spin-queue dummy dummy)))
824
 
825
 (defun push-spin-queue (value queue) 
826
   "Push VALUE onto QUEUE."
827
   (declare (ftype (function (t spin-queue) (values)) push-spin-queue))
828
   ;; Attempt CAS, repeat upon failure. Upon success update QUEUE-TAIL.
829
   (let ((new (cons value nil)))
830
     (loop (when (sb-ext:cas (cdr (spin-queue-tail queue)) nil new)
831
             (setf (spin-queue-tail queue) new)
832
             (return (values))))))
833
 
834
 (defun pop-spin-queue (queue) 
835
   "Attempt to CAS QUEUE-HEAD with the next node, repeat upon failure. Upon
836
 success, clear the discarded node and set the CAR of QUEUE-HEAD to +DUMMY+."
837
   (declare (ftype (function (spin-queue) (values t boolean))))
838
   (loop (let* ((head (spin-queue-head queue))
839
                (next (cdr head)))
840
           ;; NEXT could be +DEAD-END+, whereupon we try again.
841
           (typecase next
842
             (null (return (values nil nil)))
843
             (cons (when (sb-ext:cas (spin-queue-head queue) head next)
844
                     (let ((value (car next)))
845
                       (setf (cdr head) +dead-end+
846
                             (car next) +dummy+)
847
                       (return (values value t)))))))))
848
 
849
 (defun spin-queue-empty-p (queue)
850
   "Return T if QUEUE is empty."
851
   (null (cdr (spin-queue-head queue))))
852
 
853
 (defun try-each-elem (fun queue)
854
   "Try FUN on each element of QUEUE."
855
   (declare ((function (t) (values t boolean)) fun))
856
   (let ((node (spin-queue-head queue)))
857
     (loop
858
       (let ((value (car node)))
859
         (unless (eq value +dummy+)
860
           (funcall fun value)))
861
       (setf node (cdr node))
862
       (cond 
863
         ((eq node +dead-end+)
864
          (return nil))
865
         ((null node)
866
          (return t))))))
867
 
868
 (defun spin-queue-count (queue)
869
   "Return the count of QUEUE."
870
   (tagbody
871
    :retry
872
      (let ((count 0))
873
        (declare (fixnum count))
874
        (unless (try-each-elem
875
                 (lambda (elem)
876
                   (declare (ignore elem))
877
                   (incf count))
878
                 queue)
879
          (go :retry))
880
        (return-from spin-queue-count count))))
881
 
882
 (defun peek-spin-queue (queue)
883
   "Peek at the next element of QUEUE."
884
   (declare (optimize (safety 0)))
885
   (loop 
886
     until (try-each-elem 
887
            (lambda (elem)
888
              (return-from peek-spin-queue (values elem t)))
889
            queue))
890
   (values nil nil))
891
 
892
 ;;;; Protocol
893
 (deftype queue () 
894
   "Queue type spec."
895
   '(or cons-queue vector-queue raw-queue basic-queue priority-queue spin-queue))
896
 
897
 (defun make-queue (&key capacity initial-contents prioritize initial-element element-type)
898
   "Make a new queue."
899
   (cond 
900
     ((and capacity (not prioritize)) (make-vector-queue capacity :initial-contents initial-contents :initial-element initial-element))
901
     ((not prioritize) (make-cons-queue :initial-contents initial-contents))
902
     (prioritize (make-priority-queue (or capacity *default-priority-queue-size*) :initial-contents initial-contents :prioritize prioritize :initial-element initial-element :element-type element-type))))
903
 
904
 (defun call-with-cons-queue-lock (fn queue)
905
   "Call FN with a lock on QUEUE."
906
   (with-cons-queue-lock queue
907
     (funcall fn)))
908
 
909
 (defun call-with-vector-queue-lock (fn queue)
910
   "Call FN with a lock on QUEUE."
911
   (with-vector-queue-lock queue
912
     (funcall fn)))
913
 
914
 (defmacro with-queue-lock (queue &body body)
915
   "Eval BODY with a lock on QUEUE."
916
   `(call-with-queue-lock (lambda () ,@body) ,queue))
917
 
918
 (defun cons-queue-full-p (queue) 
919
   "A CONS-QUEUE is never full so this is always a no-op."
920
   (declare (ignore queue)) 
921
   nil)
922
 
923
 (macrolet ((define-queue-fn (name params cons-name vector-name)
924
              `(defun ,name ,params
925
                 (typecase ,(car (last params))
926
                   (cons-queue (,cons-name ,@params))
927
                   (vector-queue (,vector-name ,@params))
928
                   (t (error 'type-error
929
                             :datum ,(car (last params))
930
                             :expected-type 'queue)))))
931
            (define-try-pop-queue (name cons-name vector-name)
932
              `(defun ,name (queue &key timeout)
933
                 (unless timeout
934
                   (setf timeout 0))
935
                 (typecase queue
936
                   (cons-queue (,cons-name queue timeout))
937
                   (vector-queue (,vector-name queue timeout))
938
                   (t (error 'type-error
939
                             :datum queue
940
                             :expected-type 'queue))))))
941
   (define-queue-fn push-queue (obj queue)
942
     push-cons-queue
943
     push-vector-queue)
944
   (define-queue-fn push-queue* (obj queue)
945
     push-cons-queue*
946
     push-vector-queue*)
947
   (define-queue-fn pop-queue (queue)
948
     pop-cons-queue
949
     pop-vector-queue)
950
   (define-queue-fn pop-queue* (queue)
951
     pop-cons-queue*
952
     pop-vector-queue*)
953
   (define-queue-fn peek-queue (queue)
954
     peek-cons-queue
955
     peek-vector-queue)
956
   (define-queue-fn peek-queue* (queue)
957
     peek-cons-queue*
958
     peek-vector-queue*)
959
   (define-queue-fn queue-count (queue)
960
     cons-queue-count
961
     vector-queue-count)
962
   (define-queue-fn queue-count* (queue)
963
     cons-queue-count*
964
     vector-queue-count*)
965
   (define-queue-fn queue-empty-p (queue)
966
     cons-queue-empty-p
967
     vector-queue-empty-p)
968
   (define-queue-fn queue-empty-p* (queue)
969
     cons-queue-empty-p*
970
     vector-queue-empty-p*)
971
   (define-queue-fn queue-full-p (queue)
972
     cons-queue-full-p
973
     vector-queue-full-p)
974
   (define-queue-fn queue-full-p* (queue)
975
     cons-queue-full-p
976
     vector-queue-full-p*)
977
 
978
   (define-try-pop-queue try-pop-queue
979
     try-pop-cons-queue
980
     try-pop-vector-queue)
981
   (define-try-pop-queue try-pop-queue*
982
     try-pop-cons-queue*
983
     %try-pop-vector-queue)
984
 
985
   (define-queue-fn call-with-queue-lock (fn queue)
986
     call-with-cons-queue-lock
987
     call-with-vector-queue-lock))
988
 
989
 ;;; Accumulator
990
 
991
 ;; originally part of q/query, may serve useful in other contexts.
992
 
993
 (defclass accumulator ()
994
   ((value :initarg :value :accessor accumulated))
995
   (:documentation "Accumulator superclass."))
996
 
997
 (defgeneric accumulate (self val)
998
   (:documentation "Accumulate VAL into an ACCUMULATOR-like object SELF.")
999
   (:method ((self accumulator) (val number))
1000
     (setf (accumulated self) (+ val (accumulated self))))
1001
   (:method ((self list) val)
1002
     (push val self))
1003
   (:method ((self vector) val)
1004
     (vector-push val self)))
1005
 
1006
 (defgeneric make-accumulator (self)
1007
   (:documentation "Make a new ACCUMULATOR based on SELF."))
1008
 
1009
 ;; max-accumulator
1010
 (defclass max-accumulator (accumulator) ()
1011
   (:documentation "Accumulator which tracks the maximum value observed."))
1012
 
1013
 (defmethod accumulate ((self max-accumulator) (val number))
1014
   (when (> val (accumulated self))
1015
     (setf (accumulated self) val)))
1016
 
1017
 (defclass min-accumulator (accumulator) ()
1018
   (:documentation "Accumulator which tracks the minimum value observed."))
1019
 
1020
 (defmethod accumulate ((self min-accumulator) (val fixnum))
1021
   (when (< val (accumulated self))
1022
     (setf (accumulated self) val)))
1023
 
1024
 ;; simple atomic counter
1025
 (defstruct (counter (:constructor make-counter (&optional value)))
1026
   (value 0 :type sb-ext:word))
1027
 (defun inc-counter (c &optional (diff 1))
1028
   (declare (counter c) (fixnum diff))
1029
   (sb-ext:atomic-incf (counter-value c) diff))
1030
 (defun dec-counter (c &optional (diff 1))
1031
   (declare (counter c) (fixnum diff))
1032
   (sb-ext:atomic-decf (counter-value c) diff))
1033
 
1034
 ;;; Iterator
1035
 #|
1036
 The iterator protocol allows subsequently accessing some or all elements of a
1037
 sequence in forward or reverse direction. Users first call
1038
 make-sequence-iterator to create an iteration state and receive functions to
1039
 query and mutate it. These functions allow, among other things, moving to,
1040
 retrieving or modifying elements of the sequence. An iteration state consists
1041
 of a state object, a limit object, a from-end indicator and the following six
1042
 functions to query or mutate this state: step endp element (setf element) index copy
1043
 
1044
 See also: make-sequence-iterator with-sequence-iterator with-sequence-iterator-functions
1045
 |#
1046
 
1047
 (defclass iterator ()
1048
   ()
1049
   (:documentation "Iterator superclass inherited by objects implementing the iterator protocol."))
1050
 
1051
 ;; Protocol
1052
 (defvar *idx* 0)
1053
 (let ((*idx* 0))
1054
   (defgeneric next (self)
1055
     (:method ((self array))
1056
       (prog1 (aref self *idx*)
1057
         (incf *idx*))))
1058
   (defgeneric idx (self)
1059
     (:method ((self t)) *idx*))
1060
   (defgeneric prev (self)
1061
     (:method ((self array))
1062
       (decf *idx*)
1063
       (aref self *idx*))))
1064
 (defgeneric key (self))
1065
 (defgeneric (setf key) (new self))
1066
 (defgeneric val (self))
1067
 (defgeneric (setf val) (new self))
1068
 (defgeneric iter (self &key &allow-other-keys))
1069
 (defgeneric iter-valid-p (self))
1070
 (defgeneric seek (self key &key))
1071
 (defgeneric seek-to-first (self))
1072
 (defgeneric seek-to-last (self))
1073
 (defgeneric seek-for-prev (self key &key))
1074
 
1075
 (defvar *iter*)
1076
 
1077
 (defvar *iterator-functions*
1078
   '((next (next *iter*))
1079
     (prev (prev *iter*))
1080
     (seek-to-first (seek-to-first *iter*))
1081
     (seek-to-last (seek-to-last *iter*))
1082
     ;; (seek-for-prev (key &optional (s *iter*)) (seek-for-prev s key))
1083
     (iter-valid-p (iter-valid-p *iter*))
1084
     ;; (seek (key &optional (s *iter*)) (seek s key))
1085
     (val (val *iter*))
1086
     (key (key *iter*)))
1087
   "A list of function signatures for symbols which are bound via FLET around the body of WITH-ITER.")
1088
 
1089
 (defmacro with-iter ((sym iter) &body body)
1090
   `(let ((,sym ,iter))
1091
      (setf *iter* ,sym)
1092
      (symbol-macrolet ,*iterator-functions*
1093
        ;; (declare (ignorable ,@(mapcar (lambda (x) `(function ,(car x))) *iterator-functions*)))
1094
        ,@body)))