Posted 2019-02-11 15:59:28 GMT
MOP vs マクロなネタを探していますが、古えのメールに面白そうなものがあったので、これをどうにかMOP vs マクロの枠内で再現してみることにします。
ちなみに、このECLOSですが、Metaclass libraryとあるように、MOP的なツールを纏めた商用ライブラリだったようです。
メタクラス関係だけで商品になってたというのが凄い。
告知メールによると主なアイテムは、
copy-object,
equal-object-p with suscint in-class specifications)propagate as if graph still unchanged semantics).ですが、定番そうなものから何やら良く分からないものまであります。
今回は、このリストの中からlet*-like slot initialization semanticsをMOPとマクロで再現してみたいと思います。
例のごとくまずはマクロでの実現から始めます。
まず、動作の確認ですが、詳細は不明なものの、多分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