今回のMOP vs マクロは、defmethodのカスタマイズネタで比較してみたいと思います。

メソッド定義でselfを使いたい

Common Lispはマルチメソッドなので、シングルメソッドの言語のようなselfはありませんが、なんとなく気分で、

(defmethod foo ((self bar) x y) ...)

のように書いたりすることもあります。

このようにディスパッチは先頭一つでしか行なわない場合に、defmethod内部でselfも使えたら便利なんじゃないか、ということで、そのようなカスタマイズをしてみたいと思います。

マクロ篇

まずはマクロでの実現。とりあえず、安直に下記のように書いてみました。

(ql:quickload :closer-mop)
(defpackage "9ef5d5fa-900d-5269-8012-a9c0d39a1860" 
  (:use :c2cl))
(in-package "9ef5d5fa-900d-5269-8012-a9c0d39a1860")
(defmacro defgeneric-self (name (&rest args) &body body)
  (destructuring-bind (class name)
                      name
    `(defgeneric ,name (,class ,@args) ,@body)))
(defmacro defmethod-self (name (&rest args) &body body)
  (destructuring-bind (class name)
                      name
    `(defmethod ,name ((self ,class) ,@args) 
       (with-slots ,(mapcar #'slot-definition-name (class-slots (find-class class))) self
         ,@body))))

selfとなるインスタンスのクラスをどう指定するかですが、Flavors風に(defmethod (class name) ()...)としてみています。

また、defmethod内部では、selfとインスタンスのスロットがスロット名の変数でアクセスできるようにしたいので、with-slotsでボディを囲んでいます。

なお、マクロで実現といってもスロット名を取得したりする必要があるので、MOPを使う必要はあります。

試してみる

(defconstant <foo>
  (defclass foo () 
    ((a :initform nil)
     (b :initform nil)
     (c :initform nil))))
(finalize-inheritance <foo>)
(defmethod-self (foo frob) (a b c)
  (list self a b c))
(frob (make-instance <foo>) 0 1 2)
→ (#<foo 4020290013> nil nil nil) 

クラスのスロット名とメソッドの引数名が被った時にはクラスのスロットに遮蔽されてしまいますが、Flavorsもこんな動作なので良しとします。

MOP篇

(ql:quickload :closer-mop)
(defpackage "a16a6b7f-083d-52aa-a466-d22b941a23c8" 
  (:use :c2cl))
(in-package "a16a6b7f-083d-52aa-a466-d22b941a23c8")
(defclass self-generic-function (standard-generic-function)
  ()
  (:metaclass funcallable-standard-class))
(defmethod make-method-lambda 
           ((gf self-generic-function) (method standard-method) λxp env)
  (destructuring-bind (lambda (self &rest args) &body body)
                      λxp
    (call-next-method gf 
                      method
                      (let ((slot-names (mapcar #'slot-definition-name (class-slots (find-class self)))))
                        `(,lambda (,self ,@args)
                           (let ((self ,self))
                             (declare (ignorable self))
                             (with-slots ,slot-names self
                               (declare (ignorable ,@slot-names))
                               ,@body))))
                      env)))

メソッドのボディのコードをカスタマイズするには、make-method-lambdaが返す、lambda式を編集することになるようです。
ボディのコードをいじる用途には、ちょっと面倒なインターフェイスという印象。

試してみる

(defconstant <foo>
  (defclass foo () 
    ((a :initform nil)
     (b :initform nil)
     (c :initform nil))))
(defgeneric frob (foo a b c)
  (:generic-function-class self-generic-function))
(defmethod frob (foo a b c)
  (list self a b c))
(frob (make-instance <foo>) 0 1 2)
→ (#<foo 402028F48B> nil nil nil) 

やっていることはマクロ版と殆ど変わりありません。
第一引数のシンボルをクラス名にする必要があるという所が危ういですが、まあ良しとします。

マクロでお化粧することも可能ですが、そうするとMOPで書く意味があまりないなという気分になってしまいます。

(defmacro defgeneric-self (name (&rest args) &body body)
  (destructuring-bind (class name)
                      name
    `(defgeneric ,name (,class ,@args) ,@body
       (:generic-function-class self-generic-function))))
(defmacro defmethod-self (name (&rest args) &body body)
  (destructuring-bind (class name)
                      name
    `(defmethod ,name (,class ,@args) ,@body)))

(defgeneric-self (foo bar) ())
(defmethod-self (foo bar) ()
  (list self a b c))

まとめ

クラスの情報を得るのにMOPのイントロスペクション機能を使う必要はありますが、得た情報からコード生成をすることに関しては、マクロの方が単純で明解ですね。

■

HTML generated by 3bmd in LispWorks 7.0.0

今回のMOP vs マクロは、Gaucheのpropagatedスロット再現で比較してみたいと思います。

propagatedスロットについてはブログでの紹介記事に詳しいですが、合成した部品のスロットにアクセスする際に子コンポーネントのスロットが親のスロットとしてアクセスできる、というものです。

• Island Life: コンポジションに便利なpropagatedスロット

マクロ篇

そもそもGaucheのpropagatedスロットが想定している利用法からするとマクロで実現してみようというのは色々と無理があるのですが、色々捨てて挙動だけ同じにしました。

(defpackage "6401746F-BD45-5DB6-BD1D-B29A1EFA0494"
  (:use :c2cl))
(cl:in-package "6401746F-BD45-5DB6-BD1D-B29A1EFA0494")
(defmacro with-slots/propagation ((&rest specs) obj &body body)
  (etypecase specs
    (null
     `(with-slots () ,obj
        ,@body))
    ((cons atom null)
     (let ((_obj (gensym "_obj")))
       `(let ((,_obj ,obj))
          (with-slots (,(car specs)) ,_obj
            (with-slots/propagation (,@(cdr specs)) ,_obj
              ,@body)))))
    (cons
     (destructuring-bind (target-slot slots) (car specs)
       (let ((_obj (gensym "_obj")))
         `(let ((,_obj ,obj))
            (with-slots (,@slots) (slot-value ,_obj ',target-slot)
              (with-slots/propagation (,@(cdr specs)) ,_obj
                ,@body))))))))

(defclass rect ()
  ((width  :initform 0 :initarg :width)
   (height :initform 0 :initarg :height)))
(defclass viewport ()
  ((dimension :initform (make-instance 'rect))
   (width :initarg :width)
   (height :initarg :height)))
(let ((obj (make-instance 'viewport)))
  (with-slots/propagation ((dimension (width height))) obj
    (setq width 42 height 42))
  (describe (slot-value obj 'dimension)))
;>> #<rect 40200074CB> is a rect
;>> width       42
;>> height      42

当初の目的からは外れていますが、局所的にオブジェクトを合成したりするのには使えなくもないかも。
(暗黙の規約が多過ぎますが)

MOP篇

マクロでの実現はやりたいことの中身が全部外側に露出してしまっていますが、これをMOPで内側に収めます。

Gaucheでは、compute-get-n-setという便利なメソッドがあるので圧縮して記述できていますが、AMOP作法だと長くなります。
さらに、standard-instance-accessの利用でアクセス速度向上を狙ってみたので、より長くなりました。

(ql:quickload '(closer-mop))
(defpackage "5ADAD164-D620-594D-A9C7-8E192966CA64"
  (:use :c2cl))
(cl:in-package "5ADAD164-D620-594D-A9C7-8E192966CA64")
(defclass propagated-slot-class (standard-class) 
  ())
(defmethod validate-superclass ((c propagated-slot-class) (sc standard-class))
  T)
(defclass propagated-slot-definition (standard-slot-definition) 
  ((propagate-to :initform nil
                 :initarg :propagate
                 :initarg :propagate-to
                 :accessor propagated-slot-definition-propagate-to)
   (propagate-to# :initform nil
                  :accessor propagated-slot-definition-propagate-to#)))
(defmethod slot-definition-allocation ((slotd propagated-slot-definition))
  :propagated)
(defmethod (setf slot-definition-allocation) (allocation (slotd propagated-slot-definition))
  (unless (eq allocation :propagated)
    (error "Cannot change the allocation of a ~S"
           slotd))
  allocation)
(defconstant <propagated-direct-slot-definition>
  (defclass propagated-direct-slot-definition (standard-direct-slot-definition propagated-slot-definition)
    ()))
(defmethod direct-slot-definition-class ((class propagated-slot-class) &rest initargs)
  (if (eq (getf initargs :allocation) :propagated)
      <propagated-direct-slot-definition>
      (call-next-method)))
(defconstant <propagated-effective-slot-definition>
  (defclass propagated-effective-slot-definition (standard-effective-slot-definition propagated-slot-definition) 
    ()))
(defmethod effective-slot-definition-class ((class propagated-slot-class) &rest initargs)
  (if (eq :propagated (getf initargs :allocation))
      <propagated-effective-slot-definition>
      (call-next-method)))
(defmethod compute-effective-slot-definition ((class propagated-slot-class) name direct-slot-definitions)
  (declare (ignore name))
  (let ((effective-slotd (call-next-method)))
    (dolist (slotd direct-slot-definitions)
      (when (typep slotd 'propagated-slot-definition)
        (setf (propagated-slot-definition-propagate-to effective-slotd) 
              (propagated-slot-definition-propagate-to slotd))
        (return)))
    effective-slotd))
(defmethod finalize-inheritance :after ((class propagated-slot-class))
  (let ((slotds (class-slots class)))
    (dolist (sd slotds)
      (when (typep sd 'propagated-slot-definition)
        (setf (propagated-slot-definition-propagate-to# sd) 
              (slot-definition-location (find (propagated-slot-definition-propagate-to sd)
                                              slotds
                                              :key #'slot-definition-name)))))))
#-lispworks
(defmacro slot-foo (fctn class object slotd)
  (declare (ignore class))
  `(,fctn
    (standard-instance-access ,object
                              (propagated-slot-definition-propagate-to# slotd))
    (slot-definition-name ,slotd)))
#-lispworks
(progn
  (defmethod slot-value-using-class
             ((class propagated-slot-class) object (slotd propagated-slot-definition))
    (slot-foo slot-value class object slotd))
  (defmethod (setf slot-value-using-class)
             (value (class propagated-slot-class) object (slotd propagated-slot-definition))
    (setf (slot-foo slot-value class object slotd)
          value))
  (defmethod slot-boundp-using-class
             ((class propagated-slot-class) object (slotd propagated-slot-definition))
    (slot-foo slot-boundp class object slotd))
  (defmethod slot-makunbound-using-class
             ((class propagated-slot-class) object (slotd propagated-slot-definition))
    (slot-foo slot-makunbound class object slotd))
  (defmethod slot-exists-p-using-class
             ((class propagated-slot-class) object (slotd propagated-slot-definition))
    (slot-foo slot-exists-p class object slotd)))
;;; おまけ:LispWorksの場合

#+lispworks
(defmacro slot-foo (fctn class object slot-name)
  `(let ((slotd (find ,slot-name (class-slots ,class) :key #'slot-definition-name)))
     (if (typep slotd 'propagated-slot-definition)
         (,fctn
          (standard-instance-access ,object
                                    (propagated-slot-definition-propagate-to# slotd))
          ,slot-name)
       (call-next-method))))
#+lispworks
(progn
  (defmethod slot-value-using-class
             ((class propagated-slot-class) object slot-name)
    (slot-foo slot-value class object slot-name))
  (defmethod (setf slot-value-using-class)
             (value (class propagated-slot-class) object slot-name)
    (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name)))
      (if (typep slotd 'propagated-slot-definition)
          (setf (slot-value (standard-instance-access object
                                                      (propagated-slot-definition-propagate-to# slotd))
                            slot-name)
                value)
          (call-next-method))))
  (defmethod slot-boundp-using-class
             ((class propagated-slot-class) object slot-name)
    (slot-foo slot-boundp class object slot-name))
  (defmethod slot-makunbound-using-class
             ((class propagated-slot-class) object slot-name)
    (slot-foo slot-makunbound class object slot-name))
  (defmethod slot-exists-p-using-class
             ((class propagated-slot-class) object slot-name)
    (slot-foo slot-exists-p class object slot-name)))

試してみる

(defclass rect ()
  ((width  :initform 0 :initarg :width)
   (height :initform 0 :initarg :height)))
(defclass viewport ()
  ((dimension :initform (make-instance <rect>))
   (width     :allocation :propagated :propagate dimension
              :initarg :width)
   (height    :allocation :propagated :propagate dimension
              :initarg :height))
  (:metaclass propagated-slot-class))
(let ((vp (make-instance 'viewport' :width 42 :height 42)))
  (describe vp)
  (describe (slot-value vp 'dimension)))
;>> #<viewport 4020098D8B> is a viewport
;>> dimension      #<rect 4020098DBB>
;>> width          42
;>> height         42
;>> #<rect 4020098DBB> is a rect
;>> width       42
;>> height      42

速度比較

LispWorksだと素のインスタンス生成/スロットアクセスに比較して大体1.5倍程度の遅さで済んでいるようです。

(defclass c000001 ()
  ((x :initform 0)
   (y :initform 0)
   (z :initform 0)))
(let ((times 1000000)
      (ans 0))
  (time (dotimes (i times)
          (slot-value (make-instance 'viewport) 'width)))
  (time (dotimes (i times)
          (slot-value (make-instance 'c000001) 'x)))
  ans)
Evaluation took:
  0.686 seconds of real time
  0.680000 seconds of total run time (0.680000 user, 0.000000 system)
  99.13% CPU
  2,258,481,555 processor cycles
  95,986,800 bytes consed
Evaluation took:
  0.413 seconds of real time
  0.410000 seconds of total run time (0.410000 user, 0.000000 system)
  99.27% CPU
  1,360,213,671 processor cycles
  64,028,672 bytes consed

まとめ

今回は、マクロ向きのお題ではありませんでしたが、動作の内容はMOPの内側か外側かの違いだけではありました。

MOPで組む前に、マクロで適当に書いてみて動作を考える、というもの場合によっては、悪くないかもしれません。

■

HTML generated by 3bmd in LispWorks 7.0.0

Common Lispでお馴染のdefun。 ClojureだとdefnでCommon Lispと同じくデ(ィ)ファンと読むらしいですが、Jon L White氏によってMACLISPに導入されたのが、50年前の今日、1969-03-01でした。

• LISPNEWS(3/1/69)

3/1/69 JONL
 THE CURRENT VERSION OF LISP, "LISP 102", HAS
THE FOLLOWING AS-YET UNDOCUMENTED FEATURES:
    1)"DEFUN" IS AN FSUBR USED TO DEFINE
FUNCTIONS. EXAMPLES ARE
    (DEFUN ONECONS (X) (CONS 1 X))
WHICH IS EQUIVALENT TO 
    (DEFPROP ONECONS 
        (LAMBDA (X) (CONS 1 X)
     EXPR)
AND (DEFUN SMASH FEXPR (L) (RPLACD L NIL))
 IS EQUIVALENT TO
    (DEFPROP SMASH 
        (LAMBDA (L) (RPLACD L NIL))
     FEXPR)
THE NOVEL FEATURE OF "DEFUN" IS THAT ONE NEED
 NOT BE SO CONCERNED WITH BALANCING
PARENTHESES AT THE VERY END OF THE FUNCTION
DEFINITION, SINCE THE TYPE FLAG MAY BE 
OMITTED IF IT IS "EXPR", AND APPEARS NEAR 
THE FRONT OF THE "DEFUN" LIST IF IT IS SOME 
OTHER.  ALSO, THE "LAMBDA" NEED NOT BE 
DIRECTLY INSERTED.

defun誕生以前は、defpropでシンボルのexprや、fexpr、macroプロパティに関数定義をセットしていたようです。

ちなみに、defunとは別の流儀にdeがありますが、こちらは、MIT LISP 1.6(後のPDP-6 LISP/MACLISP)がスタンフォード大学に導入された後にdefunと同様の目的で考案されたものです。

defunは当初、通常の関数(expr)だけでなくマクロ等の各種関数を定義できました。
exprの定義は、defun foo (x)でfexprの定義はdefun foo fexpr (x)とし、同様にマクロは、defun foo macro (x)で定義可能です。
これらは、Common Lispの祖先のLisp Machine Lispで、各種専用構文に分岐します。

上述のStanford LISP 1.6の場合は、exprは、de、fexprは、df、マクロは、dmと二文字の専用構文となっていますが、defunの方は、先祖のdefpropの影響を引き摺ったのかもしれません。

50年も生き延びたdefun構文ですが、100歳まで生き残るでしょうか。

■

HTML generated by 3bmd in LispWorks 7.0.0

たまに、Common Lispの仕様では(lambda (x) ...)を関数の名前として定められている、というような話がされることがあります。
しかし、結論としては、ANSI Common Lisp規格では関数の名前ではありません。
今回は、その辺りを調べてまとめてみました。

ANSI Common Lisp規格での関数の名前

(lambda (x) ...)は、ANSI Common Lisp規格では、lambda expressionと呼びますが、その説明を読むとfunction nameが位置する場所にあるlambdaから始まるリスト、のように持って回った説明がされています。

とりあえず、lambda expressionの方は置いておいて、function nameの方を確認すると、シンボルもしくは、(setf シンボル)というリストがfunction nameとなっています。

Common Lisp(1984)での関数の名前

しかし、CLtL1でお馴染のCommon Lisp(1984)での記述を確認してみると、ANSI規格に比べると記述は曖昧で、関数名としてのシンボルと、ラムダ式を同一視しているような記述ではありました。

CLtL1: 5.2 Functions

There are two ways to indicate a function to be used in a function call form. One is to use a symbol that names the function. This use of symbols to name functions is completely independent of their use in naming special and lexical variables. The other way is to use a lambda-expression, which is a list whose first element is the symbol lambda. A lambda-expression is not a form; it cannot be meaningfully evaluated. Lambda-expressions and symbols, when used in programs as names of functions, can appear only as the first element of a function-call form, or as the second element of the function special form. Note that symbols and lambda-expressions are treated as names of functions in these two contexts. This should be distinguished from the treatment of symbols and lambda-expressions as function objects, that is, objects that satisfy the predicate functionp, as when giving such an object to apply or funcall to be invoked.

これはANSI規格へ向けての中間報告であるCLtL2(1990)でも同様です。

この記述をうけてか、竹内郁雄先生の1980年代の著作である「初めての人のためのLisp」11章の脚注にもこんな記述があります。

Common Lispではこのリストを，関数実体を表わす一種の"名前"と呼んでいます。

ちなみに、増補改訂版(2010)では、脚注から本文の先生の台詞に昇格して

Common Lispではこのリストを，関数実体を表わす一種の"名前"であるとしておる

となっています。 まあ、「一種の“名前”」となっているので、どうとでも解釈できそうです。

Common Lisp(1984)からANSI Common Lisp(1994)までに何が変化したのか

ANSI Common Lisp(1994)は、オブジェクト指向システムやコンディションシステムの追加等が目立つところですが、それまで曖昧だった概念や記述が大分整理されました。
function nameとlambda expressionが分離した背景については、Issue FUNCTION-NAME Writeupに記録があります。

まず、function nameについての整理があり、function、fdefinition、defun、fboundp、fmakunbound等々、関数の名前を取るものの整理がされ、(setf ...)が新しく関数名とされました。

これを推進して、lambda expressionを関数名として扱うかの提案が、FUNCTION-NAME:LARGEの12番にあります。

12. Declare that any lamba expression (i.e., a list whose car is LAMBDA and
    whose cdr is a well-formed lambda argument list and body) is a function
    name. 

lambda expressionが名前となれば、

(fmakunbound (lambda () ...))

のようなケースも考えていくことになると思うのですが、しかし、結局、lambda expressionが無名関数を表す慣習からすると、それをもって名前とするのは矛盾としています。
名は体を表すといいますが、lambda expressionは体が体を表してしまっているというところでしょうか。

Lambda expressions are often thought to denote "anonymous" functions, so
it may seem paradoxical to treat them as names.  The paradox is only
apparent, since the expression itself has the properties of a Lisp
function name: It is (typically) a cons tree which can be read, printed,
and stored in source files, and it denotes a well-defined Lisp function.

ここからどのような投票が行なわれ、どう決定されたかの資料はみあたらないのですが、12番の提案は採用されなかったのは確かで、function nameにlambda expressionは含まれることは無かった、ということでしょう。

まとめ

年配の方々はもうしょうがないと思いますが、若者はANSI Common Lisp規格を読みましょう。
また、CLtL2はCLtL1からANSI Common Lispまでの中間報告であり規格ではありませんので、CLtL1/2で得た知識は一度ANSI Common Lisp規格でどう変更された/されていないのかの確認をしましょう。

■

HTML generated by 3bmd in LispWorks 7.0.0

今回は前回に引き続き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のライブラリ中から探して眺めてみましょう。