今回は前回に引き続きECLOSネタから、

• instance-recording-class (get to instances from their class, but allow their garbage collection).

でMOP vs マクロ比較をしてみたいと思います。

インスタンス生成を何らかの形で記録するというのはAMOPの3.1章にも出てくる定番ネタです。

この機能の実現は、インスタンス生成で使うmake-instanceに記録を行う関数のフックをかけてやればOKでしょう。
加えて、ECLOSではインスタンスを記録しつつもGCされたら消えるとのことなのですが、これは弱参照リストかなにかにすれば、これもOKでしょう。

ということで書いてみました。

MOPでの実装

LispWorksとSBCLで弱参照のシークエンスを物色してみましたが、弱参照の配列にしてみました。
LispWorksでは、weak-arrayというものがありadjustableなのですが、SBCLにはないので、結局make-weak-pointerで包んでいます。
trivial-garbageを利用すればいくらか可搬性は増すかもしれません。

(cl:in-package :cl-user)
(ql:quickload :closer-mop)
(defpackage "d5fc135c-3bcf-4976-9a9e-e6b92c12bd9d"
  (:use :c2cl :alexandria))
(in-package "d5fc135c-3bcf-4976-9a9e-e6b92c12bd9d")
(defun make-weak-vector (size &rest initargs)
  (declare (dynamic-extent initargs))
  #+lispworks (apply #'hcl:make-weak-vector size initargs)
  #+sbcl (apply #'make-array size :element-type 'sb-ext:weak-pointer initargs))
(defclass instance-recording-class (standard-class)
  ((instance-record :initform (make-weak-vector 0 :adjustable T :fill-pointer 0)
                    :accessor class-instance-record)))
(defmethod validate-superclass ((c instance-recording-class) (sc standard-class))
  T)
(defmethod make-instance :around ((class instance-recording-class) &rest initargs)
  (let* ((inst (call-next-method))
         #+sbcl (inst (sb-ext:make-weak-pointer inst)))
    (vector-push-extend inst (class-instance-record class))
    inst))
(defun reset-instance-record (class)
  (setf (class-instance-record class)
        (make-weak-vector 0 :adjustable T :fill-pointer 0)))

試してみる

(defconstant <zot> 
  (defclass zot () 
    ((a :initform 42))
    (:metaclass instance-recording-class)))
(dotimes (i 8)
  (make-instance <zot>))
(class-instance-record <zot>)
#+sbcl
→#(#<weak pointer: #<zot {10349DBA73}>> #<weak pointer: #<zot {10349ECDF3}>> #<weak pointer: #<zot {10349ECE63}>> #<weak pointer: #<zot {10349ECEE3}>>
        #<weak pointer: #<zot {10349ECF33}>> #<weak pointer: #<zot {10349ECFD3}>> #<weak pointer: #<zot {10349ED023}>> #<weak pointer: #<zot {10349ED073}>>)
#+lispworks
→ #(#<zot 4020034723> #<zot 4020034B43> #<zot 4020034EAB> #<zot 4020035213>
    #<zot 402003557B> #<zot 40200358E3> #<zot 4020035C4B> #<zot 4020035FB3>) 
#+lispworks (hcl:gc-all)
#+sbcl (sb-ext:gc :full t)
(class-instance-record <zot>)
#+sbcl
→ #(#<broken weak pointer> #<broken weak pointer> #<broken weak pointer> #<broken weak pointer> #<broken weak pointer> #<broken weak pointer>
       #<broken weak pointer> #<broken weak pointer>)
#+lispworks
→ #(nil nil nil nil nil nil nil nil) 
;; (clear-instance-record <zot>)

SBCLのほうはweak-pointerオブジェクトで包まれるのでちょっと扱いが面倒ですが、まあこんなものでしょう。

allocate-instanceにフックをかけるのでは駄目なのか

AMOPの例でもこういう記録系の拡張は、make-instanceにフックをかけますが、生成ならばallocate-instanceへのフックでも良さそうです。

両者で何が違うのか考えてみましたが、class-prototypeを実行するとプロトタイプの生成でallocate-instanceが呼ばれるので、クラスのプロトタイプインスタンスも含みたい場合はallocate-instanceの方が良いのでしょう。
恐らく、インスタンス記録系は、クラスのプロトタイプインスタンスは大抵除外して考えそうなので、make-instanceの方が自然かと思います。

allocate-instanceを利用した場合

(defmethod allocate-instance :around ((class instance-recording-class) &rest initargs)
  (let* ((inst (call-next-method))
         #+sbcl (inst (sb-ext:make-weak-pointer inst)))
    (vector-push-extend inst (class-instance-record class))
    inst))
(defconstant <bar> 
  (defclass bar () 
    ((a :initform 42))
    (:metaclass instance-recording-class)))
(class-instance-record <bar>)
→ #() 
(class-prototype <bar>)
→ #<bar 402008BEE3> 
(class-instance-record <bar>)
→ #(#<bar 402008BEE3>) 

マクロで考えてみた

あまりこういうのはマクロに向いていない気もしますが、比較のために書いてみました。

(defvar *instance-recording-table*
  (make-hash-table))
(defmacro with-instance-recording ((type) &body form)
  (with-unique-names (inst)
    `(let* ((,inst (progn ,@form))
            #+sbcl (,inst (sb-ext:make-weak-pointer ,inst)))
       #-sbcl (check-type ,inst ,type)
       #+sbcl (check-type (sb-ext:weak-pointer-value ,inst) ,type)
       (vector-push-extend ,inst
                           (or (gethash ',type *instance-recording-table*)
                               (setf (gethash ',type *instance-recording-table*)
                                     (make-weak-vector 0 :adjustable T :fill-pointer 0))))
       ,inst)))
(defun get-instance-record (type)
  (values (gethash type *instance-recording-table*)))
(defun reset-instance-record (type)
  (setf (gethash type *instance-recording-table*)
        (make-weak-vector 0 :adjustable T :fill-pointer 0)))

試してみる

(defclass quux ()
  ((x :initform 0)))
(dotimes (i 8)
  (with-instance-recording (quux) 
    (make-instance 'quux)))
(get-instance-record 'quux)
→ #(#<quux 40200A1413> #<quux 40200A26A3> #<quux 40200A351B> #<quux 40200A4393>
    #<quux 40200A520B> #<quux 40200A6083> #<quux 40200A6EFB> #<quux 40200A7D73>) 
(hcl:gc-all)
(get-instance-record 'quux)
→ #(nil nil nil nil nil nil nil nil) 

マクロなのでクラスオブジェクト以外にも使えます。
(というかそういう風に作っただけ)

(defstruct sss a b c)
(dotimes (i 8)
  (with-instance-recording (sss) 
    (make-sss)))
(get-instance-record 'sss)
→ #(#S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil)
   #S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil)
   #S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil)
   #S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil))  
(hcl:gc-all)
(get-instance-record 'sss)
→ #(nil nil nil nil nil nil nil nil) 

まとめ

インスタンスの記録についてMOPとマクロで比較してみましたが、元がMOP向きな問題だけにさすがにMOPの方がすっきりします。
しかし、実現している内容はマクロ版も大して変わらないので、あとは使い勝手がどうなるか、でしょうか。

■

HTML generated by 3bmd in LispWorks 7.0.0

前回のlet*-like slot initialization semanticsはマクロ主体での実装でしたが、今回はMOP主体でチャレンジです。

しかし、defclassが周囲のレキシカル変数を取り込むので何にせよ全体はマクロでまとめる他なさそうですが、そこは諦めます。

あれこれ試行錯誤しましたが、今回の方針は、

• let*風の逐次初期化を実行する関数を収めるスロットを付ける (direct-slot-definitionに追加)
• メタクラスにインスタンスの初期化をする関数を収めるスロットを付ける (class-let*-initfunction)
• compute-slotsでスロット構成を生成する際に、追加したスロットの初期化関数をまとめる
• まとめた関数をshared-initializeで呼ぶ

shared-initializeで呼ばれる関数ですが、下記のようなものを生成します。 初期化されるインスタンスを引数に取り、内部では、専らstandard-instance-accessを使って読み書きします。

(lambda (obj)
  (symbol-macrolet ((a (standard-instance-access obj 0))
                    (b (standard-instance-access obj 1)))
    (when (eq unbound-marker (standard-instance-access obj 0))
      (setf (standard-instance-access obj 0)
            (funcall #<Function 1 subfunction of (lw:top-level-form 1) 4060007E8C>
                     nil
                     nil)))
    (when (eq unbound-marker (standard-instance-access obj 1))
      (setf (standard-instance-access obj 1)
            (funcall #<Function 2 subfunction of (lw:top-level-form 1) 4060007E34>
                     a
                     nil)))
    (when (eq unbound-marker (standard-instance-access obj 2))
      (setf (standard-instance-access obj 2)
            (funcall #<Function 3 subfunction of (lw:top-level-form 1) 4060007DAC>
                     a
                     b)))))

そして、下記がMOPチャレンジ版のコードですが、大したことはしていないのに長くなりました。

(cl:in-package :cl-user)
(ql:quickload :closer-mop)
(defpackage :64d0b072-4e6b-44c3-b565-dcf8d4ca63e3
  (:use :c2cl)
  #+sbcl (:shadowing-import-from :cl :defmethod))
(cl:in-package :64d0b072-4e6b-44c3-b565-dcf8d4ca63e3)
(defconstant unbound-marker 
  (if (boundp 'unbound-marker)
      unbound-marker
      (gensym "unbound")))
(defclass let*-slot-class (standard-class) 
  ((let*-slots :initform nil :accessor class-let*-slots :initarg :let*-slots)
   (let*-initfunction :accessor class-let*-initfunction :initarg :let*-initfunction)))
(defmethod validate-superclass ((c let*-slot-class) (sc standard-class))
  T)
(defclass let*-standard-object (standard-object)
  ())
(defun process-a-slot (slot)
  (loop :with name := (car slot)
        :for (k v) :on (cdr slot) :by #'cddr
        :when (eq k :initform) 
        :append `(:initform ,v :initfunction (constantly unbound-marker)) :into initform
        :when (eq k :initarg) :collect v :into initargs
        :when (eq k :writer) :collect v :into writers
        :when (eq k :reader) :collect v :into readers
        :when (eq k :accessor) :collect v :into readers :and :collect `(setf ,v) :into writers
        :finally (return
                  `(:name ,name
                    :initargs ,initargs
                    ,@initform
                    :writers ,writers
                    :readers ,readers))))
(defclass let*-direct-slot-definition (standard-direct-slot-definition)
  ((let*-initfunction :initarg :let*-initfunction :accessor slot-definition-let*-initfunction)))
(defmethod direct-slot-definition-class ((class let*-slot-class) &rest initargs)
  (find-class 'let*-direct-slot-definition))
(defmethod compute-slots :around ((class let*-slot-class))
  (let* ((let*-slots (class-let*-slots class))
         (slots (call-next-method))
         (let*-slot#s (loop :for s :in let*-slots
                            :for pos := (position s slots :key #'slot-definition-name)
                            :when pos :collect (cons s pos))))
    (setf (class-let*-initfunction class)
          (compile nil
                   `(lambda (obj)
                      (symbol-macrolet (,@(loop :for s :in (butlast let*-slots)
                                                :collect `(,s (standard-instance-access obj ,(cdr (assoc s let*-slot#s))))))
                        ,@(loop :for s :in let*-slots
                                :for pos := (cdr (assoc s let*-slot#s))
                                :for argpos :from 0
                                :collect `(when (eq unbound-marker (standard-instance-access obj ,pos))
                                            (setf (standard-instance-access obj ,pos)
                                                  (funcall ,(slot-definition-let*-initfunction
                                                             (find s (class-direct-slots class) :key #'slot-definition-name))
                                                           ,@(replace (make-list (length (cdr let*-slots)))
                                                                      (subseq (butlast let*-slots) 0 argpos))))))))))
    slots))
(defmethod shared-initialize :after
           ((obj let*-standard-object) slot-names &rest initargs &key &allow-other-keys)
  (funcall (class-let*-initfunction (class-of obj)) obj))
(defmacro defclass* (name (&rest superclasses) (&rest slots) &rest class-options)
  (loop :with slot-names := (mapcar (lambda (x) (if (consp x) (car x) x))
                                    slots)
        :for s :in slots
        :for cs := (copy-list (process-a-slot s))
        :collect `(,@cs 
                   :let*-initfunction
                   (lambda (,@(butlast slot-names))
                     (declare (ignorable ,@(butlast slot-names)))
                     ,(getf cs :initform))) :into canonicalized-slots
        :finally (return 
                  `(eval-when (:compile-toplevel :load-toplevel :execute)
                     (ensure-class ',name
                                   :metaclass 'let*-slot-class
                                   :direct-superclasses (adjoin 'let*-standard-object
                                                                ',superclasses)
                                   :direct-slots (list ,@(mapcar (lambda (s) 
                                                                   (destructuring-bind (&key name
                                                                                             initargs
                                                                                             initform
                                                                                             initfunction
                                                                                             writers
                                                                                             readers
                                                                                             let*-initfunction
                                                                                             &allow-other-keys) 
                                                                                       s
                                                                     `(list :name ',name
                                                                            :initargs ',initargs
                                                                            :initform ',initform
                                                                            :initfunction ,initfunction
                                                                            :writers ',writers
                                                                            :readers ',readers
                                                                            :let*-initfunction ,let*-initfunction)))
                                                                 canonicalized-slots))
                                   :let*-slots ',slot-names
                                   ,@class-options)))))

動作

(defclass* qqq ()
  ((a :initform 42 :initarg :a)
   (b :initform a :initarg :b)
   (c :initform (+ a b) :initarg :c)))
(with-slots (a b c) (make-instance 'qqq)
  (list a b c))
;=>  (42 42 84)

(with-slots (a b c) (make-instance 'qqq :c 0)
  (list a b c))
;=>  (42 42 0)

(with-slots (a b c) (make-instance 'qqq :b 0)
  (list a b c))
;=>  (42 0 42)

(with-slots (a b c) (make-instance 'qqq :a 0)
  (list a b c))
;=>  (0 0 0)

(with-slots (a b c) (make-instance 'qqq :a 0 :b 1)
  (list a b c))
;=>  (0 1 1)

MOPにして良いことがあるのか

マクロ主体の場合は、スロットアクセスが名前参照ベースなので若干非効率効率ですが、MOPを使えば、standard-instance-access等の効率の良いアクセス方法が使えるので速くできるだろうということで、今回は、standard-instance-accessの利用を軸に組み立ててみました。

素のインスタンス生成〜初期化と比較して、マクロ版は、約1.8倍の時間のところをMOP版では、約1.3倍程度にまで抑えることができました。
まあもっと速くできそうではありますが……。

(defclass let-slot ()
  ((a :initform 42)
   (b :initform 42)
   (c :initform 42)))
(defclass* let*-slot ()
  ((a :initform 42 :initarg :a)
   (b :initform a :initarg :b)
   (c :initform (+ a b) :initarg :c)))
(dc07f5fa-62ee-40a1-ae1a-d1a0f87d19bb::defclass* let*-slot-macro ()
  ((a :initform 42 :initarg :a)
   (b :initform a :initarg :b)
   (c :initform (+ a b) :initarg :c)))

計時

(let ((cnt 1000000))
  (time 
   (dotimes (i cnt)
     (make-instance 'let-slot)))
  (time 
   (dotimes (i cnt)
     (make-instance 'let*-slot)))
  (time 
   (dotimes (i cnt)
     (make-instance 'let*-slot-macro))))
Timing the evaluation of (dotimes (i cnt) (make-instance 'let-slot))
User time    =        1.270
System time  =        0.000
Elapsed time =        1.258
Allocation   = 1352109704 bytes
0 Page faults
Calls to %EVAL    17000036
Timing the evaluation of (dotimes (i cnt) (make-instance 'let*-slot))
User time    =        1.660
System time  =        0.000
Elapsed time =        1.654
Allocation   = 1352029784 bytes
0 Page faults
Calls to %EVAL    17000036
Timing the evaluation of (dotimes (i cnt) (make-instance 'let*-slot-macro))
User time    =        2.260
System time  =        0.000
Elapsed time =        2.260
Allocation   = 1352020600 bytes
0 Page faults
Calls to %EVAL    17000036
nil

継承した場合にスロットのインデックスの位置関係はどうなるのか

具体的には下記のような場合に、standard-instance-accessが指す先がどのような構成になるのかを把握していないと使えないのですが、

(defclass A ()
  ((a :initform 0 :initarg :a)
   (b :initform 1 :initarg :b)
   (c :initform 2 :initarg :c)))
(defclass* B (A)
  ((x :initform 42 :initarg :x)
   (y :initform x :initarg :y)
   (z :initform (+ x y) :initarg :z)))
(with-slots (a b c x y z) (make-instance 'B :y 1)
  (list a b c x y z))
;=> (0 1 2 42 1 43) 

AMOPのInstance Structure Protocolの例では、compute-slotsの並び順で、standard-instance-accessのインデックスを決められる的なことが書いてあります。
実際に試してみると、継承した場合、上位クラスのスロット数分だけオフセットしたり(SBCL、LispWorks)名前とスロットの値が一致しなかったり(LispWorks)で、compute-slotsで並べた順がすなわちインデックスとはならない実装があるようです。

しょうがないので、結局名前からインデックスを求めるようにしましたが、私が何か勘違いをしているのか、もしくはこの仕様に準拠している処理系が少ないのか。

まとめ

これまでlet*風にスロットの逐次初期化を2パスで考えてみましたが、shared-initializeを差し替えてしまった方が素直なのかもしれません。
そのうち試してみようかなと思います。

■

HTML generated by 3bmd in LispWorks 7.0.0

MOP vs マクロなネタを探していますが、古えのメールに面白そうなものがあったので、これをどうにかMOP vs マクロの枠内で再現してみることにします。

• ANNOUNCE : ECLOS 3.3 (Metaclass library)

ちなみに、このECLOSですが、Metaclass libraryとあるように、MOP的なツールを纏めた商用ライブラリだったようです。
メタクラス関係だけで商品になってたというのが凄い。

告知メールによると主なアイテムは、

• self-referent class
• instance-recording-class (get to instances from their class, but allow their garbage collection).
• operating-class (implement recursive operations like copy-object, equal-object-p with suscint in-class specifications)
• lazy-class (establish inter-slot/access dependencies to avoid initializing slots until they are needed/make-sense)
• attributed-class (arbitrary-depth attributes in slots, great for frame-like programming)
• constrained-class (multi-way constraints and daemons can be stored in and refer transparently to slots).
• An enhanced Delta-Blue constraint solver with a higher-order architecture for dynamic update of constraint graphs (no propagate as if graph still unchanged semantics).
• let*-like slot initialization semantics

ですが、定番そうなものから何やら良く分からないものまであります。

今回は、このリストの中からlet*-like slot initialization semanticsをMOPとマクロで再現してみたいと思います。
例のごとくまずはマクロでの実現から始めます。

let*-like slot initialization semantics をマクロで書いてみる

まず、動作の確認ですが、詳細は不明なものの、多分let*のように上方のスロットの値が次のスロットで使えるということなのではないかと思います。

動作例を考えると、下記のようになるかと思いますが、やりたいことが単純な割には実現は面倒臭そうです。

(let ((z 42))
  (defclass* qqq ()
   ((a :initform z :initarg :a :initarg a)
    (b :initform a :initarg :b :initarg b)
    (c :initform (+ a b) :initarg :c :initarg c))))
(with-slots (a b c) (make-instance 'qqq)
  (list a b c))
;=>  (42 42 84)

(with-slots (a b c) (make-instance 'qqq :c 0)
  (list a b c))
;=>  (42 42 0)

(with-slots (a b c) (make-instance 'qqq :b 0)
  (list a b c))
;=>  (42 0 42)

(with-slots (a b c) (make-instance 'qqq :a 0)
  (list a b c))
;=>  (0 0 0)

(with-slots (a b c) (make-instance 'qqq :a 0 :b 1)
  (list a b c))
;=>  (0 1 1)

一応の解説ですが、上記のクラス定義フォームを素のdefclassで置き換えた場合、bとcスロットでaとbが未束縛でエラーになります。
変数zに関してはdefclassは外側の変数を取り込めるのでzはレキシカル変数になります。

(let ((z 42))
  (defclass ppp ()
   ((a :initform z :initarg :a :initarg a)
    (b :initform a :initarg :b :initarg b)
    (c :initform (+ a b) :initarg :c :initarg c))))
(make-instance 'ppp)
;!!! The variable a is unbound.

このlet*的な初期化構文のポイントは、let*的な順次初期化は、クラス定義時に行なわれるのではなく、インスタンス(再)初期化時に行なわれるということです。

マクロでどうするか考えてみる

あれこれ考えてみましたが、とりあえずスロットの初期化を2パスにするのが一番簡単そうなので、それで行くことにしました。

• スロットの:initfunctionに設定する関数でクロージャーを返すようにしインスタンス初期化まで評価を遅らせる
• インスタンス初期化時に、スロットの値が保留になっているかを調べて保留状態ならクロージャーを評価し値を設定

という所です。

マクロ展開を眺めるのが一番早いと思うのですが下記のような展開になります。

(defclass* qqq ()
  ((a :initform 42 :initarg :a)
   (b :initform a :initarg :b)
   (c :initform (+ a b) :initarg :c)))
===>
(eval-when (:compile-toplevel :load-toplevel :execute)
  (let ((#:a368281
         (lambda (obj)
           (with-slots (a b c) obj (declare (ignorable a b c)) 42)))
        (#:b368282
         (lambda (obj) (with-slots (a b c) obj (declare (ignorable a b c)) a)))
        (#:c368283
         (lambda (obj)
           (with-slots (a b c) obj (declare (ignorable a b c)) (+ a b)))))
    (ensure-class 'qqq
                  :direct-superclasses
                  (adjoin 'let*-standard-object 'nil)
                  :direct-slots
                  (list (list :name 'a :initargs '(:a) :initform '42 :initfunction (lambda () #:a368281) :writers 'nil :readers 'nil)
                        (list :name 'b :initargs '(:b) :initform 'a :initfunction (lambda () #:b368282) :writers 'nil :readers 'nil)
                        (list :name 'c :initargs '(:c) :initform '(+ a b) :initfunction (lambda () #:c368283) :writers 'nil :readers 'nil)))
    (defmethod initialize-let*-slots ((obj qqq))
      (let ((sname 'a))
        (when (slot-boundp obj sname)
          (let ((sval (slot-value obj sname)))
            (when (eq #:a368281 sval)
              (setf (slot-value obj sname) (funcall sval obj))))))
      (let ((sname 'b))
        (when (slot-boundp obj sname)
          (let ((sval (slot-value obj sname)))
            (when (eq #:b368282 sval)
              (setf (slot-value obj sname) (funcall sval obj))))))
      (let ((sname 'c))
        (when (slot-boundp obj sname)
          (let ((sval (slot-value obj sname)))
            (when (eq #:c368283 sval)
              (setf (slot-value obj sname) (funcall sval obj)))))))))

マクロ定義(およびクラス定義)

(cl:in-package :cl-user)
(ql:quickload :closer-mop)
(cl:defpackage :dc07f5fa-62ee-40a1-ae1a-d1a0f87d19bb
  (:use :c2cl))
(cl:in-package :dc07f5fa-62ee-40a1-ae1a-d1a0f87d19bb)
(defclass let*-standard-object (standard-object)
  ())
(defun process-a-slot (slot)
  (loop :with name := (car slot)
        :for (k v) :on (cdr slot) :by #'cddr
        :when (eq k :initform) 
        :append `(:initform ,v :initfunction ,(coerce `(lambda () ,v) 'function)) :into initform
        :when (eq k :initarg) :collect v :into initargs
        :when (eq k :writer) :collect v :into writers
        :when (eq k :reader) :collect v :into readers
        :when (eq k :accessor) :collect v :into readers :and :collect `(setf ,v) :into writers
        :finally (return
                  `(:name ,name
                    :initargs ,initargs
                    ,@initform
                    :writers ,writers
                    :readers ,readers))))
(defgeneric initialize-let*-slots (obj)) 
(defmethod shared-initialize :after
           ((obj let*-standard-object) slot-names &rest initargs &key &allow-other-keys)
  (initialize-let*-slots obj))
(defmacro defclass* (name (&rest superclasses) (&rest slots) &rest class-options)
  (loop :with slot-names := (mapcar (lambda (x) (if (consp x) (car x) x))
                                    slots)
        :for s :in slots
        :for cs := (copy-list (process-a-slot s))
        :for ifn := (gensym (string (getf cs :name)))
        :collect cs :into canonicalized-slots
        :collect `(,ifn (lambda (obj)
                          (with-slots (,@slot-names) obj
                            (declare (ignorable ,@slot-names))
                            ,(getf cs :initform)))) :into bvs
        :collect `(let ((sname ',(getf cs :name)))
                    (when (slot-boundp obj sname)
                      (let ((sval (slot-value obj sname)))
                        (when (eq ,ifn sval)
                          (setf (slot-value obj sname)
                                (funcall sval obj)))))) :into slot-init-forms
        :do (setf (getf cs :initfunction) 
                  `(lambda () ,ifn))
        :finally (return 
                  `(eval-when (:compile-toplevel :load-toplevel :execute)
                     (let (,@bvs)
                       (ensure-class ',name
                                     :direct-superclasses (adjoin 'let*-standard-object
                                                                  ',superclasses)
                                     :direct-slots (list
                                                    ,@(mapcar (lambda (s)
                                                                (destructuring-bind (&key name
                                                                                          initargs
                                                                                          initform
                                                                                          initfunction
                                                                                          writers
                                                                                          readers
                                                                                          &allow-other-keys) 
                                                                                    s
                                                                  `(list :name ',name
                                                                         :initargs ',initargs
                                                                         :initform ',initform
                                                                         :initfunction ,initfunction
                                                                         :writers ',writers
                                                                         :readers ',readers)))
                                                              canonicalized-slots))
                                     ,@class-options)
                       (defmethod initialize-let*-slots ((obj ,name))
                         ,@slot-init-forms))))))

まとめ

案外ほとんどMOP的な要素を使わずにマクロのみで実現できてしまいましたが、スコープ的なものを扱うのでマクロの方が得意なのかもしれません。

ちなみに、スロットの:initfunctionは、ANSI Common Lispの規格にはなく、MOPで規定されているものですが、まあこれくらいは良しとしましょう。

さてこれを今後MOP的にして行きたいと思います。

■

HTML generated by 3bmd in LispWorks 7.0.0

前回は、全面的なマクロから、ensure-classを使って若干のMOP利用へと進めましたが、今回は、ensure-class-using-classを利用して、もう一歩進めてみたいと思います。

ensure-class-using-class を利用してみる

ensure-classは関数ということもあり、プロトコルを成しているメソッド群をカスタマイズするという感じではありませんが、ensure-classの下請けのensure-class-using-classは、standard-classをカスタマイズしたメタクラスでディスパッチさせることが可能です。

(defpackage d34ab7fb-8666-4f9c-ac95-833380ffefee 
  (:use :c2mop :cl)
  (:shadowing-import-from :c2mop
   :defmethod :standard-class :defgeneric 
   :standard-generic-function :funcallable-standard-class))
(in-package d34ab7fb-8666-4f9c-ac95-833380ffefee)
(defun slot-name-conc (prefix name)
  (let ((pkg (etypecase prefix
               ((or null string) *package*)
               (symbol (symbol-package prefix)))))
    (intern (concatenate 'string (string prefix) (string name)) pkg)))
(defclass conc-name-class (standard-class)
  ((conc-name :initarg :conc-name :accessor class-conc-name)))
(defmethod validate-superclass ((class conc-name-class) (super standard-class))
  T)

上記では、standard-classメタクラスのサブクラスとしてconc-name-classメタクラスを定義してみています。

これで、ensure-class-using-classがディスパッチできるようになります。

(defmethod ensure-class-using-class ((class conc-name-class) name
                                     &rest initargs
                                     &key (conc-name (concatenate 'string (string name) ".") conc-name-sup?)
                                          direct-slots
                                     &allow-other-keys)
  (when conc-name-sup?
    (setq conc-name (car conc-name)))
  (setq direct-slots
        (loop :for s :in direct-slots
              :collect (destructuring-bind (&key name readers writers &allow-other-keys) 
                                           s
                         (let ((aname (slot-name-conc conc-name name)))
                           `(:name ,name
                             :readers (,aname ,@readers)
                             :writers ((setf ,aname) ,@writers))))))
  (let ((class (apply #'call-next-method class name :direct-slots direct-slots
                      initargs)))
    (setf (class-conc-name class) conc-name)
    class))

ensure-classと同じく、ensure-class-using-classが取るキーワード引数は、defclassのクラスオプションが渡ってきますので、以上で下記のように書けます。

(defclass foo ()
  (x 
   y 
   (z :accessor z))
  (:metaclass conc-name-class)
  (:conc-name foo.))
(let ((qqq (make-instance 'foo)))
  (with-slots (x y z) qqq
    (setq x 42 y 43 z 44))
  (incf (foo.z qqq))
  (list (foo.x qqq)
        (foo.y qqq)
        (foo.z qqq)))
→ (42 43 45) 

マクロ的なアプローチの問題点として

• defclassの派生構文ができてしまう

というのがありましたが、:metaclassを一々指定するのは面倒臭いもののdefclassの標準構文に収まりました。
また、

• マクロ内でdefclassのオプションを解析するのがめんどくさい

というのもensure-classが正規化して渡してくれるので、ensure-classよりはすっきりします。

しかし今度もあまりMOP的でない?

しかし、上記のコードを眺めると判るように前回とさして変化ありません。
アクセサの名前に接頭辞を付けるのだから、MOP的にするなら、スロット定義メタオブジェクトをあれこれするのが筋なのではないか、ということになります。

ということで、スロット定義のプロトコルをカスタマイズしてみます。

(defclass conc-name-direct-slot-definition (standard-direct-slot-definition)
  ((conc-name :initform nil :initarg :conc-name)))
(defmethod direct-slot-definition-class ((class conc-name-class) &rest initargs)
  (find-class 'conc-name-direct-slot-definition))
(defmethod initialize-instance :around ((sd conc-name-direct-slot-definition) &rest args &key name conc-name)
  (let ((aname (slot-name-conc conc-name name))
        (inst (call-next-method)))
    (pushnew aname (slot-definition-readers sd) :test #'equal)
    (pushnew `(setf ,aname) (slot-definition-writers sd) :test #'equal)
    inst))
(defmethod ensure-class-using-class ((class conc-name-class) name
                                     &rest initargs
                                     &key (default-conc-name (concatenate 'string (string name) ".") default-conc-name-sup?)
                                          direct-slots
                                     &allow-other-keys)
  (when default-conc-name-sup?
    (setq default-conc-name (car default-conc-name)))
  (apply #'call-next-method 
         class
         name
         :default-conc-name default-conc-name
         :direct-slots (mapcar (lambda (s)
                                 (if (getf s :conc-name)
                                     s
                                     (list* :conc-name default-conc-name s)))
                               direct-slots)
         initargs))

解説すると、まずデフォルトのstandard-direct-slot-definitionをカスタマイズするために、conc-name-direct-slot-definitionを定義します。
conc-name-direct-slot-definitionの中では、指定された接頭辞をもとにアクセサ名を生成します。
スロット定義では、:conc-nameで接頭辞を指定しますが、スロット定義メタオブジェクトを生成する時のキーワード引数はdefclassのスロットのキーワード引数が正規化されたものになりますので、単純に:conc-nameを追加しておけばOKです。

次に、このスロット定義を呼び出すために、direct-slot-definition-classが返すクラスをconc-name-direct-slot-definitionに設定します。
direct-slot-definition-classが返すクラスでスロット定義を生成するプロトコルなので、スロット定義のサブクラスを作ってカスタマイズしても、これに設定しないと有効にできません。

また、クラス定義の方で指定する接頭辞とスロットで指定する接頭辞を区別したいので、クラス定義の方は、default-conc-nameと変更します。

(defclass conc-name-class (standard-class)
  ((conc-name :initarg :default-conc-name :accessor class-conc-name)))

これでこんな感じに書けます

(defclass bar ()
  ((x :conc-name bar=) 
   (y :conc-name bar_) 
   (z :accessor z))
  (:default-conc-name bar.)
  (:metaclass conc-name-class))
(let ((qqq (make-instance 'bar)))
  (with-slots (x y z) qqq
    (setq x 42 y 43 z 44))
  (incf (bar.z qqq))
  (list (bar=x qqq)
        (bar_y qqq)
        (bar.z qqq)))
→ (42 43 45) 

スロットごとに接頭辞を付けて便利なことがあるかは不明ですが、スロット定義のプロトコルに従ったお蔭でおまけ的に別個に指定できたりします。

まとめ

以上、マクロだけでの実現からMOP的なものまでを順に考えてきましたが、MOPの方は作法を憶えるのが面倒臭いです。
まあしかし、MOPの作法は一応標準化されていますので、俺マクロの使い方を憶えるよりは、ましだったりするかもしれません。

■

HTML generated by 3bmd in LispWorks 7.0.0

長くなりそうなので数回に分けた記事にしようと思っていましたが、前回の記事を書くなかで自分の中では問題は解決してしまったので、続きを書くのをすっかり忘れていました。

それはさておき、前回は、お題を全部マクロで実現した訳ですが、今回は若干MOPよりです。
といっても、MOPが定めている便利ユーティリティを利用するのみでメタオブジェクトをあれこれという訳ではありません。 「マクロだけでがんばる」から「MOPだけでがんばる」の方向に進めて行き、丁度良い落とし所はどの辺りかを探っていければ良いなと考えています。

ensure-class を利用してみる

前回は、defclassのラッパーという感じでしたが、今回はMOPが定めるdefclassを組み立てるための関数であるensure-classを利用します。
ensure-classは、defclassを組み立てるための関数ともいえますし、ensure-classをお化粧したのがdefclassともいえるでしょう。
(setf (fdefinition 'foo) ...)と(defun foo (...) ...)のような関係と考えるとわかりやすいかと思います。

コードは長いので後ろに置きますが、ensure-classを使えばこんな感じのものに構成できます。

(defclass/conc-name foo ()
  (x 
   y 
   (z :accessor z))
  (:conc-name foo.))
;;; マクロ展開
===>
(eval-when (:compile-toplevel :load-toplevel :execute)
  (ensure-class 'foo
                :direct-superclasses 'nil
                :direct-slots '((:name x :writers ((setf foo.x)) :readers (foo.x))
                                (:name y :writers ((setf foo.y)) :readers (foo.y))
                                (:name z :writers ((setf z) (setf foo.z)) :readers (z foo.z)))
                :direct-default-initargs 'nil))
(let ((qqq (make-instance 'foo)))
  (with-slots (x y z) qqq
    (setq x 42 y 43 z 44))
  (incf (foo.z qqq))
  (list (foo.x qqq)
        (foo.y qqq)
        (foo.z qqq)))
→ (42 43 45) 

前回の問題点として

• defclassの派生構文ができてしまう
• マクロ内でdefclassのオプションを解析するのがめんどくさい

の二点がありましたが、ensure-classを使っても別段問題は解消されていません。
ensure-classを使った場合、:accessorは、:writerと:readerの組み合わせとして正規化する必要があるので、見通しが若干良くなるのかも、というところです。

オプションの解析部分をより拡張性のあるものにすれば(例えば総称関数にする等)、汎用的な構文として綺麗にまとめられるかもしれません。

既にこの辺りが落とし所な気はしますが、次回はさらにMOP的にすべくensure-class-using-classの活用を考えてみます。

付録: ensure-class を使ってみた場合の定義例

(defpackage 05d2b99b-651a-4352-ba04-47593339a944 
  (:use :c2mop :cl)
  (:shadowing-import-from :c2mop :defmethod :standard-class :defgeneric :standard-generic-function))
(in-package 05d2b99b-651a-4352-ba04-47593339a944)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun canonicalize-slots (slots)
    (labels ((canonicalize-slot (slot)
               (typecase slot
                 ((and symbol (not null)) (list slot))
                 (T slot))))
      (mapcar #'canonicalize-slot slots)))
  (defun slot-name-conc (prefix name)
    (let ((pkg (etypecase prefix
                 ((or null string) *package*)
                 (symbol (symbol-package prefix)))))
      (intern (concatenate 'string (string prefix) (string name)) pkg)))
  (defun process-a-slot (slot)
    (loop :with name := (car slot)
          :for (k v) :on (cdr slot) :by #'cddr
          :when (eq k :initform) 
          :append `(:initform ,v :initfunction (lambda () ,v)) :into initform
          :when (eq k :writer) :collect v :into writers
          :when (eq k :reader) :collect v :into readers
          :when (eq k :accessor) :collect v :into readers :collect `(setf ,v) :into writers
          :finally (return
                    `(:name ,name
                      ,@initform
                      :writers ,writers
                      :readers ,readers)))))
(defmacro defclass/conc-name (name superclasses slots &rest class-options)
  (let* ((conc-name (concatenate 'string (string name) "-"))
         (class-options (loop :for opt :in class-options
                              :if (eq :conc-name (car opt))
                              :do (when (cadr opt)
                                    (setq conc-name (cadr opt)))
                              :else :collect opt)))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (ensure-class ',name
                     :direct-superclasses '(,@superclasses)
                     :direct-slots '(,@(loop :for s :in (canonicalize-slots slots)
                                             :for aname := (slot-name-conc conc-name (car s))
                                             :collect (process-a-slot `(,@s :accessor ,aname))))
                     :direct-default-initargs '(,@class-options)))))

■

HTML generated by 3bmd in LispWorks 7.0.0

オブジェクト指向システムを拡張する際に、痒い所に微妙に手が届かない気がするMOPと、なんでもできるけど安易なメタプログラミングも嫌だなあというマクロで使い分けに迷うことはないでしょうか。

例えばですが、defstructにはアクセサを自動で生成する機能があり、この機能については善し悪しがありますが、defclassで同様のアクセサの自動生成を実装するとします。
さて、こういう場合、MOPで実現するのが良いのか、マクロでやっつけてしまえば良いのか微妙に悩んだりしないでしょうか(自分だけ?)

defclassでアクセサの生成をするということは、定義時には名前が確定しているということで、マクロが担当するのが良い気もします。
しかしクラスに関することなので、MOPを使った方が既存の構文の枠組みで拡張できたりもしそうです。

どっちもどっちなのですが、とりあえずはマクロで書いてみました。
defclass/conc-nameは、defcassに展開されるマクロですが、:conc-nameでアクセサの接頭辞を指定できます。

(defclass/conc-name foo ()
  (x 
   y 
   (z :accessor z))
  (:conc-name foo.))

;;; マクロ展開
===>
(defclass foo ()
  ((x :accessor foo.x)
   (y :accessor foo.y)
   (z :accessor z :accessor foo.z)))

(let ((qqq (make-instance 'foo)))
  (with-slots (x y z) qqq
    (setq x 42 y 43 z 44))
  (incf (foo.z qqq))
  (list (foo.x qqq)
        (foo.y qqq)
        (foo.z qqq)))
→ (42 43 45) 

defclass/conc-name定義

(defun canonicalize-slots (slots)
  (labels ((canonicalize-slot (slot)
             (typecase slot
               ((and symbol (not null)) (list slot))
               (T slot))))
    (mapcar #'canonicalize-slot slots)))
(defun slot-name-conc (prefix name)
  (let ((pkg (etypecase prefix
               ((or null string) *package*)
               (symbol (symbol-package prefix)))))
    (intern (concatenate 'string (string prefix) (string name)) pkg)))
(defun ->conc-name (name)
  (etypecase name
    (null "")
    (symbol (string name))
    (string name)))
(defmacro defclass/conc-name (name superclasses slots &rest class-options)
  (let* ((conc-name-p nil)
         (conc-name (concatenate 'string (string name) "-"))
         (class-options (loop :for opt :in class-options
                              :if (eq :conc-name (car opt))
                              :do (setq conc-name-p T
                                        conc-name (->conc-name (cadr opt)))
                              :else :collect opt)))
    `(defclass ,name (,@superclasses)
       (,@(loop :for s :in (canonicalize-slots slots)
                :when conc-name-p
                :do (setf (cdr (last s)) 
                          (list :accessor (slot-name-conc conc-name (car s))))
                :collect s))
       ,@class-options)))

マクロで実装してみた感想

マクロで書いた場合ですが、今回の場合は、

• defclassの派生構文ができてしまう
• マクロ内でdefclassのオプションを解析するのがめんどくさい

等々が問題かなと感じます。

defclassのオプションを解析するのがめんどくさいのは、defclassの作法に従おうとした結果で、その方が、使い手も類推できて良かろうという判断なのですが、どうせ拡張された構文なので解析しやすそうな構成にすることも可能かなとは思います。
defstructの作法に近付けるなら、

(defclass/conc-name (foo (:conc-name foo.)) ()
  (x 
   y 
   (z :accessor z)))

のようにできるかもしれません。
問題は、defclass/conc-nameはdefstructの作法で書くという情報の取扱がめんどう(使う側の人が色々憶えないといけない)ということです。

利用者の負担を減らすということでは、構文乗っ取り型マクロにしてしまう手もなくはありませんが、どうなんでしょう。

(with-conc-name foo.
  (defclass foo ()
    (x 
     y 
     (z :accessor z))))
;; or
(with-accessor-options ((:conc-name foo.)
                        (:foo opt))
  (defclass foo ()
    (x 
     y 
     (z :accessor z))))
...

この場合は、見掛け上defclassが本体に見えますがwith-conc-nameがdefclassフォームを引数として処理することになります。

トリッキーですが派生構文を処理する場合には、defclass/conc-nameのような新しい名前を導入せずに既存の作法を継承できるので、一番スマートな方法だったりするかもしれません。

次回はMOPの作法で考えてみます。

■

HTML generated by 3bmd in LispWorks 7.0.0

たまにCommon Lisp標準が利用するキーワードシンボル一覧が欲しい時がありますが、どこにあるんでしょうか。

とりあえずのところは、HyperSpecのインデックスが利用できると思います。

• Common Lisp HyperSpec: Index

しかし、どこかにキーワードシンボルだけまとめたものがありそうなのですが……。

少し探しても見当らなかったので、HyperSpecを参考に逆引きCommon Lispに記事を作成してみました。

• Common Lisp標準が利用するキーワードシンボル一覧

ちなみに、HyperSpecのものは記事からインデックスを自動生成かなにかをしているようでタイポがあったり、コード例に使われているだけのキーワードシンボルも計上されているようです。

まとめ

エディタの補完機能まわりをカスタマイズしているときに関数が利用するキーワードだけを補完して欲しいのですが、まずは補完対象の一覧が欲しいなと思って、ここに至ります。
ひょっとしたら、ANSI Common Lisp規格票には掲載されていたりするかもと思い確認してみましたが、こちらにも無いようです。うーむ。

■

HTML generated by 3bmd in LispWorks 7.0.0

毎年振り返りのまとめを書いているので、今回も書いてみます。

Lisp的進捗

ここ数年マニアックなLispネタでアドベントカレンダーを開催することで、色々調べたりしてLispのマイナー機能に詳しくなるというのをやっていました。
2017年はお休みしたのですが、若干の悔いが残ったので、2018年は、setfとメソッドコンビネーションネタでやってみました。
毎回これ以上はないなという所まで掘り下げられるので良い勉強になります(多分)。

メソッドコンビネーションに関しては、まだ掘り下げて書けることがありそうなので、そのうちちょっと書いてみたいと思います。

ブログ

今年書いた記事は72記事だったようです。
アドベントカレンダーで50記事位書いたのを除けば、大体二週間に一記事書いたり書かなかったりというところです。
近年、ブログを書く人も大分少なくなりましたが、2019年もそこそこ書いていきたいと思います。

LispWorks

LispWorksを購入してから早三年半ですが、持ち前の吝嗇根性からLispWorksを使い倒すべくメインに使い続けています。

ちなみに、以前は、SBCLをメインに使っていました。
SBCLはコンパイラ優秀で、実行速度からいうとほぼ最速の処理系で、ユーザーも一番多く、その上自由ソフトな処理系ということもあり、これ以外の選択はないだろうという感じでもあるのですが、GUIツールキット、Common Lispと統合された開発環境、出荷機能まで一通り揃っている完成度の高い処理系というとLispWorks、Allegro CL、MCL位しかありません。
Allegro CLは個人で使うにはお値段が謎、MCLはPPC Macと共に過去のものになってしまった等で、現実的な統合環境としてはLispWorks位かなと思います。

また、職場の社内ツールをLispWorksで作成してみたところ、色々な条件がたまたま上手くはまり、現在もLispWorksで開発が進んでいます。

• 社内にLispWorksユーザーがたまたま二人いた
• MacでGUIのアプリが必要だったので、LispWorksのCAPIに詳しい人がプロトタイプを作ってみたら手早くできちゃった

というところで、まさに偶然ですが、折角の機会なので活用していきたいところです。
ちなみに開発は同僚にお任せしているので、たまに思い付きの機能追加をしてみたりする以外では私はほとんど開発してません😺

2019年やってみたいこと

ここ二三年でLispマシンのエミュレータも、CADR、LMI Lambda、Symbolics Open Genera、TI Explorer、等一通り出揃いましたが、あまりキャッチアップできてないので2019年は力を入れようかなと思っています。

あと年末には、コンディションシステムアドベントカレンダーを開催したいので、色々準備しておきたいところです。

過去のまとめ

• #:g1: 2017年振り返り
• #:g1: 2016年振り返り
• #:g1: 2015年振り返り
• #:g1: 2014年振り返り
• #:g1: 2013年振り返り
• #:g1: 2012年振り返り
• #:g1: 2011年を振り返る
• #:g1: 2010年を振り返る
• #:g1: 2009年を振り返る
• #:g1: 今年一年をふりかえる

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp SETF Advent Calendar 2018 25日目 》

メソッドコンビネーションでアドベントカレンダーを開催することを決めてから、もう一品と考えてsetfアドベントカレンダーを開催してみましたが、後半はネタを捻り出すのがきつかったです。

よくよく考えれば、ただの代入機構なので、話題が広げられる余地はあまりないのですが、ファーストクラスの参照を持つLISP方言についてもうちょっと掘り下げて書けたかもしれません(といっても一回分位だと思いますが)

setfアドベントカレンダーのを書いたお蔭で、setfの定義構文の使い分けについて、きっちり把握できたのは収穫かなと思います。

-完-

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp メソッドコンビネーション Advent Calendar 2018 25目 》

メソッドコンビネーションでアドベントカレンダーは無謀かなと思いましたが、果してそれなりに無謀でした。

このアドベントカレンダーでの収穫は、eshamsterさんに define-method-combinationの詳細な解説を書いて頂けたことかなと思います。
今後define-method-combinationを書く際には参照することも多くなるのではないでしょうか。

• define-method-combinationを理解する
• 小ネタ: define-method-combinationで遊ぶ

メソッドコンビネーションについて分かったこと

私的にメソッドコンビネーションについて分かったことを纏めると

• define-method-combinationは、Common Lispには珍しく細部仕様の詰めが甘いらしい
• :aroundはメソッド周囲をletで囲むような使い方をするもので、:afterや、:beforeとは一線を画す(ので同じ感覚で多用するものではなさそう)
• 割とカジュアルに定義して使うことを考えていたらしい(New flavorsあたりの論文では)
• メソッドの分別の単位はメソッド修飾子。なのでクラスの継承関係とは別個に構成可能。かと思えば、メソッドコンビネーションにメソッドを参加させるためにmixinするようなことも行われていたらしい。
• メソッドの組織化全般に使える

位でしょうか。

メソッドコンビネーションは、まだまだ開拓の余地があると思いますので、今後、さらに活用されることを期待しています。

-完-

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp メソッドコンビネーション Advent Calendar 2018 24目 》

前回、MOPでのメソッドコンビネーションAPIの実現は、紆余曲折ありつつ、曖昧なところを残しているらしい、と書きました。
今回は、ANSI CLでは取り入れられなかったMOP仕様の草案である X3J13-88-003R の 1988-03-11 版にメソッドコンビネーションのAPIについての記述があったので、それを実際に動かしてみて、どのような設計方針であったのかを探ります。

なお、X3J13-88-003R の 1988-03-11版はTeXをPDFにしたものがこちらにありますので、適宜参照してください。

• Common Lisp Object System Specification: 3. Metaobject Protocol (1988-03-11)

下準備

シンボル名の競合がありそうなので、専用のパッケージを作成します。

(defpackage X3J13-88-003R
  (:use :cl :c2mop)
  (:shadowing-import-from :c2mop
   :defmethod :standard-class :defgeneric :standard-generic-function)
  (:shadow :define-method-combination))
(in-package :X3J13-88-003R)

メソッドコンビネーションクラスの定義

method-combinationのサブクラスにstandard-method-combinationとsimple-method-combinationが標準で用意されています。
ただ使い分けについてはいまいちはっきりしません。
とりあえず記述をそのままコードにしています。

(defclass x3j13-88-003r-method-combination (method-combination)
  ((name
    :initarg :name
    :reader method-combination-name)
   (order
    :initarg :order
    :reader method-combination-order)
   (operator
    :initarg :operator
    :reader method-combination-operator)
   (identity-with-one-argument
    :initarg :identity-with-one-argument
    :reader method-combination-identity-with-one-argument)
   (documentation 
    :initarg :documentation))
  (:default-initargs
   :name nil
   :order :most-specific-first
   :operator nil
   :identity-with-one-argument nil
   :documentation nil))
(defclass standard-method-combination (x3j13-88-003r-method-combination)
  ())
(defclass simple-method-combination (x3j13-88-003r-method-combination)
  ())
(defclass short-form-method-combination (simple-method-combination) ())

ここでは、x3j13-88-003r-method-combinationをmethod-combinationのサブクラスにしていますが、恐らくこの定義が、method-combinationの定義になる予定だったのでしょう。

ANSI CLのdefine-method-combinationで指定するようなオプションが、method-combinationの方で定義されていることが分かります。

メソッドコンビネーションオブジェクトのメソッド

メソッドコンビネーション名からメソッドコンビネーションオブジェクトを引いてくるのにmethod-combination-objectを定義します。
AMOPのfind-method-combinationとほぼ同じですが、こちらは総称関数は指定しません。
中身のコードは大体想像で書いています。

(defgeneric method-combination-object (name options))
(defmethod method-combination-object ((name (eql nil)) options)
  (class-prototype 'standard-method-combination))
(defmethod method-combination-object ((name (eql nil)) options)
  (class-prototype 'standard-method-combination))
(defmethod method-combination-object 
           ((name (eql 'standard-method-combination)) options)
  (class-prototype 'standard-method-combination))

define-method-combinationの定義

define-method-combinationは、名前を指定するだけでmethod-combination-objectを簡便に定義できるような位置付けになっています。

short-form-method-combinationが決め打ちになっているのですが、意図的なものなのか間違いなのかははっきりしません。

(defmacro define-method-combination (name &key (documentation nil)
                                          (operator name)
                                          (identity-with-one-argument nil))
  `(defmethod method-combination-object
              ((name (eql ',name))
               options)
     (apply (lambda (&optional (order ':most-specific-first))
              (check-type order (member :most-specific-first
                                        :most-specific-last))
              (make-instance 'short-form-method-combination
                             :name ',name
                             :order order
                             :documentation ',documentation
                             :operator ',operator
                             :identity-with-one-argument
                             ',identity-with-one-argument))
            options)))

メソッド呼び出しのフォームを作るユーティリティ

make-method-callというユーティリティがあったようですが、このインターフェイスではメソッドの引数を上手く取り扱えないということで廃止になったようです。

ユーティリティが何もない現在は結局ベタ書している状況ですが、このmake-method-callを使っても大抵は問題はなさそうではあります。

なお、このコードも使用例から想像して書いています。

(defun make-method-call (method-list &key operator identity-with-one-argument)
  (case operator
    (:call-next-method `(call-method ,(car method-list)
                                     ,(cdr method-list)))
    (ohterwise `(,operator 
                 ,@(loop :for m :in method-list :collect `(call-method ,m))))))

大体これくらいの定義ですが、これだけでもメソッドコンビネーションが定義できます。

compute-effective-method

define-method-combinationは、メソッドコンビネーションオブジェクトに名前を付けて登録する程度の役割になっていましたが、代りにcompute-effective-methodが式の組み立てのメインになります。

(defmethod compute-effective-method (generic-function
                                     (mc short-form-method-combination)
                                     methods)
  (let ((primary-methods (remove (list (slot-value mc 'name))
                                 methods :key #'method-qualifiers
                                 :test-not #'equal))
        (around-methods (remove '(:around)
                                methods :key #'method-qualifiers
                                :test-not #'equal)))
    (when (eq (slot-value mc 'order) ':most-specific-last)
      (setq primary-methods (reverse primary-methods)))
    (dolist (method (set-difference methods
                                    (union primary-methods around-methods)))
      (error "The qualifiers of ~S, ~:S, are not ~S or ~S"
             method (method-qualifiers method)
             (list (slot-value mc 'name)) '(:around)))
    (make-method-call `(,@around-methods
                        (make-method 
                         ,(make-method-call primary-methods
                                            :operator (slot-value mc 'operator)
                                            :identity-with-one-argument
                                            (slot-value mc 'identity-with-one-argument))))
                      :operator :call-next-method)))

メソッドを定義してみる

ではメソッドを定義して動作を確認してみましょう。
総称関数の:method-combination指定が構文チェックでエラーになったりするのでensure-generic-functionを直に使ってみます。

(define-method-combination foo :operator :call-next-method)
(ensure-generic-function 
 'zot 
 :lambda-list '(x)
 :method-combination (method-combination-object 'foo nil))
;; ≡ (defgeneric zot (x))
;;
;;    (setf (generic-function-method-combination #'zot)
;;          (method-combination-object 'foo nil))

(defmethod zot foo (x) (list :p x))
(defmethod zot foo ((x integer)) (list :p 'integer (call-next-method)))
(defmethod zot :around (x) 
  (list :around (call-next-method)))

(zot 8)
→ (:around (:p integer (:p 8))) 

• メソッドコンビネーション展開

(compute-effective-method #'zot 
                          (method-combination-object 'foo nil)
                          (compute-applicable-methods #'zot (list 8)))
→
(call-method
 #<standard-method zot (:around) (t) 41E012FF53>
 ((make-method
   (call-method
    #<standard-method zot (foo) (integer) 41E012FCDB>
    (#<standard-method zot (foo) (t) 41E01306C3>))))) 

上手く動いているようです。

まとめ

以上、X3J13 88-003Rでの定義でしたが、それなりにすっきり纏まっている気がします。
define-method-combinationの:argumentsオプションについては触れられていないのですが、compute-discriminating-functionの祖先の定義お眺める限りは、compute-discriminating-functionがcompute-effective-methodの内容を元に関数オブジェクトを生成する際、総称関数の引数と連結するスコープを差し込むつもりだったのかなと想像しています。

(generic-function (gf-args ...)
  ((lambda (args ...) ;;; define-method-combination の :arguments
     ,@effective-method)
   gf-args ...))

謎が多い、define-method-combinationまわりですが、MOPベースだったら、もうちょっとカスタマイズされたメソッドコンビネーションも活用されていたかもしれません(そうでもないか)

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp SETF Advent Calendar 2018 24日目 》

これまでも何度かget-setf-expansionや、define-setf-expanderを利用する例を取り上げてきましたが、返り値が5つもあります。
そのお蔭で、多値の何番目がなんの役割だったか毎度調べたりしていますが、これだとちょっと面倒なので、専用構文を作って開発環境のシンタックス補完等の恩恵に与る作戦を考えました。

まずは、get-setf-expansionですが、キーワード引数ならぬ、キーワード多値で値を返すことにしてみました。

(defun get-setf-expansion* (place &optional env)
  (multiple-value-bind (vars vals store-vars writer-form reader-form)
                       (get-setf-expansion place env)
    (values :vars vars
            :vals vals
            :store-vars store-vars
            :writer-form writer-form
            :reader-form reader-form)))

• 素のget-setf-expansion

(get-setf-expansion '(ldb bytespec i))
→ (#:g255423) 
   (bytespec) 
   (#:g255424) 
   (let ((#:|Store-Var-255422| (dpb #:g255424 #:g255423 i)))
     (setq i #:|Store-Var-255422|)
     #:g255424) 
   (ldb #:g255423 i) 

• 拡張したget-setf-expansion*

(get-setf-expansion* '(ldb bytespec i))
→ :vars 
   (#:g255429) 
   :vals 
   (bytespec) 
   :store-vars 
   (#:g255430) 
   :writer-form 
   (let ((#:|Store-Var-255428| (dpb #:g255430 #:g255429 i)))
     (setq i #:|Store-Var-255428|)
     #:g255430) 
   :reader-form 
   (ldb #:g255429 i) 

返り値に注釈が付けば、位置とその役割を忘れても大丈夫です。

次に、このキーワード多値を受ける構文を考えてみました。

(defmacro setf-expansion-bind 
          ((&key vars vals store-vars writer-form reader-form)
           setf-expansion-form
           &body body)
  (loop :for (k . v) :in `((:vars . ,vars)
                           (:vals . ,vals)
                           (:store-vars . ,store-vars)
                           (:writer-form . ,writer-form)
                           (:reader-form . ,reader-form))
        :when v :collect `((,k ,v)) :into key-args
        :finally (return 
                  `(macrolet ((setf-expansion-values (&key vars vals store-vars writer-form reader-form)
                                `(values ,vars ,vals ,store-vars ,writer-form ,reader-form)))
                     (multiple-value-call 
                         (lambda (&key ,@key-args &allow-other-keys) 
                           ,@body)
                       ,setf-expansion-form)))))

ボディの中では、setf-expansion-valuesオペレーターで注釈付きで多値を記述できるようにしてあります。

(setf-expansion-bind (:vars vars 
                      :vals vals
                      :store-vars store-vars
                      :writer-form writer-form
                      :reader-form reader-form)
                     (get-setf-expansion* '(ldb bytespec i))
  (setf-expansion-values :vars vars 
                         :vals vals
                         :store-vars store-vars
                         :writer-form writer-form
                         :reader-form reader-form))
→ (#:g255477) 
   (bytespec) 
   (#:g255478) 
   (let ((#:|Store-Var-255476| (dpb #:g255478 #:g255477 i)))
     (setq i #:|Store-Var-255476|)
     #:g255478) 
   (ldb #:g255477 i) 

記述は面倒ですが、たまにしか使わないのとキーワードによる注釈が付くので扱いやすい気がします。
ごちゃごちゃしたキーワード引数はSLIME等でまとめて補完可能なので手打ちする必要はありません。

まとめ

今回は、構文定義 & IDEでの補完 の組み合わせで考えてみましたが、get-setf-expansionのフォームをmultiple-value-bindのフォームで包むような補完ができるIDEの拡張を作ってみても良いかなと思ったりしています。

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp SETF Advent Calendar 2018 23日目 》

あと三回setfネタで記事を書かないといけないのですが、何が書けるでしょうか。

とりあえず、今回はsetfのような代入構文をさらに便利にしたような構文を紹介してみたいと思います。

自己代入系

これまで自己代入系の定義構文を紹介したりしましたが、都度定義するのではなく、汎用的なものを定義して使う、というパターンです。

Gauche: update!

(update! place proc)という形式ですが、incfみたいなものは、

(let ((x (list 0)))
  (update! (car x) (lambda (v) (+ v 1))) 
  x)
→ (1)

と書けます。
define-modify-macroで一々定義するよりずっと良いですね。

Arc: zap

Gaucheのupdate!とほぼ同じです。引数の順番と名前が違う位です。

(let x (list 0)
  (zap (fn (v) (+ v 1))
       (car x)) 
  x)
→ (1)

TAO/ELIS: !!

以前も紹介しましたが、TAOの!!は自己代入専用の構文です。
!で印を付けた場所に書き戻せます。

(let ((x (list 0)))
  (!!(lambda (v) (+ v 1)) !(car x))
  x)
≡
(let ((x (list 0)))
  (!!1+ !(car x))
  x)

その他便利なユーティリティ

私見ではPaul Graham氏は面白い代入系ユーティリティを定義しているので、2、3眺めてみます。

Arc: pull

Common Lispのremove-ifとsetf`を組合せた感じです。

(let x '(1 100 2 50 3) 
  (pull [< _ 10] x) x)
→ ((100 50) foo) 

pushend

pushは先頭に追加なので末尾に追加したい場合に使えます

(let ((x (list 0 1 2)))
  (pushend 100 x)
  x)
→ (0 1 2 100) 

merge-into

述語で場所を探してマージします。

(let ((x (list 0 1 2 0 0 0 8 2 -1)))
  (merge-into x 5 #'<)
  x)
→ (0 1 2 0 0 0 5 8 2 -1) 

元定義は下記のような感じですが、define-modify-macroでlambda式を取れるのは処理系拡張なので、可搬的に書くならdefmacroで定義する必要があるでしょう。

しかしdefine-modify-macro版だとpushendの定義のnconcがすっぽ抜け問題が発生しそうな見た目が気持ち悪いですが、define-modify-macroの展開ではplaceに代入し直されるので大丈夫です。

;;; http://lib.store.yahoo.net/lib/paulgraham/utx.lisp

(define-modify-macro pushend (obj)
  (lambda (place obj)
    (nconc place (list obj))))
(define-modify-macro merge-into (obj fn)
  (lambda (place obj fn)
    (merge 'list place (list obj) fn)))

• 可搬的

(defmacro pushend (obj place)
  (let ((p (gensym)))
    `(let ((,p ,place))
       (setf ,p (nconc ,p (list ,obj))))))

(defmacro merge-into (place obj fn)
  (let ((p (gensym)))
    `(let ((,p ,place))
       (merge 'list ,p (list ,obj) ,fn))))

まとめ

setf系の便利構文を紹介してみました。
色々定義してみるもの面白いかなと思います。

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp メソッドコンビネーション Advent Calendar 2018 23目 》

先日、Common Lispのメソッドコンビネーションの実現具合とAMOPでの実現に結構な差異があると書きましたが、今回は、define-method-combinationを使わないでMOP中心でメソッドコンビネーションを定義するとどんな感じになるか、を確かめてみたいと思います。

とりあえず、Common LispとAMOP近辺のメソッドコンビネーションを実現方式を調べてみると5つ位バリエーションがみつかりました。

• ANSI Common Lisp
• Closer to MOP
• X3J13-88-003R Metaobject Protocol (Draft)
• AMOPの本文、Closetteの実装
• 各処理系の実装

まず、X3J13-88-003R Metaobject Protocolは草稿どまりですが、AMOPの流儀をベースにしつつも最適化についても考慮していたようなので複雑になっています。
また、define-method-combinationというFlavorsの流れも、MOP上に統合しようとしていたようですがこれも未完です。

次に、ANSI CL規格は、X3J13-88-003Rで練られていた事項を踏まえつつ、MOPの詳細については踏み込まない、という感じになっています。

AMOPの本文、Closetteの実装、は一つの理想形で、ANSI CL規格との兼ね合いのような瑣末なことは考慮されていません(先行しているので当然)

また、各処理系の実装は、概観するとAMOPに準拠しようとしつつ、参照実装の挙動が仕様だ、という感じになっています。
しかし参照実装とはいえ、Portable CommonLoopsの実装が仕様に準拠していない所もあり、その辺りのあやふやさは現在にも受け継がれています。

Closer to MOPは、AMOPの内容を現在メジャーなANSI Common Lisp処理系の上にポータブルな仕様と実装を実現しようとしたものです。

メソッドコンビネーションの枠組み作成

とりあえず、MOP的にメソッドコンビネーションの枠組みを作成してみましょう。

仕様は色々ありますが、compute-effective-methodがメソッドの集合を指定されたメソッドコンビネーションに応じでフォームを組み立てる、というのは共通しています。

なお、以下では、Closer to MOPを利用します。

(ql:quickload :closer-mop)

総称関数の定義

標準では、define-method-combination経由でしかメソッドコンビネーションを定義できないので、総称関数ごと別に作成します。

(defclass mcacgf (standard-generic-function)
  ()
  (:metaclass funcallable-standard-class))

メソッドコンビネーションクラスの定義

ANSI CLには、method-combinationクラスが定義されているのですが、使い方やスロットの詳細は曖昧なままです。
X3J13-88-003Rでは、サブクラスにstandard-method-combinationとstandard-simple-method-combinationを定義しているようです。
この流儀に沿っているLispWorksのような実装もある様子。

とりあえずは標準のもののサブクラスにします。

(defclass ac-method-combination (method-combination) ())

メソッドコンビネーションの配置生成定義

effective-methodというとメソッドオブジェクト(メタオブジェクト)っぽいのですが、どうも式(メタプログラム)を指しているようです。

compute-effective-methodが式を生成するので、ここで直接書き下してしまえばOKです。

下記では、単純にするために:aroundなしのstandardにしています。
(Flavorsでいうdaemon)。

define-method-combination構文の便利機能を使わず手書きしている、という感じですね。

(defmethod c2mop:compute-effective-method ((gf mcacgf)
                                           (mc method-combination)
                                           (methods list))
  (loop :for m :in methods
        :for mq := (method-qualifiers m)
        :when (equal '(:before) mq) :collect `(call-method ,m) :into bs
        :when (equal nil mq) :collect m :into ps
        :when (equal '(:after) mq) :collect `(call-method ,m) :into as
        :finally (return `(multiple-value-prog1 
                              (progn (progn :before-daemons ,@bs)
                                :primaries
                                (call-method ,(car ps) (,@(cdr ps))))
                            (progn :after-daemons ,@as)))))

メソッドコンビネーション名の登録

defgenericの:method-combinationオプションで指定できるように登録します。
しかし、find-method-combinationが実装されていない処理系もあるので、フックできないかもしれません(LispWorks等)

(defmethod c2mop:find-method-combination 
           ((gf mcacgf) (type (eql 'mcac)) opts)
  (make-instance 'ac-method-combination))
;;; LispWorksではしょうがないのでテーブルに直に登録
(setf (gethash 'mcac clos::*method-combination-types*)
      (make-instance 'ac-method-combination))

動かしてみる

(defgeneric foo (x)
  (:generic-function-class mcacgf)
  (:method-combination mcac))
(defmethod foo (x) x)
(defmethod foo :after (x) 
  (print (list :after x)))
(defmethod foo :before (x)
  (print (list :before x)))
(foo 42)
▻ (:before 42) 
▻ (:after 42) 
→ 42

• メソッドコンビネーション展開

(c2mop:compute-effective-method #'foo
                                (make-instance 'ac-method-combination)
                                (compute-applicable-methods #'foo (list t)))
→ (multiple-value-prog1
      (progn
        (progn
          :before-daemons
          (call-method #<standard-method foo (:before) (t) 40E0460B83>))
        :primaries
        (call-method #<standard-method foo nil (t) 40E042A5EB> nil))
    (progn
      :after-daemons
      (call-method #<standard-method foo (:after) (t) 40E0429F9B>)))

困った所

define-method-combinationオプションの:argumentsのサポートが鬼門なのですが、

1. まともに実装している処理系がないっぽい
2. MOPでどうするか文献がない

等で、MOPで:argumentsをサポートする場合、どういうAPI構成で書くべきなのか良く分かりません。
ANSI CL規格では、effective method中に展開されるとありますが、このあたりも処理系によって挙動がまちまちのようです。

まとめ

とりあえず、define-method-combinationを経由しないでメソッドコンビネーションを定義してみました。
define-method-combinationのマイナーな機能/オプションについてはCommon Lispの仕様が中途半端なせいか、どうやら忠実に実装できているは処理系がなさそうです。

SICL等は綺麗なCommon Lispを目指しているようなので、今後はSICLあたりも参照してみようかなと思います。

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp メソッドコンビネーション Advent Calendar 2018 22目 》
《 Lisp SETF Advent Calendar 2018 22日目 》

これまで、メソッドコンビネーションで19記事、setfで17記事程書いてきましたが、もう書くことがないです。

setfでメソッドコンビネーション活用について書けば、一挙両得なのでは!、と考えこのネタでひとつ考えてみたいと思います。

setfとメソッドコンビネーション

まず、setfでメソッドコンビネーションの活用が成立する為には、どう考えてもスロットのライタである必要があります。

(defclass foo ()
  ((x :initarg :x :accessor x :writer (setf x/))))
(defvar *foo* (make-instance 'foo :x 42))
(x *foo*)
→ 42 
(setf (x/ *foo*) 69)
(x *foo*)
→ 69 

クラスのスロット定義で、スロットに対して複数のアクセサ総称関数が定義可能ですが、setfが関係するのは、:accessorか、:writterオプションになります。

defclassで定義するアクセサは、デフォルトではstandardになることが規格で定まっています。

そのため、メソッドコンビネーションを指定したい場合は、defclassでアクセサは作らず、別途定義することになると思われます。

試してみましょう

(defgeneric (setf x-list) (val o)
  (:method-combination list))
(defmethod (setf x-list) list (val (o foo))
  (setf (c2mop:slot-value-using-class (class-of o) o 'x) val)
  val)
(defclass bar (foo) ())
(defmethod (setf x-list) list (val (o bar))
  (setf (c2mop:slot-value-using-class (class-of o) o 'x) val)
  val)
(defvar *bar* (make-instance 'bar :x 42))
(x *bar*)
→ 42 
(setf (x-list *bar*) 69)
→ (69 69) 
(x *bar*)
→ 69 

上記では、listメソッドコンビネーションを実行し代入の返り値をリストにして返しています。

これは、standardメソッドコンビネーション以外で、役に立ちそうな例を考えるのが難しい……。

setfに関しては、実行前後のフック(daemonメソッドコンビネーション)か、乗っ取り(around)があれば十分そうですね(即ちstandardメソッドコンビネーション)

通常は、同一の値を同一スロットに複数回書き込む挙動は求められていないということからもprogn等で有用なことはできなさそうです。

MOPで

(defclass foo ()
  ((x :initarg :x :accessor x :accessor-method-combination progn)))

のように書けるようにすることも検討してみましたが、これも微妙

一応役に立つ例も紹介

メソッドコンビネーションのカスタマイズの方向で書いてしまいましたが、standardとsetfの組み合わせであれば、値の設定前後のフックとして有用な使い方が可能です。

• 事前事後の値チェック(:before、:after)
• 副作用目的での手続の差し込み(:before、:after)
• 乗っ取りで、アクションを加えたり元動作を削除してしまったり(:around)

(defmethod (setf x/) :after (val (foo foo))
  (write-line "こんにちは"))
(setf (x/ *foo*) 42)
▻ こんにちは
→ 42
(defmethod (setf x/) :before (val (foo foo))
  (check-type val integer))
(setf (x/ *foo*) 'foo)
>>> error
(defmethod (setf x/) :around (val (foo foo))
  nil)
(setf (x/ *foo*) 'foo)
→ nil

まとめ

リーダーもを含めたアクセサ全般と、メソッドコンビネーションの組み合わせでは何か有用なことも可能かもしれませんが、setfのライタ限定となると、デフォルトのstandardが必要にして十分だった、ということがわかりました。

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp メソッドコンビネーション Advent Calendar 2018 21目 》

もうメソッドコンビネーションについて書くことがないので、深刻なネタ不足、準備不足と格闘しておりますが、このあたりでMOPとメソッドコンビネーションについて整理してみましょう。

Common Lispの場合

Common Lispの場合というか、MOPがあって、メソッドコンビネーションもあるというのはCommon Lisp位しか存在しないですが……。

まず、MOPはANSI Common Lisp規格外です。
MOPをサポートする処理系があっても良くて、それの場合はAMOP(The Art of the Metaobject Protocol)が拠り所になるでしょう程度の微妙な距離感になっています。

しかし実際にはANSI Common Lispの処理系の殆どが上述のAMOPの仕様を元にある程度互換性のあるMOPを組んで提供しています。
といってもAMOP自体、ANSI Common Lispの規格程かっちり規定できてはいないので、処理系ごとに差異はあり、その差異を埋めようというライブラリがCloser to MOPになります。

MOPの前置きが長くなりましたが、メソッドコンビネーションを定義するdefine-method-combinationはANSI Common Lisp規格で定義されているものでMOPのサポートを前提とはしていません。
メソッドを配置するコードを定義するのが、define-method-combinationですが、配置定義をしているだけで、定義に従ってあれこれするのは処理系依存です。

また、仮にMOPが存在することを前提に考えても、define-method-combinationにMOP的にオーバーライドできるフックポイントがあるわけでもないのでMOPという感じもあまりないかなと思います(MOPを前提としないデザインなので当たり前かもしれません)

たまに、Common LispのメソッドコンビネーションはMOPでカスタマイズする/可能、と説明している人がいますが、ちょっと違うかなと思います。
もしかすると、AMOPでメソッドコンビネーションを実現するのに、define-method-combinationは使わず、MOPの観点からapply-methodや、compute-effective-method-functionというものを定義して、これで解説してみせているのでCommon Lispもそうなっていると誤解していたりするのかもしれません。
実際の所は、メソッドコンビネーションはMOPがないFlavorsにもありますし、別個の概念と考えた方が良いでしょう。
AMOPはメソッドコンビネーションをMOPで実装してみせた例で、メソッドコンビネーションの追加等のカスタマイズはメソッドのオーバーライドで行う等、MOP的です。

Common Lispのメソッドコンビネーションの処理とMOP

Common Lisp場合のMOPとメソッドコンビネーションの兼ね合いですが、

1. define-method-combinationでメソッド配置を定義(コード生成の定義)
2. compute-effective-methodがコード生成の定義と、総称関数、メソッド、メソッドコンビネーションの各メタオブジェクトからコード(effective-method)を生成
3. effective-methodはcompute-discriminating-functionが総称関数の関数を作るのに使う

(defmethod foo (x) x)
(defmethod foo :after (x) x)
(set 'ms (compute-applicable-methods #'foo '(8)))
→ (#<standard-method foo (:after) (t) 402053A353>
    #<standard-method foo nil (t) 402052BAEB>) 
(set 'mc (c2mop:find-method-combination #'foo 'standard nil))
→ #<clos::standard-method-combination standard 41A10AAD3B> 
(c2mop:compute-effective-method #'foo mc ms)
→
(multiple-value-prog1
  (call-method #<standard-method foo nil (t) 411000E97B> nil)
  (call-method #<standard-method foo (:after) (t) 411000E773> nil)) 

となっています。

ちなみに、AMOPでは、

1. メソッドコンビネーションごとに、総称関数をサブクラス化する。補助メソッドの特定にはメソッド修飾子を利用。
2. compute-applicable-methods-using-classesがメソッドを集めてくる
3. メソッド群を起動するapply-methods(もしくは効率改善のcompute-effective-method-function)をオーバーライドして、メソッドの起動の組織化をカスタマイズ可能。補助メソッドは特定できるので任意に選別し配置可能。

となっていて、上に述べたように、よりMOP的になっています。
下記のコードはclosetteの例ですが、std-compute-effective-method-functionというコード生成のメソッドになっているもののAMOPのcompute-effective-method-functionと同様の雰囲気です。

(defun std-compute-effective-method-function (gf methods)
  (let ((primaries (remove-if-not #'primary-method-p methods))
        (around (find-if #'around-method-p methods)))
    (when (null primaries)
      (error "No primary methods for the~@
             generic function ~S." gf))
    (if around
        (let ((next-emfun
                (funcall
                   (if (eq (class-of gf) the-class-standard-gf)
                       #'std-compute-effective-method-function
                       #'compute-effective-method-function)
                   gf (remove around methods))))
          #'(lambda (args)
              (funcall (method-function around) args next-emfun)))
        (let ((next-emfun (compute-primary-emfun (cdr primaries)))
              (befores (remove-if-not #'before-method-p methods))
              (reverse-afters
                (reverse (remove-if-not #'after-method-p methods))))
          #'(lambda (args)
              (dolist (before befores)
                (funcall (method-function before) args nil))
              (multiple-value-prog1
                (funcall (method-function (car primaries)) args next-emfun)
                (dolist (after reverse-afters)
                  (funcall (method-function after) args nil))))))))

まとめ

Common Lispは、AMOPの記述を基準にするなら、結構Flavors寄りということなのかもしれません。

AMOP的にメソッドコンビネーション定義をするならば、compute-effective-methodをオーバーライドすることになるかなと思います。
ネタ切れなので、AMOP版メソッドコンビネーションを実装してみるかもしれません。

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp SETF Advent Calendar 2018 20日目 》

今回は、Pythonや、Rubyにある自己代入構文をsetfで再現してみようかなと思います。

自己代入構文とは

a = a + bをa += bと書ける構文ですが、起源はCなのでしょうか。
aが二回評価されないので効率が良いなんていう話もあるようです。

setfで再現してみる

それではとりあえず、(setf (op a) b)の形式で定義してみましょう。
下記では、標準のオペレーターと名前が被るのでパッケージを別にしています。

(defpackage :self-assignment
  (:use :cl)
  (:shadow "+" "-" "/" "//" "OR" "AND"))
(in-package :self-assignment)
(defmacro define-self-assignment-setf (op fn)
  `(define-setf-expander ,op (place)
     (multiple-value-bind (dv v sv setter getter)
                          (get-setf-expansion place)
       (values dv
               v
               sv
               `(let ((,@sv (,',fn ,getter ,@sv)))
                  ,setter)
               getter))))
(define-self-assignment-setf + cl:+)
(define-self-assignment-setf - cl:-)
(define-self-assignment-setf / cl:/)
(define-self-assignment-setf // cl:floor)
(define-self-assignment-setf % cl:mod)
(define-self-assignment-setf or cl:or)
(define-self-assignment-setf and cl:and)

試してみる

(let ((a 100) (b 42))
  (setf (+ a) b) a)
→ 142 
(let ((a 100) (b 42))
  (setf (- a) b) a)
→ 58 
(let ((a 100) (b 42))
  (setf (/ a) b) a)
→ 50/21 
(let ((a 100) (b 42))
  (setf (// a) b) a)
→ 2 
(let ((a 100) (b 42))
  (setf (% a) b) a)
→ 16 
(let ((a 100) (b 42))
  (setf (or a) b) a)
→ 100 
(let ((a (list (list 100))) (b 42))
  (setf (and (caar a)) b) a)
→ ((42)) 

まとめ

Common Lispにはincf、decfがありますが、自己代入のようなものは、(setf place)で考えた場合、placeっぽくないので、define-modify-macroで定義するのがCommon Lisp流だなあ、と作ってみてから思ったりです。

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp メソッドコンビネーション Advent Calendar 2018 20日目 》

これまでメソッドコンビネーションの定義方法の解説や実際に定義してみたりをしていましたが、メソッドコンビネーションが実際にはどのように使われているかをQuicklispのライブラリ中から探して眺めてみましょう。

method-versions

メソッドコンビネーション: method-version-method-combination

メソッド修飾子でメソッドのバージョンを表現したというもの。
確かにメソッドのまとまりをメソッドコンビネーションの枠組みを使えばバージョンごとに起動したりの管理ができます。
なかなか面白いアイデアですね。

clweb

メソッドコンビネーション: join-strings

文字列を連結するメソッドコンビネーションのようです。
大分限定された使い方ですが、appendやnconcも標準にありますし、そんな感じの気分なのでしょう。

mcclim

メソッドコンビネーション: values-max-min

標準でmin、maxはありますが、多値で両方を返してくるというものです。

chanl

メソッドコンビネーション: select

CSPライブラリのchanlですが、プロセスの制御をメソッドコンビネーションで表現しているようです。
並列処理とメソッドコンビネーションで色々探してみたのですが、chanlで使われていたとは。
修飾子にsend、recv がありますが、結構活用している事例かもしれません。

3b-swf

メソッドコンビネーション: swf-part

swfファイル生成ライブラリですが、daemon各々を:most-specific-lastで起動するもののようです。

serapeum / arnesi

standard/context / wrapping-standard

もとネタは、Tim Bradshaw氏のwrapping-standardメソッドコンビネーションのようです。
standardメソッドコンビネーションの周囲を:wrap-aroundでさらに囲みます(serapeumでは:context)
:wrap-aroundはデフォルトでは、:aroundと逆順の:most-specific-lastです。

filtered-functions

filtered-functionsをメソッドコンビネーション活用の方向から眺めてみましたが、どちらかというと、メソッドコンビネーションより前の段階に工夫がある感じでした。
filtered-functionsについては過去に紹介記事がありますので、そちらをどうぞ。

• #:g1: MOPでディスパッチの多様化: filtered-functions
• #:g1: Filtered Functions面白そう

method-combination-utilities

primary / lax / basic / append/nconc

メソッドコンビネーション定義のためのユーティリティと、有用そうなメソッドコンビネーション定義のライブラリです。

すっかり忘れていましたが、過去に紹介記事も書いていました。

• #:g1: method-combination-utilitiesの紹介

このブログでもmc-expandのようなものを定義していましたが、method-combination-expandみたいなものも定義されています。
メソッドコンビネーションを活用するなら試してみて損はなさそうなユーティリティです。
しかし、LispWorksで動かない様子(PR出そうかな)

まとめ

案外使う人はカジュアルに使っている様子。
メソッドコンビネーションを学んで活用しましょう!

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp メソッドコンビネーション Advent Calendar 2018 19日目 》

メソッドコンビネーションでD風の契約プログラミング: その1の続きですが、前回は、不変条件をメソッドコンビネーションでどう組むかというところまででした。

Dでは、不変条件は、クラス内でinvariantで定義され、

• すべてのコンストラクタの末尾
• デストラクタの冒頭
• メソッドの冒頭と末尾

に設置されるらしいです。
総称関数でこれをどう表現するかというところですが、

• すべてのコンストラクタの末尾 ⇒ スロットアクセスチェックを:afterで起動?
• デストラクタの冒頭 ⇒ clange-classで起動?
• メソッドの冒頭と末尾 ⇒ 総称関数なのでスロットアクセスチェックで良いでしょう

位になるでしょうか。

定義してみる

とりあえず、こんなdateクラスがあったとして、

(defclass date () 
  ((year :initarg :year :accessor year)
   (month :initarg :month :accessor month)
   (day  :initarg :day :accessor day))
  (:default-initargs :year 1900 :month 1 :day 1))
(make-instance 'date)
→ #<date 402026FA73> 

invariantメソッドが差し込んで使うようなメソッドコンビネーションを定義します。
andと同じような感じですが、基底クラスから順に適用してandの関係になるようにするので、継承順をreverseし、同じクラスに複数のメソッドを付けたいので、修飾子をワイルドカードにしました。

(define-method-combination invariant ()
  ((pri *))
  `(and ,@(loop :for m :in (reverse pri) :collect `(call-method ,m))))

これで、dateのスロットについてinvariantメソッドで不変条件を記述します。

(defmethod invariant year ((date date))
  (etypecase (year date)
    (integer T)))
(defmethod invariant month ((date date))
  (etypecase (month date)
    ((integer 1 12) T)))
(defmethod invariant day ((date date))
  (etypecase (day date)
    ((eql 29) (or (/= 2 (month date))
                  (leap-year-p (year date))))
    ((eql 30) (/= 2 (month date)))
    ((eql 31) (typep (month date) '(member 1 3 5 7 8 10 12)))))

このinvariantをスロットに取り付けます。

(defmethod c2mop:slot-value-using-class ((date-class standard-class)
                                         (date date)
                                         slot)
  (invariant date)
  (multiple-value-prog1
    (call-next-method)
    (invariant date)))

(defmethod (setf c2mop:slot-value-using-class) 
           (value (date-class standard-class) (date date) slot)
  (invariant date)
  (multiple-value-prog1
    (call-next-method)
    (invariant date)))

これだけでいけるかなと思ったのですが、

(make-instance 'date :year 100 :month 2 :day -2)
→ #<date 4020118C13> 

あれ……?

インスタンス生成もチェックする

インスタンス生成はslot-value-using-classはスルーする(かもしれない)ようなので、clange-classのことも考えて、shared-initializeにinvariantを設置しました(もうちょっと細かく設定した方が良いかもしれません)

(defmethod shared-initialize :after ((date date) slots &key)
  (invariant date))

これで生成系はエラーにできます。

(make-instance 'date :year 100 :month 2 :day -2)
>>> error
(defclass date2 () 
  ((year :initform 1900 :initarg :year :accessor year)
   (month :initform 1 :initarg :month :accessor month)
   (day :initform 1 :initarg :day :accessor day)))
(change-class (make-instance 'date2 :year 100 :month 2 :day -2)
              'date)
>>> error

invariantメソッドコンビネーションの展開はこんな感じになります

(defclass datetime (date) 
  ((hour :initarg :hour :accessor hour)
   (minute :initarg :minute :accessor minute)
   (second  :initarg :second :accessor sec))
  (:default-initargs :hour 0 :minute 0 :second 0))
(defmethod invariant hour ((dt datetime))
  (etypecase (hour dt)
    ((integer 0 24) T)))
(defmethod invariant minute ((dt datetime))
  (etypecase (minute dt)
    ((integer 0 59) T)))
(defmethod invariant second ((dt datetime))
  (etypecase (sec dt)
    ((integer 0 59) T)))
(mc-expand #'invariant
           'invariant
           nil
           (make-instance 'datetime))
→
(and (call-method #<standard-method invariant (year) (date) 41602356B3>)
     (call-method #<standard-method invariant (month) (date) 40D035A8B3>)
     (call-method #<standard-method invariant (day) (date) 40D035A113>)
     (call-method #<standard-method invariant (hour) (datetime) 40D04205BB>)
     (call-method #<standard-method invariant (minute) (datetime) 402025F913>)
     (call-method #<standard-method invariant (second) (datetime) 402027434B>)) 

これらinvariantを付加する作業をどうにかまとめたいのですが、MOPを使うかマクロて手続きを纏めるか悩む所です。 invariant手続きをdefclassで指定した方が良さそうなので、MOPになりそうです。

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp SETF Advent Calendar 2018 19日目 》

今回は、たまに便利な(setf apply)/(setf values)を解説してみたいと思います。

(setf values) | VALUES Forms as Places

(setf values)はそこそこ使われているかと思いますが、Common Lisp(1984)の時代から知識の更新がない年配の方々がmultiple-value-setqしか知らないような場面に遭遇することもままあります。
(古い書籍で勉強してしまったので知らなかった、ということもあります)

• 5.1.2.3 VALUES Forms as Places

multiple-value-setq的な使い方

(let (q r)
  (setf (values q r) (floor 1 2))
  (list q r))
→ (0 1) 

psetq、psetf的な使い方

(let ((a 0) (b 1))
  (setf (values a b) (values b a))
  (list a b))
→ (1 0) 

(setf values)は他のsetfの場所と複合できるのも便利です

(let ((x (list 0 1)))
  (setf (values (car x) (cadr x))
        (values (cadr x) (car x)))
  x)
→ (1 0) 

(setf apply) | APPLY Forms as Places

こちらは、Common Lisp(1984)からありますが、配列を多用する人以外は使う機会もないからか、それほど知られていない機能です。

• 5.1.2.5 APPLY Forms as Places

添字のリストだけあって、それを適用したい、ということはあるのですが、(setf apply)とarefを組合せれば可能です。

(let ((subs (list 2 1 0)))
  (setf (apply #'aref *a* subs) 42)
  *a*)
→
#3A(((0 0 0) (0 0 0) (0 0 0))
    ((0 0 0) (0 0 0) (0 0 0))
    ((0 0 0) (42 0 0) (0 0 0))) 

規格では、aref、bit、sbitと(setf apply)の組合せは保証されていますが、他は、処理系依存です。
というのも、(setf fn)は必ずしも関数である必要はないためで、マクロで実装されている場合、applyできない、ということになるからです。

ユーザー定義の#'(setf fn)関数であれば、applyが適用できるので(setf apply)も可能です。

まとめ

(setf values)はもっと知られても良いかなと思っています。
ANSI Common Lispと、それ以前のCLtL2、CLtL1は結構違ってますので、仕様の参照/勉強では、ANSI Common Lisp規格を元にした文献を参照しましょう。

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp メソッドコンビネーション Advent Calendar 2018 18日目 》

メソッドコンビネーションでD風の契約プログラミングの続きを書こうと思いましたが、準備が間に合わないので、思い付きでマクロでもメソッドコンビネーションというネタを書きます。

ANSI Common LispにはAdviceはありませんが、処理系拡張でdefadviceのようなものでadviceを定義することが可能だったりします。
adviceは関数だけでなく、マクロやメソッドにも付けられたりしますが、LispWorksでマクロのadvice定義を利用した例は、こんな感じです。

(defmacro mydefun (name (&rest args) &body body)
  `(defun ,name (,@args) ,@body))

(defadvice (mydefun inline :around) (form env)
  (destructuring-bind (def name args &body body)
                      form
    (declare (ignore def args body))
    `(progn
       (declaim (inline ,name))
       ,(call-next-advice form env))))

(mydefun foo (n) n)
;===> (PROGN (DECLAIM (INLINE FOO)) (DEFUN FOO (N) N))

標準では、マクロの展開関数は関数なので拡張できないのですが、メソッドにして、好きなメソッドコンビネーションを指定してしまえば良い!ということで、マクロ展開メソッドでメソッドコンビネーションです。

雑ですが、こんな感じに書いてみました。

(defmacro defmacro* (name-&-method-qualifiers (&rest args) &body body)
  (destructuring-bind (name &rest method-qualifiers)
                      (if (consp name-&-method-qualifiers) 
                          name-&-method-qualifiers
                          (list name-&-method-qualifiers))
    (let ((form (gensym "form-"))
          (env (gensym "env-"))
          (xn (or (get name :expander)
                  (setf (get name :expander) 
                        (make-symbol (string name))))))
      `(eval-when (:compile-toplevel :load-toplevel :execute)
         (defmethod ,xn ,@method-qualifiers (,form ,env)
           (macrolet ((call-next-expander (&rest args)
                        `(call-next-method ,@args)))
             (destructuring-bind (,name ,@args)
                                 ,form
               (declare (ignore ,name))
               ,@body)))
         (setf (macro-function ',name)
               #',xn)))))

deという名前でdefunのエイリアス的なものを定義してみる

(defmacro* de (name (&rest args) &body body)
  `(defun ,name (,@args) ,@body))
(de foo (n) (list n n))
===> 
(defun foo (n) (list n n))

de周囲をeval-whenで囲みたくなった

(defmacro* (de :around) (name (&rest args) &body body)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     ,(call-next-expander)))

(de foo (n) (list n n))
===>
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun foo (n) (list n n)))

deの定義は全部無効にしたくなった

(defmacro* (de :around) (name (&rest args) &body body)
  nil)
(de foo (n) (list n n))
===> nil

雑なのでメソッドの良さを全然活かせてないですが、使いようによっては便利なこともあるかも、と少しだけ思いました。

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp SETF Advent Calendar 2018 18日目 》

今回は、処理系拡張のsetfのうち解構destructuring系の拡張を眺めてみたいと思います。

destructuringの邦訳語はいまいち一定しない感がありますが、中華圏では、ほぼ、解構destructuringで通っているようです。

• 例: 解構賦值 | MDN

解構destructuringは短くて意味の通りも良い気がするので、本記事では、解構destructuringで通します。
(しかし流行らなそうな言葉の響き……)

解構destructuring拡張のsetfとは

setfの場所placeで解構destructuringを使うという拡張です。
Lisp Machine Lispには標準装備だったみたいですが、Common Lispで実装している処理系はないかもしれません。
ということで、以下は、Lisp Machine Lispでの例の紹介です。
(Common Lispでも定義はできます)

(setf list)

これまで、左辺値についてCPLを調べたりもしましたが、CPLは左辺にリスト構文が取れたりしました。

x, y, z := 0, 1, 2

これをそのままsetfで書いた感じです。

(let (x y z)
  (setf (list x y z) '(0 1 2))
  (list x y z))
→ (0 1 2)

(setf cons) / (setf list*)

cons、list*も使えます。

(let (x y)
  (setf (cons x y) '(0 1 2))
  (list x y))
→ (0 (1 2))
(let (x y z)
  (setf (list* x y z) '(0 1 2))
  (list x y))
→ (0 1 (2))

(setf `(,foo ,@bar))

バッククォート式も使えます。
但し、appendの形には対応していないので、,@はリストの最後の部分にしか使えません。

(let (x y)
  (setf `(,x ,@y) '(0 1 2))
  (list x y))
→ (0 (1 2))
(let (x y z)
  (setf `(,x ,y ,@z) '(0 1 2))
  (list x y))
→ (0 1 (2))

appendの形には対応していないものの、入れ子にすることは可能です。

(let (a b c d e f)
  (setf `(,a (,b (,c ,@d) ,e ,@f))
        `(a (b (c d d d) e f f f)))
  (list a b c d e f))
→ (a (b (c (d d d) e (f f f))))

list、list*、consも同様

(let (a b c d e f)
  (setf (list (list* (cons c d) e f))
        `(a (b (c d d d) e f f f)))
  (list a b c d e f))
→ (a (b (c (d d d) e (f f f))))

まとめ

setfとバッククォートの組み合わせはなかなか良いんじゃないかと思うのですが、実際の所、あってもそんなに利用頻度は高くなさそうですね。

■

HTML generated by 3bmd in LispWorks 7.0.0

《 Lisp メソッドコンビネーション Advent Calendar 2018 17日目 》

契約プログラミングをメソッドコンビネーションを表現するネタは既にあるのですが、

• #:g1: MOPで契約プログラミング 参照

もうちょっと簡潔に書けそうな気がしてきたので、試しにD風の契約プログラミングの仕組みを書いてみることにしました。

Dには契約プログラミングが組み込み機能ですが、in節で事前条件のチェック、body節は本体、out節で事後条件をチェックするようになっています。

継承がからんだ場合は、事前条件は、基底クラスから条件をorのでチェック、事後条件は、基底クラスからandでチェック、のようです。

out節で返り値を受け取ってチェックするというのをどう表現するのか厄介ですが、outはチェック関数を返して、プライマリの返り値をチェックすることにしました。

(define-method-combination ddbc ()
  ((in* (:in))
   (out* (:out))
   (pri* () :required T))
  (let ((results (gensym "results-")))
    `(progn
       (or ,@(loop :for in :in (reverse in*) :collect `(call-method ,in))
           (error "in"))
       (let ((,results (multiple-value-list (call-method ,(car pri*) ,(cdr pri*)))))
         (declare (dynamic-extent ,results))
         (or (and ,@(loop :for out :in (reverse out*) :collect `(apply (call-method ,out) ,results)))
             (error "out"))
         (values-list ,results)))))