Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2008-12-02

CLとデザインパターン - Singleton

| 15:35 | CLとデザインパターン - Singleton - わだばLisperになる を含むブックマーク はてなブックマーク - CLとデザインパターン - Singleton - わだばLisperになる

今回はSingletonパターンです。

一つのクラスにつきインスタンスを一つしか作らないことを保証するようなパターンとのこと。

GaucheのMOP周りを眺めていて、MOPでSingletonを実現している例があったので(gauche.mop.singleton) これを移植しつつ考えてみることにしました。

内容としては、 Singleton用のメタクラスを作成して、そのスロットに一つだけのインスタンスが保持されるようにする、というものでCLでもそのまま行けそうです。

しかし、大まかには真似できたんですが、Gaucheでは、毎回メタクラスの指定をしなくても良いようにmixin用のsingleton-mixinというクラスを提供しているのですが、これが再現できませんでした…。

どうやら ensure-class-using-class を定義すれば良さそうなのですが、どうもややこしいのでマクロで逃げました。

:metaclassの指定回避の定番の方法を知ってる方は是非教えて下さい!

(defclass singleton-meta (standard-class)
  ((%the-singleton-instance :initform () )))

(defmethod make-instance ((class singleton-meta) &key)
  (with-slots (%the-singleton-instance) class
    (if %the-singleton-instance
        %the-singleton-instance
        (let ((ins (call-next-method)))
          (setf %the-singleton-instance ins)
          ins))))

(defmethod c2mop:validate-superclass ((class singleton-meta)
                                      (super standard-class))
  'T)

(defmacro define-singleton-class (name supers &rest args)
  (and (assoc :metaclass args)
       (error "Metaclass already specified."))
  `(defclass ,name ,supers ,@args
     (:metaclass singleton-meta)))

(define-singleton-class quux-singleton () ())

;; 動作
(eq (make-instance 'quux-singleton)
    (make-instance 'quux-singleton))
;=> T

(defmethod instance-of ((class singleton-meta) &rest initargs)
  (apply #'make-instance class initargs))

(instance-of (find-class 'quux-singleton))