SERIES の producing

今日、千葉さんに producing を教えてもらったので、 cl-ppcre:split を series にしてみた。

どうも multiple-value-bind の中の setq は拾ってくれないらしく、ダミーの setq を書いて回避した。

これで Clojure の何でもシーケンスみたいに、何でもシリーズができそうだ。

(defun scan-re-split (regex string)
  (declare (optimizable-series-function))
  (producing (z) ((r regex) (s string) (scan-start 0) subseq-start subseq-end)
    (loop
      (tagbody
         ;; multiple-value-bind の中での setq は認識されないのでダミーで setq する。
         (setq scan-start scan-start
               subseq-start subseq-start
               subseq-end subseq-end)
         (multiple-value-bind (start end) (ppcre:scan r s :start scan-start)
           (unless start
             (if (< (length s) scan-start)
                 (terminate-producing)
                 (setq start (length s)
                       end (1+ start))))
           (setq subseq-start scan-start
                 subseq-end start
                 scan-start end))
         (next-out z (subseq s subseq-start subseq-end))))))

(assert (equal '("a" "b" "c") (collect (scan-re-split "/" "a/b/c"))))
(assert (equal '("") (collect (scan-re-split "/" ""))))
(assert (equal '("" "") (collect (scan-re-split "/" "/"))))
(assert (equal '("" "a") (collect (scan-re-split "/" "/a"))))
(assert (equal '("" "a" "") (collect (scan-re-split "/" "/a/"))))
(assert (equal '("" "" "a" "" "") (collect (scan-re-split "/" "//a//"))))
(assert (equal '("a" "b" "cc" "d") (collect (scan-re-split "\\s+" "a b   cc
d"))))

(collect (scan-re-split "/" "a/b/c")) をマクロ展開すると次のようになる。

(COMMON-LISP:LET* ((#:OUT-1354 "a/b/c"))
  (COMMON-LISP:LET ((#:SCAN-1349 0)
                    (#:SUBSEQ-1348 NIL)
                    (#:SUBSEQ-1347 NIL)
                    #:Z-1350
                    (#:LASTCONS-1344 (LIST NIL))
                    #:LST-1345)
    (DECLARE (TYPE CONS #:LASTCONS-1344)
             (TYPE LIST #:LST-1345))
    (SETQ #:LST-1345 #:LASTCONS-1344)
    (TAGBODY
     #:LL-1355
      (PROGN
       (SETQ #:SCAN-1349 #:SCAN-1349)
       (SETQ #:SUBSEQ-1348 #:SUBSEQ-1348)
       (SETQ #:SUBSEQ-1347 #:SUBSEQ-1347))
      (MULTIPLE-VALUE-CALL
          #'(LAMBDA (&OPTIONAL (START) (END) &REST #:G12-1346)
              (DECLARE (IGNORE #:G12-1346))
              (IF START
                  NIL
                  (PROGN
                   (IF (< (LENGTH #:OUT-1354) #:SCAN-1349)
                       (GO SERIES::END)
                       (PROGN
                        (SETQ START (LENGTH #:OUT-1354))
                        (SETQ END (1+ START))))))
              (PROGN
               (SETQ #:SUBSEQ-1348 #:SCAN-1349)
               (SETQ #:SUBSEQ-1347 START)
               (SETQ #:SCAN-1349 END)))
        (CL-PPCRE:SCAN "/" #:OUT-1354 :START #:SCAN-1349))
      (SETQ #:Z-1350 (SUBSEQ #:OUT-1354 #:SUBSEQ-1348 #:SUBSEQ-1347))
      (SETQ #:LASTCONS-1344 (SETF (CDR #:LASTCONS-1344) (CONS #:Z-1350 NIL)))
      (GO #:LL-1355)
     SERIES::END)
    (CDR #:LST-1345)))