More helper functions defined in with-collector

 * push-name, pop-name, enqueue-name, unenqueue-name

collectors.lisp

@@ -92,7 +92,8 @@
         (let ((c (cons ,a nil)))
           (when (null ,head-place) (setf ,head-place c))
           (unless (null ,tail-place) (setf (cdr ,tail-place) c))
-          (setf ,tail-place c))))))
+          (setf ,tail-place c)
+          )))))
 
 (defmacro append-at-end (head-place tail-place values-place)
   "Macros to ease efficient collection (with appending) at the end of a list"
@@ -289,10 +290,63 @@ FUNCTION and INITIAL-VALUE are passed directly to MAKE-REDUCER."
    :collect-nil? collect-nil
    :place-setter place-setter))
 
-(defmethod operate ((o pusher) values)
+(defmethod %push ((o list-aggregator) values)
   (dolist (v (alexandria:ensure-list values))
     (with-signal-context (v (value o) o)
-      (push v (value o)))))
+      (push v (value o))
+      (when (and (typep o 'collector) (null (tail o)))
+        (setf (tail o) (value o)))))
+  (value o))
+
+(defmethod %pop-n ((o list-aggregator) &optional (n 1))
+  (let* ((head (value o))
+         (len (length head)))
+    (cond
+      ((>= n len)
+       (setf (value o) nil)
+       (when (typep o 'collector)
+         (setf (tail o) nil)))
+      (t (let ((lastcons (nthcdr (- n 1) head)))
+           (setf (value o) (cdr lastcons)
+                 (cdr lastcons) nil))))
+    (if (= 1 n)
+        (car head)
+        head)))
+
+(defmethod %unenqueue-n ((o list-aggregator) &optional (n 1))
+  (let* ((head (value o))
+         (len (length head))
+         (div (- len (+ 1 n)))
+         (rtn (cond
+                ((plusp div)
+                 (let* ((c (nthcdr div head))
+                        (rtn (cdr c)))
+                   (setf (cdr c) nil)
+                   (when (typep o 'collector)
+                     (setf (tail o) c))
+                   rtn))
+                (t
+                 (setf (value o) nil)
+                 (when (typep o 'collector)
+                   (setf (tail o) nil))
+                 head))))
+    (if (= 1 n)
+        (car rtn)
+        rtn)))
+
+(defmethod %enqueue ((o list-aggregator) values
+                     &aux (last (last (value o))))
+  (collect-at-end-with-signals
+   (value o) last values o (value o))
+  (value o))
+
+(defmethod %enqueue ((o collector) values)
+  (collect-at-end-with-signals
+   (value o) (tail o) values o (value o))
+  (value o))
+
+(defmethod operate ((o pusher) values)
+  (%push o values))
 
 (defclass collector (list-aggregator)
   ((tail :accessor tail :initarg :tail :initform nil))
@@ -307,7 +361,7 @@ FUNCTION and INITIAL-VALUE are passed directly to MAKE-REDUCER."
   (setf (tail o) (last (value o))))
 
 (defmethod operate ((o collector) values)
-  (collect-at-end-with-signals (value o) (tail o) values o (value o)))
+  (%enqueue o values))
 
 (defmethod deoperate ((o list-aggregator) to-remove
                       &key test key
@@ -398,7 +452,20 @@ FUNCTION and INITIAL-VALUE are passed directly to MAKE-REDUCER."
                  :initial-value (or ,initial-value ,place)
                  :collect-nil ,collect-nil
                  :place-setter ,(when place `(lambda (new) (setf ,place new))))))
-    (flet ((,name (&rest items) (operate ,name items)))
+    (flet ((,name (&rest items) (operate ,name items))
+           (,(symbol-munger:english->lisp-symbol `(push ,name))
+               (&rest items)
+             (%push ,name items))
+           (,(symbol-munger:english->lisp-symbol `(pop ,name))
+               (&optional (n 1))
+             (%pop-n ,name n))
+           (,(symbol-munger:english->lisp-symbol `(enqueue ,name))
+               (&rest items)
+             (%enqueue ,name items))
+           (,(symbol-munger:english->lisp-symbol `(unenqueue ,name))
+               (&optional (n 1))
+             (%unenqueue-n ,name n))
+           )
       ,@body)))
 
 (defmacro with-collector-output ((name &key (collect-nil t) initial-value from-end place)

tests/collectors.lisp

@@ -205,7 +205,7 @@
         ))))
 
 (define-test simple-collectors-init-test (:tags '(collector place initial-value))
-  (let* ((as) (bs 2) (cs '(1 2))
+  (let* ((as) (bs 2) (cs (list 1 2))
          (a (collectors:make-simple-collector-to-place as))
          (b (collectors:make-simple-collector-to-place bs))
          (c (collectors:make-simple-collector-to-place cs)))
@@ -221,3 +221,36 @@
     (assert-equal '(1 2 :c :c) cs)
     (assert-equal '(1 2 :c :c) (funcall c))
     ))
+
+
+(define-test collector-macros-push (:tags '(collector push macros))
+  (with-collector (it)
+    (push-it 1)
+    (push-it 2)
+    (assert-equal '(5 4 3 2 1 ) (push-it 3 4 5))
+    (assert-equal (it) '(5 4 3 2 1))
+    ))
+
+(define-test collector-macros-pop (:tags '(collector pop macros))
+  (with-collector (it)
+    (it 1 2 3 4 5 6)
+    (assert-equal 1 (pop-it))
+    (assert-equal '(2 3 4) (pop-it 3))
+    (assert-equal '(5 6) (it))
+    ))
+
+(define-test collector-macros-enqueu (:tags '(collector enqueue macros))
+  (with-collector (it)
+    (enqueue-it 1)
+    (enqueue-it 2)
+    (assert-equal '(1 2 3 4 5) (enqueue-it 3 4 5))
+    (assert-equal (it) '(1 2 3 4 5))
+    ))
+
+(define-test collector-macros-unenqueue (:tags '(collector unenqueue macros))
+  (with-collector (it)
+    (it 1 2 3 4 5 6)
+    (assert-equal 6 (unenqueue-it))
+    (assert-equal '(4 5) (unenqueue-it 2))
+    (assert-equal '(1 2 3) (it))
+    ))