#:g1

LISP Library 365 の提案

Posted 2013-12-26 22:00:00 GMT

LISP Library 365 の提案

LISP Library 365 とは

 2009年暮れ当時Advent Calendarが盛り上がり始めた頃、これを一年間続けたら面白いかなと思って、2009/12/12から2010/12/12にかけて Lisp365と称して毎日Lisp記事を順番に書いていくということをやってみました。

 LISP365の反響は、自分が記憶する限りでは確か全然無かった気がしますが、Lispの記事が毎日更新されるだけなので、「Lispの記事が毎日書かれていること」を評価するのもなかなか微妙だったかもしれません。

 今回は、Lisp方言のライブラリをテーマにし、365日紹介してみることにします。 Javaの資産が手軽に活用できるClojure以外ではライブラリが少ないと嘆かれるLisp系方言ですが、全体の量として少ないのは良いとしても、利用者が知らない/知ろうとしてもいないことが多い気がしています。

 ライブラリがまったく無い訳でもないですし、それなりに定番のものもあるので、365のライブラリを紹介してみるのも悪くないかなと思っています。もちろんClojureの記事も歓迎です。

 ちなみに、Common Lisp限定でしたが、同様の試みに、Common Lisp Libraries Advent Calendar 2012があります。

紹介するライブラリ

特に規定がある訳でもありませんが、

等が考えられると思います。

 Quicklispは、現在(2013/12/27)970程度、SRFIはファイナルが7〜80位、Snowも50位、CMU AI Reposも100位はあると思います。 その他含めて、ネタ的には少なくとも1000はあるので一年位は、余裕でしょう。

運用方法

  • ATNDに記事のリンクを追加していく
  • これは前回と同じ方式です。追加するのが若干めんどくさい気もしますが、一年間やったVim Advent CalendarもATNDだったみたいで、結構綺麗にまとまっているので、これでも良いかなと思います。
  • Vim Advent Calendar 2012
  • githubにページを作ってpushする
  • これも良いかなと思います。githubの扱いが若干めんどくさいでしょうか。

 等々、色々と考えられますが、とりあえず、ATNDにページを作ってみました。 問題があれば引っ越しましょう。 記事を書いてみたい方は、初回に参加登録し、都度記事をコメントに投稿してみて下さい。

RSSは、atnd.org/events/46706.rssです。

提案/質問は、@masso まで。 ■

MOP Advent Calendar 2013 まとめ

Posted 2013-12-24 15:00:00 GMT

(Metaobject Protocol(MOP) Advent Calendar 2013参加エントリ)

 Metaobject Protocol(MOP) Advent Calendar 2013 25日目です。
今回は、MOP Advent Calendar 2013 をふりかえったまとめ記事です。

参加エントリー一覧

 上記が、今回の参加エントリーです。
今回の参加人数は、5名。MOPというマイナーネタで参加してもらえた皆様には感謝感謝です。
参加言語は、Groovy、Scheme、Common Lispとなり、CLOS MOP系のエントリーが大半となりました。
微力ながらもSmalltalk、Ruby、Perl方面にも呼び掛けてみましたが、MOPにそれほど関心がないのか、反応がなかったのが残念。

 Perlは次世代のオブジェクト指向システムにMOPを採用のようなので、書いてもらえることをちょっと期待しましたが、2008〜2011年位にかけて、「Perlに採用されようとしているMOPとは何なのか」の記事がそれなりに書かれたようなので、Perlの人達的には今更感があったのかもしれません。

やってみたかったネタ

 時間とまとめ上げる技量がなくて無理でしたが、書いてみたかったネタは結構あり、書いたら良いんじゃないかというネタのアドバイスもありました。

  • よくあるパターンの紹介
  • RubyにMOPはあるのか、ないのか
  • SmalltalkにMOPはあるのか、ないのか
  • MOPで作ったDSLが言語備え付けの機能と同じように機能する利点
  • 言語の下地のOOPSが、その言語MOPに及ぼす影響(総称関数だったり、なかったりetc)
  • コンパイル時MOP
  • その他、〜時MOP(編集時MOPとか)
  • プロトコルの流れの解説

この中でも、プロトコルの流れの解説は、来年少しずつやってみたいです。
システムごとにAPIは違うので、比較してみるのも面白いかなと思っています。

まとめ

 MOP Advent Calendarは、去年のLisp Reader Macro Advent Calendar 2012 が終了した時に、次はMOPでやりたいなと思ったことが、そもそものきっかけでした。
MOPは手強そうなので準備が必要だとは思っていましたが、結局なんの準備もないまま12/1に突入してしまい、後半ネタ切れの嵐に。とりあえず完走できて良かったです。
これに懲りずに、来年もLisp系マイナー技術のAdvent Calendarをやりたいと思います。それではまた来年!

MOPでmulti-slot

Posted 2013-12-23 15:01:00 GMT

(Metaobject Protocol(MOP) Advent Calendar 2013参加エントリ)

 Metaobject Protocol(MOP) Advent Calendar 2013 24日目です。
ネタ切れしつつ残すところあと2日。ネタを探してCLOSの策定のための議論の場だったCL-Object-Oriented-Programming メーリングリストを眺めていて、面白そうなアイデアがあったのでMOPを使って実現してみました。

Multi-slotとは

 CommonLoopsを実装していたLarry Masinter氏のアイデアとのことですが、妙なアイデアだったためかCommonLoops: Merging Lisp and object-oriented programmingの論文にも含まれなかったアイデアとのこと。詳細は、リンクのメールに詳しいですが、

マルチメソッドの考え方を敷衍して、スロットにも適用してみたもののようです。
マルチメソッドは、ある複数のクラスのオブジェクトによって、ある一つの動作が決定します。
これをスロットのアクセサに応用してみると、ある複数のクラスのオブジェクトによってある一つのスロットへのアクセスが決まるということになります。
自分もなんだか良く分からないので、メールの例を元にスケッチを書いて動作を確認してみました。

Here is an example:

A "graphics device" is a kind of stream which implements a variety of operations in addition to the normal stream operations.

A "style" is a user-level description of the way in which character might get rendered.

For each style and graphics device, there is an independent specification of how that style can be rendered on the given graphics device.

(defstruct (graphics-stream (:include stream)) ...) (defstruct style)

Now, the odd part is to make "defslot" the inverse of "defstruct":

(defslot (font default-font :allocation dynamic) graphics-stream style)

which would define

(graphics-stream-style-font <stream> <style>)

as the inverse of

(setf (graphics-stream-style-font <stream> <style>) <font>)

 こんな感じに定義して

