#:g1: MOP vs マクロ (2)

Posted 2019-01-23 17:36:05 GMT

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

それはさておき、前回は、お題を全部マクロで実現した訳ですが、今回は若干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)

前回の問題点として

の二点がありましたが、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

comments powered by Disqus