2015-10-02-01-swapにバグがあった - project-enigma

2015-10-02-01-swapにバグがあった

>> Site top >> weblog >> 月別アーカイブ >> 2015年10月のlog >> 2015-10-02-01-swapにバグがあった

最終更新日付:2015/10/02 00:43:34


swapにバグがあった

2015 年 10 月 02 日

昨日みつけたバグについて確認しよう。何がいけないのかはわかっている。そして、最初のうちはどう対処したものやら皆目見当がつかなかった。これを書いている現時点ではどうにかなったものの、もっと良い解決方法がないものかと思っている。

さて、問題のコードは以下の通りだ。

* (let ((v (new stl:vector 100 0)))
   (stl:assign v #{1 2 3})
   (stl:swap v (new stl:vector v))
   (stl:data v))

; in: LET ((V (NEW CL-STL:VECTOR 100 0)))
;     (CL-STL:SWAP V (NEW CL-STL:VECTOR V))
; --> LET* MULTIPLE-VALUE-BIND MULTIPLE-VALUE-CALL FUNCTION FUNCALL 
; ==>
;   (SB-C::%FUNCALL #'(SETF CL-STL::__NEW-VECTOR) #:NEW8 #:V7)
; 
; caught STYLE-WARNING:
;   undefined function: (SETF CL-STL::__NEW-VECTOR)
; 
; compilation unit finished
;   Undefined function:
;     (SETF CL-STL::__NEW-VECTOR)
;   caught 1 STYLE-WARNING condition

 

問題の所在ははっきりしていて、例の「swap技法」だ。stl:swap に渡すパラメータとして一時 stl:vector を作成していて、それが駄目らしい。というのも、stl:swap は「setf可能な場所」が渡されるコトを期待しているからだ。詳細は後回しにして、まずは単純な変数シンボル2つを指定した場合のマクロ展開形を確認しておこう。

(stl:swap foo bar)

=> (LET* ()
     (MULTIPLE-VALUE-BIND (#:NEW1 #:NEW2)
          (CL-STL::__SWAP-2 FOO BAR)
       (SETQ FOO #:NEW1)
       (SETQ BAR #:NEW2)
       NIL))

 

CL-STL::__SWAP-2 というのは総称関数で、CL-OVERLOAD によるオーバーロードメソッドの内部名だ。stl:swap がやらなければならない処理というのはパラメータの内容によって変化する。通常は単純な入れ替えだが、例えば stl:vector が2つ渡された場合はオブジェクトの中身だけを入れ替えて、オブジェクトそのものは入れ替わらない。これは STL アルゴリズムとしての swap でなく、コンテナメソッドの swap に相当する動作だ。つまるところ、このアルゴリズムとしての swap とコンテナメソッドとしての swap が同じ記法になってしまうことに問題があると言っても良いだろう。そして、渡される2つのパラメータが「実際に何か」は実行時までわからない。だから、結局総称関数で実行時に解決するしかない。

そんなわけで、CL-STL::__SWAP-2 というのは総称関数であり、二値を返すことが期待されている。返すべき二値とは、「入れ替えを行なった結果として、呼び出し元の2つの『場所』に設定すべき値」だ。この設定を呼び出し先で実施することはできない。マクロでやるしかないのだ(クロージャでなんとかするという手もあることに今気付いたが、今回扱う問題はいずれにせよ解決しない)。

では、マクロ stl:swap の定義を確認しておこう。

(declare-method-overload swap (2) :make-top nil)
(defmacro swap (a b)
  (multiple-value-bind (vars1 forms1 var1 set1 ref1) (get-setf-expansion a)
    (multiple-value-bind (vars2 forms2 var2 set2 ref2) (get-setf-expansion b)
      `(let* (,@(mapcar #'cl:list vars1 forms1)
              ,@(mapcar #'cl:list vars2 forms2))
         (multiple-value-bind (,@var1 ,@var2)
             (,(make-overload-name 'cl-stl:swap 2) ,ref1 ,ref2)
           ,set1
           ,set2
           nil)))))

 

結局知りたいことは、以下の通りだ。

Common Lisp Hyper Spec を探してみたが、自分にはそのようなナイスガイを発見することはできなかった。となると、get-setf-expansion の結果を見て判定するしかないだろう。

では、「実際には setf 可能でない」モノを get-setf-expansion に渡したらどうなるのか、ちょっとやってみよう。関数 not-place を作成し、それを使ってみる。

(defun not-place (x) x)

* (get-setf-expansion '(not-place x))

=> (#:X7245)
   (X)
   (#:NEW7246)
   (FUNCALL #'(SETF NOT-PLACE) #:NEW7246 #:X7245)
   (NOT-PLACE #:X7245)

 

‥‥‥ふむ、こうなるのか。であれば、以下の3つに場合分けできそうだ。

これなら、コンパイル時点でなんとか片を付けられそうだ。eval を使う他ないっぽいが、やってみよう。まず、get-setf-expansion が返す第4値のフォームを使ってチェックを行う関数を2つ作成する。

(defun setf-form-p (form)
  (handler-case
      (destructuring-bind (_call (_func (_setf sym)) _newval &rest args) form
        (declare (ignorable sym _newval args))
        (when (and (eq _call 'cl:funcall)
                   (eq _func 'cl:function)
                   (eq _setf 'cl:setf))
          (second form)))
    (error (c) (declare (ignorable c)) nil)))

(defun setter-exist-p (form)
  (handler-case (eval form)
    (error (c) (declare (ignorable c)) nil)))

 

関数 setf-form-p は、与えられた form(FUNCALL #'(SETF ...) ...) 形式になっているかを判定する。そして、setter-exist-p はその形式のフォームを実際に eval して setf を行う関数が取得できるかどうかを判定する。

これらを利用して swap を書き直してみた。テスト用なので名前は my-swap だ。

(defmacro my-swap (a b)
  (multiple-value-bind (vars1 forms1 var1 set1 ref1) (get-setf-expansion a)
    (multiple-value-bind (vars2 forms2 var2 set2 ref2) (get-setf-expansion b)
      (labels ((fix-setter (form)
                 (let ((setter (setf-form-p form)))
                   (when (or (null setter) (setter-exist-p setter))
                     form))))
        `(let* (,@(mapcar #'cl:list vars1 forms1)
                ,@(mapcar #'cl:list vars2 forms2))
           (multiple-value-bind (,@var1 ,@var2)
               (,(make-overload-name 'cl-stl:swap 2) ,ref1 ,ref2)
             (declare (ignorable ,@var1 ,@var2))
             ,(fix-setter set1)
             ,(fix-setter set2)
             nil))))))

 

では試してみよう‥‥‥最初はシンボル変数をただ渡してみる。問題ないようだ。

(my-swap foo bar)

=> (LET* ()
     (MULTIPLE-VALUE-BIND (#:NEW7232 #:NEW7233)
         (CL-STL::__SWAP-2 FOO BAR)
       (DECLARE (IGNORABLE #:NEW7232 #:NEW7233))
       (SETQ FOO #:NEW7232)
       (SETQ BAR #:NEW7233)
       NIL))

 

では次に、問題となっていた「setf 可能でないモノ」を渡してみる。‥‥‥うん、大丈夫っぽい。

(my-swap v (new stl:vector v))

=> (LET* ((#:V7235 V))
     (MULTIPLE-VALUE-BIND (#:NEW7234 #:NEW7236)
         (CL-STL::__SWAP-2 V (CL-STL::__NEW-VECTOR #:V7235))
       (DECLARE (IGNORABLE #:NEW7234 #:NEW7236))
       (SETQ V #:NEW7234)
       NIL
       NIL))

 

最後に、「setf 可能なモノ」を渡してみる。選んだのは stl:first だ。大丈夫なようだ。

(my-swap v (stl:first pr))

=> (LET* ((#:PR7238 PR))
     (MULTIPLE-VALUE-BIND (#:NEW7237 #:NEW7239)
         (CL-STL::__SWAP-2 V (CL-STL:FIRST #:PR7238))
       (DECLARE (IGNORABLE #:NEW7237 #:NEW7239))
       (SETQ V #:NEW7237)
       (FUNCALL #'(SETF CL-STL:FIRST) #:NEW7239 #:PR7238)
       NIL))

 

それでは、昨日踏んづけたバグをもう一度やってみよう‥‥‥お、イケた。

(let ((v (new stl:vector 100 0)))
  (stl:assign v #{1 2 3})
  (my-swap v (new stl:vector v))
  (stl:data v))

;=> #(1 2 3 NIL NIL NIL NIL NIL)

 

たしかに問題なく動作した。しかしここで簡単に万歳はできない。なによりも心配なのは、このやり方は「おそらく移植性がない」ということだ。SBCL と CLISP では大丈夫(あるいは大丈夫っぽい)ことを確認はしたが、全ての処理系で確認はできていない。

結局、以下につきるんだな。御存知の方、情報頂けると大変喜びます。

 

コメント

このページにコメントする

 

このページのタグ

Page tag : STLとその移植

Page tag : Common Lisp

 

 


Copyright(C) 2005-2017 project-enigma.
Generated by CL-PREFAB.