(defmacro defslot ((slot-name &rest slot-spec) &rest classes)
  (let ((accessor-name (alexandria:format-symbol *package*
                                                 "~{~A~^-~}-~A" 
                                                 classes
                                                 slot-name)))
    `(let ((cache ,(car slot-spec)))
       (defmethod ,accessor-name ,(mapcar (lambda (x) (list x x))
                                          classes)
         (declare (ignore ,@classes))
         cache)
       (defmethod (setf ,accessor-name) (new-val 
                                         ,@(mapcar (lambda (x) (list x x))
                                                   classes))
         (declare (ignore ,@classes))
         (setq cache new-val)))))

 動作を眺める

(defclass quux () 
  ((x :initform 0 :accessor x)))

(defclass shme () ((x :initform 0 :accessor x)))

(defslot (y 0) quux shme)

(let ((q (make-instance 'quux)) (s (make-instance 'shme))) (setf (x q) 42) (setf (x s) 84) (setf (quux-shme-y q s) 168) (list (x q) (x s) (quux-shme-y q s))) ;=> (42 84 168)

 特定の組み合わせでスロットの場所が決まる訳ですが、一体どこに格納するのかという感じに。
とりあえずクロージャーに入れてみました。

 格納場所をあれこれ考えてみましたが、当然ながら総称関数はどんな引数の組み合わせでも必ず一つは存在するので、総称関数にスロットを付けて格納してみることにしてみましょう。
値は引数をキーにハッシュテーブルにでも入れておけば大丈夫でしょうか。
ということで書いてみました。

(defclass multi-slot-generic-function-class (standard-generic-function)
  ((vslots :initform (make-hash-table :weakness :value)))
  (:metaclass c2mop:funcallable-standard-class))

(defmethod vslot-value ((gf multi-slot-generic-function-class) key) (gethash key (slot-value gf 'vslots)))

(defmethod (setf vslot-value) (val (gf multi-slot-generic-function-class) key) (setf (gethash key (slot-value gf 'vslots)) val))

(defmacro defslot ((slot-name &rest slot-spec) &rest classes) (let* ((accessor-name (alexandria:format-symbol *package* "~{~A~^-~}-~A" classes slot-name)) (args (mapcar (lambda (x) (list x x)) classes)) (initform (getf slot-spec :initform)) (vslotv `(vslot-value #',accessor-name (sxhash (list ,@classes))))) `(progn (defgeneric ,accessor-name (,@classes) (:generic-function-class multi-slot-generic-function-class)) (defmethod ,accessor-name (,@args) (or ,vslotv ,initform)) (defmethod (setf ,accessor-name) (new-val ,@args) (setf ,vslotv new-val)))))

 実行してみます

(defclass quux () 
  ((x :initform 0 :accessor x)))
(defclass shme () 
  ((x :initform 0 :accessor x)))
(defclass quuxsub (quux) ())
(defclass shmesub (shme) ())

(defslot (y :initform 0) quux shme)

(defslot (y :initform 0) quux shme quuxsub shmesub)

(let ((q (make-instance 'quux)) (s (make-instance 'shme))) (setf (x q) 42) (setf (x s) 84) (setf (quux-shme-y q s) 168) (list (x q) (x s) (quux-shme-y q s))) ;=> (42 84 168)

(let ((q (make-instance 'quux)) (s (make-instance 'shme)) (qq (make-instance 'quuxsub)) (ss (make-instance 'shmesub))) (setf (x q) 42) (setf (x qq) (* 3 (x q))) (setf (x s) 84) (setf (x ss) (* 3 (x s))) (setf (quux-shme-y q s) 168) (setf (quux-shme-y q ss) (* 50 (quux-shme-y q s))) (setf (quux-shme-y qq ss) (* 100 (quux-shme-y q s))) (setf (quux-shme-quuxsub-shmesub-y q s qq ss) :quux-shme-quuxsub-shmesub-y-1) (setf (quux-shme-quuxsub-shmesub-y qq ss qq ss) :quux-shme-quuxsub-shmesub-y-2) (list (x q) (x s) (x qq) (x ss) (quux-shme-y q s) (quux-shme-y q ss) (quux-shme-y qq ss) (quux-shme-quuxsub-shmesub-y q s qq ss) (quux-shme-quuxsub-shmesub-y qq ss qq ss))) ;=> (42 84 126 252 168 8400 16800 :QUUX-SHME-QUUXSUB-SHMESUB-Y-1 ; :QUUX-SHME-QUUXSUB-SHMESUB-Y-2) (slot-value #'quux-shme-y 'vslots) ;=> #<HASH-TABLE :TEST EQL :COUNT 38 :WEAKNESS :VALUE {101526A793}>

 どこか抜けてる気もしますが、それなりに機能しているようです。
確かに妙ですが、面白いアイデアだなとは思います。

まとめ

 multi-slotを採用しているオブジェクト指向システムが実在するのかどうか、自分は知らないのですが、スロットもクラスに属してないシステムがあっても面白そうですね。

様々なLisp方言のdo

Posted 2013-12-23 15:00:00 GMT

(Lisp Advent Calendar 2013参加エントリ)

 Lisp Advent Calendar 2013 24日目です。
タイトルそのままですが、様々なLisp方言のdoについて書きます

Arcのdo

 まずは、Arcです。Arcでは、doは、複数のフォームを一つにまとめるものです。所謂、prognやbeginです。
prognも考えてみれば妙な名前なのでdoの方が妥当な名前の気もします。

Clojureのdo

 Arcと同じく。これがいまどきの解釈。

Common Lispのdo

 Common Lispの略称をLispだと思ってるのはにわか。
Common Lispは、MacLISP系のLispですが、doマクロはMacLISPから受け継ぎました。
DOは読みにくいという人もいますが、末尾再帰で書かれたフォームを読むと思えば良いと主張する人もいます。

(do ((x 0 (1+ x))
     (xs '() (cons x xs)))
    ((= 10 x) xs))
;=>  (9 8 7 6 5 4 3 2 1 0)

(values
 (do ((x 0 (1+ x))
      (xs '() (cons x xs)))
     ((= 10 x) (nreverse xs)))
 (labels ((frob (x xs)
            (if (= 10 x)
                (nreverse xs)
                (foo (1+ x) (cons x xs)))))
   (frob 0 '())))
;=>  (0 1 2 3 4 5 6 7 8 9)
;    (0 1 2 3 4 5 6 7 8 9)

(values (do ((#0=x #1=0 #2=(1+ x)) (#3=xs #4='() #5=(cons x xs))) (#6=(= 10 x) #7=(nreverse xs))) (labels ((frob (#0# #3#) (if #6# #7# (frob #2# #5#)))) (frob #1# #4#))) ;=> (0 1 2 3 4 5 6 7 8 9) ; (0 1 2 3 4 5 6 7 8 9)

こういうことみたいですが、まあ、似てなくもないですね。

Lisp machine Lisp/Zetalispのdo

 Lisp machine Lisp/ZetalispもMacLISP系のLispでMacLISPに由来します。

Emacs Lispのdo

 Emacs LispもMacLISP系のLispですが、doはcl-lib(cl)に含まれていて、Common Lisp互換という風に考えられているようです。

MacLISPのdo

 さて、MacLISP系の大元であるMacLISPですが、doマクロが導入されたのは、1969年。
1969年1月3日の更新記録によると、

	2)A FAST "DO" SIMILAR TO THE FORTRAN
DO FEATURE NOW EXISTS.  THE SYNTAX IS
	(DO ATOM INITIALVALUE STEPFUN ENDTEST
		STATEMENT1
		.
		.
		.
		STATEMENTN)
WHERE "ATOM" IS THE INDEX VARIABLE
OF THE LOOP, WHICH IS INITIALLY SET TO THE
EVALUATION OF "INITIALVALUE", AND IS RESET
EACH PASS THROUGH THE LOOP TO THE EVALUATION
OF "STEPFUN".  "STATEMENT1" TO "STATEMENTN"
COMPRISE A REGULAR PROG BODY (EXCEPTING THE
LIST OF PROG VARIABLES) WHICH IS EXECUTED
REPEATEDLY UNTIL "ENDTEST" EVALUATES TO 
NON-NIL.  FOR EXAMPLE,
  (DO I 0 (ADD1 I) (EQ I 400)
	(COND ((NULL (A I)) (GO B)))
	(PRINT (A I))
    B    (SETQ TOTAL (PLUS TOTAL (A I))))

とありますので、FORTRANのDOに由来することが分かりますが、DOマクロも来年で45歳です。
ちなみにDEFUNと同じ時に導入された様子。
最初のDOの形式は、

(DO ATOM INITIALVALUE STEPFUN ENDTEST BODY1 ...)

という形式で、繰り返しで扱える変数も1つだけ。これが所謂DOの古い形式と言われるものです。
古い形式をサポートしている処理系はMacLISPや、Zetalisp等位ですが、SBCLでも

(defun foo ()
  (DO ATOM INITIALVALUE STEPFUN ENDTEST BODY1))
; in: DEFUN FOO
;     (DO ATOM INITIALVALUE STEPFUN ENDTEST BODY1)
; 
; caught ERROR:
;   during macroexpansion of (DO ATOM INITIALVALUE ...). Use *BREAK-ON-SIGNALS* to
;   intercept.
;   
;    ill-formed DO -- possibly illegal old style DO?
; 
; compilation unit finished
;   caught 1 ERROR condition

なんていう警告が出たりします。
古いコードを実行した時の為なのでしょうか。

 それではお馴染のDOの構文が導入されたのはいつ頃かというと、1972年で、1972年3月17日の記録によると、

AN EXPANDED FORM THE MULTIPLE-INDEX DO HAS BEEN ADDED TO THE SYSTEM
	(DO INDEXLIST (ENDTEST RETURNVALUE) DOBODY)
THE ITEMS OF AN INDEXLIST MAY BE OF FORMS:
	  (X XINIT XSTEPPER)	WHERE X IS INITIALIZED TO XINIT
				AND MODIFIED AFTER EACH PASS THROUGH 
				DOBODY BY (SETQ X XSTEPPER)
	  (X XINIT)		X IS INITIALIZED TO XINIT,
				AND MAY BE USED LIKE A PROG VAR
	  (X)			LIKE (X NIL)
AN ALTERNATE FORM FOR (ENDTEST RETURNVALUE) IS (ENDTEST), WHICH IS 
TAKEN TO BE (ENDTEST NIL).  CAREFUL ABOUT PARENTHESES - AN ENDTEST 
OF (NULL X) IN THIS ABBREVIATED FORMAT WOULD LOOK LIKE, FOR EXAMPLE,
	   (DO	  ((X LONGLIST (CDR X)) (N 5 (SUB1 N)) (FLAG))
		  ((NULL L))
		(COND ((EQ (CAR L) 'FOO) (SETQ FLAG T))
		      (((EQ (CAR L) 'BAR) (SETQ FLAG N))))
		(INFORM (CAR L) FLAG)
		(INFORM 'GAG FLAG))
THE ORIGINAL DO FORMAT - (DO X XINIT XSTEPPER ENDTEST DOBODY) - 
IS STILL APPLICABLE, AND FOR THE NEXT FEW WEEKS, THE COMPLR WILL NOT
HANDLE THE NEW MULTIPLE FORMAT.

となっています。ここで括弧が多くて難解だと言われるようなものに進化しました。
同年11月に結果節が複数のフォームを取れるように拡張され、現在のDOと同じものになりました。

5) DO AND IOG HAVE SLIGHTLY MORE GENERAL FORMATS NOW.
    (IOG C E1 E2 . . . EN) WORKS AS BEFORE, BUT ALL OF E1 TO EN 
   ARE EVALUATED, WITH THE VALUE OF EN BEING RETURNED.
    (DO ((Z INITIALVALUE STEPPERFUN) . . .)
	(ENDTEST E1 E2 . . .EN))
   WORKS LIKE THE USUAL EXTENDED DO FORMAT, EXCEPT THAT THE ENDTEST-
   RETURNVALUE PAIR NOW LOOKS LIKE THE GENERALIZED COND CLAUSE.

これが所謂新しい形式のDOですが、新しいといっても42年前のものです。

話はここで終わらず、DOには、更に新しい第三の形式の形式も存在しました。1973年12月3日の更新記録によると、

[2] THERE IS A THIRD FORMAT FOR DO NOW:
	(DO <VAR-SPECS> NIL
	     BODY...)
    THIS IS EXACTLY LIKE A NEW-STYLE DO (MULTIPLE INDICES)
    EXCEPT THAT THE PREDICATE/RETURN VALUE CLAUSE IS NIL.
    (NOT (NIL), BUT NIL!!!) THE MEANING OF THIS IS THAT
    THE VARIABLES SHOULD BE INITIALIZED AND THE BODY
    PERFORMED EXACTLY ONCE. NOTE THAT STEPPERS FOR THE VARIABLES
    ARE ILLEGAL IN THIS MODE, SINCE STEPPERS CAN NEVER BE
    EXECUTED. EXAMPLE:
	(DO ((A 0) (B 1)) NIL
	    (PRINT 'A=)
	    (PRIN1 A)
	    (PRINT 'B=)
	    (PRIN1 B))
    PRINTS THE FOLLOWING:
	A=0
	B=1
    AND THEN RETURNS NIL. IN THIS WAY ONE GETS THE EFFECT OF
    THE FAMOUS "PROG WITH INITIALIZED VARIABLES" FEATURE.

とあり、繰り返し判定節をNILにすると、LETのように機能しました。
意外なことにLisp方言にLETが導入されるのは、1970年代の後半。
THE FAMOUS "PROG WITH INITIALIZED VARIABLES" FEATUREともありますが、PROGが良く使われていた時代です。
LETが欲しいときは、((LAMBDA (var) form ...) val)と書いてもいたようです。
第三形式のDOは存在意義が薄かったのかそのまま廃れ、Common Lispには受け継がれませんでした。

Schemeのdo

 SchemeはMIT生れでMacLISPのメンテナでもあったGLSが作者のためか、MacLISPからDOが輸入されています。
動作は大体同じですが、変数が破壊的に更新されません。

Interlispのdo

 Interlispには、CLのLOOPマクロの祖先であるFORマクロがあり、

(for i from 0 to 10 do (print i))

が、

(do (print i) for i from 0 to 10)

と書けたりするため、DOが潰されています。まあ、FORマクロと考えても良いのかも。

まとめ

 色々なLisp方言のdoを紹介してみました。
FORMATもDOもFORTRANに由来するんですね!

MOPで契約プログラミング

Posted 2013-12-22 17:50:00 GMT

(Metaobject Protocol(MOP) Advent Calendar 2013参加エントリ)

 Metaobject Protocol(MOP) Advent Calendar 2013 23日目です。
今回は、Common Lispで契約プログラミングを実現した例があるのでこれを眺めつつ、マクロで色々やっているところをMOPを使うようにしてみたいと思います。

Design by Contract in Common Lisp

 dbc.lispは、Matthias Hölzl氏がBertrand Meyer氏のEiffelにインスパイアされて作ったものです。

dbc.lispの構成

 まず、dbc.lispでは、エラー時に発生させるコンディションが細かく定義されています。

 次に、不変条件、事前/事後条件のチェックの差し込みにCLOSのメソッドコンビネーションを利用します。
メソッドコンビネーションのカスタマイズもMOPに触るところではあるのですが、CLの場合、define-method-combinationで定義するので、直接触っている感じではありません。
定義は下記のようになりますが、:precondition、:around、:invariant、:before、プライマリ、:after、:postcondition が使えます。
それぞれのメソッドは、同じものが集められいて、どんな風にcall-methodで実行されるかが記述されています。
これが、compute-effective-methodに渡されて合体されます。

(define-method-combination dbc (&key (precondition-check t)
                                     (postcondition-check t)
                                     (invariant-check t))
    ((precondition (:precondition . *))
     (around (:around))
     (invariant (:invariant . *))
     (before (:before))
     (primary () :required t)
     (after (:after))
     (postcondition (:postcondition . *)))
  (labels ((call-methods (methods)
             (maplist #'(lambda (method-list)
                          `(call-method ,(car method-list)
                                        ,(cdr method-list)))
                      methods))
	   (raise-error (error-type methods)
	     (maplist #'(lambda (method-list)
                          `(unless (call-method ,(car method-list)
                                                ,(cdr method-list))
                             (error ',error-type
                                    :description
                                    ,(second (method-qualifiers
                                              (car method-list))))))
                      methods)))
    (let* ((form (if (or before after (rest primary))
		     `(multiple-value-prog1
                        (progn ,@(call-methods before)
                               (call-method ,(first primary)
                                            ,(rest primary)))
                        ,@(call-methods (reverse after)))
                     `(call-method ,(first primary) ,(rest primary))))
	   (around-form (if around
                            `(call-method ,(first around)
                                          (,@(rest around)
                                             (make-method ,form)))
                            form))
	   (pre-form (if (and precondition-check precondition)
			 `(if (or ,@(call-methods precondition))
			      ,around-form
                              (progn
                                ,@(raise-error 'precondition-error
                                               precondition)))
                         around-form))
	   (post-form (if (and postcondition-check postcondition)
                          `(multiple-value-prog1
                             ,pre-form
                             (unless (and ,@(call-methods postcondition))
                               ,@(raise-error 'postcondition-error
                                              postcondition)))
                          pre-form))
	   (inv-form (if (and invariant-check invariant)
			 `(multiple-value-prog1
                            (progn
                              (unless (and ,@(call-methods
                                              invariant))
                                ,@(raise-error
                                   'before-invariant-error
                                   invariant))
                              ,post-form)
                            (unless (and ,@(call-methods invariant))
                              ,@(raise-error
                                 'after-invariant-error
                                 invariant)))
                         post-form)))
      inv-form)))

 次にチェックに使うメソッドですが、不変条件の検査に check-invariant を使い、クラスのライタとリーダにそれぞれ、:invariantメソッドを付加することによって読み書き時に実行されるようになっています。
これに加えて、make-instanceでもcheck-invariantが実行されるようにしてあります。
これらは、どういう風にして定義されるかというと、基本的にマクロで上記のメソッドのコードが生成されるようになっています。

(defun getf-and-remove (name list &optional acc)
  "Find NAME in the alist LIST.  Returns nil as first value if NAME is
not found, the valus associated with NAME otherwise.  The second value
returned is LIST with the first occurence of pair (NAME value)
removed."
  (if (null list)
    (values nil (reverse acc))
    (if (eql (caar list) name)
      (values (cdar list) (append (reverse acc) (rest list)))
      (getf-and-remove name (rest list) (cons (first list) acc)))))

(defun define-slot-generics (slot) "Returns a list with the reader and writer generic functions for a slot. The generic functions have method combination type `dbc'." (let ((accessor (getf (rest slot) :accessor))) (let ((reader (or (getf (rest slot) :reader) accessor)) (writer (or (getf (rest slot) :writer) (when accessor `(setf ,accessor))))) (list (when reader `(ensure-generic-function ',reader :lambda-list '(object) :method-combination #-mcl '(dbc:dbc) #+mcl (ccl::%find-method-combination nil 'dbc nil))) (when writer `(ensure-generic-function ',writer :lambda-list '(new-value object) :method-combination #-mcl'(dbc:dbc) #+mcl (ccl::%find-method-combination nil 'dbc nil)))))))

(defun define-slot-accessor-invariants (class-name slot) "Returns a list with method definitions for reader and writer invariants." (let ((accessor (getf (rest slot) :accessor))) (let ((reader (or (getf (rest slot) :reader) accessor)) (writer (or (getf (rest slot) :writer) (when accessor `(setf ,accessor))))) (list (when reader `(defmethod ,reader :invariant ((object ,class-name)) (check-invariant object))) (when writer `(defmethod ,writer :invariant (value (object ,class-name)) (declare (ignore value)) (check-invariant object)))))))

(defun define-check-invariant-method (invariant class-name) "Returns a list containing the method on CHECK-INVARIANT specialized for CLASS-NAME and executing INVARIANT." `((defmethod check-invariant ((object ,class-name)) (when (funcall ,invariant object) (call-next-method)))))

(defmacro defclass (&body body) (destructuring-bind (name supers &optional slots &rest options) body (multiple-value-bind (invariant-form new-options) (getf-and-remove :invariant options) (let ((documented-invariant (cadr invariant-form))) (let ((invariant (or documented-invariant (car invariant-form)))) `(progn ,@(if slots (apply #'append (mapcar (lambda (slot) (define-slot-generics slot)) slots)) '()) (cl:defclass ,name ,supers ,slots ,@new-options) ,@(when invariant (define-check-invariant-method invariant name)) ,@(when slots (apply #'append (mapcar (lambda (slot) (define-slot-accessor-invariants name slot)) slots)))))))))

(eval-when (:compile-toplevel :load-toplevel :execute) (defgeneric check-invariant (object) (:documentation "Methods on the generic `check-invariant' are used by the dbc method combination to perform the invariant check and should not directly be defined by the user.")) ) ; eval-when (defmethod check-invariant (object) "Default invariant, always true." (declare (ignore object)) t)

(defmethod make-instance (class-name &rest initargs) (let ((object (apply #'cl:make-instance class-name initargs))) (unless (check-invariant object) (error 'creation-invariant-error)) object))

 defclassとmake-instanceが置き換えられていて、defclassではメソッドの定義がずらっと並ぶようになっています。

MOPを使って書き直してみよう

 標準のdefclassとmake-instanceを置き換えるのは名前の衝突等を考えるとあまり嬉しくないので、ここはMOPでメソッドを追加するようにしてみよう、ということで書いたのが下記です。

(defclass dbc (standard-class)  
  ((invariant :initarg :invariant
              :initform '() 
              :reader invariant)))

(defmethod c2mop:validate-superclass ((c dbc) (sc standard-class)) T)

(eval-when (:compile-toplevel :load-toplevel :execute) (defgeneric check-invariant (object) (:documentation "Methods on the generic `check-invariant' are used by the dbc method combination to perform the invariant check and should not directly be defined by the user.")) ) ; eval-when (defmethod check-invariant (object) "Default invariant, always true." (declare (ignore object)) t)

(defun slot-writers (class) (loop :for s :in (c2mop:class-direct-slots class) :append (c2mop:slot-definition-writers s)))

(defun slot-readers (class) (loop :for s :in (c2mop:class-direct-slots class) :append (c2mop:slot-definition-readers s)))

(defun define-invariant-methods (name metaclass) (when (eql 'dbc metaclass) (let ((class (find-class name))) (eval `(defmethod check-invariant ((object ,name)) (when (funcall ,(let* ((inv (invariant class)) (inv/doc (cadr inv))) (or inv/doc (first inv))) object) (call-next-method)))) (when (slot-readers class) (dolist (m (slot-readers class)) (ensure-generic-function m :lambda-list '(object) :method-combination '(dbc:dbc)) (eval `(defmethod ,m :invariant ((object ,name)) (check-invariant object))))) (when (slot-writers class) (dolist (m (slot-writers class)) (ensure-generic-function m :lambda-list '(new-value object) :method-combination '(dbc:dbc)) (eval `(defmethod ,m :invariant (value (object ,name)) (declare (ignore value)) (check-invariant object))))))))

(defmethod c2mop:ensure-class-using-class :after ((class null) name &key metaclass) (define-invariant-methods name metaclass))

(defmethod c2mop:ensure-class-using-class :after ((class dbc) name &key metaclass) (define-invariant-methods name metaclass))

(defmethod make-instance ((class-name dbc) &key) (let ((object (call-next-method))) (unless (check-invariant object) (error 'creation-invariant-error)) object))

 defclassの定義時にマクロを展開するのではなくて、(ensure-class-using-class null)と(ensure-class-using-class dbc)時にメソッドを定義するようにしています。
(ensure-class-using-class null)を変更するのは、なんか気持ち悪い気がしますが、他に方法はあるのでしょうか。一応dbcの時だけ反応するようにしていますが、もっと良い方がある気がします。
それとメソッドを生成するフォームがdefmethodを利用しているため、これも気持ち悪いことになっています。これも改善したいところ。
make-instanceは、dbcメタクラスで不変条件をチェックするように変更。

実行してみる

 CLを使っている人以外には実感しづらいですがCLパッケージをそのままuseできているところが改善点です。
オリジナルでは、:metaclassの指定はありませんが、改変版は必要になります。ここが、めんどくさいといえば、めんどくさいところです。

(cl:defpackage "DBC-MOP-TEST"
  (:use "DBC-MOP" "CL"))

(in-package "DBC-MOP-TEST")

(defclass test () ((slot1 :accessor slot1 :initarg :slot1 :initform 0)) (:metaclass dbc) (:invariant (lambda (class) (format t "~& >> Invariant check for class ~A~%" class) (numberp (slot-value class 'slot1)))))

(defgeneric test-dbc (arg1 arg2) (:method-combination dbc :invariant-check nil))

(defmethod test-dbc :precondition "first arg zero" ((m test) (n test)) (format t "~& >> precondition (test test)~%") (not (zerop (slot1 m))))

(defmethod test-dbc ((m test) (n test)) (/ (slot1 n) (slot1 m)))

 こういう定義で、事前条件のチェック

(test-dbc (make-instance 'test) (make-instance 'test))
;>>   >> Invariant check for class #<TEST {101BF22FB3}>
;>>   >> Invariant check for class #<TEST {101BF23A13}>
;>>   >> precondition (test test)
;>>   >> Invariant check for class #<TEST {101BF22FB3}>
;>>   >> Invariant check for class #<TEST {101BF22FB3}>
;>>   >> precondition (test test)
;>>   >> Invariant check for class #<TEST {101BF22FB3}>
;>>   >> Invariant check for class #<TEST {101BF22FB3}>
;>>!! error: Precondition violation: first arg zero.

testのslot1は初期値0なので、0除算チェックにひっかかる

(test-dbc (make-instance 'test :slot1 2) (make-instance 'test :slot1 8))
;>>   >> Invariant check for class #<TEST {101B93BD13}>
;>>   >> Invariant check for class #<TEST {101B93FDE3}>
;>>   >> precondition (test test)
;>>   >> Invariant check for class #<TEST {101B93BD13}>
;>>   >> Invariant check for class #<TEST {101B93BD13}>
;>>   >> Invariant check for class #<TEST {101B93FDE3}>
;>>   >> Invariant check for class #<TEST {101B93FDE3}>
;>>   >> Invariant check for class #<TEST {101B93BD13}>
;>>   >> Invariant check for class #<TEST {101B93BD13}>
;>>  
;=>  4

チェック通過

まとめ

 もっと綺麗に書けると良かったのですが、小汚くなりました。
不変条件は、スロットごとメソッドを付ける位なら、指定もスロットごとにしてみても良いような気もします。
改善のアドバイスがありましたら是非お願いします!

MOPを活用するユーティリティを眺める(3): mop-utils

Posted 2013-12-22 10:30:00 GMT

(Metaobject Protocol(MOP) Advent Calendar 2013参加エントリ)

 Metaobject Protocol(MOP) Advent Calendar 2013 22日目です。
MOPを活用するユーティリティを眺めるの三回目。今回は、mop-utilsを眺めてみたいと思います。

mop-utilsとは

 mop-utils はRyszard Szopa氏作のMOP系のユーティリティ集です。
元々は、O/RマッパーのSubmarineを作成する際に必要となったものをまとめたものとのこと

mop-utilsを眺める

 では、mop-utilsを早速眺めていきましょう。
動作確認用にクラスを定義しておきます。

(defclass counted-class-slot-definition ()
  ((foo :initform nil :initarg :foo)))

(defmetaclass counted-class (standard-class) ((counter :initform 0)) (:validate-superclasses standard-class) (:slot-fixtures counted-class-slot-definition))

(defclass foo-counted () ((x :initform 42)) (:metaclass counted-class))

(defclass bar-counted (foo-counted) ((x :initform 84)) (:metaclass counted-class))

defmetaclass

(defmetaclass counted-class (standard-class)
  ((counter :initform 0))
  (:validate-superclasses standard-class)
  (:slot-fixtures counted-class-slot-definition))

 メタクラスを定義する時に便利なマクロで、一連の作業をまとめたものです。
:validate-superclassesや:slot-fixturesを指定することで、DIRECT-SLOT-DEFINITION-CLASSや、EFFECTIVE-SLOT-DEFINITION-CLASSの定義も一緒にできます。

スロット定義は、予め

(defclass counted-class-slot-definition ()
  ((foo :initform nil :initarg :foo)))

等々のように定義済みであることが前提となっています。
上記のdefmetaclassのマクロ展開は、

(PROGN
 (DEFCLASS COUNTED-CLASS (STANDARD-CLASS) ((COUNTER :INITFORM 0)))
 (DEFCLASS COUNTED-CLASS-DIRECT-SLOT-DEFINITION
           (SB-MOP:STANDARD-DIRECT-SLOT-DEFINITION
            COUNTED-CLASS-SLOT-DEFINITION)
           NIL)
 (DEFCLASS COUNTED-CLASS-EFFECTIVE-SLOT-DEFINITION
           (SB-MOP:STANDARD-EFFECTIVE-SLOT-DEFINITION
            COUNTED-CLASS-SLOT-DEFINITION)
           NIL)
 (DEFMETHOD SB-MOP:DIRECT-SLOT-DEFINITION-CLASS
            ((CLASS COUNTED-CLASS) &REST MOP-UTILS::INITARGS)
   (DECLARE (IGNORE MOP-UTILS::INITARGS))
   (FIND-CLASS 'COUNTED-CLASS-DIRECT-SLOT-DEFINITION))
 (DEFMETHOD SB-MOP:EFFECTIVE-SLOT-DEFINITION-CLASS
            ((CLASS COUNTED-CLASS) &REST MOP-UTILS::INITARGS)
   (DECLARE (IGNORE MOP-UTILS::INITARGS))
   (FIND-CLASS 'COUNTED-CLASS-EFFECTIVE-SLOT-DEFINITION))
 (DEFMETHOD SB-MOP:VALIDATE-SUPERCLASS
            ((CLASS COUNTED-CLASS) (MOP-UTILS::SUPERCLASS STANDARD-CLASS))
   T)
 (FIND-CLASS 'COUNTED-CLASS))

 のような感じ。そのままですね。

class-name-of

(class-name-of (make-instance 'foo-counted))
;=>  FOO-COUNTED

 クラス名を取得するもの。moptilities:class-name-of と同じですね。

slot-names-of

(slot-names-of (make-instance 'foo-counted))
;=>  (X)

 スロット名一覧を取得するもの。これは、moptilities:slot-names と同じですね。

slots-of

(slots-of (make-instance 'foo-counted))
;=>  (#<COUNTED-CLASS-EFFECTIVE-SLOT-DEFINITION X>)

 スロット一覧を取得するもの。c2mop:class-slotsのインスタンスから情報を取得する版

get-slot-by-name

(get-slot-by-name (find-class 'foo-counted) 'x)
;=>  #<COUNTED-CLASS-EFFECTIVE-SLOT-DEFINITION X>

 クラスからスロット一覧を取得するもの

get-slot-of-by-name

(get-slot-of-by-name (make-instance 'foo-counted) 'x)
;=>  #<COUNTED-CLASS-EFFECTIVE-SLOT-DEFINITION X>

 get-slot-by-nameのインスタンスから情報を取得する版

do-children

(do-children (c foo-counted)
  (print (get-slot-by-name c 'x)))
;>>  
;>>  #<COUNTED-CLASS-EFFECTIVE-SLOT-DEFINITION X> 
;=>  NIL

 ダイレクトサブクラスに対してまとめて何かを実行するもの
class-direct-subclassesの結果がマクロ展開に埋め込まれてるのは、あまり良くないような

do-macro-for-children

(do-macro-for-children prin1-macro foo-counted)
;>>  BAR-COUNTED
;=>  NIL

 do-childrenで要素にマクロを適用するというもの。怪しい。
展開はこんな感じ

(DO-CHILDREN (#:|child2943| FOO-COUNTED)
  (LET ((#:|child-name2944| (CLASS-NAME #:|child2943|)))
    (EVAL `(PRIN1-MACRO ,#:|child-name2944|))))

まとめ

 今回はmop-utilsを眺めてみました、
MOP Advent Calendarもあと3日。尻切れトンボ気味ですが、あと3日書けそうなネタを探します。

MOPを活用するユーティリティを眺める(2): Moptilities

Posted 2013-12-21 06:30:00 GMT

(Metaobject Protocol(MOP) Advent Calendar 2013参加エントリ)

 Metaobject Protocol(MOP) Advent Calendar 2013 21日目です。
MOPを活用するユーティリティを眺めるの二回目。今回は、Moptilitiesを眺めてみたいと思います。

Moptilitiesとは

 Moptilities はGary King氏作のMOP系のユーティリティ集です。

Moptilitiesを眺める

 では、Moptilitiesを早速眺めていきましょう。
動作確認用にクラスを定義しておきます。

(defclass foo ()
  ((x :reader x)
   (y :writer y)
   (z :accessor z)))

(defclass bar (foo) (a b c))

get-class

(get-class 'standard-object)
;=>  #<STANDARD-CLASS STANDARD-OBJECT>

(get-class 'so)
;=>  NIL

 find-classとclass-ofを合体したような便利関数

finalize-class-if-necessary

 c2mop:class-finalized-pして必要時 c2mop:finalize-inheritance するという便利関数

superclasses

(superclasses 'standard-class)
;=>  (#<STANDARD-CLASS SB-PCL::STD-CLASS> #<STANDARD-CLASS SB-PCL::SLOT-CLASS>
;     #<STANDARD-CLASS SB-PCL::PCL-CLASS> #<STANDARD-CLASS CLASS>
;     #<STANDARD-CLASS SB-PCL::DEPENDENT-UPDATE-MIXIN>
;     #<STANDARD-CLASS SB-PCL::PLIST-MIXIN>
;     #<STANDARD-CLASS SB-PCL::DEFINITION-SOURCE-MIXIN>
;     #<STANDARD-CLASS SB-PCL::STANDARD-SPECIALIZER>
;     #<STANDARD-CLASS SB-MOP:SPECIALIZER> #<STANDARD-CLASS SB-MOP:METAOBJECT>
;     #<STANDARD-CLASS STANDARD-OBJECT> #<SB-PCL::SLOT-CLASS SB-PCL::SLOT-OBJECT>
;     #<BUILT-IN-CLASS T>)

 その名の通り、 superclass を列挙するもの

direct-superclasses

(direct-superclasses 'standard-class)
;=>  (#<STANDARD-CLASS SB-PCL::STD-CLASS>)

 その名の通り、direct-superclasses を列挙するもの

method-name

(method-name (find-method #'foo '() `(,(find-class 'list))))
;=>  FOO

 メソッドから総称関数の名前を取得するもの

get-method

(get-method #'foo '() 'list)
;=>  #<STANDARD-METHOD FOO (LIST) {10145845D3}>

 その名の通り、メソッドを取得するものですが、fboundpが関数を返す処理系でしか動きません。
fboundp name => generalized-boolean なのでOKではありますが、fdefinitionなら処理系依存でないので、こっちの方が好ましいような。
さらに、cl:standard-generic-function クラスが c2mop:standard-generic-function に差し替わっているのはOKなのでしょうか。バグなのかどうか。

remove-generic-function

(remove-generic-function 'foo)
;=>  FOO

 総称関数のメソッドを全部削除してからfmakunboundするというもの。 fmakunbound だけじゃ駄目なんですかね。駄目なんでしょう。

slot-names

(slot-names 'standard-generic-function)
;=>  (SB-PCL::SOURCE SB-PCL::PLIST SB-PCL::%DOCUMENTATION SB-PCL::INITIAL-METHODS
;     SB-PCL::NAME SB-PCL::METHODS SB-PCL::METHOD-CLASS SB-PCL::%METHOD-COMBINATION
;     SB-PCL::DECLARATIONS SB-PCL::ARG-INFO SB-PCL::DFUN-STATE SB-PCL::%LOCK
;     SB-PCL::INFO-NEEDS-UPDATE)

 その名の通り、スロット名一覧を所得

slot-properties

(slot-properties 'standard-generic-function 'SB-PCL::%LOCK)
;=>  (:NAME SB-PCL::%LOCK :INITARGS NIL :INITFORM
;     (SB-THREAD:MAKE-MUTEX :NAME "GF lock") :READERS (SB-PCL::GF-LOCK) :WRITERS NIL
;     :DOCUMENTATION "")

 指定したスロットの内容を取得

get-slot-definition

(get-slot-definition 'standard-generic-function 'SB-PCL::%LOCK)
;=>  #<SB-MOP:STANDARD-DIRECT-SLOT-DEFINITION SB-PCL::%LOCK>
;    NIL

 指定したスロットの定義を取得

direct-slot-names

(direct-slot-names 'standard-generic-function)
;=>  (SB-PCL::NAME SB-PCL::METHODS SB-PCL::METHOD-CLASS SB-PCL::%METHOD-COMBINATION
;     SB-PCL::DECLARATIONS SB-PCL::ARG-INFO SB-PCL::DFUN-STATE SB-PCL::%LOCK
;     SB-PCL::INFO-NEEDS-UPDATE)

 ダイレクトスロット一覧を取得

reader-method-p

(reader-method-p (get-method #'x '() 'foo))
;=>  T

(reader-method-p (get-method #'y '() t 'foo))
;=>  NIL

 リーダーメソッドかどうかを判定

writer-method-p

(writer-method-p (get-method #'x '() 'foo))
;=>  NIL

(writer-method-p (get-method #'y '() t 'foo))
;=>  T

 ライターメソッドかどうかを判定

map-methods

(map-methods 'foo (lambda (gf m) (print (method-name m))))
;>>  
;>>  (SETF Z) 
;>>  Z 
;>>  Y 
;>>  X 
;=>  NIL

 クラスに紐付いているメソッドに関数を適用。 CL系では、map系の名前で副作用目的なものもありなので要注意。

remove-methods

(remove-methods 'foo :dry-run? T)
;>>  #<STANDARD-WRITER-METHOD (SETF Z), slot:Z, (T FOO) {101E81AF63}>
;>>  #<STANDARD-READER-METHOD Z, slot:Z, (FOO) {101E896AC3}>
;>>  #<STANDARD-WRITER-METHOD Y, slot:Y, (T FOO) {101E81AF83}>
;>>  #<STANDARD-READER-METHOD X, slot:X, (FOO) {101E896AE3}>
;=>  4

 クラスに紐付いているメソッドを削除。 :dry-run? オプションで動作確認のみ

remove-methods-if

 任意の述語を取れる remove-methods の汎用版

(generic-functions 'standard-class)
;=>  (#<STANDARD-GENERIC-FUNCTION SB-PCL::STANDARD-CLASS-P (2)>
;     #<STANDARD-GENERIC-FUNCTION CHANGE-CLASS (7)>
;     #<STANDARD-GENERIC-FUNCTION ALLOCATE-INSTANCE (5)>
;     #<STANDARD-GENERIC-FUNCTION SB-PCL::WRAPPER-FETCHER (2)>
;     #<STANDARD-GENERIC-FUNCTION SB-PCL::SLOTS-FETCHER (2)>
;     #<STANDARD-GENERIC-FUNCTION SB-PCL::RAW-INSTANCE-ALLOCATOR (2)>
;     #<STANDARD-GENERIC-FUNCTION SB-MOP:COMPUTE-SLOTS (8)>
;     #<STANDARD-GENERIC-FUNCTION DOCUMENTATION (26)>
;     #<STANDARD-GENERIC-FUNCTION (SETF DOCUMENTATION) (23)>
;     #<STANDARD-GENERIC-FUNCTION SB-MOP:VALIDATE-SUPERCLASS (4)>
;     #<STANDARD-GENERIC-FUNCTION SWANK-BACKEND:EMACS-INSPECT (27)>)

 クラスに紐付いている総称関数を取得

direct-specializers-of

(direct-specializers-of 'standard-class)
;=>  (SWANK-BACKEND:EMACS-INSPECT SB-MOP:VALIDATE-SUPERCLASS (SETF DOCUMENTATION)
;                                 (SETF DOCUMENTATION) DOCUMENTATION DOCUMENTATION
;                                 SB-MOP:COMPUTE-SLOTS SB-MOP:COMPUTE-SLOTS
;                                 SB-PCL::RAW-INSTANCE-ALLOCATOR
;                                 SB-PCL::SLOTS-FETCHER SB-PCL::WRAPPER-FETCHER
;                                 ALLOCATE-INSTANCE CHANGE-CLASS CHANGE-CLASS
;                                 CHANGE-CLASS SB-PCL::STANDARD-CLASS-P)

 指定したクラスを引数で直接特定化しているメソッド一覧を取得

specializers-of

(specializers-of 'standard-class)
;=>  (SWANK-BACKEND:EMACS-INSPECT (SETF DOCUMENTATION) DOCUMENTATION
;                                 SB-MOP:COMPUTE-SLOTS
;                                 SB-PCL::RAW-INSTANCE-ALLOCATOR
;                                 SB-PCL::SLOTS-FETCHER SB-PCL::WRAPPER-FETCHER
...
  ...
    ...
;                                 (SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DFUN-STATE
;                                  SB-PCL::READER))

 指定したクラスを引数で特定化しているメソッド一覧を取得

map-subclasses

(map-subclasses 'standard-class #'identity)
;=>  (#<STANDARD-CLASS JSON:FLUID-CLASS>)

(map-subclasses 'standard-class (lambda (x) (print (class-name x))))
;>>  
;>>  STANDARD-CLASS 
;>>  JSON:FLUID-CLASS 
;=>  (#<STANDARD-CLASS JSON:FLUID-CLASS>)

 サブクラスをマップ処理するもの。あまり関係ないですが、mapcの返り値を使ってる関数を初めて見ました。

subclasses

(subclasses 'standard-generic-function)
;=>  (#<SB-MOP:FUNCALLABLE-STANDARD-CLASS C2MOP:STANDARD-GENERIC-FUNCTION>)

 その名の通りサブクラス一覧を取得

function-arglist

(function-arglist 'make-instance)
;=>  (CLASS &REST SB-PCL::INITARGS &ALLOW-OTHER-KEYS)

 関数の引数を取得。これは別にMOPに特化しているという訳でもないですが。

mopu-class-initargs

;;; LispWorksでの例
(mopu-class-initargs 'standard-class)
;=> (:METHOD-COMBINATION-OPTIONS :METHOD-COMBINATION :METHOD-CLASS :INITIAL-METHODS :DOCUMENTATION :DECLARATIONS :ARGUMENT-PRECEDENCE-ORDER :LAMBDA-LIST :NAME :DECLARATIONS)

 SBCLだと実装されていません

eql-specializer-p

(eql-specializer-p (c2mop:intern-eql-specializer 'x))
;=>  (EQL X)

 eql-specializerかどうかを判定。

default-initargs

(default-initargs 'standard-generic-function)
;=>  ((:METHOD-CLASS SB-PCL::*THE-CLASS-STANDARD-METHOD* #<FUNCTION # {10099DB2BB}>)
;     (:METHOD-COMBINATION SB-PCL::*STANDARD-METHOD-COMBINATION*
;      #<FUNCTION # {10099DB36B}>))

 class-direct-default-initargs と、 class-default-initargs を足したものを返す

leaf-class-p

(leaf-class-p 'bar)
;=>  T

 サブクラスがないクラスかどうかを判定

leaf-subclasses

(leaf-subclasses 'standard-generic-function)
;=>  (#<SB-MOP:FUNCALLABLE-STANDARD-CLASS C2MOP:STANDARD-GENERIC-FUNCTION>)

 サブクラスがないクラス一覧を取得

class-name-of

(class-name-of (find-class 'foo))
;=>  FOO

 class-of して class-name するもの

copy-template

(copy-template (get-class 'foo))
;=>  #<STANDARD-CLASS FOO>

 インスタンスをコピーしてテンプレートに使うというもの。

(make-graph (type-of old-graph)
            :vertex-test (vertex-test old-graph) 
            :vertex-key (vertex-key old-graph)
            :edge-test (edge-test old-graph)
            :edge-key (edge-key old-graph)
            :default-edge-type (default-edge-type old-graph)
            :default-edge-class (default-edge-class old-graph)
            :directed-edge-class (directed-edge-class old-graph)
            :undirected-edge-class (undirected-edge-class old-graph))

みたいな場合に便利よ、とのこと fare-mop:remake-object と同じものですね

*debugging-finalization*

 デバッグ時用の変数で、非nilにすると、ファイナライズ指定したオブジェクトの回収時にメッセージが *debug-io* に印字

care-when-finalized

(let ((*debugging-finalization* T)
      (x (make-instance 'standard-generic-function)))
  (care-when-finalized x)
  (setq x nil)
  (sb-ext:gc :full t))
;>> Finalized #<STANDARD-GENERIC-FUNCTION NIL (0) {1015226BDB}>
;=>  NIL

 MOP利用に限定されるものでもありませんが、オブジェクトをファイナライズ指定します。
SBCLだと sb-ext:finalize が取る引数の関数は、無引数なので修正の必要あり

ignore-finalization

 ファイナライズをキャンセル

まとめ

 今回はMetatilitiesを眺めてみました、
開発時に便利っぽい関数が結構ありますね。

MOPを活用するユーティリティを眺める(1): closer to mop/fare-mop

Posted 2013-12-19 15:00:00 GMT

(Metaobject Protocol(MOP) Advent Calendar 2013参加エントリ)

 Metaobject Protocol(MOP) Advent Calendar 2013 20日目です。

 MOP Advent Calendarも20日目ともなると、皆さんもMOP系のユーティリティを眺めたくなってきたかなと思います。
早速、Common Lispのライブラリ管理システムのquicklispに登録されているMOP系のユーティリティを眺めて行きましょう。

quicklispにはどんなものが登録されているのかな

 quicklispに登録のライブラリを"mop"で検索してみると、こんな感じです。

(ql-dist:system-apropos "mop")
;>>  #<SYSTEM closer-mop / closer-mop-20131111-git / quicklisp 2013-11-11>
;>>  #<SYSTEM fare-mop / fare-mop-20130615-git / quicklisp 2013-11-11>
;>>  #<SYSTEM hu.dwim.util.mop / hu.dwim.util-20131111-darcs / quicklisp 2013-11-11>
;>>  #<SYSTEM mop-utils / mop-utils-20120811-http / quicklisp 2013-11-11>
;>>  #<SYSTEM moptilities / moptilities-20110110-http / quicklisp 2013-11-11>
;>>  #<SYSTEM moptilities-test / moptilities-20110110-http / quicklisp 2013-11-11>
;>>  #<SYSTEM nst-mop-utils / nst-4.0.1 / quicklisp 2013-11-11>
;>>  #<SYSTEM xml-mop / xml-mop-20110418-git / quicklisp 2013-11-11>
;>>  
;=>  <no values>

mopを使ったプログラミングに使えそうなユーティリティライブラリが4つ、5つありそうですね。
適当に眺めて行きましょう。

Closer to MOP: closer-mop

 Closer to MOPは、AMOP(The Art of the Metaobject Protocol)の定義のコンパチパッケージです。
何故、このようなパッケージが必要になるのかというと、残念ながらMOPはCommon Lispの標準仕様には含まれなかった為で、各処理系は、AMOPを下敷きにしてはいるものの、それぞれ拡張していたり、仕様に準拠していなかったりします。
この非互換をカバーする目的で作られたライブラリです。
ちなみにCloser to MOPが何かの仕様の名前という訳ではありません。

fare-mop

 fare氏作のMOP系の機能を使ったユーティリティです。
ちょっとしたユーティリティ集なので全部眺めてみましょう。

collect-slots

 名前の通り、オブジェクトのスロットを集めるものです。束縛されていないスロットは無視されます。

(defclass foo ()
  ((x :initform '())
   (y :initform '())
   (z :initform '())))

(fare-mop:collect-slots (make-instance 'foo)) ;=> (X NIL Y NIL Z NIL) (fare-mop:collect-slots (make-instance 'foo) :slots '(x z)) ;=> (X NIL Z NIL)

simple-print-object

 通常インスタンスは、print-objectによって

(print (make-instance 'foo) t)
;=>  #<FOO {1018079513}>

のように印字されますが、スロットの中身も印字するようにしたものです。スロットの取得に上のcollect-slotsが使われていますが、Common Lispでは、印字するためのprint-objectもユーザーが拡張メソッドとなっているのでカスタマイズすることが可能です。

(fare-mop:simple-print-object (make-instance 'foo) t)
;>>  #<FOO (X NIL Z NIL)>
;=>  NIL

(fare-mop:simple-print-object (make-instance 'standard-generic-function) t) ;>> #<STANDARD-GENERIC-FUNCTION (:DEFINITION-SOURCE NIL SB-PCL::PLIST NIL ;>> :DOCUMENTATION NIL SB-PCL::INITIAL-METHODS NIL ;>> :NAME NIL SB-PCL::METHODS NIL :METHOD-CLASS ;>> #<STANDARD-CLASS STANDARD-METHOD> ;>> :METHOD-COMBINATION ;>> #<SB-PCL::STANDARD-METHOD-COMBINATION STANDARD NIL ;>> {1000649613}> ;>> :DECLARE NIL SB-PCL::ARG-INFO ;>> #S(SB-PCL::ARG-INFO ;>> :ARG-INFO-LAMBDA-LIST :NO-LAMBDA-LIST ;>> :ARG-INFO-PRECEDENCE NIL ;>> :ARG-INFO-METATYPES NIL ;>> :ARG-INFO-NUMBER-OPTIONAL NIL ;>> :ARG-INFO-KEY/REST-P NIL ;>> :ARG-INFO-KEYS NIL ;>> :GF-INFO-SIMPLE-ACCESSOR-TYPE NIL ;>> :GF-PRECOMPUTE-DFUN-AND-EMF-P NIL ;>> :GF-INFO-STATIC-C-A-M-EMF #S(SB-PCL::FAST-METHOD-CALL ;>> :FUNCTION # ;>> :PV NIL ;>> :NEXT-METHOD-CALL NIL ;>> :ARG-INFO (2)) ;>> :GF-INFO-C-A-M-EMF-STD-P T ;>> :GF-INFO-FAST-MF-P T) ;>> SB-PCL::DFUN-STATE NIL SB-PCL::%LOCK ;>> #<SB-THREAD:MUTEX "GF lock" (free)> ;>> SB-PCL::INFO-NEEDS-UPDATE NIL)> ;=> NIL (fare-mop:simple-print-object (make-instance 'standard-generic-function) t :slots '(:method-combination) :identity t) ;>> #<STANDARD-GENERIC-FUNCTION (:METHOD-COMBINATION ;>> #<SB-PCL::STANDARD-METHOD-COMBINATION STANDARD NIL ;>> {1000649613}>)> ;=> NIL

必要なスロットのみ表示させることも可能。
さらにsimple-print-object-mixinというものも定義されているので、好みに応じて、

(defclass pp (fare-mop:simple-print-object-mixin)
  ((x :initform 42)
   (y)
   (z)))

(defmethod fare-mop:slots-to-print ((obj pp)) '(x))

(make-instance 'pp) ;=> #<PP (X 42)>

というような利用方法もありです。

remake-object

 オブジェクトからスロットの内容を読み取り、その情報からmake-instanceするというものです。

(fare-mop:remake-object (make-instance 'pp))
;=>  #<PP (X 42)>

まとめ

 今回はCLOS MOPのユーティリティライブラリを少し眺めてみましたが、やはりユーティリティを眺めるのは、他の人の仕事を眺めているようで楽しいですね。
他にも数点あるので何度かに分けて眺めてみましょう。
…連休はもう少しがんばります。

MOPでローカルメソッドの構文を作ってみよう: generic-flet

Posted 2013-12-18 15:48:00 GMT

(Metaobject Protocol(MOP) Advent Calendar 2013参加エントリ)

 Metaobject Protocol(MOP) Advent Calendar 2013 19日目です。

 いよいよ、ネタ切れもどん詰まり。とりあえずなにかMetaobjectをいじってみましょうということでローカルメソッドの構文を作ってみます。

generic-fletとは

 Common Lispにはローカル関数用の構文として、fletとlabelsがあります。
これのメソッド版が、generic-fletです。1985年のCommonLoopsの論文ではmletとして紹介されているのですが、登場の頃から、何の為に使うのか良く分からない、正しい挙動を定義するのが難しいのではないか、と文句を言われていました。そんなmletも、CLtL2位までは、generic-fletとして生き残っていた様子。

 そんなgeneric-fletですが、CLtL2では存在したもののANSI CLになる際には、他のローカルメソッド構文(generic-labels等)といっしょに葬り去られました。
僅かな処理系で実装されたこともあるようですが、ほぼサポートしている処理系はありません。ちなみに、現在では、CLISPに定義が存在していたりします。

generic-fletを作ってみよう

 Common Lispでは、総称関数があって、それにメソッドがくっ付いている構成になっています。
具体的には、standard-generic-functionのインスタンスにstandard-methodのインスタンスがadd-methodにより破壊的に合体されています。
非常に簡単そうですね。
適当に作ってみると下記のようになります。ラムダリストの処理は端折ったので興味のある方は作り込んでみて下さい。

(defmacro generic-flet ((&rest definitions) &body body)
  (loop :with known := (make-hash-table)
        :for (name args/t . form) :in definitions
        :for gf   := (gensym (string name))
        :for m    := (gensym (concatenate 'string (string name) "-METH"))
        :for args := (extract-args args/t)
        :unless (gethash name known)
          :collect `(,gf ,(make-gf-form)) :into gfs 
          :and :do (setf (gethash name known) gf)
        :collect `(,m ,(make-method-form args args/t form)) :into gfs
        :collect `(add-method ,(gethash name known) ,m) :into add-methods
        :collect (make-funcall-form name args (gethash name known))
        :into defs
        :finally (return
                   `(let* (,@gfs)
                      ,@add-methods
                      (flet (,@(remove-duplicates defs :test #'equal))
                        ,@body)))))
;;; マクロの補助関数
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun make-gf-form ()
    (copy-list '(make-instance 'standard-generic-function)))

(defun make-method-form (args args/t body) (let ((margs (gensym)) (ignore (gensym))) `(make-instance 'standard-method :function (lambda (,margs ,ignore) (declare (ignore ,ignore)) (apply (lambda (,@args) ,@body) ,margs)) :lambda-list ',args :specializers (list ,@(mapcar (lambda (x) `(find-class ',x)) (c2mop:extract-specializer-names args/t))))))

(deftype lambda-list-keyword () `(member ,@lambda-list-keywords))

(defun make-funcall-form (name args gfname) `(,name ,args (funcall ,gfname ,@(mapcan (lambda (x) (etypecase x (LAMBDA-LIST-KEYWORD '() ) (CONS (list (first x))) (SYMBOL (list x)))) args)))))

generic-flet実行例

(defmethod plus (x y)
  :global)

(generic-flet ((plus ((x cons) (y cons)) (append x y)) (plus ((x number) (y number)) (+ x y)) (plus (x y) (list x y))) (list (plus 8 8) (plus '(1 2 3 4) '(1 2 3 4)) (plus 'z 'z))) ;=> (16 (1 2 3 4 1 2 3 4) (Z Z))

(plus 8 8) ;=> :GLOBAL

(list (funcall #'plus '(foo) '(bar)) (funcall (generic-flet ((plus ((x cons) (y cons)) (append x y))) #'plus) '(foo) '(bar))) ;=> (:GLOBAL (FOO BAR))

 なんとなくSchemeではなんの苦もなくできる気がしてきましたね。
実際のところどうなんでしょう。

マクロを展開して眺めてみる

 さて、マクロを展開すると、こんな感じです、

(LET* ((#:PLUS4110 (MAKE-INSTANCE 'STANDARD-GENERIC-FUNCTION))
       (#:PLUS-METH4111
        (MAKE-INSTANCE 'STANDARD-METHOD :FUNCTION
                       (LAMBDA (#:G4112 #:G4113)
                         (DECLARE (IGNORE #:G4113))
                         (APPLY (LAMBDA (X Y) (APPEND X Y)) #:G4112))
                       :LAMBDA-LIST '(X Y) :SPECIALIZERS
                       (LIST (FIND-CLASS 'CONS) (FIND-CLASS 'CONS))))
       (#:PLUS-METH4115
        (MAKE-INSTANCE 'STANDARD-METHOD :FUNCTION
                       (LAMBDA (#:G4116 #:G4117)
                         (DECLARE (IGNORE #:G4117))
                         (APPLY (LAMBDA (X Y) (+ X Y)) #:G4116))
                       :LAMBDA-LIST '(X Y) :SPECIALIZERS
                       (LIST (FIND-CLASS 'NUMBER) (FIND-CLASS 'NUMBER))))
       (#:PLUS-METH4119
        (MAKE-INSTANCE 'STANDARD-METHOD :FUNCTION
                       (LAMBDA (#:G4120 #:G4121)
                         (DECLARE (IGNORE #:G4121))
                         (APPLY (LAMBDA (X Y) (LIST X Y)) #:G4120))
                       :LAMBDA-LIST '(X Y) :SPECIALIZERS
                       (LIST (FIND-CLASS 'T) (FIND-CLASS 'T)))))
  (ADD-METHOD #:PLUS4110 #:PLUS-METH4111)
  (ADD-METHOD #:PLUS4110 #:PLUS-METH4115)
  (ADD-METHOD #:PLUS4110 #:PLUS-METH4119)
  (FLET ((PLUS (X Y)
           (FUNCALL #:PLUS4110 X Y)))
    (LIST (PLUS 8 8) (PLUS '(1 2 3 4) '(1 2 3 4)) (PLUS 'Z 'Z))))

上で説明したように、standard-generic-functionにメソッドを足しているというそのままな感じが読み取れると思います。

まとめ

 今回はCommon Lispのメソッドを分解して遊んでみました。
色々面白いことができそうだなと思った方は、是非遊んでみましょう!!

 MOP Advent Calendarも残すところあと6日。長い!!

MOPでディスパッチの多様化: filtered-functions

Posted 2013-12-17 16:05:00 GMT

(Metaobject Protocol(MOP) Advent Calendar 2013参加エントリ)

 Metaobject Protocol(MOP) Advent Calendar 2013 18日目です。

filtered-functionsを眺める

 今回は、ネタも無いということで、MOPの応用例を眺めてみよう、ということで、filtered-functionsを眺めてみます。

filtered-functionsとは

 総称関数のディスパッチにフィルタリングする関数を付けてみよう、というアイデアです。
詳しくは、配布元のページと、このページにある論文を参照して下さい。

とりあえず利用例

 シンプルな利用例としては、こんな感じです

まず、総称関数のベースを定義
(define-filtered-function fib (n)
  (:filters (:signum #'signum)))
フィルターは複数取れますが、ここでは一つ指定しています。
(:フィルター名 #'関数)
という構成になっていて、フィルター名をdefmethodのメソッドコンビネーションの引数で指定するようになっています。
次にメソッド
(defmethod fib ((n integer))
  (if (< n 2)
      n
      (+ (fib (1- n))
         (fib (- n 2)))))
こちらは普通にintegerに対して定義
(defmethod fib :filter :signum 
           ((n (eql -1)))
  (error "fib not defined for negative numbers: ~A." n))
そして、これが、
(eql (signum x) -1)
の場合に起動されるメソッドです。
こんな感じで、メソッドに引数が渡される前に、フィルター関数で処理される、という訳です。
(fib 10)
;=>  55

(fib -8)
;>!! fib not defined for negative numbers: -8.

filtered-functionsの中身を読んでみる

さて、どういう仕組みで実現されているのか眺めてみますが、肝となるのは、compute-applicable-methods と、 compute-applicable-methods-using-classes と、compute-discriminating-function です。
まず、フィルター関数がどこで実行されているのかというと、 compute-applicable-methods で
compute-applicable-methods
(defmethod compute-applicable-methods ((ff simple-filtered-function) required-args)
  (let* ((filter-expression (generic-function-filter-expression ff))
         (filter-functions (apply filter-expression required-args)))
    (cond ((consp filter-functions)
            (loop for arg in required-args
                  for filter-function = (pop filter-functions)
                  collect (if filter-function
                              (funcall filter-function arg)
                              arg)
                    into filtered-args
                  finally (return (call-next-method ff filtered-args))))
           ((null filter-functions) '())
           ((eq filter-functions 't) (call-next-method))
           (t (call-next-method ff (cons (funcall filter-functions (first required-args))
                                         (rest required-args)))))))
の (funcall filter-function arg) になります。
そしてfilter-functionで処理済みの引数が上位メソッドに渡されます。つまり上の例でいうとfibに渡された-8が、signumで-1にされるところです。あとは、-1が上位に渡されます。そしてそれから、(eql -1)の条件に掴まるという訳です。
compute-applicable-methods-using-classes
次に謎の定義の compute-applicable-methods-using-classes ですが、
(defmethod compute-applicable-methods-using-classes ((ff simple-filtered-function) classes)
  (declare (ignore classes))
  (values '() nil))

となっています。注目するところは、多値の第二値でnilを返しているところです。

 何故にnilを返しているかというと、compute-discriminating-function では、compute-applicable-methods-using-classes の返り値の第二値を見て、キャッシュした値を使うか、再計算するかを決定するからで、nilの場合は、 compute-applicable-methods が呼ばれるので、毎度nilが返ってくるということは、キャッシュされず、毎度 compute-applicable-methods が呼ばれるということになり、フィルター関数も毎度実行される、という訳です。
もちろん、simple-filtered-function の場合だけ毎度呼ばれるのみで、上位メソッドでは通常通りになります。

その他

 あとは、メソッドコンビネーションの定義が、 define-method-combination 等で色々とありますので、参考になるでしょう。
さらに、単発のフィルターを持つ simple-filtered-function クラスと、複数のフィルターを持つクラスの、filter-functionクラスに分かれているので、複数の場合の処理も眺めてみると良いと思います。

まとめ

 filter-functionsは、既存の枠組みを活かした面白い拡張だと思います。コードも250行位と短いので、総称関数を拡張する場合には参考になるのではないかと思いますので是非読んでみて下さい。

 MOP Advent Calendarも残すところあと一週間。MOPネタならどんなネタでもOKですので参加お待ちしています!

Older entries (1574 remaining)