Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2010-01-12

KMRCLを眺める (63) STREAM-SUBST

| 23:17 | KMRCLを眺める (63) STREAM-SUBST - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (63) STREAM-SUBST - わだばLisperになる

今回はKMRCLのio.lisp中からSTREAM-SUBSTです。

順番どおりだと、STREAM-SUBSTはもう少し後になるのですが、以降は、中でSTREAM-SUBSTを使っているのがあるので、先に読むことにしました。

まず、バッファを構造体で定義し、操作する関数群を定義しています。

;; Buffered stream substitute

(defstruct buf
  vec (start -1) (used -1) (new -1) (end -1))

(defun bref (buf n)
  (svref (buf-vec buf)
         (mod n (length (buf-vec buf)))))

(defun (setf bref) (val buf n)
  (setf (svref (buf-vec buf)
               (mod n (length (buf-vec buf))))
        val))

(defun new-buf (len)
  (make-buf :vec (make-array len)))

(defun buf-insert (x b)
  (setf (bref b (incf (buf-end b))) x))

(defun buf-pop (b)
  (prog1
    (bref b (incf (buf-start b)))
    (setf (buf-used b) (buf-start b)
          (buf-new  b) (buf-end   b))))

(defun buf-next (b)
  (when (< (buf-used b) (buf-new b))
    (bref b (incf (buf-used b)))))

(defun buf-reset (b)
  (setf (buf-used b) (buf-start b)
        (buf-new  b) (buf-end   b)))

(defun buf-clear (b)
  (setf (buf-start b) -1 (buf-used  b) -1
        (buf-new   b) -1 (buf-end   b) -1))

(defun buf-flush (b str)
  (do ((i (1+ (buf-used b)) (1+ i)))
      ((> i (buf-end b)))
    (princ (bref b i) str)))

こんな感じです。

自分的には、いまいち動作と関数名の印象が微妙に一致しないので読み辛い気がしました。

このbrefを利用して、stream-substを定義しています。

名前からすると、streamをsubstするという印象ですが、その通りで、ストリーム中の"old"文字列を"new"文字列に置換します。

(defun stream-subst (old new in out)
  (declare (string old new))
  (let* ((pos 0)
         (len (length old))
         (buf (new-buf len))
         (from-buf nil))
    (declare (fixnum pos len))
    (do ((c (read-char in nil :eof)
            (or (setf from-buf (buf-next buf))
                (read-char in nil :eof))))
        ((eql c :eof))
      (declare (character c))
      (cond ((char= c (char old pos))
             (incf pos)
             (cond ((= pos len)            ; 3
                    (princ new out)
                    (setf pos 0)
                    (buf-clear buf))
                   ((not from-buf)         ; 2
                    (buf-insert c buf))))
            ((zerop pos)                   ; 1
             (princ c out)
             (when from-buf
               (buf-pop buf)
               (buf-reset buf)))
            (t                             ; 4
             (unless from-buf
               (buf-insert c buf))
             (princ (buf-pop buf) out)
             (buf-reset buf)
             (setf pos 0))))
    (buf-flush buf out)))

なんとなく動作が追い掛けにくいのですが、

(DEFVAR *FOO* "こんにちは")

(WITH-OUTPUT-TO-STRING (OUT)
  (WITH-INPUT-FROM-STRING (IN *FOO*)
    (STREAM-SUBST "にち" "ばん" IN OUT)))
;⇒ こんばんは

という風に動きます。簡易版のsedというところ。

ところで、この関数をコンパイルして実行すると、SBCL等だと、

The value :EOF is not of type CHARACTER.

と怒られます。

DOの中で、変数Cを

(declare (character c))

と文字として宣言しているからなのですが、終端で:EOFというシンボルを返しているので:EOFが来た時にエラーとなるわけですね。

ということで、変数をcharacterとして宣言できて、かつ上手くいく方法はないかと考えたのですが、READ-CHARのEND-OF-FILEシグナルを拾うのはどうだろうと思いました。

(他の方法としては、:EOFとcharacterを合体させた新しい型を作るとか?)

(defun stream-subst (old new in out)
  (declare (string old new))
  (let* ((pos 0)
         (len (length old))
         (buf (new-buf len))
         (from-buf nil))
    (declare (fixnum pos len))
    (handler-case 
        (do ((c (read-char in)
                (or (setf from-buf (buf-next buf))
                    (read-char in))))
            (nil)
          (declare (character c))
          (cond ((char= c (char old pos))
                 (incf pos)
                 (cond ((= pos len)            ; 3
                        (princ new out)
                        (setf pos 0)
                        (buf-clear buf))
                       ((not from-buf)         ; 2
                        (buf-insert c buf))))
                ((zerop pos)                   ; 1
                 (princ c out)
                 (when from-buf
                   (buf-pop buf)
                   (buf-reset buf)))
                (t                             ; 4
                 (unless from-buf
                   (buf-insert c buf))
                 (princ (buf-pop buf) out)
                 (buf-reset buf)
                 (setf pos 0))))
      (end-of-file ()
        (buf-flush buf out)))))

自分はこれまで、READ系の関数は、デフォルトではシグナルを上げるようになっているのに、毎回わざわざNILと指定してやることに、なんとなく納得が行かなかったのですが、HANDLER-CASEで拾うようにすると、なんとなく気分が良い!

とはいえ、HANDLER-CASEの外で値を集積する書き方しかできないのが、使い勝手が微妙なところ。

(WITH-OPEN-FILE (IN "/etc/motd")
  (LET (ANS)
    (HANDLER-CASE 
        (LOOP (PUSH (READ-LINE IN) ANS))
      (END-OF-FILE () (NREVERSE ANS)))))
⇒ ("Linux setq 2.6.31-14-generic #48-Ubuntu SMP Fri Oct 16 14:05:01 UTC 2009 x86_64"
 "" "To access official Ubuntu documentation, please visit:"
 "http://help.ubuntu.com/")

ゲスト



トラックバック - http://cadr.g.hatena.ne.jp/g000001/20100112